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_5005THREADS)
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_5005THREADS)
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_5005THREADS) || 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 sts = setup_cmddsc(aTHX_ cmd,0);
2067 case RMS$_FNF: case RMS$_DNF:
2068 set_errno(ENOENT); break;
2070 set_errno(ENOTDIR); break;
2072 set_errno(ENODEV); break;
2074 set_errno(EACCES); break;
2076 set_errno(EINVAL); break;
2077 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2078 set_errno(E2BIG); break;
2079 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2080 _ckvmssts(sts); /* fall through */
2081 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2084 set_vaxc_errno(sts);
2085 if (ckWARN(WARN_PIPE)) {
2086 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2090 New(1301,info,1,Info);
2094 info->completion = 0;
2095 info->closing = FALSE;
2099 info->in_done = TRUE;
2100 info->out_done = TRUE;
2101 info->err_done = TRUE;
2102 in[0] = out[0] = err[0] = '\0';
2104 if (*mode == 'r') { /* piping from subroutine */
2106 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2108 info->out->pipe_done = &info->out_done;
2109 info->out_done = FALSE;
2110 info->out->info = info;
2112 info->fp = PerlIO_open(mbx, mode);
2113 if (!info->fp && info->out) {
2114 sys$cancel(info->out->chan_out);
2116 while (!info->out_done) {
2118 _ckvmssts(sys$setast(0));
2119 done = info->out_done;
2120 if (!done) _ckvmssts(sys$clref(pipe_ef));
2121 _ckvmssts(sys$setast(1));
2122 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2125 if (info->out->buf) Safefree(info->out->buf);
2126 Safefree(info->out);
2131 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2133 info->err->pipe_done = &info->err_done;
2134 info->err_done = FALSE;
2135 info->err->info = info;
2138 } else { /* piping to subroutine , mode=w*/
2140 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2141 info->fp = PerlIO_open(mbx, mode);
2143 info->in->pipe_done = &info->in_done;
2144 info->in_done = FALSE;
2145 info->in->info = info;
2149 if (!info->fp && info->in) {
2151 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2152 0, 0, 0, 0, 0, 0, 0, 0));
2154 while (!info->in_done) {
2156 _ckvmssts(sys$setast(0));
2157 done = info->in_done;
2158 if (!done) _ckvmssts(sys$clref(pipe_ef));
2159 _ckvmssts(sys$setast(1));
2160 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2163 if (info->in->buf) Safefree(info->in->buf);
2170 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2172 info->out->pipe_done = &info->out_done;
2173 info->out_done = FALSE;
2174 info->out->info = info;
2177 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2179 info->err->pipe_done = &info->err_done;
2180 info->err_done = FALSE;
2181 info->err->info = info;
2185 symbol[MAX_DCL_SYMBOL] = '\0';
2187 strncpy(symbol, in, MAX_DCL_SYMBOL);
2188 d_symbol.dsc$w_length = strlen(symbol);
2189 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2191 strncpy(symbol, err, MAX_DCL_SYMBOL);
2192 d_symbol.dsc$w_length = strlen(symbol);
2193 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2195 strncpy(symbol, out, MAX_DCL_SYMBOL);
2196 d_symbol.dsc$w_length = strlen(symbol);
2197 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2199 p = VMScmd.dsc$a_pointer;
2200 while (*p && *p != '\n') p++;
2201 *p = '\0'; /* truncate on \n */
2202 p = VMScmd.dsc$a_pointer;
2203 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2204 if (*p == '$') p++; /* remove leading $ */
2205 while (*p == ' ' || *p == '\t') p++;
2206 strncpy(symbol, p, MAX_DCL_SYMBOL);
2207 d_symbol.dsc$w_length = strlen(symbol);
2208 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2210 _ckvmssts(sys$setast(0));
2211 info->next=open_pipes; /* prepend to list */
2213 _ckvmssts(sys$setast(1));
2214 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2215 0, &info->pid, &info->completion,
2216 0, popen_completion_ast,info,0,0,0));
2218 /* if we were using a tempfile, close it now */
2220 if (tpipe) fclose(tpipe);
2222 /* once the subprocess is spawned, its copied the symbols and
2223 we can get rid of ours */
2225 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2226 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2227 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2228 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2231 PL_forkprocess = info->pid;
2233 } /* end of safe_popen */
2236 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2238 Perl_my_popen(pTHX_ char *cmd, char *mode)
2241 TAINT_PROPER("popen");
2242 PERL_FLUSHALL_FOR_CHILD;
2243 return safe_popen(aTHX_ cmd,mode);
2248 /*{{{ I32 my_pclose(PerlIO *fp)*/
2249 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2251 pInfo info, last = NULL;
2252 unsigned long int retsts;
2255 for (info = open_pipes; info != NULL; last = info, info = info->next)
2256 if (info->fp == fp) break;
2258 if (info == NULL) { /* no such pipe open */
2259 set_errno(ECHILD); /* quoth POSIX */
2260 set_vaxc_errno(SS$_NONEXPR);
2264 /* If we were writing to a subprocess, insure that someone reading from
2265 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2266 * produce an EOF record in the mailbox.
2268 * well, at least sometimes it *does*, so we have to watch out for
2269 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2272 PerlIO_flush(info->fp); /* first, flush data */
2274 _ckvmssts(sys$setast(0));
2275 info->closing = TRUE;
2276 done = info->done && info->in_done && info->out_done && info->err_done;
2277 /* hanging on write to Perl's input? cancel it */
2278 if (info->mode == 'r' && info->out && !info->out_done) {
2279 if (info->out->chan_out) {
2280 _ckvmssts(sys$cancel(info->out->chan_out));
2281 if (!info->out->chan_in) { /* EOF generation, need AST */
2282 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2286 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2287 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2289 _ckvmssts(sys$setast(1));
2290 PerlIO_close(info->fp);
2293 we have to wait until subprocess completes, but ALSO wait until all
2294 the i/o completes...otherwise we'll be freeing the "info" structure
2295 that the i/o ASTs could still be using...
2299 _ckvmssts(sys$setast(0));
2300 done = info->done && info->in_done && info->out_done && info->err_done;
2301 if (!done) _ckvmssts(sys$clref(pipe_ef));
2302 _ckvmssts(sys$setast(1));
2303 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2305 retsts = info->completion;
2307 /* remove from list of open pipes */
2308 _ckvmssts(sys$setast(0));
2309 if (last) last->next = info->next;
2310 else open_pipes = info->next;
2311 _ckvmssts(sys$setast(1));
2313 /* free buffers and structures */
2316 if (info->in->buf) Safefree(info->in->buf);
2320 if (info->out->buf) Safefree(info->out->buf);
2321 Safefree(info->out);
2324 if (info->err->buf) Safefree(info->err->buf);
2325 Safefree(info->err);
2331 } /* end of my_pclose() */
2333 /* sort-of waitpid; use only with popen() */
2334 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2336 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2341 for (info = open_pipes; info != NULL; info = info->next)
2342 if (info->pid == pid) break;
2344 if (info != NULL) { /* we know about this child */
2345 while (!info->done) {
2346 _ckvmssts(sys$setast(0));
2348 if (!done) _ckvmssts(sys$clref(pipe_ef));
2349 _ckvmssts(sys$setast(1));
2350 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2353 *statusp = info->completion;
2356 else { /* we haven't heard of this child */
2357 $DESCRIPTOR(intdsc,"0 00:00:01");
2358 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2359 unsigned long int interval[2],sts;
2361 if (ckWARN(WARN_EXEC)) {
2362 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2363 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2364 if (ownerpid != mypid)
2365 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2368 _ckvmssts(sys$bintim(&intdsc,interval));
2369 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2370 _ckvmssts(sys$schdwk(0,0,interval,0));
2371 _ckvmssts(sys$hiber());
2373 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2376 /* There's no easy way to find the termination status a child we're
2377 * not aware of beforehand. If we're really interested in the future,
2378 * we can go looking for a termination mailbox, or chase after the
2379 * accounting record for the process.
2385 } /* end of waitpid() */
2390 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2392 my_gconvert(double val, int ndig, int trail, char *buf)
2394 static char __gcvtbuf[DBL_DIG+1];
2397 loc = buf ? buf : __gcvtbuf;
2399 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2401 sprintf(loc,"%.*g",ndig,val);
2407 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2408 return gcvt(val,ndig,loc);
2411 loc[0] = '0'; loc[1] = '\0';
2419 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2420 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2421 * to expand file specification. Allows for a single default file
2422 * specification and a simple mask of options. If outbuf is non-NULL,
2423 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2424 * the resultant file specification is placed. If outbuf is NULL, the
2425 * resultant file specification is placed into a static buffer.
2426 * The third argument, if non-NULL, is taken to be a default file
2427 * specification string. The fourth argument is unused at present.
2428 * rmesexpand() returns the address of the resultant string if
2429 * successful, and NULL on error.
2431 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2434 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2436 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2437 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2438 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2439 struct FAB myfab = cc$rms_fab;
2440 struct NAM mynam = cc$rms_nam;
2442 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2444 if (!filespec || !*filespec) {
2445 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2449 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2450 else outbuf = __rmsexpand_retbuf;
2452 if ((isunix = (strchr(filespec,'/') != NULL))) {
2453 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2454 filespec = vmsfspec;
2457 myfab.fab$l_fna = filespec;
2458 myfab.fab$b_fns = strlen(filespec);
2459 myfab.fab$l_nam = &mynam;
2461 if (defspec && *defspec) {
2462 if (strchr(defspec,'/') != NULL) {
2463 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2466 myfab.fab$l_dna = defspec;
2467 myfab.fab$b_dns = strlen(defspec);
2470 mynam.nam$l_esa = esa;
2471 mynam.nam$b_ess = sizeof esa;
2472 mynam.nam$l_rsa = outbuf;
2473 mynam.nam$b_rss = NAM$C_MAXRSS;
2475 retsts = sys$parse(&myfab,0,0);
2476 if (!(retsts & 1)) {
2477 mynam.nam$b_nop |= NAM$M_SYNCHK;
2478 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2479 retsts = sys$parse(&myfab,0,0);
2480 if (retsts & 1) goto expanded;
2482 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2483 (void) sys$parse(&myfab,0,0); /* Free search context */
2484 if (out) Safefree(out);
2485 set_vaxc_errno(retsts);
2486 if (retsts == RMS$_PRV) set_errno(EACCES);
2487 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2488 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2489 else set_errno(EVMSERR);
2492 retsts = sys$search(&myfab,0,0);
2493 if (!(retsts & 1) && retsts != RMS$_FNF) {
2494 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2495 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2496 if (out) Safefree(out);
2497 set_vaxc_errno(retsts);
2498 if (retsts == RMS$_PRV) set_errno(EACCES);
2499 else set_errno(EVMSERR);
2503 /* If the input filespec contained any lowercase characters,
2504 * downcase the result for compatibility with Unix-minded code. */
2506 for (out = myfab.fab$l_fna; *out; out++)
2507 if (islower(*out)) { haslower = 1; break; }
2508 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2509 else { out = esa; speclen = mynam.nam$b_esl; }
2510 /* Trim off null fields added by $PARSE
2511 * If type > 1 char, must have been specified in original or default spec
2512 * (not true for version; $SEARCH may have added version of existing file).
2514 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2515 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2516 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2517 if (trimver || trimtype) {
2518 if (defspec && *defspec) {
2519 char defesa[NAM$C_MAXRSS];
2520 struct FAB deffab = cc$rms_fab;
2521 struct NAM defnam = cc$rms_nam;
2523 deffab.fab$l_nam = &defnam;
2524 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2525 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2526 defnam.nam$b_nop = NAM$M_SYNCHK;
2527 if (sys$parse(&deffab,0,0) & 1) {
2528 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2529 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2532 if (trimver) speclen = mynam.nam$l_ver - out;
2534 /* If we didn't already trim version, copy down */
2535 if (speclen > mynam.nam$l_ver - out)
2536 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2537 speclen - (mynam.nam$l_ver - out));
2538 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2541 /* If we just had a directory spec on input, $PARSE "helpfully"
2542 * adds an empty name and type for us */
2543 if (mynam.nam$l_name == mynam.nam$l_type &&
2544 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2545 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2546 speclen = mynam.nam$l_name - out;
2547 out[speclen] = '\0';
2548 if (haslower) __mystrtolower(out);
2550 /* Have we been working with an expanded, but not resultant, spec? */
2551 /* Also, convert back to Unix syntax if necessary. */
2552 if (!mynam.nam$b_rsl) {
2554 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2556 else strcpy(outbuf,esa);
2559 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2560 strcpy(outbuf,tmpfspec);
2562 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2563 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2564 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2568 /* External entry points */
2569 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2570 { return do_rmsexpand(spec,buf,0,def,opt); }
2571 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2572 { return do_rmsexpand(spec,buf,1,def,opt); }
2576 ** The following routines are provided to make life easier when
2577 ** converting among VMS-style and Unix-style directory specifications.
2578 ** All will take input specifications in either VMS or Unix syntax. On
2579 ** failure, all return NULL. If successful, the routines listed below
2580 ** return a pointer to a buffer containing the appropriately
2581 ** reformatted spec (and, therefore, subsequent calls to that routine
2582 ** will clobber the result), while the routines of the same names with
2583 ** a _ts suffix appended will return a pointer to a mallocd string
2584 ** containing the appropriately reformatted spec.
2585 ** In all cases, only explicit syntax is altered; no check is made that
2586 ** the resulting string is valid or that the directory in question
2589 ** fileify_dirspec() - convert a directory spec into the name of the
2590 ** directory file (i.e. what you can stat() to see if it's a dir).
2591 ** The style (VMS or Unix) of the result is the same as the style
2592 ** of the parameter passed in.
2593 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2594 ** what you prepend to a filename to indicate what directory it's in).
2595 ** The style (VMS or Unix) of the result is the same as the style
2596 ** of the parameter passed in.
2597 ** tounixpath() - convert a directory spec into a Unix-style path.
2598 ** tovmspath() - convert a directory spec into a VMS-style path.
2599 ** tounixspec() - convert any file spec into a Unix-style file spec.
2600 ** tovmsspec() - convert any file spec into a VMS-style spec.
2602 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2603 ** Permission is given to distribute this code as part of the Perl
2604 ** standard distribution under the terms of the GNU General Public
2605 ** License or the Perl Artistic License. Copies of each may be
2606 ** found in the Perl standard distribution.
2609 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2610 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2612 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2613 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2614 char *retspec, *cp1, *cp2, *lastdir;
2615 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2617 if (!dir || !*dir) {
2618 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2620 dirlen = strlen(dir);
2621 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2622 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2623 strcpy(trndir,"/sys$disk/000000");
2627 if (dirlen > NAM$C_MAXRSS) {
2628 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2630 if (!strpbrk(dir+1,"/]>:")) {
2631 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2632 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2634 dirlen = strlen(dir);
2637 strncpy(trndir,dir,dirlen);
2638 trndir[dirlen] = '\0';
2641 /* If we were handed a rooted logical name or spec, treat it like a
2642 * simple directory, so that
2643 * $ Define myroot dev:[dir.]
2644 * ... do_fileify_dirspec("myroot",buf,1) ...
2645 * does something useful.
2647 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2648 dir[--dirlen] = '\0';
2649 dir[dirlen-1] = ']';
2652 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2653 /* If we've got an explicit filename, we can just shuffle the string. */
2654 if (*(cp1+1)) hasfilename = 1;
2655 /* Similarly, we can just back up a level if we've got multiple levels
2656 of explicit directories in a VMS spec which ends with directories. */
2658 for (cp2 = cp1; cp2 > dir; cp2--) {
2660 *cp2 = *cp1; *cp1 = '\0';
2664 if (*cp2 == '[' || *cp2 == '<') break;
2669 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2670 if (dir[0] == '.') {
2671 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2672 return do_fileify_dirspec("[]",buf,ts);
2673 else if (dir[1] == '.' &&
2674 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2675 return do_fileify_dirspec("[-]",buf,ts);
2677 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2678 dirlen -= 1; /* to last element */
2679 lastdir = strrchr(dir,'/');
2681 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2682 /* If we have "/." or "/..", VMSify it and let the VMS code
2683 * below expand it, rather than repeating the code to handle
2684 * relative components of a filespec here */
2686 if (*(cp1+2) == '.') cp1++;
2687 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2688 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2689 if (strchr(vmsdir,'/') != NULL) {
2690 /* If do_tovmsspec() returned it, it must have VMS syntax
2691 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2692 * the time to check this here only so we avoid a recursion
2693 * loop; otherwise, gigo.
2695 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2697 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2698 return do_tounixspec(trndir,buf,ts);
2701 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2702 lastdir = strrchr(dir,'/');
2704 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2705 /* Ditto for specs that end in an MFD -- let the VMS code
2706 * figure out whether it's a real device or a rooted logical. */
2707 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2708 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2709 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2710 return do_tounixspec(trndir,buf,ts);
2713 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2714 !(lastdir = cp1 = strrchr(dir,']')) &&
2715 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2716 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2718 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2719 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2720 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2721 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2722 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2723 (ver || *cp3)))))) {
2725 set_vaxc_errno(RMS$_DIR);
2731 /* If we lead off with a device or rooted logical, add the MFD
2732 if we're specifying a top-level directory. */
2733 if (lastdir && *dir == '/') {
2735 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2742 retlen = dirlen + (addmfd ? 13 : 6);
2743 if (buf) retspec = buf;
2744 else if (ts) New(1309,retspec,retlen+1,char);
2745 else retspec = __fileify_retbuf;
2747 dirlen = lastdir - dir;
2748 memcpy(retspec,dir,dirlen);
2749 strcpy(&retspec[dirlen],"/000000");
2750 strcpy(&retspec[dirlen+7],lastdir);
2753 memcpy(retspec,dir,dirlen);
2754 retspec[dirlen] = '\0';
2756 /* We've picked up everything up to the directory file name.
2757 Now just add the type and version, and we're set. */
2758 strcat(retspec,".dir;1");
2761 else { /* VMS-style directory spec */
2762 char esa[NAM$C_MAXRSS+1], term, *cp;
2763 unsigned long int sts, cmplen, haslower = 0;
2764 struct FAB dirfab = cc$rms_fab;
2765 struct NAM savnam, dirnam = cc$rms_nam;
2767 dirfab.fab$b_fns = strlen(dir);
2768 dirfab.fab$l_fna = dir;
2769 dirfab.fab$l_nam = &dirnam;
2770 dirfab.fab$l_dna = ".DIR;1";
2771 dirfab.fab$b_dns = 6;
2772 dirnam.nam$b_ess = NAM$C_MAXRSS;
2773 dirnam.nam$l_esa = esa;
2775 for (cp = dir; *cp; cp++)
2776 if (islower(*cp)) { haslower = 1; break; }
2777 if (!((sts = sys$parse(&dirfab))&1)) {
2778 if (dirfab.fab$l_sts == RMS$_DIR) {
2779 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2780 sts = sys$parse(&dirfab) & 1;
2784 set_vaxc_errno(dirfab.fab$l_sts);
2790 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2791 /* Yes; fake the fnb bits so we'll check type below */
2792 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2794 else { /* No; just work with potential name */
2795 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2797 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2798 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2799 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2804 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2805 cp1 = strchr(esa,']');
2806 if (!cp1) cp1 = strchr(esa,'>');
2807 if (cp1) { /* Should always be true */
2808 dirnam.nam$b_esl -= cp1 - esa - 1;
2809 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2812 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2813 /* Yep; check version while we're at it, if it's there. */
2814 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2815 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2816 /* Something other than .DIR[;1]. Bzzt. */
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);
2820 set_vaxc_errno(RMS$_DIR);
2824 esa[dirnam.nam$b_esl] = '\0';
2825 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2826 /* They provided at least the name; we added the type, if necessary, */
2827 if (buf) retspec = buf; /* in sys$parse() */
2828 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2829 else retspec = __fileify_retbuf;
2830 strcpy(retspec,esa);
2831 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2832 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2835 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2836 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2838 dirnam.nam$b_esl -= 9;
2840 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2841 if (cp1 == NULL) { /* should never happen */
2842 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2843 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2848 retlen = strlen(esa);
2849 if ((cp1 = strrchr(esa,'.')) != NULL) {
2850 /* There's more than one directory in the path. Just roll back. */
2852 if (buf) retspec = buf;
2853 else if (ts) New(1311,retspec,retlen+7,char);
2854 else retspec = __fileify_retbuf;
2855 strcpy(retspec,esa);
2858 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2859 /* Go back and expand rooted logical name */
2860 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2861 if (!(sys$parse(&dirfab) & 1)) {
2862 dirnam.nam$l_rlf = NULL;
2863 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2865 set_vaxc_errno(dirfab.fab$l_sts);
2868 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2869 if (buf) retspec = buf;
2870 else if (ts) New(1312,retspec,retlen+16,char);
2871 else retspec = __fileify_retbuf;
2872 cp1 = strstr(esa,"][");
2874 memcpy(retspec,esa,dirlen);
2875 if (!strncmp(cp1+2,"000000]",7)) {
2876 retspec[dirlen-1] = '\0';
2877 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2878 if (*cp1 == '.') *cp1 = ']';
2880 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2881 memcpy(cp1+1,"000000]",7);
2885 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2886 retspec[retlen] = '\0';
2887 /* Convert last '.' to ']' */
2888 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2889 if (*cp1 == '.') *cp1 = ']';
2891 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2892 memcpy(cp1+1,"000000]",7);
2896 else { /* This is a top-level dir. Add the MFD to the path. */
2897 if (buf) retspec = buf;
2898 else if (ts) New(1312,retspec,retlen+16,char);
2899 else retspec = __fileify_retbuf;
2902 while (*cp1 != ':') *(cp2++) = *(cp1++);
2903 strcpy(cp2,":[000000]");
2908 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2909 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2910 /* We've set up the string up through the filename. Add the
2911 type and version, and we're done. */
2912 strcat(retspec,".DIR;1");
2914 /* $PARSE may have upcased filespec, so convert output to lower
2915 * case if input contained any lowercase characters. */
2916 if (haslower) __mystrtolower(retspec);
2919 } /* end of do_fileify_dirspec() */
2921 /* External entry points */
2922 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2923 { return do_fileify_dirspec(dir,buf,0); }
2924 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2925 { return do_fileify_dirspec(dir,buf,1); }
2927 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2928 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2930 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2931 unsigned long int retlen;
2932 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2934 if (!dir || !*dir) {
2935 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2938 if (*dir) strcpy(trndir,dir);
2939 else getcwd(trndir,sizeof trndir - 1);
2941 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2942 && my_trnlnm(trndir,trndir,0)) {
2943 STRLEN trnlen = strlen(trndir);
2945 /* Trap simple rooted lnms, and return lnm:[000000] */
2946 if (!strcmp(trndir+trnlen-2,".]")) {
2947 if (buf) retpath = buf;
2948 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2949 else retpath = __pathify_retbuf;
2950 strcpy(retpath,dir);
2951 strcat(retpath,":[000000]");
2957 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2958 if (*dir == '.' && (*(dir+1) == '\0' ||
2959 (*(dir+1) == '.' && *(dir+2) == '\0')))
2960 retlen = 2 + (*(dir+1) != '\0');
2962 if ( !(cp1 = strrchr(dir,'/')) &&
2963 !(cp1 = strrchr(dir,']')) &&
2964 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2965 if ((cp2 = strchr(cp1,'.')) != NULL &&
2966 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2967 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2968 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2969 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2971 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2972 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2973 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2974 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2975 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2976 (ver || *cp3)))))) {
2978 set_vaxc_errno(RMS$_DIR);
2981 retlen = cp2 - dir + 1;
2983 else { /* No file type present. Treat the filename as a directory. */
2984 retlen = strlen(dir) + 1;
2987 if (buf) retpath = buf;
2988 else if (ts) New(1313,retpath,retlen+1,char);
2989 else retpath = __pathify_retbuf;
2990 strncpy(retpath,dir,retlen-1);
2991 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2992 retpath[retlen-1] = '/'; /* with '/', add it. */
2993 retpath[retlen] = '\0';
2995 else retpath[retlen-1] = '\0';
2997 else { /* VMS-style directory spec */
2998 char esa[NAM$C_MAXRSS+1], *cp;
2999 unsigned long int sts, cmplen, haslower;
3000 struct FAB dirfab = cc$rms_fab;
3001 struct NAM savnam, dirnam = cc$rms_nam;
3003 /* If we've got an explicit filename, we can just shuffle the string. */
3004 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3005 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3006 if ((cp2 = strchr(cp1,'.')) != NULL) {
3008 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3009 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3010 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3011 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3012 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3013 (ver || *cp3)))))) {
3015 set_vaxc_errno(RMS$_DIR);
3019 else { /* No file type, so just draw name into directory part */
3020 for (cp2 = cp1; *cp2; cp2++) ;
3023 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3025 /* We've now got a VMS 'path'; fall through */
3027 dirfab.fab$b_fns = strlen(dir);
3028 dirfab.fab$l_fna = dir;
3029 if (dir[dirfab.fab$b_fns-1] == ']' ||
3030 dir[dirfab.fab$b_fns-1] == '>' ||
3031 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3032 if (buf) retpath = buf;
3033 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3034 else retpath = __pathify_retbuf;
3035 strcpy(retpath,dir);
3038 dirfab.fab$l_dna = ".DIR;1";
3039 dirfab.fab$b_dns = 6;
3040 dirfab.fab$l_nam = &dirnam;
3041 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3042 dirnam.nam$l_esa = esa;
3044 for (cp = dir; *cp; cp++)
3045 if (islower(*cp)) { haslower = 1; break; }
3047 if (!(sts = (sys$parse(&dirfab)&1))) {
3048 if (dirfab.fab$l_sts == RMS$_DIR) {
3049 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3050 sts = sys$parse(&dirfab) & 1;
3054 set_vaxc_errno(dirfab.fab$l_sts);
3060 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3061 if (dirfab.fab$l_sts != RMS$_FNF) {
3062 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3063 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3065 set_vaxc_errno(dirfab.fab$l_sts);
3068 dirnam = savnam; /* No; just work with potential name */
3071 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3072 /* Yep; check version while we're at it, if it's there. */
3073 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3074 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3075 /* Something other than .DIR[;1]. Bzzt. */
3076 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3077 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3079 set_vaxc_errno(RMS$_DIR);
3083 /* OK, the type was fine. Now pull any file name into the
3085 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3087 cp1 = strrchr(esa,'>');
3088 *dirnam.nam$l_type = '>';
3091 *(dirnam.nam$l_type + 1) = '\0';
3092 retlen = dirnam.nam$l_type - esa + 2;
3093 if (buf) retpath = buf;
3094 else if (ts) New(1314,retpath,retlen,char);
3095 else retpath = __pathify_retbuf;
3096 strcpy(retpath,esa);
3097 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3098 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3099 /* $PARSE may have upcased filespec, so convert output to lower
3100 * case if input contained any lowercase characters. */
3101 if (haslower) __mystrtolower(retpath);
3105 } /* end of do_pathify_dirspec() */
3107 /* External entry points */
3108 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3109 { return do_pathify_dirspec(dir,buf,0); }
3110 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3111 { return do_pathify_dirspec(dir,buf,1); }
3113 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3114 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3116 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3117 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3118 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3120 if (spec == NULL) return NULL;
3121 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3122 if (buf) rslt = buf;
3124 retlen = strlen(spec);
3125 cp1 = strchr(spec,'[');
3126 if (!cp1) cp1 = strchr(spec,'<');
3128 for (cp1++; *cp1; cp1++) {
3129 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3130 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3131 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3134 New(1315,rslt,retlen+2+2*expand,char);
3136 else rslt = __tounixspec_retbuf;
3137 if (strchr(spec,'/') != NULL) {
3144 dirend = strrchr(spec,']');
3145 if (dirend == NULL) dirend = strrchr(spec,'>');
3146 if (dirend == NULL) dirend = strchr(spec,':');
3147 if (dirend == NULL) {
3151 if (*cp2 != '[' && *cp2 != '<') {
3154 else { /* the VMS spec begins with directories */
3156 if (*cp2 == ']' || *cp2 == '>') {
3157 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3160 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3161 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3162 if (ts) Safefree(rslt);
3167 while (*cp3 != ':' && *cp3) cp3++;
3169 if (strchr(cp3,']') != NULL) break;
3170 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3172 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3173 retlen = devlen + dirlen;
3174 Renew(rslt,retlen+1+2*expand,char);
3180 *(cp1++) = *(cp3++);
3181 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3185 else if ( *cp2 == '.') {
3186 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3187 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3193 for (; cp2 <= dirend; cp2++) {
3196 if (*(cp2+1) == '[') cp2++;
3198 else if (*cp2 == ']' || *cp2 == '>') {
3199 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3201 else if (*cp2 == '.') {
3203 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3204 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3205 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3206 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3207 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3209 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3210 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3214 else if (*cp2 == '-') {
3215 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3216 while (*cp2 == '-') {
3218 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3220 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3221 if (ts) Safefree(rslt); /* filespecs like */
3222 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3226 else *(cp1++) = *cp2;
3228 else *(cp1++) = *cp2;
3230 while (*cp2) *(cp1++) = *(cp2++);
3235 } /* end of do_tounixspec() */
3237 /* External entry points */
3238 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3239 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3241 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3242 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3243 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3244 char *rslt, *dirend;
3245 register char *cp1, *cp2;
3246 unsigned long int infront = 0, hasdir = 1;
3248 if (path == NULL) return NULL;
3249 if (buf) rslt = buf;
3250 else if (ts) New(1316,rslt,strlen(path)+9,char);
3251 else rslt = __tovmsspec_retbuf;
3252 if (strpbrk(path,"]:>") ||
3253 (dirend = strrchr(path,'/')) == NULL) {
3254 if (path[0] == '.') {
3255 if (path[1] == '\0') strcpy(rslt,"[]");
3256 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3257 else strcpy(rslt,path); /* probably garbage */
3259 else strcpy(rslt,path);
3262 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3263 if (!*(dirend+2)) dirend +=2;
3264 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3265 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3270 char trndev[NAM$C_MAXRSS+1];
3274 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3276 if (!buf & ts) Renew(rslt,18,char);
3277 strcpy(rslt,"sys$disk:[000000]");
3280 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3282 islnm = my_trnlnm(rslt,trndev,0);
3283 trnend = islnm ? strlen(trndev) - 1 : 0;
3284 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3285 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3286 /* If the first element of the path is a logical name, determine
3287 * whether it has to be translated so we can add more directories. */
3288 if (!islnm || rooted) {
3291 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3295 if (cp2 != dirend) {
3296 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3297 strcpy(rslt,trndev);
3298 cp1 = rslt + trnend;
3311 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3312 cp2 += 2; /* skip over "./" - it's redundant */
3313 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3315 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3316 *(cp1++) = '-'; /* "../" --> "-" */
3319 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3320 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3321 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3322 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3325 if (cp2 > dirend) cp2 = dirend;
3327 else *(cp1++) = '.';
3329 for (; cp2 < dirend; cp2++) {
3331 if (*(cp2-1) == '/') continue;
3332 if (*(cp1-1) != '.') *(cp1++) = '.';
3335 else if (!infront && *cp2 == '.') {
3336 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3337 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3338 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3339 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3340 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3341 else { /* back up over previous directory name */
3343 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3344 if (*(cp1-1) == '[') {
3345 memcpy(cp1,"000000.",7);
3350 if (cp2 == dirend) break;
3352 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3353 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3354 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3355 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3357 *(cp1++) = '.'; /* Simulate trailing '/' */
3358 cp2 += 2; /* for loop will incr this to == dirend */
3360 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3362 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3365 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3366 if (*cp2 == '.') *(cp1++) = '_';
3367 else *(cp1++) = *cp2;
3371 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3372 if (hasdir) *(cp1++) = ']';
3373 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3374 while (*cp2) *(cp1++) = *(cp2++);
3379 } /* end of do_tovmsspec() */
3381 /* External entry points */
3382 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3383 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3385 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3386 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3387 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3389 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3391 if (path == NULL) return NULL;
3392 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3393 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3394 if (buf) return buf;
3396 vmslen = strlen(vmsified);
3397 New(1317,cp,vmslen+1,char);
3398 memcpy(cp,vmsified,vmslen);
3403 strcpy(__tovmspath_retbuf,vmsified);
3404 return __tovmspath_retbuf;
3407 } /* end of do_tovmspath() */
3409 /* External entry points */
3410 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3411 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3414 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3415 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3416 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3418 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3420 if (path == NULL) return NULL;
3421 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3422 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3423 if (buf) return buf;
3425 unixlen = strlen(unixified);
3426 New(1317,cp,unixlen+1,char);
3427 memcpy(cp,unixified,unixlen);
3432 strcpy(__tounixpath_retbuf,unixified);
3433 return __tounixpath_retbuf;
3436 } /* end of do_tounixpath() */
3438 /* External entry points */
3439 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3440 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3443 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3445 *****************************************************************************
3447 * Copyright (C) 1989-1994 by *
3448 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3450 * Permission is hereby granted for the reproduction of this software, *
3451 * on condition that this copyright notice is included in the reproduction, *
3452 * and that such reproduction is not for purposes of profit or material *
3455 * 27-Aug-1994 Modified for inclusion in perl5 *
3456 * by Charles Bailey bailey@newman.upenn.edu *
3457 *****************************************************************************
3461 * getredirection() is intended to aid in porting C programs
3462 * to VMS (Vax-11 C). The native VMS environment does not support
3463 * '>' and '<' I/O redirection, or command line wild card expansion,
3464 * or a command line pipe mechanism using the '|' AND background
3465 * command execution '&'. All of these capabilities are provided to any
3466 * C program which calls this procedure as the first thing in the
3468 * The piping mechanism will probably work with almost any 'filter' type
3469 * of program. With suitable modification, it may useful for other
3470 * portability problems as well.
3472 * Author: Mark Pizzolato mark@infocomm.com
3476 struct list_item *next;
3480 static void add_item(struct list_item **head,
3481 struct list_item **tail,
3485 static void mp_expand_wild_cards(pTHX_ char *item,
3486 struct list_item **head,
3487 struct list_item **tail,
3490 static int background_process(int argc, char **argv);
3492 static void pipe_and_fork(pTHX_ char **cmargv);
3494 /*{{{ void getredirection(int *ac, char ***av)*/
3496 mp_getredirection(pTHX_ int *ac, char ***av)
3498 * Process vms redirection arg's. Exit if any error is seen.
3499 * If getredirection() processes an argument, it is erased
3500 * from the vector. getredirection() returns a new argc and argv value.
3501 * In the event that a background command is requested (by a trailing "&"),
3502 * this routine creates a background subprocess, and simply exits the program.
3504 * Warning: do not try to simplify the code for vms. The code
3505 * presupposes that getredirection() is called before any data is
3506 * read from stdin or written to stdout.
3508 * Normal usage is as follows:
3514 * getredirection(&argc, &argv);
3518 int argc = *ac; /* Argument Count */
3519 char **argv = *av; /* Argument Vector */
3520 char *ap; /* Argument pointer */
3521 int j; /* argv[] index */
3522 int item_count = 0; /* Count of Items in List */
3523 struct list_item *list_head = 0; /* First Item in List */
3524 struct list_item *list_tail; /* Last Item in List */
3525 char *in = NULL; /* Input File Name */
3526 char *out = NULL; /* Output File Name */
3527 char *outmode = "w"; /* Mode to Open Output File */
3528 char *err = NULL; /* Error File Name */
3529 char *errmode = "w"; /* Mode to Open Error File */
3530 int cmargc = 0; /* Piped Command Arg Count */
3531 char **cmargv = NULL;/* Piped Command Arg Vector */
3534 * First handle the case where the last thing on the line ends with
3535 * a '&'. This indicates the desire for the command to be run in a
3536 * subprocess, so we satisfy that desire.
3539 if (0 == strcmp("&", ap))
3540 exit(background_process(--argc, argv));
3541 if (*ap && '&' == ap[strlen(ap)-1])
3543 ap[strlen(ap)-1] = '\0';
3544 exit(background_process(argc, argv));
3547 * Now we handle the general redirection cases that involve '>', '>>',
3548 * '<', and pipes '|'.
3550 for (j = 0; j < argc; ++j)
3552 if (0 == strcmp("<", argv[j]))
3556 fprintf(stderr,"No input file after < on command line");
3557 exit(LIB$_WRONUMARG);
3562 if ('<' == *(ap = argv[j]))
3567 if (0 == strcmp(">", ap))
3571 fprintf(stderr,"No output file after > on command line");
3572 exit(LIB$_WRONUMARG);
3591 fprintf(stderr,"No output file after > or >> on command line");
3592 exit(LIB$_WRONUMARG);
3596 if (('2' == *ap) && ('>' == ap[1]))
3613 fprintf(stderr,"No output file after 2> or 2>> on command line");
3614 exit(LIB$_WRONUMARG);
3618 if (0 == strcmp("|", argv[j]))
3622 fprintf(stderr,"No command into which to pipe on command line");
3623 exit(LIB$_WRONUMARG);
3625 cmargc = argc-(j+1);
3626 cmargv = &argv[j+1];
3630 if ('|' == *(ap = argv[j]))
3638 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3641 * Allocate and fill in the new argument vector, Some Unix's terminate
3642 * the list with an extra null pointer.
3644 New(1302, argv, item_count+1, char *);
3646 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3647 argv[j] = list_head->value;
3653 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3654 exit(LIB$_INVARGORD);
3656 pipe_and_fork(aTHX_ cmargv);
3659 /* Check for input from a pipe (mailbox) */
3661 if (in == NULL && 1 == isapipe(0))
3663 char mbxname[L_tmpnam];
3665 long int dvi_item = DVI$_DEVBUFSIZ;
3666 $DESCRIPTOR(mbxnam, "");
3667 $DESCRIPTOR(mbxdevnam, "");
3669 /* Input from a pipe, reopen it in binary mode to disable */
3670 /* carriage control processing. */
3672 fgetname(stdin, mbxname);
3673 mbxnam.dsc$a_pointer = mbxname;
3674 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3675 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3676 mbxdevnam.dsc$a_pointer = mbxname;
3677 mbxdevnam.dsc$w_length = sizeof(mbxname);
3678 dvi_item = DVI$_DEVNAM;
3679 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3680 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3683 freopen(mbxname, "rb", stdin);
3686 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3690 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3692 fprintf(stderr,"Can't open input file %s as stdin",in);
3695 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3697 fprintf(stderr,"Can't open output file %s as stdout",out);
3700 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3703 if (strcmp(err,"&1") == 0) {
3704 dup2(fileno(stdout), fileno(stderr));
3705 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3708 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3710 fprintf(stderr,"Can't open error file %s as stderr",err);
3714 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3718 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3721 #ifdef ARGPROC_DEBUG
3722 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3723 for (j = 0; j < *ac; ++j)
3724 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3726 /* Clear errors we may have hit expanding wildcards, so they don't
3727 show up in Perl's $! later */
3728 set_errno(0); set_vaxc_errno(1);
3729 } /* end of getredirection() */
3732 static void add_item(struct list_item **head,
3733 struct list_item **tail,
3739 New(1303,*head,1,struct list_item);
3743 New(1304,(*tail)->next,1,struct list_item);
3744 *tail = (*tail)->next;
3746 (*tail)->value = value;
3750 static void mp_expand_wild_cards(pTHX_ char *item,
3751 struct list_item **head,
3752 struct list_item **tail,
3756 unsigned long int context = 0;
3762 char vmsspec[NAM$C_MAXRSS+1];
3763 $DESCRIPTOR(filespec, "");
3764 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3765 $DESCRIPTOR(resultspec, "");
3766 unsigned long int zero = 0, sts;
3768 for (cp = item; *cp; cp++) {
3769 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3770 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3772 if (!*cp || isspace(*cp))
3774 add_item(head, tail, item, count);
3777 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3778 resultspec.dsc$b_class = DSC$K_CLASS_D;
3779 resultspec.dsc$a_pointer = NULL;
3780 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3781 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3782 if (!isunix || !filespec.dsc$a_pointer)
3783 filespec.dsc$a_pointer = item;
3784 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3786 * Only return version specs, if the caller specified a version
3788 had_version = strchr(item, ';');
3790 * Only return device and directory specs, if the caller specifed either.
3792 had_device = strchr(item, ':');
3793 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3795 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3796 &defaultspec, 0, 0, &zero))))
3801 New(1305,string,resultspec.dsc$w_length+1,char);
3802 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3803 string[resultspec.dsc$w_length] = '\0';
3804 if (NULL == had_version)
3805 *((char *)strrchr(string, ';')) = '\0';
3806 if ((!had_directory) && (had_device == NULL))
3808 if (NULL == (devdir = strrchr(string, ']')))
3809 devdir = strrchr(string, '>');
3810 strcpy(string, devdir + 1);
3813 * Be consistent with what the C RTL has already done to the rest of
3814 * the argv items and lowercase all of these names.
3816 for (c = string; *c; ++c)
3819 if (isunix) trim_unixpath(string,item,1);
3820 add_item(head, tail, string, count);
3823 if (sts != RMS$_NMF)
3825 set_vaxc_errno(sts);
3828 case RMS$_FNF: case RMS$_DNF:
3829 set_errno(ENOENT); break;
3831 set_errno(ENOTDIR); break;
3833 set_errno(ENODEV); break;
3834 case RMS$_FNM: case RMS$_SYN:
3835 set_errno(EINVAL); break;
3837 set_errno(EACCES); break;
3839 _ckvmssts_noperl(sts);
3843 add_item(head, tail, item, count);
3844 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3845 _ckvmssts_noperl(lib$find_file_end(&context));
3848 static int child_st[2];/* Event Flag set when child process completes */
3850 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3852 static unsigned long int exit_handler(int *status)
3856 if (0 == child_st[0])
3858 #ifdef ARGPROC_DEBUG
3859 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3861 fflush(stdout); /* Have to flush pipe for binary data to */
3862 /* terminate properly -- <tp@mccall.com> */
3863 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3864 sys$dassgn(child_chan);
3866 sys$synch(0, child_st);
3871 static void sig_child(int chan)
3873 #ifdef ARGPROC_DEBUG
3874 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3876 if (child_st[0] == 0)
3880 static struct exit_control_block exit_block =
3885 &exit_block.exit_status,
3889 static void pipe_and_fork(pTHX_ char **cmargv)
3892 $DESCRIPTOR(cmddsc, "");
3893 static char mbxname[64];
3894 $DESCRIPTOR(mbxdsc, mbxname);
3896 unsigned long int zero = 0, one = 1;
3898 strcpy(subcmd, cmargv[0]);
3899 for (j = 1; NULL != cmargv[j]; ++j)
3901 strcat(subcmd, " \"");
3902 strcat(subcmd, cmargv[j]);
3903 strcat(subcmd, "\"");
3905 cmddsc.dsc$a_pointer = subcmd;
3906 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3908 create_mbx(aTHX_ &child_chan,&mbxdsc);
3909 #ifdef ARGPROC_DEBUG
3910 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3911 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3913 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3914 0, &pid, child_st, &zero, sig_child,
3916 #ifdef ARGPROC_DEBUG
3917 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3919 sys$dclexh(&exit_block);
3920 if (NULL == freopen(mbxname, "wb", stdout))
3922 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3926 static int background_process(int argc, char **argv)
3928 char command[2048] = "$";
3929 $DESCRIPTOR(value, "");
3930 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3931 static $DESCRIPTOR(null, "NLA0:");
3932 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3934 $DESCRIPTOR(pidstr, "");
3936 unsigned long int flags = 17, one = 1, retsts;
3938 strcat(command, argv[0]);
3941 strcat(command, " \"");
3942 strcat(command, *(++argv));
3943 strcat(command, "\"");
3945 value.dsc$a_pointer = command;
3946 value.dsc$w_length = strlen(value.dsc$a_pointer);
3947 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3948 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3949 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3950 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3953 _ckvmssts_noperl(retsts);
3955 #ifdef ARGPROC_DEBUG
3956 PerlIO_printf(Perl_debug_log, "%s\n", command);
3958 sprintf(pidstring, "%08X", pid);
3959 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3960 pidstr.dsc$a_pointer = pidstring;
3961 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3962 lib$set_symbol(&pidsymbol, &pidstr);
3966 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3969 /* OS-specific initialization at image activation (not thread startup) */
3970 /* Older VAXC header files lack these constants */
3971 #ifndef JPI$_RIGHTS_SIZE
3972 # define JPI$_RIGHTS_SIZE 817
3974 #ifndef KGB$M_SUBSYSTEM
3975 # define KGB$M_SUBSYSTEM 0x8
3978 /*{{{void vms_image_init(int *, char ***)*/
3980 vms_image_init(int *argcp, char ***argvp)
3982 char eqv[LNM$C_NAMLENGTH+1] = "";
3983 unsigned int len, tabct = 8, tabidx = 0;
3984 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3985 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3986 unsigned short int dummy, rlen;
3987 struct dsc$descriptor_s **tabvec;
3988 #if defined(PERL_IMPLICIT_CONTEXT)
3991 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3992 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3993 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3996 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3997 _ckvmssts_noperl(iosb[0]);
3998 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3999 if (iprv[i]) { /* Running image installed with privs? */
4000 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4005 /* Rights identifiers might trigger tainting as well. */
4006 if (!will_taint && (rlen || rsz)) {
4007 while (rlen < rsz) {
4008 /* We didn't get all the identifiers on the first pass. Allocate a
4009 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4010 * were needed to hold all identifiers at time of last call; we'll
4011 * allocate that many unsigned long ints), and go back and get 'em.
4012 * If it gave us less than it wanted to despite ample buffer space,
4013 * something's broken. Is your system missing a system identifier?
4015 if (rsz <= jpilist[1].buflen) {
4016 /* Perl_croak accvios when used this early in startup. */
4017 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4018 rsz, (unsigned long) jpilist[1].buflen,
4019 "Check your rights database for corruption.\n");
4022 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4023 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4024 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4025 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4026 _ckvmssts_noperl(iosb[0]);
4028 mask = jpilist[1].bufadr;
4029 /* Check attribute flags for each identifier (2nd longword); protected
4030 * subsystem identifiers trigger tainting.
4032 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4033 if (mask[i] & KGB$M_SUBSYSTEM) {
4038 if (mask != rlst) Safefree(mask);
4040 /* We need to use this hack to tell Perl it should run with tainting,
4041 * since its tainting flag may be part of the PL_curinterp struct, which
4042 * hasn't been allocated when vms_image_init() is called.
4046 New(1320,newap,*argcp+2,char **);
4047 newap[0] = argvp[0];
4049 Copy(argvp[1],newap[2],*argcp-1,char **);
4050 /* We orphan the old argv, since we don't know where it's come from,
4051 * so we don't know how to free it.
4053 *argcp++; argvp = newap;
4055 else { /* Did user explicitly request tainting? */
4057 char *cp, **av = *argvp;
4058 for (i = 1; i < *argcp; i++) {
4059 if (*av[i] != '-') break;
4060 for (cp = av[i]+1; *cp; cp++) {
4061 if (*cp == 'T') { will_taint = 1; break; }
4062 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4063 strchr("DFIiMmx",*cp)) break;
4065 if (will_taint) break;
4070 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4072 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4073 else if (tabidx >= tabct) {
4075 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4077 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4078 tabvec[tabidx]->dsc$w_length = 0;
4079 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4080 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4081 tabvec[tabidx]->dsc$a_pointer = NULL;
4082 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4084 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4086 getredirection(argcp,argvp);
4087 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4089 # include <reentrancy.h>
4090 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4099 * Trim Unix-style prefix off filespec, so it looks like what a shell
4100 * glob expansion would return (i.e. from specified prefix on, not
4101 * full path). Note that returned filespec is Unix-style, regardless
4102 * of whether input filespec was VMS-style or Unix-style.
4104 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4105 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4106 * vector of options; at present, only bit 0 is used, and if set tells
4107 * trim unixpath to try the current default directory as a prefix when
4108 * presented with a possibly ambiguous ... wildcard.
4110 * Returns !=0 on success, with trimmed filespec replacing contents of
4111 * fspec, and 0 on failure, with contents of fpsec unchanged.
4113 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4115 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4117 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4118 *template, *base, *end, *cp1, *cp2;
4119 register int tmplen, reslen = 0, dirs = 0;
4121 if (!wildspec || !fspec) return 0;
4122 if (strpbrk(wildspec,"]>:") != NULL) {
4123 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4124 else template = unixwild;
4126 else template = wildspec;
4127 if (strpbrk(fspec,"]>:") != NULL) {
4128 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4129 else base = unixified;
4130 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4131 * check to see that final result fits into (isn't longer than) fspec */
4132 reslen = strlen(fspec);
4136 /* No prefix or absolute path on wildcard, so nothing to remove */
4137 if (!*template || *template == '/') {
4138 if (base == fspec) return 1;
4139 tmplen = strlen(unixified);
4140 if (tmplen > reslen) return 0; /* not enough space */
4141 /* Copy unixified resultant, including trailing NUL */
4142 memmove(fspec,unixified,tmplen+1);
4146 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4147 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4148 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4149 for (cp1 = end ;cp1 >= base; cp1--)
4150 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4152 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4156 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4157 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4158 int ells = 1, totells, segdirs, match;
4159 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4160 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4162 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4164 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4165 if (ellipsis == template && opts & 1) {
4166 /* Template begins with an ellipsis. Since we can't tell how many
4167 * directory names at the front of the resultant to keep for an
4168 * arbitrary starting point, we arbitrarily choose the current
4169 * default directory as a starting point. If it's there as a prefix,
4170 * clip it off. If not, fall through and act as if the leading
4171 * ellipsis weren't there (i.e. return shortest possible path that
4172 * could match template).
4174 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4175 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4176 if (_tolower(*cp1) != _tolower(*cp2)) break;
4177 segdirs = dirs - totells; /* Min # of dirs we must have left */
4178 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4179 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4180 memcpy(fspec,cp2+1,end - cp2);
4184 /* First off, back up over constant elements at end of path */
4186 for (front = end ; front >= base; front--)
4187 if (*front == '/' && !dirs--) { front++; break; }
4189 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4190 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4191 if (cp1 != '\0') return 0; /* Path too long. */
4193 *cp2 = '\0'; /* Pick up with memcpy later */
4194 lcfront = lcres + (front - base);
4195 /* Now skip over each ellipsis and try to match the path in front of it. */
4197 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4198 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4199 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4200 if (cp1 < template) break; /* template started with an ellipsis */
4201 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4202 ellipsis = cp1; continue;
4204 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4206 for (segdirs = 0, cp2 = tpl;
4207 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4209 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4210 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4211 if (*cp2 == '/') segdirs++;
4213 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4214 /* Back up at least as many dirs as in template before matching */
4215 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4216 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4217 for (match = 0; cp1 > lcres;) {
4218 resdsc.dsc$a_pointer = cp1;
4219 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4221 if (match == 1) lcfront = cp1;
4223 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4225 if (!match) return 0; /* Can't find prefix ??? */
4226 if (match > 1 && opts & 1) {
4227 /* This ... wildcard could cover more than one set of dirs (i.e.
4228 * a set of similar dir names is repeated). If the template
4229 * contains more than 1 ..., upstream elements could resolve the
4230 * ambiguity, but it's not worth a full backtracking setup here.
4231 * As a quick heuristic, clip off the current default directory
4232 * if it's present to find the trimmed spec, else use the
4233 * shortest string that this ... could cover.
4235 char def[NAM$C_MAXRSS+1], *st;
4237 if (getcwd(def, sizeof def,0) == NULL) return 0;
4238 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4239 if (_tolower(*cp1) != _tolower(*cp2)) break;
4240 segdirs = dirs - totells; /* Min # of dirs we must have left */
4241 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4242 if (*cp1 == '\0' && *cp2 == '/') {
4243 memcpy(fspec,cp2+1,end - cp2);
4246 /* Nope -- stick with lcfront from above and keep going. */
4249 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4254 } /* end of trim_unixpath() */
4259 * VMS readdir() routines.
4260 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4262 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4263 * Minor modifications to original routines.
4266 /* Number of elements in vms_versions array */
4267 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4270 * Open a directory, return a handle for later use.
4272 /*{{{ DIR *opendir(char*name) */
4274 Perl_opendir(pTHX_ char *name)
4277 char dir[NAM$C_MAXRSS+1];
4280 if (do_tovmspath(name,dir,0) == NULL) {
4283 if (flex_stat(dir,&sb) == -1) return NULL;
4284 if (!S_ISDIR(sb.st_mode)) {
4285 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4288 if (!cando_by_name(S_IRUSR,0,dir)) {
4289 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4292 /* Get memory for the handle, and the pattern. */
4294 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4296 /* Fill in the fields; mainly playing with the descriptor. */
4297 (void)sprintf(dd->pattern, "%s*.*",dir);
4300 dd->vms_wantversions = 0;
4301 dd->pat.dsc$a_pointer = dd->pattern;
4302 dd->pat.dsc$w_length = strlen(dd->pattern);
4303 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4304 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4307 } /* end of opendir() */
4311 * Set the flag to indicate we want versions or not.
4313 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4315 vmsreaddirversions(DIR *dd, int flag)
4317 dd->vms_wantversions = flag;
4322 * Free up an opened directory.
4324 /*{{{ void closedir(DIR *dd)*/
4328 (void)lib$find_file_end(&dd->context);
4329 Safefree(dd->pattern);
4330 Safefree((char *)dd);
4335 * Collect all the version numbers for the current file.
4338 collectversions(pTHX_ DIR *dd)
4340 struct dsc$descriptor_s pat;
4341 struct dsc$descriptor_s res;
4343 char *p, *text, buff[sizeof dd->entry.d_name];
4345 unsigned long context, tmpsts;
4347 /* Convenient shorthand. */
4350 /* Add the version wildcard, ignoring the "*.*" put on before */
4351 i = strlen(dd->pattern);
4352 New(1308,text,i + e->d_namlen + 3,char);
4353 (void)strcpy(text, dd->pattern);
4354 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4356 /* Set up the pattern descriptor. */
4357 pat.dsc$a_pointer = text;
4358 pat.dsc$w_length = i + e->d_namlen - 1;
4359 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4360 pat.dsc$b_class = DSC$K_CLASS_S;
4362 /* Set up result descriptor. */
4363 res.dsc$a_pointer = buff;
4364 res.dsc$w_length = sizeof buff - 2;
4365 res.dsc$b_dtype = DSC$K_DTYPE_T;
4366 res.dsc$b_class = DSC$K_CLASS_S;
4368 /* Read files, collecting versions. */
4369 for (context = 0, e->vms_verscount = 0;
4370 e->vms_verscount < VERSIZE(e);
4371 e->vms_verscount++) {
4372 tmpsts = lib$find_file(&pat, &res, &context);
4373 if (tmpsts == RMS$_NMF || context == 0) break;
4375 buff[sizeof buff - 1] = '\0';
4376 if ((p = strchr(buff, ';')))
4377 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4379 e->vms_versions[e->vms_verscount] = -1;
4382 _ckvmssts(lib$find_file_end(&context));
4385 } /* end of collectversions() */
4388 * Read the next entry from the directory.
4390 /*{{{ struct dirent *readdir(DIR *dd)*/
4392 Perl_readdir(pTHX_ DIR *dd)
4394 struct dsc$descriptor_s res;
4395 char *p, buff[sizeof dd->entry.d_name];
4396 unsigned long int tmpsts;
4398 /* Set up result descriptor, and get next file. */
4399 res.dsc$a_pointer = buff;
4400 res.dsc$w_length = sizeof buff - 2;
4401 res.dsc$b_dtype = DSC$K_DTYPE_T;
4402 res.dsc$b_class = DSC$K_CLASS_S;
4403 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4404 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4405 if (!(tmpsts & 1)) {
4406 set_vaxc_errno(tmpsts);
4409 set_errno(EACCES); break;
4411 set_errno(ENODEV); break;
4413 set_errno(ENOTDIR); break;
4414 case RMS$_FNF: case RMS$_DNF:
4415 set_errno(ENOENT); break;
4422 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4423 buff[sizeof buff - 1] = '\0';
4424 for (p = buff; *p; p++) *p = _tolower(*p);
4425 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4428 /* Skip any directory component and just copy the name. */
4429 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4430 else (void)strcpy(dd->entry.d_name, buff);
4432 /* Clobber the version. */
4433 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4435 dd->entry.d_namlen = strlen(dd->entry.d_name);
4436 dd->entry.vms_verscount = 0;
4437 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4440 } /* end of readdir() */
4444 * Return something that can be used in a seekdir later.
4446 /*{{{ long telldir(DIR *dd)*/
4455 * Return to a spot where we used to be. Brute force.
4457 /*{{{ void seekdir(DIR *dd,long count)*/
4459 Perl_seekdir(pTHX_ DIR *dd, long count)
4461 int vms_wantversions;
4463 /* If we haven't done anything yet... */
4467 /* Remember some state, and clear it. */
4468 vms_wantversions = dd->vms_wantversions;
4469 dd->vms_wantversions = 0;
4470 _ckvmssts(lib$find_file_end(&dd->context));
4473 /* The increment is in readdir(). */
4474 for (dd->count = 0; dd->count < count; )
4477 dd->vms_wantversions = vms_wantversions;
4479 } /* end of seekdir() */
4482 /* VMS subprocess management
4484 * my_vfork() - just a vfork(), after setting a flag to record that
4485 * the current script is trying a Unix-style fork/exec.
4487 * vms_do_aexec() and vms_do_exec() are called in response to the
4488 * perl 'exec' function. If this follows a vfork call, then they
4489 * call out the the regular perl routines in doio.c which do an
4490 * execvp (for those who really want to try this under VMS).
4491 * Otherwise, they do exactly what the perl docs say exec should
4492 * do - terminate the current script and invoke a new command
4493 * (See below for notes on command syntax.)
4495 * do_aspawn() and do_spawn() implement the VMS side of the perl
4496 * 'system' function.
4498 * Note on command arguments to perl 'exec' and 'system': When handled
4499 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4500 * are concatenated to form a DCL command string. If the first arg
4501 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4502 * the the command string is handed off to DCL directly. Otherwise,
4503 * the first token of the command is taken as the filespec of an image
4504 * to run. The filespec is expanded using a default type of '.EXE' and
4505 * the process defaults for device, directory, etc., and if found, the resultant
4506 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4507 * the command string as parameters. This is perhaps a bit complicated,
4508 * but I hope it will form a happy medium between what VMS folks expect
4509 * from lib$spawn and what Unix folks expect from exec.
4512 static int vfork_called;
4514 /*{{{int my_vfork()*/
4525 vms_execfree(pTHX) {
4527 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4530 if (VMScmd.dsc$a_pointer) {
4531 Safefree(VMScmd.dsc$a_pointer);
4532 VMScmd.dsc$w_length = 0;
4533 VMScmd.dsc$a_pointer = Nullch;
4538 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4540 char *junk, *tmps = Nullch;
4541 register size_t cmdlen = 0;
4548 tmps = SvPV(really,rlen);
4555 for (idx++; idx <= sp; idx++) {
4557 junk = SvPVx(*idx,rlen);
4558 cmdlen += rlen ? rlen + 1 : 0;
4561 New(401,PL_Cmd,cmdlen+1,char);
4563 if (tmps && *tmps) {
4564 strcpy(PL_Cmd,tmps);
4567 else *PL_Cmd = '\0';
4568 while (++mark <= sp) {
4570 char *s = SvPVx(*mark,n_a);
4572 if (*PL_Cmd) strcat(PL_Cmd," ");
4578 } /* end of setup_argstr() */
4580 #define MAX_DCL_LINE_LENGTH 255
4582 static unsigned long int
4583 setup_cmddsc(pTHX_ char *cmd, int check_img)
4585 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4586 $DESCRIPTOR(defdsc,".EXE");
4587 $DESCRIPTOR(defdsc2,".");
4588 $DESCRIPTOR(resdsc,resspec);
4589 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4590 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4591 register char *s, *rest, *cp, *wordbreak;
4594 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4595 return CLI$_BUFOVF; /* continuation lines currently unsupported */
4597 while (*s && isspace(*s)) s++;
4599 if (*s == '@' || *s == '$') {
4600 vmsspec[0] = *s; rest = s + 1;
4601 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4603 else { cp = vmsspec; rest = s; }
4604 if (*rest == '.' || *rest == '/') {
4607 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4608 rest++, cp2++) *cp2 = *rest;
4610 if (do_tovmsspec(resspec,cp,0)) {
4613 for (cp2 = vmsspec + strlen(vmsspec);
4614 *rest && cp2 - vmsspec < sizeof vmsspec;
4615 rest++, cp2++) *cp2 = *rest;
4620 /* Intuit whether verb (first word of cmd) is a DCL command:
4621 * - if first nonspace char is '@', it's a DCL indirection
4623 * - if verb contains a filespec separator, it's not a DCL command
4624 * - if it doesn't, caller tells us whether to default to a DCL
4625 * command, or to a local image unless told it's DCL (by leading '$')
4627 if (*s == '@') isdcl = 1;
4629 register char *filespec = strpbrk(s,":<[.;");
4630 rest = wordbreak = strpbrk(s," \"\t/");
4631 if (!wordbreak) wordbreak = s + strlen(s);
4632 if (*s == '$') check_img = 0;
4633 if (filespec && (filespec < wordbreak)) isdcl = 0;
4634 else isdcl = !check_img;
4638 imgdsc.dsc$a_pointer = s;
4639 imgdsc.dsc$w_length = wordbreak - s;
4640 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4642 _ckvmssts(lib$find_file_end(&cxt));
4643 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4644 if (!(retsts & 1) && *s == '$') {
4645 _ckvmssts(lib$find_file_end(&cxt));
4646 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4647 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4649 _ckvmssts(lib$find_file_end(&cxt));
4650 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4654 _ckvmssts(lib$find_file_end(&cxt));
4659 while (*s && !isspace(*s)) s++;
4662 /* check that it's really not DCL with no file extension */
4663 fp = fopen(resspec,"r","ctx=bin,shr=get");
4665 char b[4] = {0,0,0,0};
4666 read(fileno(fp),b,4);
4667 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4670 if (check_img && isdcl) return RMS$_FNF;
4672 if (cando_by_name(S_IXUSR,0,resspec)) {
4673 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4675 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4677 strcpy(VMScmd.dsc$a_pointer,"@");
4679 strcat(VMScmd.dsc$a_pointer,resspec);
4680 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4681 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4682 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4684 else retsts = RMS$_PRV;
4687 /* It's either a DCL command or we couldn't find a suitable image */
4688 VMScmd.dsc$w_length = strlen(cmd);
4689 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4690 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4691 if (!(retsts & 1)) {
4692 /* just hand off status values likely to be due to user error */
4693 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4694 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4695 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4696 else { _ckvmssts(retsts); }
4699 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4701 } /* end of setup_cmddsc() */
4704 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4706 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4709 if (vfork_called) { /* this follows a vfork - act Unixish */
4711 if (vfork_called < 0) {
4712 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4715 else return do_aexec(really,mark,sp);
4717 /* no vfork - act VMSish */
4718 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4723 } /* end of vms_do_aexec() */
4726 /* {{{bool vms_do_exec(char *cmd) */
4728 Perl_vms_do_exec(pTHX_ char *cmd)
4731 if (vfork_called) { /* this follows a vfork - act Unixish */
4733 if (vfork_called < 0) {
4734 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4737 else return do_exec(cmd);
4740 { /* no vfork - act VMSish */
4741 unsigned long int retsts;
4744 TAINT_PROPER("exec");
4745 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4746 retsts = lib$do_command(&VMScmd);
4749 case RMS$_FNF: case RMS$_DNF:
4750 set_errno(ENOENT); break;
4752 set_errno(ENOTDIR); break;
4754 set_errno(ENODEV); break;
4756 set_errno(EACCES); break;
4758 set_errno(EINVAL); break;
4759 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4760 set_errno(E2BIG); break;
4761 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4762 _ckvmssts(retsts); /* fall through */
4763 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4766 set_vaxc_errno(retsts);
4767 if (ckWARN(WARN_EXEC)) {
4768 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4769 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4776 } /* end of vms_do_exec() */
4779 unsigned long int Perl_do_spawn(pTHX_ char *);
4781 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4783 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4785 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4788 } /* end of do_aspawn() */
4791 /* {{{unsigned long int do_spawn(char *cmd) */
4793 Perl_do_spawn(pTHX_ char *cmd)
4795 unsigned long int sts, substs, hadcmd = 1;
4798 TAINT_PROPER("spawn");
4799 if (!cmd || !*cmd) {
4801 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4804 sts = setup_cmddsc(aTHX_ cmd,0);
4806 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4808 substs = sts; /* didn't spawn, use command setup failure for return */
4814 case RMS$_FNF: case RMS$_DNF:
4815 set_errno(ENOENT); break;
4817 set_errno(ENOTDIR); break;
4819 set_errno(ENODEV); break;
4821 set_errno(EACCES); break;
4823 set_errno(EINVAL); break;
4824 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4825 set_errno(E2BIG); break;
4826 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4827 _ckvmssts(sts); /* fall through */
4828 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4831 set_vaxc_errno(sts);
4832 if (ckWARN(WARN_EXEC)) {
4833 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4834 hadcmd ? VMScmd.dsc$w_length : 0,
4835 hadcmd ? VMScmd.dsc$a_pointer : "",
4842 } /* end of do_spawn() */
4846 static unsigned int *sockflags, sockflagsize;
4849 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4850 * routines found in some versions of the CRTL can't deal with sockets.
4851 * We don't shim the other file open routines since a socket isn't
4852 * likely to be opened by a name.
4854 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4855 FILE *my_fdopen(int fd, const char *mode)
4857 FILE *fp = fdopen(fd, (char *) mode);
4860 unsigned int fdoff = fd / sizeof(unsigned int);
4861 struct stat sbuf; /* native stat; we don't need flex_stat */
4862 if (!sockflagsize || fdoff > sockflagsize) {
4863 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4864 else New (1324,sockflags,fdoff+2,unsigned int);
4865 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4866 sockflagsize = fdoff + 2;
4868 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4869 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4878 * Clear the corresponding bit when the (possibly) socket stream is closed.
4879 * There still a small hole: we miss an implicit close which might occur
4880 * via freopen(). >> Todo
4882 /*{{{ int my_fclose(FILE *fp)*/
4883 int my_fclose(FILE *fp) {
4885 unsigned int fd = fileno(fp);
4886 unsigned int fdoff = fd / sizeof(unsigned int);
4888 if (sockflagsize && fdoff <= sockflagsize)
4889 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4897 * A simple fwrite replacement which outputs itmsz*nitm chars without
4898 * introducing record boundaries every itmsz chars.
4899 * We are using fputs, which depends on a terminating null. We may
4900 * well be writing binary data, so we need to accommodate not only
4901 * data with nulls sprinkled in the middle but also data with no null
4904 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4906 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
4908 register char *cp, *end, *cpd, *data;
4909 register unsigned int fd = fileno(dest);
4910 register unsigned int fdoff = fd / sizeof(unsigned int);
4912 int bufsize = itmsz * nitm + 1;
4914 if (fdoff < sockflagsize &&
4915 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4916 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4920 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4921 memcpy( data, src, itmsz*nitm );
4922 data[itmsz*nitm] = '\0';
4924 end = data + itmsz * nitm;
4925 retval = (int) nitm; /* on success return # items written */
4928 while (cpd <= end) {
4929 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4930 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4932 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4936 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4939 } /* end of my_fwrite() */
4942 /*{{{ int my_flush(FILE *fp)*/
4944 Perl_my_flush(pTHX_ FILE *fp)
4947 if ((res = fflush(fp)) == 0 && fp) {
4948 #ifdef VMS_DO_SOCKETS
4950 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4952 res = fsync(fileno(fp));
4955 * If the flush succeeded but set end-of-file, we need to clear
4956 * the error because our caller may check ferror(). BTW, this
4957 * probably means we just flushed an empty file.
4959 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4966 * Here are replacements for the following Unix routines in the VMS environment:
4967 * getpwuid Get information for a particular UIC or UID
4968 * getpwnam Get information for a named user
4969 * getpwent Get information for each user in the rights database
4970 * setpwent Reset search to the start of the rights database
4971 * endpwent Finish searching for users in the rights database
4973 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4974 * (defined in pwd.h), which contains the following fields:-
4976 * char *pw_name; Username (in lower case)
4977 * char *pw_passwd; Hashed password
4978 * unsigned int pw_uid; UIC
4979 * unsigned int pw_gid; UIC group number
4980 * char *pw_unixdir; Default device/directory (VMS-style)
4981 * char *pw_gecos; Owner name
4982 * char *pw_dir; Default device/directory (Unix-style)
4983 * char *pw_shell; Default CLI name (eg. DCL)
4985 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4987 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4988 * not the UIC member number (eg. what's returned by getuid()),
4989 * getpwuid() can accept either as input (if uid is specified, the caller's
4990 * UIC group is used), though it won't recognise gid=0.
4992 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4993 * information about other users in your group or in other groups, respectively.
4994 * If the required privilege is not available, then these routines fill only
4995 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4998 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5001 /* sizes of various UAF record fields */
5002 #define UAI$S_USERNAME 12
5003 #define UAI$S_IDENT 31
5004 #define UAI$S_OWNER 31
5005 #define UAI$S_DEFDEV 31
5006 #define UAI$S_DEFDIR 63
5007 #define UAI$S_DEFCLI 31
5010 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5011 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5012 (uic).uic$v_group != UIC$K_WILD_GROUP)
5014 static char __empty[]= "";
5015 static struct passwd __passwd_empty=
5016 {(char *) __empty, (char *) __empty, 0, 0,
5017 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5018 static int contxt= 0;
5019 static struct passwd __pwdcache;
5020 static char __pw_namecache[UAI$S_IDENT+1];
5023 * This routine does most of the work extracting the user information.
5025 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5028 unsigned char length;
5029 char pw_gecos[UAI$S_OWNER+1];
5031 static union uicdef uic;
5033 unsigned char length;
5034 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5037 unsigned char length;
5038 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5041 unsigned char length;
5042 char pw_shell[UAI$S_DEFCLI+1];
5044 static char pw_passwd[UAI$S_PWD+1];
5046 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5047 struct dsc$descriptor_s name_desc;
5048 unsigned long int sts;
5050 static struct itmlst_3 itmlst[]= {
5051 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5052 {sizeof(uic), UAI$_UIC, &uic, &luic},
5053 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5054 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5055 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5056 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5057 {0, 0, NULL, NULL}};
5059 name_desc.dsc$w_length= strlen(name);
5060 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5061 name_desc.dsc$b_class= DSC$K_CLASS_S;
5062 name_desc.dsc$a_pointer= (char *) name;
5064 /* Note that sys$getuai returns many fields as counted strings. */
5065 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5066 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5067 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5069 else { _ckvmssts(sts); }
5070 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5072 if ((int) owner.length < lowner) lowner= (int) owner.length;
5073 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5074 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5075 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5076 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5077 owner.pw_gecos[lowner]= '\0';
5078 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5079 defcli.pw_shell[ldefcli]= '\0';
5080 if (valid_uic(uic)) {
5081 pwd->pw_uid= uic.uic$l_uic;
5082 pwd->pw_gid= uic.uic$v_group;
5085 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5086 pwd->pw_passwd= pw_passwd;
5087 pwd->pw_gecos= owner.pw_gecos;
5088 pwd->pw_dir= defdev.pw_dir;
5089 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5090 pwd->pw_shell= defcli.pw_shell;
5091 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5093 ldir= strlen(pwd->pw_unixdir) - 1;
5094 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5097 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5098 __mystrtolower(pwd->pw_unixdir);
5103 * Get information for a named user.
5105 /*{{{struct passwd *getpwnam(char *name)*/
5106 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5108 struct dsc$descriptor_s name_desc;
5110 unsigned long int status, sts;
5112 __pwdcache = __passwd_empty;
5113 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5114 /* We still may be able to determine pw_uid and pw_gid */
5115 name_desc.dsc$w_length= strlen(name);
5116 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5117 name_desc.dsc$b_class= DSC$K_CLASS_S;
5118 name_desc.dsc$a_pointer= (char *) name;
5119 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5120 __pwdcache.pw_uid= uic.uic$l_uic;
5121 __pwdcache.pw_gid= uic.uic$v_group;
5124 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5125 set_vaxc_errno(sts);
5126 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5129 else { _ckvmssts(sts); }
5132 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5133 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5134 __pwdcache.pw_name= __pw_namecache;
5136 } /* end of my_getpwnam() */
5140 * Get information for a particular UIC or UID.
5141 * Called by my_getpwent with uid=-1 to list all users.
5143 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5144 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5146 const $DESCRIPTOR(name_desc,__pw_namecache);
5147 unsigned short lname;
5149 unsigned long int status;
5151 if (uid == (unsigned int) -1) {
5153 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5154 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5155 set_vaxc_errno(status);
5156 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5160 else { _ckvmssts(status); }
5161 } while (!valid_uic (uic));
5165 if (!uic.uic$v_group)
5166 uic.uic$v_group= PerlProc_getgid();
5168 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5169 else status = SS$_IVIDENT;
5170 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5171 status == RMS$_PRV) {
5172 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5175 else { _ckvmssts(status); }
5177 __pw_namecache[lname]= '\0';
5178 __mystrtolower(__pw_namecache);
5180 __pwdcache = __passwd_empty;
5181 __pwdcache.pw_name = __pw_namecache;
5183 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5184 The identifier's value is usually the UIC, but it doesn't have to be,
5185 so if we can, we let fillpasswd update this. */
5186 __pwdcache.pw_uid = uic.uic$l_uic;
5187 __pwdcache.pw_gid = uic.uic$v_group;
5189 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5192 } /* end of my_getpwuid() */
5196 * Get information for next user.
5198 /*{{{struct passwd *my_getpwent()*/
5199 struct passwd *Perl_my_getpwent(pTHX)
5201 return (my_getpwuid((unsigned int) -1));
5206 * Finish searching rights database for users.
5208 /*{{{void my_endpwent()*/
5209 void Perl_my_endpwent(pTHX)
5212 _ckvmssts(sys$finish_rdb(&contxt));
5218 #ifdef HOMEGROWN_POSIX_SIGNALS
5219 /* Signal handling routines, pulled into the core from POSIX.xs.
5221 * We need these for threads, so they've been rolled into the core,
5222 * rather than left in POSIX.xs.
5224 * (DRS, Oct 23, 1997)
5227 /* sigset_t is atomic under VMS, so these routines are easy */
5228 /*{{{int my_sigemptyset(sigset_t *) */
5229 int my_sigemptyset(sigset_t *set) {
5230 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5236 /*{{{int my_sigfillset(sigset_t *)*/
5237 int my_sigfillset(sigset_t *set) {
5239 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5240 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5246 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5247 int my_sigaddset(sigset_t *set, int sig) {
5248 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5249 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5250 *set |= (1 << (sig - 1));
5256 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5257 int my_sigdelset(sigset_t *set, int sig) {
5258 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5259 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5260 *set &= ~(1 << (sig - 1));
5266 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5267 int my_sigismember(sigset_t *set, int sig) {
5268 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5269 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5270 *set & (1 << (sig - 1));
5275 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5276 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5279 /* If set and oset are both null, then things are badly wrong. Bail out. */
5280 if ((oset == NULL) && (set == NULL)) {
5281 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5285 /* If set's null, then we're just handling a fetch. */
5287 tempmask = sigblock(0);
5292 tempmask = sigsetmask(*set);
5295 tempmask = sigblock(*set);
5298 tempmask = sigblock(0);
5299 sigsetmask(*oset & ~tempmask);
5302 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5307 /* Did they pass us an oset? If so, stick our holding mask into it */
5314 #endif /* HOMEGROWN_POSIX_SIGNALS */
5317 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5318 * my_utime(), and flex_stat(), all of which operate on UTC unless
5319 * VMSISH_TIMES is true.
5321 /* method used to handle UTC conversions:
5322 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5324 static int gmtime_emulation_type;
5325 /* number of secs to add to UTC POSIX-style time to get local time */
5326 static long int utc_offset_secs;
5328 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5329 * in vmsish.h. #undef them here so we can call the CRTL routines
5338 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5339 * qualifier with the extern prefix pragma. This provisional
5340 * hack circumvents this prefix pragma problem in previous
5343 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5344 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5345 # pragma __extern_prefix save
5346 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5347 # define gmtime decc$__utctz_gmtime
5348 # define localtime decc$__utctz_localtime
5349 # define time decc$__utc_time
5350 # pragma __extern_prefix restore
5352 struct tm *gmtime(), *localtime();
5358 static time_t toutc_dst(time_t loc) {
5361 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5362 loc -= utc_offset_secs;
5363 if (rsltmp->tm_isdst) loc -= 3600;
5366 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5367 ((gmtime_emulation_type || my_time(NULL)), \
5368 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5369 ((secs) - utc_offset_secs))))
5371 static time_t toloc_dst(time_t utc) {
5374 utc += utc_offset_secs;
5375 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5376 if (rsltmp->tm_isdst) utc += 3600;
5379 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5380 ((gmtime_emulation_type || my_time(NULL)), \
5381 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5382 ((secs) + utc_offset_secs))))
5384 #ifndef RTL_USES_UTC
5387 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5388 DST starts on 1st sun of april at 02:00 std time
5389 ends on last sun of october at 02:00 dst time
5390 see the UCX management command reference, SET CONFIG TIMEZONE
5391 for formatting info.
5393 No, it's not as general as it should be, but then again, NOTHING
5394 will handle UK times in a sensible way.
5399 parse the DST start/end info:
5400 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5404 tz_parse_startend(char *s, struct tm *w, int *past)
5406 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5407 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5412 if (!past) return 0;
5415 if (w->tm_year % 4 == 0) ly = 1;
5416 if (w->tm_year % 100 == 0) ly = 0;
5417 if (w->tm_year+1900 % 400 == 0) ly = 1;
5420 dozjd = isdigit(*s);
5421 if (*s == 'J' || *s == 'j' || dozjd) {
5422 if (!dozjd && !isdigit(*++s)) return 0;
5425 d = d*10 + *s++ - '0';
5427 d = d*10 + *s++ - '0';
5430 if (d == 0) return 0;
5431 if (d > 366) return 0;
5433 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5436 } else if (*s == 'M' || *s == 'm') {
5437 if (!isdigit(*++s)) return 0;
5439 if (isdigit(*s)) m = 10*m + *s++ - '0';
5440 if (*s != '.') return 0;
5441 if (!isdigit(*++s)) return 0;
5443 if (n < 1 || n > 5) return 0;
5444 if (*s != '.') return 0;
5445 if (!isdigit(*++s)) return 0;
5447 if (d > 6) return 0;
5451 if (!isdigit(*++s)) return 0;
5453 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5455 if (!isdigit(*++s)) return 0;
5457 if (isdigit(*s)) min = 10*min + *s++ - '0';
5459 if (!isdigit(*++s)) return 0;
5461 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5471 if (w->tm_yday < d) goto before;
5472 if (w->tm_yday > d) goto after;
5474 if (w->tm_mon+1 < m) goto before;
5475 if (w->tm_mon+1 > m) goto after;
5477 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5478 k = d - j; /* mday of first d */
5480 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5481 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5482 if (w->tm_mday < k) goto before;
5483 if (w->tm_mday > k) goto after;
5486 if (w->tm_hour < hour) goto before;
5487 if (w->tm_hour > hour) goto after;
5488 if (w->tm_min < min) goto before;
5489 if (w->tm_min > min) goto after;
5490 if (w->tm_sec < sec) goto before;
5504 /* parse the offset: (+|-)hh[:mm[:ss]] */
5507 tz_parse_offset(char *s, int *offset)
5509 int hour = 0, min = 0, sec = 0;
5512 if (!offset) return 0;
5514 if (*s == '-') {neg++; s++;}
5516 if (!isdigit(*s)) return 0;
5518 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5519 if (hour > 24) return 0;
5521 if (!isdigit(*++s)) return 0;
5523 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5524 if (min > 59) return 0;
5526 if (!isdigit(*++s)) return 0;
5528 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5529 if (sec > 59) return 0;
5533 *offset = (hour*60+min)*60 + sec;
5534 if (neg) *offset = -*offset;
5539 input time is w, whatever type of time the CRTL localtime() uses.
5540 sets dst, the zone, and the gmtoff (seconds)
5542 caches the value of TZ and UCX$TZ env variables; note that
5543 my_setenv looks for these and sets a flag if they're changed
5546 We have to watch out for the "australian" case (dst starts in
5547 october, ends in april)...flagged by "reverse" and checked by
5548 scanning through the months of the previous year.
5553 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5558 char *dstzone, *tz, *s_start, *s_end;
5559 int std_off, dst_off, isdst;
5560 int y, dststart, dstend;
5561 static char envtz[1025]; /* longer than any logical, symbol, ... */
5562 static char ucxtz[1025];
5563 static char reversed = 0;
5569 reversed = -1; /* flag need to check */
5570 envtz[0] = ucxtz[0] = '\0';
5571 tz = my_getenv("TZ",0);
5572 if (tz) strcpy(envtz, tz);
5573 tz = my_getenv("UCX$TZ",0);
5574 if (tz) strcpy(ucxtz, tz);
5575 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5578 if (!*tz) tz = ucxtz;
5581 while (isalpha(*s)) s++;
5582 s = tz_parse_offset(s, &std_off);
5584 if (!*s) { /* no DST, hurray we're done! */
5590 while (isalpha(*s)) s++;
5591 s2 = tz_parse_offset(s, &dst_off);
5595 dst_off = std_off - 3600;
5598 if (!*s) { /* default dst start/end?? */
5599 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5600 s = strchr(ucxtz,',');
5602 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5604 if (*s != ',') return 0;
5607 when = _toutc(when); /* convert to utc */
5608 when = when - std_off; /* convert to pseudolocal time*/
5610 w2 = localtime(&when);
5613 s = tz_parse_startend(s_start,w2,&dststart);
5615 if (*s != ',') return 0;
5618 when = _toutc(when); /* convert to utc */
5619 when = when - dst_off; /* convert to pseudolocal time*/
5620 w2 = localtime(&when);
5621 if (w2->tm_year != y) { /* spans a year, just check one time */
5622 when += dst_off - std_off;
5623 w2 = localtime(&when);
5626 s = tz_parse_startend(s_end,w2,&dstend);
5629 if (reversed == -1) { /* need to check if start later than end */
5633 if (when < 2*365*86400) {
5634 when += 2*365*86400;
5638 w2 =localtime(&when);
5639 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5641 for (j = 0; j < 12; j++) {
5642 w2 =localtime(&when);
5643 (void) tz_parse_startend(s_start,w2,&ds);
5644 (void) tz_parse_startend(s_end,w2,&de);
5645 if (ds != de) break;
5649 if (de && !ds) reversed = 1;
5652 isdst = dststart && !dstend;
5653 if (reversed) isdst = dststart || !dstend;
5656 if (dst) *dst = isdst;
5657 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5658 if (isdst) tz = dstzone;
5660 while(isalpha(*tz)) *zone++ = *tz++;
5666 #endif /* !RTL_USES_UTC */
5668 /* my_time(), my_localtime(), my_gmtime()
5669 * By default traffic in UTC time values, using CRTL gmtime() or
5670 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5671 * Note: We need to use these functions even when the CRTL has working
5672 * UTC support, since they also handle C<use vmsish qw(times);>
5674 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5675 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5678 /*{{{time_t my_time(time_t *timep)*/
5679 time_t Perl_my_time(pTHX_ time_t *timep)
5684 if (gmtime_emulation_type == 0) {
5686 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5687 /* results of calls to gmtime() and localtime() */
5688 /* for same &base */
5690 gmtime_emulation_type++;
5691 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5692 char off[LNM$C_NAMLENGTH+1];;
5694 gmtime_emulation_type++;
5695 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5696 gmtime_emulation_type++;
5697 utc_offset_secs = 0;
5698 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5700 else { utc_offset_secs = atol(off); }
5702 else { /* We've got a working gmtime() */
5703 struct tm gmt, local;
5706 tm_p = localtime(&base);
5708 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5709 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5710 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5711 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5717 # ifdef RTL_USES_UTC
5718 if (VMSISH_TIME) when = _toloc(when);
5720 if (!VMSISH_TIME) when = _toutc(when);
5723 if (timep != NULL) *timep = when;
5726 } /* end of my_time() */
5730 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5732 Perl_my_gmtime(pTHX_ const time_t *timep)
5738 if (timep == NULL) {
5739 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5742 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5746 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5748 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5749 return gmtime(&when);
5751 /* CRTL localtime() wants local time as input, so does no tz correction */
5752 rsltmp = localtime(&when);
5753 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5756 } /* end of my_gmtime() */
5760 /*{{{struct tm *my_localtime(const time_t *timep)*/
5762 Perl_my_localtime(pTHX_ const time_t *timep)
5764 time_t when, whenutc;
5768 if (timep == NULL) {
5769 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5772 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5773 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5776 # ifdef RTL_USES_UTC
5778 if (VMSISH_TIME) when = _toutc(when);
5780 /* CRTL localtime() wants UTC as input, does tz correction itself */
5781 return localtime(&when);
5783 # else /* !RTL_USES_UTC */
5786 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5787 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5790 #ifndef RTL_USES_UTC
5791 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5792 when = whenutc - offset; /* pseudolocal time*/
5795 /* CRTL localtime() wants local time as input, so does no tz correction */
5796 rsltmp = localtime(&when);
5797 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5801 } /* end of my_localtime() */
5804 /* Reset definitions for later calls */
5805 #define gmtime(t) my_gmtime(t)
5806 #define localtime(t) my_localtime(t)
5807 #define time(t) my_time(t)
5810 /* my_utime - update modification time of a file
5811 * calling sequence is identical to POSIX utime(), but under
5812 * VMS only the modification time is changed; ODS-2 does not
5813 * maintain access times. Restrictions differ from the POSIX
5814 * definition in that the time can be changed as long as the
5815 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5816 * no separate checks are made to insure that the caller is the
5817 * owner of the file or has special privs enabled.
5818 * Code here is based on Joe Meadows' FILE utility.
5821 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5822 * to VMS epoch (01-JAN-1858 00:00:00.00)
5823 * in 100 ns intervals.
5825 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5827 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5828 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5831 long int bintime[2], len = 2, lowbit, unixtime,
5832 secscale = 10000000; /* seconds --> 100 ns intervals */
5833 unsigned long int chan, iosb[2], retsts;
5834 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5835 struct FAB myfab = cc$rms_fab;
5836 struct NAM mynam = cc$rms_nam;
5837 #if defined (__DECC) && defined (__VAX)
5838 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5839 * at least through VMS V6.1, which causes a type-conversion warning.
5841 # pragma message save
5842 # pragma message disable cvtdiftypes
5844 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5845 struct fibdef myfib;
5846 #if defined (__DECC) && defined (__VAX)
5847 /* This should be right after the declaration of myatr, but due
5848 * to a bug in VAX DEC C, this takes effect a statement early.
5850 # pragma message restore
5852 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5853 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5854 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5856 if (file == NULL || *file == '\0') {
5858 set_vaxc_errno(LIB$_INVARG);
5861 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5863 if (utimes != NULL) {
5864 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5865 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5866 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5867 * as input, we force the sign bit to be clear by shifting unixtime right
5868 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5870 lowbit = (utimes->modtime & 1) ? secscale : 0;
5871 unixtime = (long int) utimes->modtime;
5873 /* If input was UTC; convert to local for sys svc */
5874 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5876 unixtime >>= 1; secscale <<= 1;
5877 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5878 if (!(retsts & 1)) {
5880 set_vaxc_errno(retsts);
5883 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5884 if (!(retsts & 1)) {
5886 set_vaxc_errno(retsts);
5891 /* Just get the current time in VMS format directly */
5892 retsts = sys$gettim(bintime);
5893 if (!(retsts & 1)) {
5895 set_vaxc_errno(retsts);
5900 myfab.fab$l_fna = vmsspec;
5901 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5902 myfab.fab$l_nam = &mynam;
5903 mynam.nam$l_esa = esa;
5904 mynam.nam$b_ess = (unsigned char) sizeof esa;
5905 mynam.nam$l_rsa = rsa;
5906 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5908 /* Look for the file to be affected, letting RMS parse the file
5909 * specification for us as well. I have set errno using only
5910 * values documented in the utime() man page for VMS POSIX.
5912 retsts = sys$parse(&myfab,0,0);
5913 if (!(retsts & 1)) {
5914 set_vaxc_errno(retsts);
5915 if (retsts == RMS$_PRV) set_errno(EACCES);
5916 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5917 else set_errno(EVMSERR);
5920 retsts = sys$search(&myfab,0,0);
5921 if (!(retsts & 1)) {
5922 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5923 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5924 set_vaxc_errno(retsts);
5925 if (retsts == RMS$_PRV) set_errno(EACCES);
5926 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5927 else set_errno(EVMSERR);
5931 devdsc.dsc$w_length = mynam.nam$b_dev;
5932 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5934 retsts = sys$assign(&devdsc,&chan,0,0);
5935 if (!(retsts & 1)) {
5936 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5937 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5938 set_vaxc_errno(retsts);
5939 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5940 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5941 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5942 else set_errno(EVMSERR);
5946 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5947 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5949 memset((void *) &myfib, 0, sizeof myfib);
5950 #if defined(__DECC) || defined(__DECCXX)
5951 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5952 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5953 /* This prevents the revision time of the file being reset to the current
5954 * time as a result of our IO$_MODIFY $QIO. */
5955 myfib.fib$l_acctl = FIB$M_NORECORD;
5957 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5958 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5959 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5961 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5962 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5963 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5964 _ckvmssts(sys$dassgn(chan));
5965 if (retsts & 1) retsts = iosb[0];
5966 if (!(retsts & 1)) {
5967 set_vaxc_errno(retsts);
5968 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5969 else set_errno(EVMSERR);
5974 } /* end of my_utime() */
5978 * flex_stat, flex_fstat
5979 * basic stat, but gets it right when asked to stat
5980 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5983 /* encode_dev packs a VMS device name string into an integer to allow
5984 * simple comparisons. This can be used, for example, to check whether two
5985 * files are located on the same device, by comparing their encoded device
5986 * names. Even a string comparison would not do, because stat() reuses the
5987 * device name buffer for each call; so without encode_dev, it would be
5988 * necessary to save the buffer and use strcmp (this would mean a number of
5989 * changes to the standard Perl code, to say nothing of what a Perl script
5992 * The device lock id, if it exists, should be unique (unless perhaps compared
5993 * with lock ids transferred from other nodes). We have a lock id if the disk is
5994 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5995 * device names. Thus we use the lock id in preference, and only if that isn't
5996 * available, do we try to pack the device name into an integer (flagged by
5997 * the sign bit (LOCKID_MASK) being set).
5999 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6000 * name and its encoded form, but it seems very unlikely that we will find
6001 * two files on different disks that share the same encoded device names,
6002 * and even more remote that they will share the same file id (if the test
6003 * is to check for the same file).
6005 * A better method might be to use sys$device_scan on the first call, and to
6006 * search for the device, returning an index into the cached array.
6007 * The number returned would be more intelligable.
6008 * This is probably not worth it, and anyway would take quite a bit longer
6009 * on the first call.
6011 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6012 static mydev_t encode_dev (pTHX_ const char *dev)
6015 unsigned long int f;
6020 if (!dev || !dev[0]) return 0;
6024 struct dsc$descriptor_s dev_desc;
6025 unsigned long int status, lockid, item = DVI$_LOCKID;
6027 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6028 can try that first. */
6029 dev_desc.dsc$w_length = strlen (dev);
6030 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6031 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6032 dev_desc.dsc$a_pointer = (char *) dev;
6033 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6034 if (lockid) return (lockid & ~LOCKID_MASK);
6038 /* Otherwise we try to encode the device name */
6042 for (q = dev + strlen(dev); q--; q >= dev) {
6045 else if (isalpha (toupper (*q)))
6046 c= toupper (*q) - 'A' + (char)10;
6048 continue; /* Skip '$'s */
6050 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6052 enc += f * (unsigned long int) c;
6054 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6056 } /* end of encode_dev() */
6058 static char namecache[NAM$C_MAXRSS+1];
6061 is_null_device(name)
6064 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6065 The underscore prefix, controller letter, and unit number are
6066 independently optional; for our purposes, the colon punctuation
6067 is not. The colon can be trailed by optional directory and/or
6068 filename, but two consecutive colons indicates a nodename rather
6069 than a device. [pr] */
6070 if (*name == '_') ++name;
6071 if (tolower(*name++) != 'n') return 0;
6072 if (tolower(*name++) != 'l') return 0;
6073 if (tolower(*name) == 'a') ++name;
6074 if (*name == '0') ++name;
6075 return (*name++ == ':') && (*name != ':');
6078 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6079 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6080 * subset of the applicable information.
6083 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6085 char fname_phdev[NAM$C_MAXRSS+1];
6086 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6088 char fname[NAM$C_MAXRSS+1];
6089 unsigned long int retsts;
6090 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6091 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6093 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6094 device name on successive calls */
6095 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6096 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6097 namdsc.dsc$a_pointer = fname;
6098 namdsc.dsc$w_length = sizeof fname - 1;
6100 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6101 &namdsc,&namdsc.dsc$w_length,0,0);
6103 fname[namdsc.dsc$w_length] = '\0';
6105 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6106 * but if someone has redefined that logical, Perl gets very lost. Since
6107 * we have the physical device name from the stat buffer, just paste it on.
6109 strcpy( fname_phdev, statbufp->st_devnam );
6110 strcat( fname_phdev, strrchr(fname, ':') );
6112 return cando_by_name(bit,effective,fname_phdev);
6114 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6115 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6119 return FALSE; /* Should never get to here */
6121 } /* end of cando() */
6125 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6127 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6129 static char usrname[L_cuserid];
6130 static struct dsc$descriptor_s usrdsc =
6131 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6132 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6133 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6134 unsigned short int retlen;
6135 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6136 union prvdef curprv;
6137 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6138 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6139 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6142 if (!fname || !*fname) return FALSE;
6143 /* Make sure we expand logical names, since sys$check_access doesn't */
6144 if (!strpbrk(fname,"/]>:")) {
6145 strcpy(fileified,fname);
6146 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6149 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6150 retlen = namdsc.dsc$w_length = strlen(vmsname);
6151 namdsc.dsc$a_pointer = vmsname;
6152 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6153 vmsname[retlen-1] == ':') {
6154 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6155 namdsc.dsc$w_length = strlen(fileified);
6156 namdsc.dsc$a_pointer = fileified;
6159 if (!usrdsc.dsc$w_length) {
6161 usrdsc.dsc$w_length = strlen(usrname);
6165 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6166 access = ARM$M_EXECUTE; break;
6167 case S_IRUSR: case S_IRGRP: case S_IROTH:
6168 access = ARM$M_READ; break;
6169 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6170 access = ARM$M_WRITE; break;
6171 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6172 access = ARM$M_DELETE; break;
6177 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6178 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6179 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6180 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6181 set_vaxc_errno(retsts);
6182 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6183 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6184 else set_errno(ENOENT);
6187 if (retsts == SS$_NORMAL) {
6188 if (!privused) return TRUE;
6189 /* We can get access, but only by using privs. Do we have the
6190 necessary privs currently enabled? */
6191 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6192 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6193 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6194 !curprv.prv$v_bypass) return FALSE;
6195 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6196 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6197 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6200 if (retsts == SS$_ACCONFLICT) {
6205 return FALSE; /* Should never get here */
6207 } /* end of cando_by_name() */
6211 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6213 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6215 if (!fstat(fd,(stat_t *) statbufp)) {
6216 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6217 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6218 # ifdef RTL_USES_UTC
6221 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6222 statbufp->st_atime = _toloc(statbufp->st_atime);
6223 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6228 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6232 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6233 statbufp->st_atime = _toutc(statbufp->st_atime);
6234 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6241 } /* end of flex_fstat() */
6244 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6246 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6248 char fileified[NAM$C_MAXRSS+1];
6249 char temp_fspec[NAM$C_MAXRSS+300];
6252 strcpy(temp_fspec, fspec);
6253 if (statbufp == (Stat_t *) &PL_statcache)
6254 do_tovmsspec(temp_fspec,namecache,0);
6255 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6256 memset(statbufp,0,sizeof *statbufp);
6257 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6258 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6259 statbufp->st_uid = 0x00010001;
6260 statbufp->st_gid = 0x0001;
6261 time((time_t *)&statbufp->st_mtime);
6262 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6266 /* Try for a directory name first. If fspec contains a filename without
6267 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6268 * and sea:[wine.dark]water. exist, we prefer the directory here.
6269 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6270 * not sea:[wine.dark]., if the latter exists. If the intended target is
6271 * the file with null type, specify this by calling flex_stat() with
6272 * a '.' at the end of fspec.
6274 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6275 retval = stat(fileified,(stat_t *) statbufp);
6276 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6277 strcpy(namecache,fileified);
6279 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6281 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6282 # ifdef RTL_USES_UTC
6285 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6286 statbufp->st_atime = _toloc(statbufp->st_atime);
6287 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6292 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6296 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6297 statbufp->st_atime = _toutc(statbufp->st_atime);
6298 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6304 } /* end of flex_stat() */
6308 /*{{{char *my_getlogin()*/
6309 /* VMS cuserid == Unix getlogin, except calling sequence */
6313 static char user[L_cuserid];
6314 return cuserid(user);
6319 /* rmscopy - copy a file using VMS RMS routines
6321 * Copies contents and attributes of spec_in to spec_out, except owner
6322 * and protection information. Name and type of spec_in are used as
6323 * defaults for spec_out. The third parameter specifies whether rmscopy()
6324 * should try to propagate timestamps from the input file to the output file.
6325 * If it is less than 0, no timestamps are preserved. If it is 0, then
6326 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6327 * propagated to the output file at creation iff the output file specification
6328 * did not contain an explicit name or type, and the revision date is always
6329 * updated at the end of the copy operation. If it is greater than 0, then
6330 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6331 * other than the revision date should be propagated, and bit 1 indicates
6332 * that the revision date should be propagated.
6334 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6336 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6337 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6338 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6339 * as part of the Perl standard distribution under the terms of the
6340 * GNU General Public License or the Perl Artistic License. Copies
6341 * of each may be found in the Perl standard distribution.
6343 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6345 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6347 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6348 rsa[NAM$C_MAXRSS], ubf[32256];
6349 unsigned long int i, sts, sts2;
6350 struct FAB fab_in, fab_out;
6351 struct RAB rab_in, rab_out;
6353 struct XABDAT xabdat;
6354 struct XABFHC xabfhc;
6355 struct XABRDT xabrdt;
6356 struct XABSUM xabsum;
6358 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6359 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6360 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6364 fab_in = cc$rms_fab;
6365 fab_in.fab$l_fna = vmsin;
6366 fab_in.fab$b_fns = strlen(vmsin);
6367 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6368 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6369 fab_in.fab$l_fop = FAB$M_SQO;
6370 fab_in.fab$l_nam = &nam;
6371 fab_in.fab$l_xab = (void *) &xabdat;
6374 nam.nam$l_rsa = rsa;
6375 nam.nam$b_rss = sizeof(rsa);
6376 nam.nam$l_esa = esa;
6377 nam.nam$b_ess = sizeof (esa);
6378 nam.nam$b_esl = nam.nam$b_rsl = 0;
6380 xabdat = cc$rms_xabdat; /* To get creation date */
6381 xabdat.xab$l_nxt = (void *) &xabfhc;
6383 xabfhc = cc$rms_xabfhc; /* To get record length */
6384 xabfhc.xab$l_nxt = (void *) &xabsum;
6386 xabsum = cc$rms_xabsum; /* To get key and area information */
6388 if (!((sts = sys$open(&fab_in)) & 1)) {
6389 set_vaxc_errno(sts);
6391 case RMS$_FNF: case RMS$_DNF:
6392 set_errno(ENOENT); break;
6394 set_errno(ENOTDIR); break;
6396 set_errno(ENODEV); break;
6398 set_errno(EINVAL); break;
6400 set_errno(EACCES); break;
6408 fab_out.fab$w_ifi = 0;
6409 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6410 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6411 fab_out.fab$l_fop = FAB$M_SQO;
6412 fab_out.fab$l_fna = vmsout;
6413 fab_out.fab$b_fns = strlen(vmsout);
6414 fab_out.fab$l_dna = nam.nam$l_name;
6415 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6417 if (preserve_dates == 0) { /* Act like DCL COPY */
6418 nam.nam$b_nop = NAM$M_SYNCHK;
6419 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6420 if (!((sts = sys$parse(&fab_out)) & 1)) {
6421 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6422 set_vaxc_errno(sts);
6425 fab_out.fab$l_xab = (void *) &xabdat;
6426 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6428 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6429 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6430 preserve_dates =0; /* bitmask from this point forward */
6432 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6433 if (!((sts = sys$create(&fab_out)) & 1)) {
6434 set_vaxc_errno(sts);
6437 set_errno(ENOENT); break;
6439 set_errno(ENOTDIR); break;
6441 set_errno(ENODEV); break;
6443 set_errno(EINVAL); break;
6445 set_errno(EACCES); break;
6451 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6452 if (preserve_dates & 2) {
6453 /* sys$close() will process xabrdt, not xabdat */
6454 xabrdt = cc$rms_xabrdt;
6456 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6458 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6459 * is unsigned long[2], while DECC & VAXC use a struct */
6460 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6462 fab_out.fab$l_xab = (void *) &xabrdt;
6465 rab_in = cc$rms_rab;
6466 rab_in.rab$l_fab = &fab_in;
6467 rab_in.rab$l_rop = RAB$M_BIO;
6468 rab_in.rab$l_ubf = ubf;
6469 rab_in.rab$w_usz = sizeof ubf;
6470 if (!((sts = sys$connect(&rab_in)) & 1)) {
6471 sys$close(&fab_in); sys$close(&fab_out);
6472 set_errno(EVMSERR); set_vaxc_errno(sts);
6476 rab_out = cc$rms_rab;
6477 rab_out.rab$l_fab = &fab_out;
6478 rab_out.rab$l_rbf = ubf;
6479 if (!((sts = sys$connect(&rab_out)) & 1)) {
6480 sys$close(&fab_in); sys$close(&fab_out);
6481 set_errno(EVMSERR); set_vaxc_errno(sts);
6485 while ((sts = sys$read(&rab_in))) { /* always true */
6486 if (sts == RMS$_EOF) break;
6487 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6488 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6489 sys$close(&fab_in); sys$close(&fab_out);
6490 set_errno(EVMSERR); set_vaxc_errno(sts);
6495 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6496 sys$close(&fab_in); sys$close(&fab_out);
6497 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6499 set_errno(EVMSERR); set_vaxc_errno(sts);
6505 } /* end of rmscopy() */
6509 /*** The following glue provides 'hooks' to make some of the routines
6510 * from this file available from Perl. These routines are sufficiently
6511 * basic, and are required sufficiently early in the build process,
6512 * that's it's nice to have them available to miniperl as well as the
6513 * full Perl, so they're set up here instead of in an extension. The
6514 * Perl code which handles importation of these names into a given
6515 * package lives in [.VMS]Filespec.pm in @INC.
6519 rmsexpand_fromperl(pTHX_ CV *cv)
6522 char *fspec, *defspec = NULL, *rslt;
6525 if (!items || items > 2)
6526 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6527 fspec = SvPV(ST(0),n_a);
6528 if (!fspec || !*fspec) XSRETURN_UNDEF;
6529 if (items == 2) defspec = SvPV(ST(1),n_a);
6531 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6532 ST(0) = sv_newmortal();
6533 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6538 vmsify_fromperl(pTHX_ CV *cv)
6544 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6545 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6546 ST(0) = sv_newmortal();
6547 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6552 unixify_fromperl(pTHX_ CV *cv)
6558 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6559 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6560 ST(0) = sv_newmortal();
6561 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6566 fileify_fromperl(pTHX_ CV *cv)
6572 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6573 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6574 ST(0) = sv_newmortal();
6575 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6580 pathify_fromperl(pTHX_ CV *cv)
6586 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6587 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6588 ST(0) = sv_newmortal();
6589 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6594 vmspath_fromperl(pTHX_ CV *cv)
6600 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6601 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6602 ST(0) = sv_newmortal();
6603 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6608 unixpath_fromperl(pTHX_ CV *cv)
6614 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6615 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6616 ST(0) = sv_newmortal();
6617 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6622 candelete_fromperl(pTHX_ CV *cv)
6625 char fspec[NAM$C_MAXRSS+1], *fsp;
6630 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6632 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6633 if (SvTYPE(mysv) == SVt_PVGV) {
6634 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6635 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6642 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6643 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6649 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6654 rmscopy_fromperl(pTHX_ CV *cv)
6657 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6659 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6660 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6661 unsigned long int sts;
6666 if (items < 2 || items > 3)
6667 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6669 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6670 if (SvTYPE(mysv) == SVt_PVGV) {
6671 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6672 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6679 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6680 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6685 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6686 if (SvTYPE(mysv) == SVt_PVGV) {
6687 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6688 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6695 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6696 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6701 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6703 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6709 mod2fname(pTHX_ CV *cv)
6712 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6713 workbuff[NAM$C_MAXRSS*1 + 1];
6714 int total_namelen = 3, counter, num_entries;
6715 /* ODS-5 ups this, but we want to be consistent, so... */
6716 int max_name_len = 39;
6717 AV *in_array = (AV *)SvRV(ST(0));
6719 num_entries = av_len(in_array);
6721 /* All the names start with PL_. */
6722 strcpy(ultimate_name, "PL_");
6724 /* Clean up our working buffer */
6725 Zero(work_name, sizeof(work_name), char);
6727 /* Run through the entries and build up a working name */
6728 for(counter = 0; counter <= num_entries; counter++) {
6729 /* If it's not the first name then tack on a __ */
6731 strcat(work_name, "__");
6733 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6737 /* Check to see if we actually have to bother...*/
6738 if (strlen(work_name) + 3 <= max_name_len) {
6739 strcat(ultimate_name, work_name);
6741 /* It's too darned big, so we need to go strip. We use the same */
6742 /* algorithm as xsubpp does. First, strip out doubled __ */
6743 char *source, *dest, last;
6746 for (source = work_name; *source; source++) {
6747 if (last == *source && last == '_') {
6753 /* Go put it back */
6754 strcpy(work_name, workbuff);
6755 /* Is it still too big? */
6756 if (strlen(work_name) + 3 > max_name_len) {
6757 /* Strip duplicate letters */
6760 for (source = work_name; *source; source++) {
6761 if (last == toupper(*source)) {
6765 last = toupper(*source);
6767 strcpy(work_name, workbuff);
6770 /* Is it *still* too big? */
6771 if (strlen(work_name) + 3 > max_name_len) {
6772 /* Too bad, we truncate */
6773 work_name[max_name_len - 2] = 0;
6775 strcat(ultimate_name, work_name);
6778 /* Okay, return it */
6779 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6787 char* file = __FILE__;
6788 char temp_buff[512];
6789 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6790 no_translate_barewords = TRUE;
6792 no_translate_barewords = FALSE;
6795 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6796 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6797 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6798 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6799 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6800 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6801 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6802 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6803 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6804 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6806 store_pipelocs(aTHX);