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
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
41 #include <str$routines.h>
46 /* Older versions of ssdef.h don't have these */
47 #ifndef SS$_INVFILFOROP
48 # define SS$_INVFILFOROP 3930
50 #ifndef SS$_NOSUCHOBJECT
51 # define SS$_NOSUCHOBJECT 2696
54 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
55 #define PERLIO_NOT_STDIO 0
57 /* Don't replace system definitions of vfork, getenv, and stat,
58 * code below needs to get to the underlying CRTL routines. */
59 #define DONT_MASK_RTL_CALLS
63 /* Anticipating future expansion in lexical warnings . . . */
65 # define WARN_INTERNAL WARN_MISC
68 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
69 # define RTL_USES_UTC 1
73 /* gcc's header files don't #define direct access macros
74 * corresponding to VAXC's variant structs */
76 # define uic$v_format uic$r_uic_form.uic$v_format
77 # define uic$v_group uic$r_uic_form.uic$v_group
78 # define uic$v_member uic$r_uic_form.uic$v_member
79 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
80 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
81 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
82 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
85 #if defined(NEED_AN_H_ERRNO)
90 unsigned short int buflen;
91 unsigned short int itmcode;
93 unsigned short int *retlen;
96 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
97 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
98 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
99 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
100 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
101 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
102 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
103 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
104 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
106 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
107 #define PERL_LNM_MAX_ALLOWED_INDEX 127
109 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
110 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
112 static char *__mystrtolower(char *str)
114 if (str) for (; *str; ++str) *str= tolower(*str);
118 static struct dsc$descriptor_s fildevdsc =
119 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
120 static struct dsc$descriptor_s crtlenvdsc =
121 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
122 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
123 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
124 static struct dsc$descriptor_s **env_tables = defenv;
125 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
127 /* True if we shouldn't treat barewords as logicals during directory */
129 static int no_translate_barewords;
132 static int tz_updated = 1;
135 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
137 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
138 struct dsc$descriptor_s **tabvec, unsigned long int flags)
140 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
141 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
142 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
143 unsigned char acmode;
144 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
146 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
147 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
149 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
150 #if defined(PERL_IMPLICIT_CONTEXT)
152 # if defined(USE_5005THREADS)
153 /* We jump through these hoops because we can be called at */
154 /* platform-specific initialization time, which is before anything is */
155 /* set up--we can't even do a plain dTHX since that relies on the */
156 /* interpreter structure to be initialized */
158 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
164 aTHX = PERL_GET_INTERP;
172 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
175 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
176 *cp2 = _toupper(*cp1);
177 if (cp1 - lnm > LNM$C_NAMLENGTH) {
178 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
182 lnmdsc.dsc$w_length = cp1 - lnm;
183 lnmdsc.dsc$a_pointer = uplnm;
184 uplnm[lnmdsc.dsc$w_length] = '\0';
185 secure = flags & PERL__TRNENV_SECURE;
186 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
187 if (!tabvec || !*tabvec) tabvec = env_tables;
189 for (curtab = 0; tabvec[curtab]; curtab++) {
190 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
191 if (!ivenv && !secure) {
196 Perl_warn(aTHX_ "Can't read CRTL environ\n");
199 retsts = SS$_NOLOGNAM;
200 for (i = 0; environ[i]; i++) {
201 if ((eq = strchr(environ[i],'=')) &&
202 !strncmp(environ[i],uplnm,eq - environ[i])) {
204 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
205 if (!eqvlen) continue;
210 if (retsts != SS$_NOLOGNAM) break;
213 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
214 !str$case_blind_compare(&tmpdsc,&clisym)) {
215 if (!ivsym && !secure) {
216 unsigned short int deflen = LNM$C_NAMLENGTH;
217 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
218 /* dynamic dsc to accomodate possible long value */
219 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
220 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
223 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
225 /* Special hack--we might be called before the interpreter's */
226 /* fully initialized, in which case either thr or PL_curcop */
227 /* might be bogus. We have to check, since ckWARN needs them */
228 /* both to be valid if running threaded */
229 #if defined(USE_5005THREADS)
230 if (thr && PL_curcop) {
232 if (ckWARN(WARN_MISC)) {
233 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
235 #if defined(USE_5005THREADS)
237 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
242 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
244 _ckvmssts(lib$sfree1_dd(&eqvdsc));
245 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
246 if (retsts == LIB$_NOSUCHSYM) continue;
251 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
252 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
253 if (retsts == SS$_NOLOGNAM) continue;
254 /* PPFs have a prefix */
257 *((int *)uplnm) == *((int *)"SYS$") &&
259 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
260 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
261 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
262 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
263 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
264 memcpy(eqv,eqv+4,eqvlen-4);
270 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
271 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
272 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
273 retsts == SS$_NOLOGNAM) {
274 set_errno(EINVAL); set_vaxc_errno(retsts);
276 else _ckvmssts(retsts);
278 } /* end of vmstrnenv */
281 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
282 /* Define as a function so we can access statics. */
283 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
285 return vmstrnenv(lnm,eqv,idx,fildev,
286 #ifdef SECURE_INTERNAL_GETENV
287 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
296 * Note: Uses Perl temp to store result so char * can be returned to
297 * caller; this pointer will be invalidated at next Perl statement
299 * We define this as a function rather than a macro in terms of my_getenv_len()
300 * so that it'll work when PL_curinterp is undefined (and we therefore can't
303 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
305 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
307 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
308 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
309 unsigned long int idx = 0;
310 int trnsuccess, success, secure, saverr, savvmserr;
313 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
314 /* Set up a temporary buffer for the return value; Perl will
315 * clean it up at the next statement transition */
316 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
317 if (!tmpsv) return NULL;
320 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
321 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
322 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
323 getcwd(eqv,LNM$C_NAMLENGTH);
327 if ((cp2 = strchr(lnm,';')) != NULL) {
329 uplnm[cp2-lnm] = '\0';
330 idx = strtoul(cp2+1,NULL,0);
333 /* Impose security constraints only if tainting */
335 /* Impose security constraints only if tainting */
336 secure = PL_curinterp ? PL_tainting : will_taint;
337 saverr = errno; savvmserr = vaxc$errno;
340 success = vmstrnenv(lnm,eqv,idx,
341 secure ? fildev : NULL,
342 #ifdef SECURE_INTERNAL_GETENV
343 secure ? PERL__TRNENV_SECURE : 0
348 /* Discard NOLOGNAM on internal calls since we're often looking
349 * for an optional name, and this "error" often shows up as the
350 * (bogus) exit status for a die() call later on. */
351 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
352 return success ? eqv : Nullch;
355 } /* end of my_getenv() */
359 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
361 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
363 char *buf, *cp1, *cp2;
364 unsigned long idx = 0;
365 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
366 int secure, saverr, savvmserr;
369 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
370 /* Set up a temporary buffer for the return value; Perl will
371 * clean it up at the next statement transition */
372 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
373 if (!tmpsv) return NULL;
376 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
377 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
378 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
379 getcwd(buf,LNM$C_NAMLENGTH);
384 if ((cp2 = strchr(lnm,';')) != NULL) {
387 idx = strtoul(cp2+1,NULL,0);
391 /* Impose security constraints only if tainting */
392 secure = PL_curinterp ? PL_tainting : will_taint;
393 saverr = errno; savvmserr = vaxc$errno;
396 *len = vmstrnenv(lnm,buf,idx,
397 secure ? fildev : NULL,
398 #ifdef SECURE_INTERNAL_GETENV
399 secure ? PERL__TRNENV_SECURE : 0
404 /* Discard NOLOGNAM on internal calls since we're often looking
405 * for an optional name, and this "error" often shows up as the
406 * (bogus) exit status for a die() call later on. */
407 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
408 return *len ? buf : Nullch;
411 } /* end of my_getenv_len() */
414 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
416 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
418 /*{{{ void prime_env_iter() */
421 /* Fill the %ENV associative array with all logical names we can
422 * find, in preparation for iterating over it.
425 static int primed = 0;
426 HV *seenhv = NULL, *envhv;
428 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
429 unsigned short int chan;
430 #ifndef CLI$M_TRUSTED
431 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
433 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
434 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
436 bool have_sym = FALSE, have_lnm = FALSE;
437 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
438 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
439 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
440 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
441 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
442 #if defined(PERL_IMPLICIT_CONTEXT)
445 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
446 static perl_mutex primenv_mutex;
447 MUTEX_INIT(&primenv_mutex);
450 #if defined(PERL_IMPLICIT_CONTEXT)
451 /* We jump through these hoops because we can be called at */
452 /* platform-specific initialization time, which is before anything is */
453 /* set up--we can't even do a plain dTHX since that relies on the */
454 /* interpreter structure to be initialized */
455 #if defined(USE_5005THREADS)
457 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
463 aTHX = PERL_GET_INTERP;
470 if (primed || !PL_envgv) return;
471 MUTEX_LOCK(&primenv_mutex);
472 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
473 envhv = GvHVn(PL_envgv);
474 /* Perform a dummy fetch as an lval to insure that the hash table is
475 * set up. Otherwise, the hv_store() will turn into a nullop. */
476 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
478 for (i = 0; env_tables[i]; i++) {
479 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
480 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
481 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
483 if (have_sym || have_lnm) {
484 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
485 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
486 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
487 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
490 for (i--; i >= 0; i--) {
491 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
494 for (j = 0; environ[j]; j++) {
495 if (!(start = strchr(environ[j],'='))) {
496 if (ckWARN(WARN_INTERNAL))
497 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
501 sv = newSVpv(start,0);
503 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
508 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
509 !str$case_blind_compare(&tmpdsc,&clisym)) {
510 strcpy(cmd,"Show Symbol/Global *");
511 cmddsc.dsc$w_length = 20;
512 if (env_tables[i]->dsc$w_length == 12 &&
513 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
514 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
515 flags = defflags | CLI$M_NOLOGNAM;
518 strcpy(cmd,"Show Logical *");
519 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
520 strcat(cmd," /Table=");
521 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
522 cmddsc.dsc$w_length = strlen(cmd);
524 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
525 flags = defflags | CLI$M_NOCLISYM;
528 /* Create a new subprocess to execute each command, to exclude the
529 * remote possibility that someone could subvert a mbx or file used
530 * to write multiple commands to a single subprocess.
533 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
534 0,&riseandshine,0,0,&clidsc,&clitabdsc);
535 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
536 defflags &= ~CLI$M_TRUSTED;
537 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
539 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
540 if (seenhv) SvREFCNT_dec(seenhv);
543 char *cp1, *cp2, *key;
544 unsigned long int sts, iosb[2], retlen, keylen;
547 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
548 if (sts & 1) sts = iosb[0] & 0xffff;
549 if (sts == SS$_ENDOFFILE) {
551 while (substs == 0) { sys$hiber(); wakect++;}
552 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
557 retlen = iosb[0] >> 16;
558 if (!retlen) continue; /* blank line */
560 if (iosb[1] != subpid) {
562 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
566 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
567 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
569 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
570 if (*cp1 == '(' || /* Logical name table name */
571 *cp1 == '=' /* Next eqv of searchlist */) continue;
572 if (*cp1 == '"') cp1++;
573 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
574 key = cp1; keylen = cp2 - cp1;
575 if (keylen && hv_exists(seenhv,key,keylen)) continue;
576 while (*cp2 && *cp2 != '=') cp2++;
577 while (*cp2 && *cp2 == '=') cp2++;
578 while (*cp2 && *cp2 == ' ') cp2++;
579 if (*cp2 == '"') { /* String translation; may embed "" */
580 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
581 cp2++; cp1--; /* Skip "" surrounding translation */
583 else { /* Numeric translation */
584 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
585 cp1--; /* stop on last non-space char */
587 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
588 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
591 PERL_HASH(hash,key,keylen);
592 sv = newSVpvn(cp2,cp1 - cp2 + 1);
594 hv_store(envhv,key,keylen,sv,hash);
595 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
597 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
598 /* get the PPFs for this process, not the subprocess */
599 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
600 char eqv[LNM$C_NAMLENGTH+1];
602 for (i = 0; ppfs[i]; i++) {
603 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
604 sv = newSVpv(eqv,trnlen);
606 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
611 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
612 if (buf) Safefree(buf);
613 if (seenhv) SvREFCNT_dec(seenhv);
614 MUTEX_UNLOCK(&primenv_mutex);
617 } /* end of prime_env_iter */
621 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
622 /* Define or delete an element in the same "environment" as
623 * vmstrnenv(). If an element is to be deleted, it's removed from
624 * the first place it's found. If it's to be set, it's set in the
625 * place designated by the first element of the table vector.
626 * Like setenv() returns 0 for success, non-zero on error.
629 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
631 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
632 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
633 unsigned long int retsts, usermode = PSL$C_USER;
634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
638 $DESCRIPTOR(local,"_LOCAL");
640 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
641 *cp2 = _toupper(*cp1);
642 if (cp1 - lnm > LNM$C_NAMLENGTH) {
643 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
647 lnmdsc.dsc$w_length = cp1 - lnm;
648 if (!tabvec || !*tabvec) tabvec = env_tables;
650 if (!eqv) { /* we're deleting n element */
651 for (curtab = 0; tabvec[curtab]; curtab++) {
652 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
654 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
655 if ((cp1 = strchr(environ[i],'=')) &&
656 !strncmp(environ[i],lnm,cp1 - environ[i])) {
658 return setenv(lnm,"",1) ? vaxc$errno : 0;
661 ivenv = 1; retsts = SS$_NOLOGNAM;
663 if (ckWARN(WARN_INTERNAL))
664 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
665 ivenv = 1; retsts = SS$_NOSUCHPGM;
671 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
672 !str$case_blind_compare(&tmpdsc,&clisym)) {
673 unsigned int symtype;
674 if (tabvec[curtab]->dsc$w_length == 12 &&
675 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
676 !str$case_blind_compare(&tmpdsc,&local))
677 symtype = LIB$K_CLI_LOCAL_SYM;
678 else symtype = LIB$K_CLI_GLOBAL_SYM;
679 retsts = lib$delete_symbol(&lnmdsc,&symtype);
680 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
681 if (retsts == LIB$_NOSUCHSYM) continue;
685 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
686 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
687 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
688 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
689 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
693 else { /* we're defining a value */
694 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
696 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
698 if (ckWARN(WARN_INTERNAL))
699 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
700 retsts = SS$_NOSUCHPGM;
704 eqvdsc.dsc$a_pointer = eqv;
705 eqvdsc.dsc$w_length = strlen(eqv);
706 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
707 !str$case_blind_compare(&tmpdsc,&clisym)) {
708 unsigned int symtype;
709 if (tabvec[0]->dsc$w_length == 12 &&
710 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
711 !str$case_blind_compare(&tmpdsc,&local))
712 symtype = LIB$K_CLI_LOCAL_SYM;
713 else symtype = LIB$K_CLI_GLOBAL_SYM;
714 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
717 if (!*eqv) eqvdsc.dsc$w_length = 1;
718 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
719 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
720 if (ckWARN(WARN_MISC)) {
721 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
724 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
730 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
731 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
732 set_errno(EVMSERR); break;
733 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
734 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
735 set_errno(EINVAL); break;
742 set_vaxc_errno(retsts);
743 return (int) retsts || 44; /* retsts should never be 0, but just in case */
746 /* We reset error values on success because Perl does an hv_fetch()
747 * before each hv_store(), and if the thing we're setting didn't
748 * previously exist, we've got a leftover error message. (Of course,
749 * this fails in the face of
750 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
751 * in that the error reported in $! isn't spurious,
752 * but it's right more often than not.)
754 set_errno(0); set_vaxc_errno(retsts);
758 } /* end of vmssetenv() */
761 /*{{{ void my_setenv(char *lnm, char *eqv)*/
762 /* This has to be a function since there's a prototype for it in proto.h */
764 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
767 int len = strlen(lnm);
771 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
772 if (!strcmp(uplnm,"DEFAULT")) {
773 if (eqv && *eqv) chdir(eqv);
778 if (len == 6 || len == 2) {
781 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
783 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
784 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
788 (void) vmssetenv(lnm,eqv,NULL);
792 /*{{{static void vmssetuserlnm(char *name, char *eqv);
794 * sets a user-mode logical in the process logical name table
795 * used for redirection of sys$error
798 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
800 $DESCRIPTOR(d_tab, "LNM$PROCESS");
801 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
802 unsigned long int iss, attr = LNM$M_CONFINE;
803 unsigned char acmode = PSL$C_USER;
804 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
806 d_name.dsc$a_pointer = name;
807 d_name.dsc$w_length = strlen(name);
809 lnmlst[0].buflen = strlen(eqv);
810 lnmlst[0].bufadr = eqv;
812 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
813 if (!(iss&1)) lib$signal(iss);
818 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
819 /* my_crypt - VMS password hashing
820 * my_crypt() provides an interface compatible with the Unix crypt()
821 * C library function, and uses sys$hash_password() to perform VMS
822 * password hashing. The quadword hashed password value is returned
823 * as a NUL-terminated 8 character string. my_crypt() does not change
824 * the case of its string arguments; in order to match the behavior
825 * of LOGINOUT et al., alphabetic characters in both arguments must
826 * be upcased by the caller.
829 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
831 # ifndef UAI$C_PREFERRED_ALGORITHM
832 # define UAI$C_PREFERRED_ALGORITHM 127
834 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
835 unsigned short int salt = 0;
836 unsigned long int sts;
838 unsigned short int dsc$w_length;
839 unsigned char dsc$b_type;
840 unsigned char dsc$b_class;
841 const char * dsc$a_pointer;
842 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
843 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
844 struct itmlst_3 uailst[3] = {
845 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
846 { sizeof salt, UAI$_SALT, &salt, 0},
847 { 0, 0, NULL, NULL}};
850 usrdsc.dsc$w_length = strlen(usrname);
851 usrdsc.dsc$a_pointer = usrname;
852 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
854 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
858 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
864 if (sts != RMS$_RNF) return NULL;
867 txtdsc.dsc$w_length = strlen(textpasswd);
868 txtdsc.dsc$a_pointer = textpasswd;
869 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
870 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
873 return (char *) hash;
875 } /* end of my_crypt() */
879 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
880 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
881 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
883 /*{{{int do_rmdir(char *name)*/
885 Perl_do_rmdir(pTHX_ char *name)
887 char dirfile[NAM$C_MAXRSS+1];
891 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
892 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
893 else retval = kill_file(dirfile);
896 } /* end of do_rmdir */
900 * Delete any file to which user has control access, regardless of whether
901 * delete access is explicitly allowed.
902 * Limitations: User must have write access to parent directory.
903 * Does not block signals or ASTs; if interrupted in midstream
904 * may leave file with an altered ACL.
907 /*{{{int kill_file(char *name)*/
909 Perl_kill_file(pTHX_ char *name)
911 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
912 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
913 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
914 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
916 unsigned char myace$b_length;
917 unsigned char myace$b_type;
918 unsigned short int myace$w_flags;
919 unsigned long int myace$l_access;
920 unsigned long int myace$l_ident;
921 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
922 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
923 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
925 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
926 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
927 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
928 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
929 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
930 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
932 /* Expand the input spec using RMS, since the CRTL remove() and
933 * system services won't do this by themselves, so we may miss
934 * a file "hiding" behind a logical name or search list. */
935 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
936 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
937 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
938 /* If not, can changing protections help? */
939 if (vaxc$errno != RMS$_PRV) return -1;
941 /* No, so we get our own UIC to use as a rights identifier,
942 * and the insert an ACE at the head of the ACL which allows us
943 * to delete the file.
945 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
946 fildsc.dsc$w_length = strlen(rspec);
947 fildsc.dsc$a_pointer = rspec;
949 newace.myace$l_ident = oldace.myace$l_ident;
950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
952 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
953 set_errno(ENOENT); break;
955 set_errno(ENOTDIR); break;
957 set_errno(ENODEV); break;
958 case RMS$_SYN: case SS$_INVFILFOROP:
959 set_errno(EINVAL); break;
961 set_errno(EACCES); break;
965 set_vaxc_errno(aclsts);
968 /* Grab any existing ACEs with this identifier in case we fail */
969 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
970 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
971 || fndsts == SS$_NOMOREACE ) {
972 /* Add the new ACE . . . */
973 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
975 if ((rmsts = remove(name))) {
976 /* We blew it - dir with files in it, no write priv for
977 * parent directory, etc. Put things back the way they were. */
978 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
981 addlst[0].bufadr = &oldace;
982 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
989 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
990 /* We just deleted it, so of course it's not there. Some versions of
991 * VMS seem to return success on the unlock operation anyhow (after all
992 * the unlock is successful), but others don't.
994 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
995 if (aclsts & 1) aclsts = fndsts;
998 set_vaxc_errno(aclsts);
1004 } /* end of kill_file() */
1008 /*{{{int my_mkdir(char *,Mode_t)*/
1010 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1012 STRLEN dirlen = strlen(dir);
1014 /* zero length string sometimes gives ACCVIO */
1015 if (dirlen == 0) return -1;
1017 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1018 * null file name/type. However, it's commonplace under Unix,
1019 * so we'll allow it for a gain in portability.
1021 if (dir[dirlen-1] == '/') {
1022 char *newdir = savepvn(dir,dirlen-1);
1023 int ret = mkdir(newdir,mode);
1027 else return mkdir(dir,mode);
1028 } /* end of my_mkdir */
1031 /*{{{int my_chdir(char *)*/
1033 Perl_my_chdir(pTHX_ char *dir)
1035 STRLEN dirlen = strlen(dir);
1037 /* zero length string sometimes gives ACCVIO */
1038 if (dirlen == 0) return -1;
1040 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1042 * null file name/type. However, it's commonplace under Unix,
1043 * so we'll allow it for a gain in portability.
1045 if (dir[dirlen-1] == '/') {
1046 char *newdir = savepvn(dir,dirlen-1);
1047 int ret = chdir(newdir);
1051 else return chdir(dir);
1052 } /* end of my_chdir */
1056 /*{{{FILE *my_tmpfile()*/
1063 if ((fp = tmpfile())) return fp;
1065 New(1323,cp,L_tmpnam+24,char);
1066 strcpy(cp,"Sys$Scratch:");
1067 tmpnam(cp+strlen(cp));
1068 strcat(cp,".Perltmp");
1069 fp = fopen(cp,"w+","fop=dlt");
1076 #ifndef HOMEGROWN_POSIX_SIGNALS
1078 * The C RTL's sigaction fails to check for invalid signal numbers so we
1079 * help it out a bit. The docs are correct, but the actual routine doesn't
1080 * do what the docs say it will.
1082 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1084 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1085 struct sigaction* oact)
1087 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1088 SETERRNO(EINVAL, SS$_INVARG);
1091 return sigaction(sig, act, oact);
1096 /* default piping mailbox size */
1097 #define PERL_BUFSIZ 512
1101 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1103 unsigned long int mbxbufsiz;
1104 static unsigned long int syssize = 0;
1105 unsigned long int dviitm = DVI$_DEVNAM;
1106 char csize[LNM$C_NAMLENGTH+1];
1109 unsigned long syiitm = SYI$_MAXBUF;
1111 * Get the SYSGEN parameter MAXBUF
1113 * If the logical 'PERL_MBX_SIZE' is defined
1114 * use the value of the logical instead of PERL_BUFSIZ, but
1115 * keep the size between 128 and MAXBUF.
1118 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1121 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1122 mbxbufsiz = atoi(csize);
1124 mbxbufsiz = PERL_BUFSIZ;
1126 if (mbxbufsiz < 128) mbxbufsiz = 128;
1127 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1129 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1131 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1132 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1134 } /* end of create_mbx() */
1137 /*{{{ my_popen and my_pclose*/
1139 typedef struct _iosb IOSB;
1140 typedef struct _iosb* pIOSB;
1141 typedef struct _pipe Pipe;
1142 typedef struct _pipe* pPipe;
1143 typedef struct pipe_details Info;
1144 typedef struct pipe_details* pInfo;
1145 typedef struct _srqp RQE;
1146 typedef struct _srqp* pRQE;
1147 typedef struct _tochildbuf CBuf;
1148 typedef struct _tochildbuf* pCBuf;
1151 unsigned short status;
1152 unsigned short count;
1153 unsigned long dvispec;
1156 #pragma member_alignment save
1157 #pragma nomember_alignment quadword
1158 struct _srqp { /* VMS self-relative queue entry */
1159 unsigned long qptr[2];
1161 #pragma member_alignment restore
1162 static RQE RQE_ZERO = {0,0};
1164 struct _tochildbuf {
1167 unsigned short size;
1175 unsigned short chan_in;
1176 unsigned short chan_out;
1178 unsigned int bufsize;
1190 #if defined(PERL_IMPLICIT_CONTEXT)
1191 void *thx; /* Either a thread or an interpreter */
1192 /* pointer, depending on how we're built */
1200 PerlIO *fp; /* file pointer to pipe mailbox */
1201 int useFILE; /* using stdio, not perlio */
1202 int pid; /* PID of subprocess */
1203 int mode; /* == 'r' if pipe open for reading */
1204 int done; /* subprocess has completed */
1205 int waiting; /* waiting for completion/closure */
1206 int closing; /* my_pclose is closing this pipe */
1207 unsigned long completion; /* termination status of subprocess */
1208 pPipe in; /* pipe in to sub */
1209 pPipe out; /* pipe out of sub */
1210 pPipe err; /* pipe of sub's sys$error */
1211 int in_done; /* true when in pipe finished */
1216 struct exit_control_block
1218 struct exit_control_block *flink;
1219 unsigned long int (*exit_routine)();
1220 unsigned long int arg_count;
1221 unsigned long int *status_address;
1222 unsigned long int exit_status;
1225 #define RETRY_DELAY "0 ::0.20"
1226 #define MAX_RETRY 50
1228 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1229 static unsigned long mypid;
1230 static unsigned long delaytime[2];
1232 static pInfo open_pipes = NULL;
1233 static $DESCRIPTOR(nl_desc, "NL:");
1235 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1239 static unsigned long int
1240 pipe_exit_routine(pTHX)
1243 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1244 int sts, did_stuff, need_eof, j;
1247 flush any pending i/o
1253 PerlIO_flush(info->fp); /* first, flush data */
1255 fflush((FILE *)info->fp);
1261 next we try sending an EOF...ignore if doesn't work, make sure we
1269 _ckvmssts(sys$setast(0));
1270 if (info->in && !info->in->shut_on_empty) {
1271 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1276 _ckvmssts(sys$setast(1));
1280 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1282 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1287 _ckvmssts(sys$setast(0));
1288 if (info->waiting && info->done)
1290 nwait += info->waiting;
1291 _ckvmssts(sys$setast(1));
1301 _ckvmssts(sys$setast(0));
1302 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1303 sts = sys$forcex(&info->pid,0,&abort);
1304 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1307 _ckvmssts(sys$setast(1));
1311 /* again, wait for effect */
1313 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1318 _ckvmssts(sys$setast(0));
1319 if (info->waiting && info->done)
1321 nwait += info->waiting;
1322 _ckvmssts(sys$setast(1));
1331 _ckvmssts(sys$setast(0));
1332 if (!info->done) { /* We tried to be nice . . . */
1333 sts = sys$delprc(&info->pid,0);
1334 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1336 _ckvmssts(sys$setast(1));
1341 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1342 else if (!(sts & 1)) retsts = sts;
1347 static struct exit_control_block pipe_exitblock =
1348 {(struct exit_control_block *) 0,
1349 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1351 static void pipe_mbxtofd_ast(pPipe p);
1352 static void pipe_tochild1_ast(pPipe p);
1353 static void pipe_tochild2_ast(pPipe p);
1356 popen_completion_ast(pInfo info)
1358 pInfo i = open_pipes;
1362 if (i == info) break;
1365 if (!i) return; /* unlinked, probably freed too */
1367 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1371 Writing to subprocess ...
1372 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1374 chan_out may be waiting for "done" flag, or hung waiting
1375 for i/o completion to child...cancel the i/o. This will
1376 put it into "snarf mode" (done but no EOF yet) that discards
1379 Output from subprocess (stdout, stderr) needs to be flushed and
1380 shut down. We try sending an EOF, but if the mbx is full the pipe
1381 routine should still catch the "shut_on_empty" flag, telling it to
1382 use immediate-style reads so that "mbx empty" -> EOF.
1386 if (info->in && !info->in_done) { /* only for mode=w */
1387 if (info->in->shut_on_empty && info->in->need_wake) {
1388 info->in->need_wake = FALSE;
1389 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1391 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1395 if (info->out && !info->out_done) { /* were we also piping output? */
1396 info->out->shut_on_empty = TRUE;
1397 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1398 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1399 _ckvmssts_noperl(iss);
1402 if (info->err && !info->err_done) { /* we were piping stderr */
1403 info->err->shut_on_empty = TRUE;
1404 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1405 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1406 _ckvmssts_noperl(iss);
1408 _ckvmssts_noperl(sys$setef(pipe_ef));
1412 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
1413 static void vms_execfree(pTHX);
1416 we actually differ from vmstrnenv since we use this to
1417 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1418 are pointing to the same thing
1421 static unsigned short
1422 popen_translate(pTHX_ char *logical, char *result)
1425 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1426 $DESCRIPTOR(d_log,"");
1428 unsigned short length;
1429 unsigned short code;
1431 unsigned short *retlenaddr;
1433 unsigned short l, ifi;
1435 d_log.dsc$a_pointer = logical;
1436 d_log.dsc$w_length = strlen(logical);
1438 itmlst[0].code = LNM$_STRING;
1439 itmlst[0].length = 255;
1440 itmlst[0].buffer_addr = result;
1441 itmlst[0].retlenaddr = &l;
1444 itmlst[1].length = 0;
1445 itmlst[1].buffer_addr = 0;
1446 itmlst[1].retlenaddr = 0;
1448 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1449 if (iss == SS$_NOLOGNAM) {
1453 if (!(iss&1)) lib$signal(iss);
1456 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1457 strip it off and return the ifi, if any
1460 if (result[0] == 0x1b && result[1] == 0x00) {
1461 memcpy(&ifi,result+2,2);
1462 strcpy(result,result+4);
1464 return ifi; /* this is the RMS internal file id */
1467 static void pipe_infromchild_ast(pPipe p);
1470 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1471 inside an AST routine without worrying about reentrancy and which Perl
1472 memory allocator is being used.
1474 We read data and queue up the buffers, then spit them out one at a
1475 time to the output mailbox when the output mailbox is ready for one.
1478 #define INITIAL_TOCHILDQUEUE 2
1481 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1485 char mbx1[64], mbx2[64];
1486 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1487 DSC$K_CLASS_S, mbx1},
1488 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1489 DSC$K_CLASS_S, mbx2};
1490 unsigned int dviitm = DVI$_DEVBUFSIZ;
1493 New(1368, p, 1, Pipe);
1495 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1496 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1497 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1500 p->shut_on_empty = FALSE;
1501 p->need_wake = FALSE;
1504 p->iosb.status = SS$_NORMAL;
1505 p->iosb2.status = SS$_NORMAL;
1511 #ifdef PERL_IMPLICIT_CONTEXT
1515 n = sizeof(CBuf) + p->bufsize;
1517 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1518 _ckvmssts(lib$get_vm(&n, &b));
1519 b->buf = (char *) b + sizeof(CBuf);
1520 _ckvmssts(lib$insqhi(b, &p->free));
1523 pipe_tochild2_ast(p);
1524 pipe_tochild1_ast(p);
1530 /* reads the MBX Perl is writing, and queues */
1533 pipe_tochild1_ast(pPipe p)
1536 int iss = p->iosb.status;
1537 int eof = (iss == SS$_ENDOFFILE);
1538 #ifdef PERL_IMPLICIT_CONTEXT
1544 p->shut_on_empty = TRUE;
1546 _ckvmssts(sys$dassgn(p->chan_in));
1552 b->size = p->iosb.count;
1553 _ckvmssts(lib$insqhi(b, &p->wait));
1555 p->need_wake = FALSE;
1556 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1559 p->retry = 1; /* initial call */
1562 if (eof) { /* flush the free queue, return when done */
1563 int n = sizeof(CBuf) + p->bufsize;
1565 iss = lib$remqti(&p->free, &b);
1566 if (iss == LIB$_QUEWASEMP) return;
1568 _ckvmssts(lib$free_vm(&n, &b));
1572 iss = lib$remqti(&p->free, &b);
1573 if (iss == LIB$_QUEWASEMP) {
1574 int n = sizeof(CBuf) + p->bufsize;
1575 _ckvmssts(lib$get_vm(&n, &b));
1576 b->buf = (char *) b + sizeof(CBuf);
1582 iss = sys$qio(0,p->chan_in,
1583 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1585 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1586 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1591 /* writes queued buffers to output, waits for each to complete before
1595 pipe_tochild2_ast(pPipe p)
1598 int iss = p->iosb2.status;
1599 int n = sizeof(CBuf) + p->bufsize;
1600 int done = (p->info && p->info->done) ||
1601 iss == SS$_CANCEL || iss == SS$_ABORT;
1602 #if defined(PERL_IMPLICIT_CONTEXT)
1607 if (p->type) { /* type=1 has old buffer, dispose */
1608 if (p->shut_on_empty) {
1609 _ckvmssts(lib$free_vm(&n, &b));
1611 _ckvmssts(lib$insqhi(b, &p->free));
1616 iss = lib$remqti(&p->wait, &b);
1617 if (iss == LIB$_QUEWASEMP) {
1618 if (p->shut_on_empty) {
1620 _ckvmssts(sys$dassgn(p->chan_out));
1621 *p->pipe_done = TRUE;
1622 _ckvmssts(sys$setef(pipe_ef));
1624 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1625 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1629 p->need_wake = TRUE;
1639 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1640 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1642 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1643 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1652 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1655 char mbx1[64], mbx2[64];
1656 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1657 DSC$K_CLASS_S, mbx1},
1658 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1659 DSC$K_CLASS_S, mbx2};
1660 unsigned int dviitm = DVI$_DEVBUFSIZ;
1662 New(1367, p, 1, Pipe);
1663 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1664 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1666 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1667 New(1367, p->buf, p->bufsize, char);
1668 p->shut_on_empty = FALSE;
1671 p->iosb.status = SS$_NORMAL;
1672 #if defined(PERL_IMPLICIT_CONTEXT)
1675 pipe_infromchild_ast(p);
1683 pipe_infromchild_ast(pPipe p)
1685 int iss = p->iosb.status;
1686 int eof = (iss == SS$_ENDOFFILE);
1687 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1688 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1689 #if defined(PERL_IMPLICIT_CONTEXT)
1693 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1694 _ckvmssts(sys$dassgn(p->chan_out));
1699 input shutdown if EOF from self (done or shut_on_empty)
1700 output shutdown if closing flag set (my_pclose)
1701 send data/eof from child or eof from self
1702 otherwise, re-read (snarf of data from child)
1707 if (myeof && p->chan_in) { /* input shutdown */
1708 _ckvmssts(sys$dassgn(p->chan_in));
1713 if (myeof || kideof) { /* pass EOF to parent */
1714 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1715 pipe_infromchild_ast, p,
1718 } else if (eof) { /* eat EOF --- fall through to read*/
1720 } else { /* transmit data */
1721 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1722 pipe_infromchild_ast,p,
1723 p->buf, p->iosb.count, 0, 0, 0, 0));
1729 /* everything shut? flag as done */
1731 if (!p->chan_in && !p->chan_out) {
1732 *p->pipe_done = TRUE;
1733 _ckvmssts(sys$setef(pipe_ef));
1737 /* write completed (or read, if snarfing from child)
1738 if still have input active,
1739 queue read...immediate mode if shut_on_empty so we get EOF if empty
1741 check if Perl reading, generate EOFs as needed
1747 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1748 pipe_infromchild_ast,p,
1749 p->buf, p->bufsize, 0, 0, 0, 0);
1750 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1752 } else { /* send EOFs for extra reads */
1753 p->iosb.status = SS$_ENDOFFILE;
1754 p->iosb.dvispec = 0;
1755 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1757 pipe_infromchild_ast, p, 0, 0, 0, 0));
1763 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1767 unsigned long dviitm = DVI$_DEVBUFSIZ;
1769 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1770 DSC$K_CLASS_S, mbx};
1772 /* things like terminals and mbx's don't need this filter */
1773 if (fd && fstat(fd,&s) == 0) {
1774 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1775 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1776 DSC$K_CLASS_S, s.st_dev};
1778 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1779 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1780 strcpy(out, s.st_dev);
1785 New(1366, p, 1, Pipe);
1786 p->fd_out = dup(fd);
1787 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1788 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1789 New(1366, p->buf, p->bufsize+1, char);
1790 p->shut_on_empty = FALSE;
1795 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1796 pipe_mbxtofd_ast, p,
1797 p->buf, p->bufsize, 0, 0, 0, 0));
1803 pipe_mbxtofd_ast(pPipe p)
1805 int iss = p->iosb.status;
1806 int done = p->info->done;
1808 int eof = (iss == SS$_ENDOFFILE);
1809 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1810 int err = !(iss&1) && !eof;
1811 #if defined(PERL_IMPLICIT_CONTEXT)
1815 if (done && myeof) { /* end piping */
1817 sys$dassgn(p->chan_in);
1818 *p->pipe_done = TRUE;
1819 _ckvmssts(sys$setef(pipe_ef));
1823 if (!err && !eof) { /* good data to send to file */
1824 p->buf[p->iosb.count] = '\n';
1825 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1828 if (p->retry < MAX_RETRY) {
1829 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1839 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1840 pipe_mbxtofd_ast, p,
1841 p->buf, p->bufsize, 0, 0, 0, 0);
1842 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1847 typedef struct _pipeloc PLOC;
1848 typedef struct _pipeloc* pPLOC;
1852 char dir[NAM$C_MAXRSS+1];
1854 static pPLOC head_PLOC = 0;
1857 free_pipelocs(pTHX_ void *head)
1860 pPLOC *pHead = (pPLOC *)head;
1872 store_pipelocs(pTHX)
1881 char temp[NAM$C_MAXRSS+1];
1885 free_pipelocs(&head_PLOC);
1887 /* the . directory from @INC comes last */
1890 p->next = head_PLOC;
1892 strcpy(p->dir,"./");
1894 /* get the directory from $^X */
1896 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1897 strcpy(temp, PL_origargv[0]);
1898 x = strrchr(temp,']');
1901 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1903 p->next = head_PLOC;
1905 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1906 p->dir[NAM$C_MAXRSS] = '\0';
1910 /* reverse order of @INC entries, skip "." since entered above */
1912 if (PL_incgv) av = GvAVn(PL_incgv);
1914 for (i = 0; av && i <= AvFILL(av); i++) {
1915 dirsv = *av_fetch(av,i,TRUE);
1917 if (SvROK(dirsv)) continue;
1918 dir = SvPVx(dirsv,n_a);
1919 if (strcmp(dir,".") == 0) continue;
1920 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1924 p->next = head_PLOC;
1926 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1927 p->dir[NAM$C_MAXRSS] = '\0';
1930 /* most likely spot (ARCHLIB) put first in the list */
1933 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1935 p->next = head_PLOC;
1937 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1938 p->dir[NAM$C_MAXRSS] = '\0';
1941 Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
1948 static int vmspipe_file_status = 0;
1949 static char vmspipe_file[NAM$C_MAXRSS+1];
1951 /* already found? Check and use ... need read+execute permission */
1953 if (vmspipe_file_status == 1) {
1954 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1955 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1956 return vmspipe_file;
1958 vmspipe_file_status = 0;
1961 /* scan through stored @INC, $^X */
1963 if (vmspipe_file_status == 0) {
1964 char file[NAM$C_MAXRSS+1];
1965 pPLOC p = head_PLOC;
1968 strcpy(file, p->dir);
1969 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1970 file[NAM$C_MAXRSS] = '\0';
1973 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1975 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1976 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1977 vmspipe_file_status = 1;
1978 return vmspipe_file;
1981 vmspipe_file_status = -1; /* failed, use tempfiles */
1988 vmspipe_tempfile(pTHX)
1990 char file[NAM$C_MAXRSS+1];
1992 static int index = 0;
1995 /* create a tempfile */
1997 /* we can't go from W, shr=get to R, shr=get without
1998 an intermediate vulnerable state, so don't bother trying...
2000 and lib$spawn doesn't shr=put, so have to close the write
2002 So... match up the creation date/time and the FID to
2003 make sure we're dealing with the same file
2008 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2009 fp = fopen(file,"w");
2011 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2012 fp = fopen(file,"w");
2014 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2015 fp = fopen(file,"w");
2018 if (!fp) return 0; /* we're hosed */
2020 fprintf(fp,"$! 'f$verify(0)\n");
2021 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2022 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2023 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2024 fprintf(fp,"$ perl_on = \"set noon\"\n");
2025 fprintf(fp,"$ perl_exit = \"exit\"\n");
2026 fprintf(fp,"$ perl_del = \"delete\"\n");
2027 fprintf(fp,"$ pif = \"if\"\n");
2028 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2029 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2030 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2031 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2032 fprintf(fp,"$! --- build command line to get max possible length\n");
2033 fprintf(fp,"$c=perl_popen_cmd0\n");
2034 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2035 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2036 fprintf(fp,"$x=perl_popen_cmd3\n");
2037 fprintf(fp,"$c=c+x\n");
2038 fprintf(fp,"$! --- get rid of global symbols\n");
2039 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2040 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2041 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2042 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
2043 fprintf(fp,"$ perl_on\n");
2044 fprintf(fp,"$ 'c\n");
2045 fprintf(fp,"$ perl_status = $STATUS\n");
2046 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2047 fprintf(fp,"$ perl_exit 'perl_status'\n");
2050 fgetname(fp, file, 1);
2051 fstat(fileno(fp), &s0);
2054 fp = fopen(file,"r","shr=get");
2056 fstat(fileno(fp), &s1);
2058 if (s0.st_ino[0] != s1.st_ino[0] ||
2059 s0.st_ino[1] != s1.st_ino[1] ||
2060 s0.st_ino[2] != s1.st_ino[2] ||
2061 s0.st_ctime != s1.st_ctime ) {
2072 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2074 static int handler_set_up = FALSE;
2075 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2076 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2078 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2079 char in[512], out[512], err[512], mbx[512];
2081 char tfilebuf[NAM$C_MAXRSS+1];
2083 char cmd_sym_name[20];
2084 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2085 DSC$K_CLASS_S, symbol};
2086 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2088 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2089 DSC$K_CLASS_S, cmd_sym_name};
2090 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2091 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2092 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2094 /* once-per-program initialization...
2095 note that the SETAST calls and the dual test of pipe_ef
2096 makes sure that only the FIRST thread through here does
2097 the initialization...all other threads wait until it's
2100 Yeah, uglier than a pthread call, it's got all the stuff inline
2101 rather than in a separate routine.
2105 _ckvmssts(sys$setast(0));
2107 unsigned long int pidcode = JPI$_PID;
2108 $DESCRIPTOR(d_delay, RETRY_DELAY);
2109 _ckvmssts(lib$get_ef(&pipe_ef));
2110 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2111 _ckvmssts(sys$bintim(&d_delay, delaytime));
2113 if (!handler_set_up) {
2114 _ckvmssts(sys$dclexh(&pipe_exitblock));
2115 handler_set_up = TRUE;
2117 _ckvmssts(sys$setast(1));
2120 /* see if we can find a VMSPIPE.COM */
2123 vmspipe = find_vmspipe(aTHX);
2125 strcpy(tfilebuf+1,vmspipe);
2126 } else { /* uh, oh...we're in tempfile hell */
2127 tpipe = vmspipe_tempfile(aTHX);
2128 if (!tpipe) { /* a fish popular in Boston */
2129 if (ckWARN(WARN_PIPE)) {
2130 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2134 fgetname(tpipe,tfilebuf+1,1);
2136 vmspipedsc.dsc$a_pointer = tfilebuf;
2137 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2139 sts = setup_cmddsc(aTHX_ cmd,0,0);
2142 case RMS$_FNF: case RMS$_DNF:
2143 set_errno(ENOENT); break;
2145 set_errno(ENOTDIR); break;
2147 set_errno(ENODEV); break;
2149 set_errno(EACCES); break;
2151 set_errno(EINVAL); break;
2152 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2153 set_errno(E2BIG); break;
2154 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2155 _ckvmssts(sts); /* fall through */
2156 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2159 set_vaxc_errno(sts);
2160 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2161 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2166 New(1301,info,1,Info);
2168 strcpy(mode,in_mode);
2171 info->completion = 0;
2172 info->closing = FALSE;
2179 info->in_done = TRUE;
2180 info->out_done = TRUE;
2181 info->err_done = TRUE;
2182 in[0] = out[0] = err[0] = '\0';
2184 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2188 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2193 if (*mode == 'r') { /* piping from subroutine */
2195 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2197 info->out->pipe_done = &info->out_done;
2198 info->out_done = FALSE;
2199 info->out->info = info;
2201 if (!info->useFILE) {
2202 info->fp = PerlIO_open(mbx, mode);
2204 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2205 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2208 if (!info->fp && info->out) {
2209 sys$cancel(info->out->chan_out);
2211 while (!info->out_done) {
2213 _ckvmssts(sys$setast(0));
2214 done = info->out_done;
2215 if (!done) _ckvmssts(sys$clref(pipe_ef));
2216 _ckvmssts(sys$setast(1));
2217 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2220 if (info->out->buf) Safefree(info->out->buf);
2221 Safefree(info->out);
2227 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2229 info->err->pipe_done = &info->err_done;
2230 info->err_done = FALSE;
2231 info->err->info = info;
2234 } else if (*mode == 'w') { /* piping to subroutine */
2236 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2238 info->out->pipe_done = &info->out_done;
2239 info->out_done = FALSE;
2240 info->out->info = info;
2243 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2245 info->err->pipe_done = &info->err_done;
2246 info->err_done = FALSE;
2247 info->err->info = info;
2250 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2251 if (!info->useFILE) {
2252 info->fp = PerlIO_open(mbx, mode);
2254 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2255 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2259 info->in->pipe_done = &info->in_done;
2260 info->in_done = FALSE;
2261 info->in->info = info;
2265 if (!info->fp && info->in) {
2267 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2268 0, 0, 0, 0, 0, 0, 0, 0));
2270 while (!info->in_done) {
2272 _ckvmssts(sys$setast(0));
2273 done = info->in_done;
2274 if (!done) _ckvmssts(sys$clref(pipe_ef));
2275 _ckvmssts(sys$setast(1));
2276 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2279 if (info->in->buf) Safefree(info->in->buf);
2287 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2288 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2290 info->out->pipe_done = &info->out_done;
2291 info->out_done = FALSE;
2292 info->out->info = info;
2295 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2297 info->err->pipe_done = &info->err_done;
2298 info->err_done = FALSE;
2299 info->err->info = info;
2303 symbol[MAX_DCL_SYMBOL] = '\0';
2305 strncpy(symbol, in, MAX_DCL_SYMBOL);
2306 d_symbol.dsc$w_length = strlen(symbol);
2307 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2309 strncpy(symbol, err, MAX_DCL_SYMBOL);
2310 d_symbol.dsc$w_length = strlen(symbol);
2311 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2313 strncpy(symbol, out, MAX_DCL_SYMBOL);
2314 d_symbol.dsc$w_length = strlen(symbol);
2315 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2317 p = VMSCMD.dsc$a_pointer;
2318 while (*p && *p != '\n') p++;
2319 *p = '\0'; /* truncate on \n */
2320 p = VMSCMD.dsc$a_pointer;
2321 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2322 if (*p == '$') p++; /* remove leading $ */
2323 while (*p == ' ' || *p == '\t') p++;
2325 for (j = 0; j < 4; j++) {
2326 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2327 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2329 strncpy(symbol, p, MAX_DCL_SYMBOL);
2330 d_symbol.dsc$w_length = strlen(symbol);
2331 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2333 if (strlen(p) > MAX_DCL_SYMBOL) {
2334 p += MAX_DCL_SYMBOL;
2339 _ckvmssts(sys$setast(0));
2340 info->next=open_pipes; /* prepend to list */
2342 _ckvmssts(sys$setast(1));
2343 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2344 0, &info->pid, &info->completion,
2345 0, popen_completion_ast,info,0,0,0));
2347 /* if we were using a tempfile, close it now */
2349 if (tpipe) fclose(tpipe);
2351 /* once the subprocess is spawned, it has copied the symbols and
2352 we can get rid of ours */
2354 for (j = 0; j < 4; j++) {
2355 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2356 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2357 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2359 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2360 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2361 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2364 PL_forkprocess = info->pid;
2368 _ckvmssts(sys$setast(0));
2370 if (!done) _ckvmssts(sys$clref(pipe_ef));
2371 _ckvmssts(sys$setast(1));
2372 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2374 *psts = info->completion;
2375 my_pclose(info->fp);
2380 } /* end of safe_popen */
2383 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2385 Perl_my_popen(pTHX_ char *cmd, char *mode)
2389 TAINT_PROPER("popen");
2390 PERL_FLUSHALL_FOR_CHILD;
2391 return safe_popen(aTHX_ cmd,mode,&sts);
2396 /*{{{ I32 my_pclose(PerlIO *fp)*/
2397 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2399 pInfo info, last = NULL;
2400 unsigned long int retsts;
2403 for (info = open_pipes; info != NULL; last = info, info = info->next)
2404 if (info->fp == fp) break;
2406 if (info == NULL) { /* no such pipe open */
2407 set_errno(ECHILD); /* quoth POSIX */
2408 set_vaxc_errno(SS$_NONEXPR);
2412 /* If we were writing to a subprocess, insure that someone reading from
2413 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2414 * produce an EOF record in the mailbox.
2416 * well, at least sometimes it *does*, so we have to watch out for
2417 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2421 PerlIO_flush(info->fp); /* first, flush data */
2423 fflush((FILE *)info->fp);
2426 _ckvmssts(sys$setast(0));
2427 info->closing = TRUE;
2428 done = info->done && info->in_done && info->out_done && info->err_done;
2429 /* hanging on write to Perl's input? cancel it */
2430 if (info->mode == 'r' && info->out && !info->out_done) {
2431 if (info->out->chan_out) {
2432 _ckvmssts(sys$cancel(info->out->chan_out));
2433 if (!info->out->chan_in) { /* EOF generation, need AST */
2434 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2438 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2439 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2441 _ckvmssts(sys$setast(1));
2444 PerlIO_close(info->fp);
2446 fclose((FILE *)info->fp);
2449 we have to wait until subprocess completes, but ALSO wait until all
2450 the i/o completes...otherwise we'll be freeing the "info" structure
2451 that the i/o ASTs could still be using...
2455 _ckvmssts(sys$setast(0));
2456 done = info->done && info->in_done && info->out_done && info->err_done;
2457 if (!done) _ckvmssts(sys$clref(pipe_ef));
2458 _ckvmssts(sys$setast(1));
2459 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2461 retsts = info->completion;
2463 /* remove from list of open pipes */
2464 _ckvmssts(sys$setast(0));
2465 if (last) last->next = info->next;
2466 else open_pipes = info->next;
2467 _ckvmssts(sys$setast(1));
2469 /* free buffers and structures */
2472 if (info->in->buf) Safefree(info->in->buf);
2476 if (info->out->buf) Safefree(info->out->buf);
2477 Safefree(info->out);
2480 if (info->err->buf) Safefree(info->err->buf);
2481 Safefree(info->err);
2487 } /* end of my_pclose() */
2489 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2490 /* Roll our own prototype because we want this regardless of whether
2491 * _VMS_WAIT is defined.
2493 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2495 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2496 created with popen(); otherwise partially emulate waitpid() unless
2497 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2498 Also check processes not considered by the CRTL waitpid().
2500 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2502 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2508 if (statusp) *statusp = 0;
2510 for (info = open_pipes; info != NULL; info = info->next)
2511 if (info->pid == pid) break;
2513 if (info != NULL) { /* we know about this child */
2514 while (!info->done) {
2515 _ckvmssts(sys$setast(0));
2517 if (!done) _ckvmssts(sys$clref(pipe_ef));
2518 _ckvmssts(sys$setast(1));
2519 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2522 if (statusp) *statusp = info->completion;
2526 else { /* this child is not one of our own pipe children */
2528 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2530 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2531 * in 7.2 did we get a version that fills in the VMS completion
2532 * status as Perl has always tried to do.
2535 sts = __vms_waitpid( pid, statusp, flags );
2537 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2540 /* If the real waitpid tells us the child does not exist, we
2541 * fall through here to implement waiting for a child that
2542 * was created by some means other than exec() (say, spawned
2543 * from DCL) or to wait for a process that is not a subprocess
2544 * of the current process.
2547 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2549 $DESCRIPTOR(intdsc,"0 00:00:01");
2550 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2551 unsigned long int pidcode = JPI$_PID, mypid;
2552 unsigned long int interval[2];
2553 int termination_mbu = 0;
2554 unsigned short qio_iosb[4];
2555 unsigned int jpi_iosb[2];
2556 struct itmlst_3 jpilist[3] = {
2557 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2558 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2561 char trmmbx[NAM$C_DVI+1];
2562 $DESCRIPTOR(trmmbxdsc,trmmbx);
2563 struct accdef trmmsg;
2564 unsigned short int mbxchan;
2567 /* Sorry folks, we don't presently implement rooting around for
2568 the first child we can find, and we definitely don't want to
2569 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2575 /* Get the owner of the child so I can warn if it's not mine, plus
2576 * get the termination mailbox. If the process doesn't exist or I
2577 * don't have the privs to look at it, I can go home early.
2579 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2580 if (sts & 1) sts = jpi_iosb[0];
2592 set_vaxc_errno(sts);
2596 if (ckWARN(WARN_EXEC)) {
2597 /* remind folks they are asking for non-standard waitpid behavior */
2598 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2599 if (ownerpid != mypid)
2600 Perl_warner(aTHX_ WARN_EXEC,
2601 "waitpid: process %x is not a child of process %x",
2605 /* It's possible to have a mailbox unit number but no actual mailbox; we
2606 * check for this by assigning a channel to it, which we need anyway.
2608 if (termination_mbu != 0) {
2609 sprintf(trmmbx, "MBA%d:", termination_mbu);
2610 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2611 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2612 if (sts == SS$_NOSUCHDEV) {
2613 termination_mbu = 0; /* set up to take "no mailbox" case */
2618 /* If the process doesn't have a termination mailbox, then simply check
2619 * on it once a second until it's not there anymore.
2621 if (termination_mbu == 0) {
2622 _ckvmssts(sys$bintim(&intdsc,interval));
2623 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2624 _ckvmssts(sys$schdwk(0,0,interval,0));
2625 _ckvmssts(sys$hiber());
2627 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2630 /* If we do have a termination mailbox, post reads to it until we get a
2631 * termination message, discarding messages of the wrong type or for other
2632 * processes. If there is a place to put the final status, then do so.
2636 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2637 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2638 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2639 if (sts & 1) sts = qio_iosb[0];
2642 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2643 && trmmsg.acc$l_pid == pid ) {
2645 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2646 sts = sys$dassgn(mbxchan);
2650 } /* termination_mbu ? */
2655 } /* else one of our own pipe children */
2657 } /* end of waitpid() */
2662 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2664 my_gconvert(double val, int ndig, int trail, char *buf)
2666 static char __gcvtbuf[DBL_DIG+1];
2669 loc = buf ? buf : __gcvtbuf;
2671 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2673 sprintf(loc,"%.*g",ndig,val);
2679 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2680 return gcvt(val,ndig,loc);
2683 loc[0] = '0'; loc[1] = '\0';
2691 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2692 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2693 * to expand file specification. Allows for a single default file
2694 * specification and a simple mask of options. If outbuf is non-NULL,
2695 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2696 * the resultant file specification is placed. If outbuf is NULL, the
2697 * resultant file specification is placed into a static buffer.
2698 * The third argument, if non-NULL, is taken to be a default file
2699 * specification string. The fourth argument is unused at present.
2700 * rmesexpand() returns the address of the resultant string if
2701 * successful, and NULL on error.
2703 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2706 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2708 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2709 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2710 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2711 struct FAB myfab = cc$rms_fab;
2712 struct NAM mynam = cc$rms_nam;
2714 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2716 if (!filespec || !*filespec) {
2717 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2721 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2722 else outbuf = __rmsexpand_retbuf;
2724 if ((isunix = (strchr(filespec,'/') != NULL))) {
2725 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2726 filespec = vmsfspec;
2729 myfab.fab$l_fna = filespec;
2730 myfab.fab$b_fns = strlen(filespec);
2731 myfab.fab$l_nam = &mynam;
2733 if (defspec && *defspec) {
2734 if (strchr(defspec,'/') != NULL) {
2735 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2738 myfab.fab$l_dna = defspec;
2739 myfab.fab$b_dns = strlen(defspec);
2742 mynam.nam$l_esa = esa;
2743 mynam.nam$b_ess = sizeof esa;
2744 mynam.nam$l_rsa = outbuf;
2745 mynam.nam$b_rss = NAM$C_MAXRSS;
2747 retsts = sys$parse(&myfab,0,0);
2748 if (!(retsts & 1)) {
2749 mynam.nam$b_nop |= NAM$M_SYNCHK;
2750 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2751 retsts = sys$parse(&myfab,0,0);
2752 if (retsts & 1) goto expanded;
2754 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2755 (void) sys$parse(&myfab,0,0); /* Free search context */
2756 if (out) Safefree(out);
2757 set_vaxc_errno(retsts);
2758 if (retsts == RMS$_PRV) set_errno(EACCES);
2759 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2760 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2761 else set_errno(EVMSERR);
2764 retsts = sys$search(&myfab,0,0);
2765 if (!(retsts & 1) && retsts != RMS$_FNF) {
2766 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2767 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2768 if (out) Safefree(out);
2769 set_vaxc_errno(retsts);
2770 if (retsts == RMS$_PRV) set_errno(EACCES);
2771 else set_errno(EVMSERR);
2775 /* If the input filespec contained any lowercase characters,
2776 * downcase the result for compatibility with Unix-minded code. */
2778 for (out = myfab.fab$l_fna; *out; out++)
2779 if (islower(*out)) { haslower = 1; break; }
2780 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2781 else { out = esa; speclen = mynam.nam$b_esl; }
2782 /* Trim off null fields added by $PARSE
2783 * If type > 1 char, must have been specified in original or default spec
2784 * (not true for version; $SEARCH may have added version of existing file).
2786 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2787 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2788 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2789 if (trimver || trimtype) {
2790 if (defspec && *defspec) {
2791 char defesa[NAM$C_MAXRSS];
2792 struct FAB deffab = cc$rms_fab;
2793 struct NAM defnam = cc$rms_nam;
2795 deffab.fab$l_nam = &defnam;
2796 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2797 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2798 defnam.nam$b_nop = NAM$M_SYNCHK;
2799 if (sys$parse(&deffab,0,0) & 1) {
2800 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2801 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2804 if (trimver) speclen = mynam.nam$l_ver - out;
2806 /* If we didn't already trim version, copy down */
2807 if (speclen > mynam.nam$l_ver - out)
2808 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2809 speclen - (mynam.nam$l_ver - out));
2810 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2813 /* If we just had a directory spec on input, $PARSE "helpfully"
2814 * adds an empty name and type for us */
2815 if (mynam.nam$l_name == mynam.nam$l_type &&
2816 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2817 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2818 speclen = mynam.nam$l_name - out;
2819 out[speclen] = '\0';
2820 if (haslower) __mystrtolower(out);
2822 /* Have we been working with an expanded, but not resultant, spec? */
2823 /* Also, convert back to Unix syntax if necessary. */
2824 if (!mynam.nam$b_rsl) {
2826 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2828 else strcpy(outbuf,esa);
2831 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2832 strcpy(outbuf,tmpfspec);
2834 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2835 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2836 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2840 /* External entry points */
2841 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2842 { return do_rmsexpand(spec,buf,0,def,opt); }
2843 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2844 { return do_rmsexpand(spec,buf,1,def,opt); }
2848 ** The following routines are provided to make life easier when
2849 ** converting among VMS-style and Unix-style directory specifications.
2850 ** All will take input specifications in either VMS or Unix syntax. On
2851 ** failure, all return NULL. If successful, the routines listed below
2852 ** return a pointer to a buffer containing the appropriately
2853 ** reformatted spec (and, therefore, subsequent calls to that routine
2854 ** will clobber the result), while the routines of the same names with
2855 ** a _ts suffix appended will return a pointer to a mallocd string
2856 ** containing the appropriately reformatted spec.
2857 ** In all cases, only explicit syntax is altered; no check is made that
2858 ** the resulting string is valid or that the directory in question
2861 ** fileify_dirspec() - convert a directory spec into the name of the
2862 ** directory file (i.e. what you can stat() to see if it's a dir).
2863 ** The style (VMS or Unix) of the result is the same as the style
2864 ** of the parameter passed in.
2865 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2866 ** what you prepend to a filename to indicate what directory it's in).
2867 ** The style (VMS or Unix) of the result is the same as the style
2868 ** of the parameter passed in.
2869 ** tounixpath() - convert a directory spec into a Unix-style path.
2870 ** tovmspath() - convert a directory spec into a VMS-style path.
2871 ** tounixspec() - convert any file spec into a Unix-style file spec.
2872 ** tovmsspec() - convert any file spec into a VMS-style spec.
2874 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2875 ** Permission is given to distribute this code as part of the Perl
2876 ** standard distribution under the terms of the GNU General Public
2877 ** License or the Perl Artistic License. Copies of each may be
2878 ** found in the Perl standard distribution.
2881 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2882 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2884 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2885 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2886 char *retspec, *cp1, *cp2, *lastdir;
2887 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2889 if (!dir || !*dir) {
2890 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2892 dirlen = strlen(dir);
2893 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2894 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2895 strcpy(trndir,"/sys$disk/000000");
2899 if (dirlen > NAM$C_MAXRSS) {
2900 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2902 if (!strpbrk(dir+1,"/]>:")) {
2903 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2904 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2906 dirlen = strlen(dir);
2909 strncpy(trndir,dir,dirlen);
2910 trndir[dirlen] = '\0';
2913 /* If we were handed a rooted logical name or spec, treat it like a
2914 * simple directory, so that
2915 * $ Define myroot dev:[dir.]
2916 * ... do_fileify_dirspec("myroot",buf,1) ...
2917 * does something useful.
2919 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2920 dir[--dirlen] = '\0';
2921 dir[dirlen-1] = ']';
2923 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2924 dir[--dirlen] = '\0';
2925 dir[dirlen-1] = '>';
2928 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2929 /* If we've got an explicit filename, we can just shuffle the string. */
2930 if (*(cp1+1)) hasfilename = 1;
2931 /* Similarly, we can just back up a level if we've got multiple levels
2932 of explicit directories in a VMS spec which ends with directories. */
2934 for (cp2 = cp1; cp2 > dir; cp2--) {
2936 *cp2 = *cp1; *cp1 = '\0';
2940 if (*cp2 == '[' || *cp2 == '<') break;
2945 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2946 if (dir[0] == '.') {
2947 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2948 return do_fileify_dirspec("[]",buf,ts);
2949 else if (dir[1] == '.' &&
2950 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2951 return do_fileify_dirspec("[-]",buf,ts);
2953 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2954 dirlen -= 1; /* to last element */
2955 lastdir = strrchr(dir,'/');
2957 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2958 /* If we have "/." or "/..", VMSify it and let the VMS code
2959 * below expand it, rather than repeating the code to handle
2960 * relative components of a filespec here */
2962 if (*(cp1+2) == '.') cp1++;
2963 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2964 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2965 if (strchr(vmsdir,'/') != NULL) {
2966 /* If do_tovmsspec() returned it, it must have VMS syntax
2967 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2968 * the time to check this here only so we avoid a recursion
2969 * loop; otherwise, gigo.
2971 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2973 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2974 return do_tounixspec(trndir,buf,ts);
2977 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2978 lastdir = strrchr(dir,'/');
2980 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2981 /* Ditto for specs that end in an MFD -- let the VMS code
2982 * figure out whether it's a real device or a rooted logical. */
2983 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2984 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2985 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2986 return do_tounixspec(trndir,buf,ts);
2989 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2990 !(lastdir = cp1 = strrchr(dir,']')) &&
2991 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2992 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2994 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2995 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2996 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2997 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2998 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2999 (ver || *cp3)))))) {
3001 set_vaxc_errno(RMS$_DIR);
3007 /* If we lead off with a device or rooted logical, add the MFD
3008 if we're specifying a top-level directory. */
3009 if (lastdir && *dir == '/') {
3011 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3018 retlen = dirlen + (addmfd ? 13 : 6);
3019 if (buf) retspec = buf;
3020 else if (ts) New(1309,retspec,retlen+1,char);
3021 else retspec = __fileify_retbuf;
3023 dirlen = lastdir - dir;
3024 memcpy(retspec,dir,dirlen);
3025 strcpy(&retspec[dirlen],"/000000");
3026 strcpy(&retspec[dirlen+7],lastdir);
3029 memcpy(retspec,dir,dirlen);
3030 retspec[dirlen] = '\0';
3032 /* We've picked up everything up to the directory file name.
3033 Now just add the type and version, and we're set. */
3034 strcat(retspec,".dir;1");
3037 else { /* VMS-style directory spec */
3038 char esa[NAM$C_MAXRSS+1], term, *cp;
3039 unsigned long int sts, cmplen, haslower = 0;
3040 struct FAB dirfab = cc$rms_fab;
3041 struct NAM savnam, dirnam = cc$rms_nam;
3043 dirfab.fab$b_fns = strlen(dir);
3044 dirfab.fab$l_fna = dir;
3045 dirfab.fab$l_nam = &dirnam;
3046 dirfab.fab$l_dna = ".DIR;1";
3047 dirfab.fab$b_dns = 6;
3048 dirnam.nam$b_ess = NAM$C_MAXRSS;
3049 dirnam.nam$l_esa = esa;
3051 for (cp = dir; *cp; cp++)
3052 if (islower(*cp)) { haslower = 1; break; }
3053 if (!((sts = sys$parse(&dirfab))&1)) {
3054 if (dirfab.fab$l_sts == RMS$_DIR) {
3055 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3056 sts = sys$parse(&dirfab) & 1;
3060 set_vaxc_errno(dirfab.fab$l_sts);
3066 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3067 /* Yes; fake the fnb bits so we'll check type below */
3068 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3070 else { /* No; just work with potential name */
3071 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3073 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3074 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3075 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3080 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3081 cp1 = strchr(esa,']');
3082 if (!cp1) cp1 = strchr(esa,'>');
3083 if (cp1) { /* Should always be true */
3084 dirnam.nam$b_esl -= cp1 - esa - 1;
3085 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3088 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3089 /* Yep; check version while we're at it, if it's there. */
3090 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3091 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3092 /* Something other than .DIR[;1]. Bzzt. */
3093 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3094 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3096 set_vaxc_errno(RMS$_DIR);
3100 esa[dirnam.nam$b_esl] = '\0';
3101 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3102 /* They provided at least the name; we added the type, if necessary, */
3103 if (buf) retspec = buf; /* in sys$parse() */
3104 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3105 else retspec = __fileify_retbuf;
3106 strcpy(retspec,esa);
3107 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3108 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3111 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3112 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3114 dirnam.nam$b_esl -= 9;
3116 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3117 if (cp1 == NULL) { /* should never happen */
3118 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3119 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3124 retlen = strlen(esa);
3125 if ((cp1 = strrchr(esa,'.')) != NULL) {
3126 /* There's more than one directory in the path. Just roll back. */
3128 if (buf) retspec = buf;
3129 else if (ts) New(1311,retspec,retlen+7,char);
3130 else retspec = __fileify_retbuf;
3131 strcpy(retspec,esa);
3134 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3135 /* Go back and expand rooted logical name */
3136 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3137 if (!(sys$parse(&dirfab) & 1)) {
3138 dirnam.nam$l_rlf = NULL;
3139 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3141 set_vaxc_errno(dirfab.fab$l_sts);
3144 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3145 if (buf) retspec = buf;
3146 else if (ts) New(1312,retspec,retlen+16,char);
3147 else retspec = __fileify_retbuf;
3148 cp1 = strstr(esa,"][");
3149 if (!cp1) cp1 = strstr(esa,"]<");
3151 memcpy(retspec,esa,dirlen);
3152 if (!strncmp(cp1+2,"000000]",7)) {
3153 retspec[dirlen-1] = '\0';
3154 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3155 if (*cp1 == '.') *cp1 = ']';
3157 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3158 memcpy(cp1+1,"000000]",7);
3162 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3163 retspec[retlen] = '\0';
3164 /* Convert last '.' to ']' */
3165 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3166 if (*cp1 == '.') *cp1 = ']';
3168 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3169 memcpy(cp1+1,"000000]",7);
3173 else { /* This is a top-level dir. Add the MFD to the path. */
3174 if (buf) retspec = buf;
3175 else if (ts) New(1312,retspec,retlen+16,char);
3176 else retspec = __fileify_retbuf;
3179 while (*cp1 != ':') *(cp2++) = *(cp1++);
3180 strcpy(cp2,":[000000]");
3185 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3186 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3187 /* We've set up the string up through the filename. Add the
3188 type and version, and we're done. */
3189 strcat(retspec,".DIR;1");
3191 /* $PARSE may have upcased filespec, so convert output to lower
3192 * case if input contained any lowercase characters. */
3193 if (haslower) __mystrtolower(retspec);
3196 } /* end of do_fileify_dirspec() */
3198 /* External entry points */
3199 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3200 { return do_fileify_dirspec(dir,buf,0); }
3201 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3202 { return do_fileify_dirspec(dir,buf,1); }
3204 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3205 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3207 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3208 unsigned long int retlen;
3209 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3211 if (!dir || !*dir) {
3212 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3215 if (*dir) strcpy(trndir,dir);
3216 else getcwd(trndir,sizeof trndir - 1);
3218 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3219 && my_trnlnm(trndir,trndir,0)) {
3220 STRLEN trnlen = strlen(trndir);
3222 /* Trap simple rooted lnms, and return lnm:[000000] */
3223 if (!strcmp(trndir+trnlen-2,".]")) {
3224 if (buf) retpath = buf;
3225 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3226 else retpath = __pathify_retbuf;
3227 strcpy(retpath,dir);
3228 strcat(retpath,":[000000]");
3234 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3235 if (*dir == '.' && (*(dir+1) == '\0' ||
3236 (*(dir+1) == '.' && *(dir+2) == '\0')))
3237 retlen = 2 + (*(dir+1) != '\0');
3239 if ( !(cp1 = strrchr(dir,'/')) &&
3240 !(cp1 = strrchr(dir,']')) &&
3241 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3242 if ((cp2 = strchr(cp1,'.')) != NULL &&
3243 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3244 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3245 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3246 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3248 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3249 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3250 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3251 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3252 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3253 (ver || *cp3)))))) {
3255 set_vaxc_errno(RMS$_DIR);
3258 retlen = cp2 - dir + 1;
3260 else { /* No file type present. Treat the filename as a directory. */
3261 retlen = strlen(dir) + 1;
3264 if (buf) retpath = buf;
3265 else if (ts) New(1313,retpath,retlen+1,char);
3266 else retpath = __pathify_retbuf;
3267 strncpy(retpath,dir,retlen-1);
3268 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3269 retpath[retlen-1] = '/'; /* with '/', add it. */
3270 retpath[retlen] = '\0';
3272 else retpath[retlen-1] = '\0';
3274 else { /* VMS-style directory spec */
3275 char esa[NAM$C_MAXRSS+1], *cp;
3276 unsigned long int sts, cmplen, haslower;
3277 struct FAB dirfab = cc$rms_fab;
3278 struct NAM savnam, dirnam = cc$rms_nam;
3280 /* If we've got an explicit filename, we can just shuffle the string. */
3281 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3282 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3283 if ((cp2 = strchr(cp1,'.')) != NULL) {
3285 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3286 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3287 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3288 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3289 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3290 (ver || *cp3)))))) {
3292 set_vaxc_errno(RMS$_DIR);
3296 else { /* No file type, so just draw name into directory part */
3297 for (cp2 = cp1; *cp2; cp2++) ;
3300 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3302 /* We've now got a VMS 'path'; fall through */
3304 dirfab.fab$b_fns = strlen(dir);
3305 dirfab.fab$l_fna = dir;
3306 if (dir[dirfab.fab$b_fns-1] == ']' ||
3307 dir[dirfab.fab$b_fns-1] == '>' ||
3308 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3309 if (buf) retpath = buf;
3310 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3311 else retpath = __pathify_retbuf;
3312 strcpy(retpath,dir);
3315 dirfab.fab$l_dna = ".DIR;1";
3316 dirfab.fab$b_dns = 6;
3317 dirfab.fab$l_nam = &dirnam;
3318 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3319 dirnam.nam$l_esa = esa;
3321 for (cp = dir; *cp; cp++)
3322 if (islower(*cp)) { haslower = 1; break; }
3324 if (!(sts = (sys$parse(&dirfab)&1))) {
3325 if (dirfab.fab$l_sts == RMS$_DIR) {
3326 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3327 sts = sys$parse(&dirfab) & 1;
3331 set_vaxc_errno(dirfab.fab$l_sts);
3337 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3338 if (dirfab.fab$l_sts != RMS$_FNF) {
3339 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3340 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3342 set_vaxc_errno(dirfab.fab$l_sts);
3345 dirnam = savnam; /* No; just work with potential name */
3348 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3349 /* Yep; check version while we're at it, if it's there. */
3350 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3351 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3352 /* Something other than .DIR[;1]. Bzzt. */
3353 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3354 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3356 set_vaxc_errno(RMS$_DIR);
3360 /* OK, the type was fine. Now pull any file name into the
3362 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3364 cp1 = strrchr(esa,'>');
3365 *dirnam.nam$l_type = '>';
3368 *(dirnam.nam$l_type + 1) = '\0';
3369 retlen = dirnam.nam$l_type - esa + 2;
3370 if (buf) retpath = buf;
3371 else if (ts) New(1314,retpath,retlen,char);
3372 else retpath = __pathify_retbuf;
3373 strcpy(retpath,esa);
3374 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3375 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3376 /* $PARSE may have upcased filespec, so convert output to lower
3377 * case if input contained any lowercase characters. */
3378 if (haslower) __mystrtolower(retpath);
3382 } /* end of do_pathify_dirspec() */
3384 /* External entry points */
3385 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3386 { return do_pathify_dirspec(dir,buf,0); }
3387 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3388 { return do_pathify_dirspec(dir,buf,1); }
3390 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3391 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3393 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3394 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3395 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3397 if (spec == NULL) return NULL;
3398 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3399 if (buf) rslt = buf;
3401 retlen = strlen(spec);
3402 cp1 = strchr(spec,'[');
3403 if (!cp1) cp1 = strchr(spec,'<');
3405 for (cp1++; *cp1; cp1++) {
3406 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3407 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3408 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3411 New(1315,rslt,retlen+2+2*expand,char);
3413 else rslt = __tounixspec_retbuf;
3414 if (strchr(spec,'/') != NULL) {
3421 dirend = strrchr(spec,']');
3422 if (dirend == NULL) dirend = strrchr(spec,'>');
3423 if (dirend == NULL) dirend = strchr(spec,':');
3424 if (dirend == NULL) {
3428 if (*cp2 != '[' && *cp2 != '<') {
3431 else { /* the VMS spec begins with directories */
3433 if (*cp2 == ']' || *cp2 == '>') {
3434 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3437 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3438 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3439 if (ts) Safefree(rslt);
3444 while (*cp3 != ':' && *cp3) cp3++;
3446 if (strchr(cp3,']') != NULL) break;
3447 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3449 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3450 retlen = devlen + dirlen;
3451 Renew(rslt,retlen+1+2*expand,char);
3457 *(cp1++) = *(cp3++);
3458 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3462 else if ( *cp2 == '.') {
3463 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3464 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3470 for (; cp2 <= dirend; cp2++) {
3473 if (*(cp2+1) == '[') cp2++;
3475 else if (*cp2 == ']' || *cp2 == '>') {
3476 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3478 else if (*cp2 == '.') {
3480 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3481 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3482 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3483 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3484 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3486 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3487 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3491 else if (*cp2 == '-') {
3492 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3493 while (*cp2 == '-') {
3495 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3497 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3498 if (ts) Safefree(rslt); /* filespecs like */
3499 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3503 else *(cp1++) = *cp2;
3505 else *(cp1++) = *cp2;
3507 while (*cp2) *(cp1++) = *(cp2++);
3512 } /* end of do_tounixspec() */
3514 /* External entry points */
3515 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3516 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3518 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3519 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3520 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3521 char *rslt, *dirend;
3522 register char *cp1, *cp2;
3523 unsigned long int infront = 0, hasdir = 1;
3525 if (path == NULL) return NULL;
3526 if (buf) rslt = buf;
3527 else if (ts) New(1316,rslt,strlen(path)+9,char);
3528 else rslt = __tovmsspec_retbuf;
3529 if (strpbrk(path,"]:>") ||
3530 (dirend = strrchr(path,'/')) == NULL) {
3531 if (path[0] == '.') {
3532 if (path[1] == '\0') strcpy(rslt,"[]");
3533 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3534 else strcpy(rslt,path); /* probably garbage */
3536 else strcpy(rslt,path);
3539 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3540 if (!*(dirend+2)) dirend +=2;
3541 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3542 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3547 char trndev[NAM$C_MAXRSS+1];
3551 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3553 if (!buf & ts) Renew(rslt,18,char);
3554 strcpy(rslt,"sys$disk:[000000]");
3557 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3559 islnm = my_trnlnm(rslt,trndev,0);
3560 trnend = islnm ? strlen(trndev) - 1 : 0;
3561 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3562 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3563 /* If the first element of the path is a logical name, determine
3564 * whether it has to be translated so we can add more directories. */
3565 if (!islnm || rooted) {
3568 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3572 if (cp2 != dirend) {
3573 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3574 strcpy(rslt,trndev);
3575 cp1 = rslt + trnend;
3588 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3589 cp2 += 2; /* skip over "./" - it's redundant */
3590 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3592 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3593 *(cp1++) = '-'; /* "../" --> "-" */
3596 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3597 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3598 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3599 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3602 if (cp2 > dirend) cp2 = dirend;
3604 else *(cp1++) = '.';
3606 for (; cp2 < dirend; cp2++) {
3608 if (*(cp2-1) == '/') continue;
3609 if (*(cp1-1) != '.') *(cp1++) = '.';
3612 else if (!infront && *cp2 == '.') {
3613 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3614 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3615 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3616 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3617 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3618 else { /* back up over previous directory name */
3620 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3621 if (*(cp1-1) == '[') {
3622 memcpy(cp1,"000000.",7);
3627 if (cp2 == dirend) break;
3629 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3630 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3631 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3632 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3634 *(cp1++) = '.'; /* Simulate trailing '/' */
3635 cp2 += 2; /* for loop will incr this to == dirend */
3637 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3639 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3642 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3643 if (*cp2 == '.') *(cp1++) = '_';
3644 else *(cp1++) = *cp2;
3648 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3649 if (hasdir) *(cp1++) = ']';
3650 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3651 while (*cp2) *(cp1++) = *(cp2++);
3656 } /* end of do_tovmsspec() */
3658 /* External entry points */
3659 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3660 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3662 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3663 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3664 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3666 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3668 if (path == NULL) return NULL;
3669 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3670 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3671 if (buf) return buf;
3673 vmslen = strlen(vmsified);
3674 New(1317,cp,vmslen+1,char);
3675 memcpy(cp,vmsified,vmslen);
3680 strcpy(__tovmspath_retbuf,vmsified);
3681 return __tovmspath_retbuf;
3684 } /* end of do_tovmspath() */
3686 /* External entry points */
3687 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3688 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3691 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3692 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3693 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3695 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3697 if (path == NULL) return NULL;
3698 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3699 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3700 if (buf) return buf;
3702 unixlen = strlen(unixified);
3703 New(1317,cp,unixlen+1,char);
3704 memcpy(cp,unixified,unixlen);
3709 strcpy(__tounixpath_retbuf,unixified);
3710 return __tounixpath_retbuf;
3713 } /* end of do_tounixpath() */
3715 /* External entry points */
3716 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3717 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3720 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3722 *****************************************************************************
3724 * Copyright (C) 1989-1994 by *
3725 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3727 * Permission is hereby granted for the reproduction of this software, *
3728 * on condition that this copyright notice is included in the reproduction, *
3729 * and that such reproduction is not for purposes of profit or material *
3732 * 27-Aug-1994 Modified for inclusion in perl5 *
3733 * by Charles Bailey bailey@newman.upenn.edu *
3734 *****************************************************************************
3738 * getredirection() is intended to aid in porting C programs
3739 * to VMS (Vax-11 C). The native VMS environment does not support
3740 * '>' and '<' I/O redirection, or command line wild card expansion,
3741 * or a command line pipe mechanism using the '|' AND background
3742 * command execution '&'. All of these capabilities are provided to any
3743 * C program which calls this procedure as the first thing in the
3745 * The piping mechanism will probably work with almost any 'filter' type
3746 * of program. With suitable modification, it may useful for other
3747 * portability problems as well.
3749 * Author: Mark Pizzolato mark@infocomm.com
3753 struct list_item *next;
3757 static void add_item(struct list_item **head,
3758 struct list_item **tail,
3762 static void mp_expand_wild_cards(pTHX_ char *item,
3763 struct list_item **head,
3764 struct list_item **tail,
3767 static int background_process(int argc, char **argv);
3769 static void pipe_and_fork(pTHX_ char **cmargv);
3771 /*{{{ void getredirection(int *ac, char ***av)*/
3773 mp_getredirection(pTHX_ int *ac, char ***av)
3775 * Process vms redirection arg's. Exit if any error is seen.
3776 * If getredirection() processes an argument, it is erased
3777 * from the vector. getredirection() returns a new argc and argv value.
3778 * In the event that a background command is requested (by a trailing "&"),
3779 * this routine creates a background subprocess, and simply exits the program.
3781 * Warning: do not try to simplify the code for vms. The code
3782 * presupposes that getredirection() is called before any data is
3783 * read from stdin or written to stdout.
3785 * Normal usage is as follows:
3791 * getredirection(&argc, &argv);
3795 int argc = *ac; /* Argument Count */
3796 char **argv = *av; /* Argument Vector */
3797 char *ap; /* Argument pointer */
3798 int j; /* argv[] index */
3799 int item_count = 0; /* Count of Items in List */
3800 struct list_item *list_head = 0; /* First Item in List */
3801 struct list_item *list_tail; /* Last Item in List */
3802 char *in = NULL; /* Input File Name */
3803 char *out = NULL; /* Output File Name */
3804 char *outmode = "w"; /* Mode to Open Output File */
3805 char *err = NULL; /* Error File Name */
3806 char *errmode = "w"; /* Mode to Open Error File */
3807 int cmargc = 0; /* Piped Command Arg Count */
3808 char **cmargv = NULL;/* Piped Command Arg Vector */
3811 * First handle the case where the last thing on the line ends with
3812 * a '&'. This indicates the desire for the command to be run in a
3813 * subprocess, so we satisfy that desire.
3816 if (0 == strcmp("&", ap))
3817 exit(background_process(--argc, argv));
3818 if (*ap && '&' == ap[strlen(ap)-1])
3820 ap[strlen(ap)-1] = '\0';
3821 exit(background_process(argc, argv));
3824 * Now we handle the general redirection cases that involve '>', '>>',
3825 * '<', and pipes '|'.
3827 for (j = 0; j < argc; ++j)
3829 if (0 == strcmp("<", argv[j]))
3833 fprintf(stderr,"No input file after < on command line");
3834 exit(LIB$_WRONUMARG);
3839 if ('<' == *(ap = argv[j]))
3844 if (0 == strcmp(">", ap))
3848 fprintf(stderr,"No output file after > on command line");
3849 exit(LIB$_WRONUMARG);
3868 fprintf(stderr,"No output file after > or >> on command line");
3869 exit(LIB$_WRONUMARG);
3873 if (('2' == *ap) && ('>' == ap[1]))
3890 fprintf(stderr,"No output file after 2> or 2>> on command line");
3891 exit(LIB$_WRONUMARG);
3895 if (0 == strcmp("|", argv[j]))
3899 fprintf(stderr,"No command into which to pipe on command line");
3900 exit(LIB$_WRONUMARG);
3902 cmargc = argc-(j+1);
3903 cmargv = &argv[j+1];
3907 if ('|' == *(ap = argv[j]))
3915 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3918 * Allocate and fill in the new argument vector, Some Unix's terminate
3919 * the list with an extra null pointer.
3921 New(1302, argv, item_count+1, char *);
3923 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3924 argv[j] = list_head->value;
3930 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3931 exit(LIB$_INVARGORD);
3933 pipe_and_fork(aTHX_ cmargv);
3936 /* Check for input from a pipe (mailbox) */
3938 if (in == NULL && 1 == isapipe(0))
3940 char mbxname[L_tmpnam];
3942 long int dvi_item = DVI$_DEVBUFSIZ;
3943 $DESCRIPTOR(mbxnam, "");
3944 $DESCRIPTOR(mbxdevnam, "");
3946 /* Input from a pipe, reopen it in binary mode to disable */
3947 /* carriage control processing. */
3949 fgetname(stdin, mbxname);
3950 mbxnam.dsc$a_pointer = mbxname;
3951 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3952 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3953 mbxdevnam.dsc$a_pointer = mbxname;
3954 mbxdevnam.dsc$w_length = sizeof(mbxname);
3955 dvi_item = DVI$_DEVNAM;
3956 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3957 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3960 freopen(mbxname, "rb", stdin);
3963 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3967 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3969 fprintf(stderr,"Can't open input file %s as stdin",in);
3972 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3974 fprintf(stderr,"Can't open output file %s as stdout",out);
3977 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3980 if (strcmp(err,"&1") == 0) {
3981 dup2(fileno(stdout), fileno(stderr));
3982 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3985 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3987 fprintf(stderr,"Can't open error file %s as stderr",err);
3991 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3995 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3998 #ifdef ARGPROC_DEBUG
3999 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4000 for (j = 0; j < *ac; ++j)
4001 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4003 /* Clear errors we may have hit expanding wildcards, so they don't
4004 show up in Perl's $! later */
4005 set_errno(0); set_vaxc_errno(1);
4006 } /* end of getredirection() */
4009 static void add_item(struct list_item **head,
4010 struct list_item **tail,
4016 New(1303,*head,1,struct list_item);
4020 New(1304,(*tail)->next,1,struct list_item);
4021 *tail = (*tail)->next;
4023 (*tail)->value = value;
4027 static void mp_expand_wild_cards(pTHX_ char *item,
4028 struct list_item **head,
4029 struct list_item **tail,
4033 unsigned long int context = 0;
4039 char vmsspec[NAM$C_MAXRSS+1];
4040 $DESCRIPTOR(filespec, "");
4041 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4042 $DESCRIPTOR(resultspec, "");
4043 unsigned long int zero = 0, sts;
4045 for (cp = item; *cp; cp++) {
4046 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4047 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4049 if (!*cp || isspace(*cp))
4051 add_item(head, tail, item, count);
4054 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4055 resultspec.dsc$b_class = DSC$K_CLASS_D;
4056 resultspec.dsc$a_pointer = NULL;
4057 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4058 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4059 if (!isunix || !filespec.dsc$a_pointer)
4060 filespec.dsc$a_pointer = item;
4061 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4063 * Only return version specs, if the caller specified a version
4065 had_version = strchr(item, ';');
4067 * Only return device and directory specs, if the caller specifed either.
4069 had_device = strchr(item, ':');
4070 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4072 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4073 &defaultspec, 0, 0, &zero))))
4078 New(1305,string,resultspec.dsc$w_length+1,char);
4079 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4080 string[resultspec.dsc$w_length] = '\0';
4081 if (NULL == had_version)
4082 *((char *)strrchr(string, ';')) = '\0';
4083 if ((!had_directory) && (had_device == NULL))
4085 if (NULL == (devdir = strrchr(string, ']')))
4086 devdir = strrchr(string, '>');
4087 strcpy(string, devdir + 1);
4090 * Be consistent with what the C RTL has already done to the rest of
4091 * the argv items and lowercase all of these names.
4093 for (c = string; *c; ++c)
4096 if (isunix) trim_unixpath(string,item,1);
4097 add_item(head, tail, string, count);
4100 if (sts != RMS$_NMF)
4102 set_vaxc_errno(sts);
4105 case RMS$_FNF: case RMS$_DNF:
4106 set_errno(ENOENT); break;
4108 set_errno(ENOTDIR); break;
4110 set_errno(ENODEV); break;
4111 case RMS$_FNM: case RMS$_SYN:
4112 set_errno(EINVAL); break;
4114 set_errno(EACCES); break;
4116 _ckvmssts_noperl(sts);
4120 add_item(head, tail, item, count);
4121 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4122 _ckvmssts_noperl(lib$find_file_end(&context));
4125 static int child_st[2];/* Event Flag set when child process completes */
4127 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4129 static unsigned long int exit_handler(int *status)
4133 if (0 == child_st[0])
4135 #ifdef ARGPROC_DEBUG
4136 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4138 fflush(stdout); /* Have to flush pipe for binary data to */
4139 /* terminate properly -- <tp@mccall.com> */
4140 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4141 sys$dassgn(child_chan);
4143 sys$synch(0, child_st);
4148 static void sig_child(int chan)
4150 #ifdef ARGPROC_DEBUG
4151 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4153 if (child_st[0] == 0)
4157 static struct exit_control_block exit_block =
4162 &exit_block.exit_status,
4167 pipe_and_fork(pTHX_ char **cmargv)
4170 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4171 int sts, j, l, ismcr, quote, tquote = 0;
4173 sts = setup_cmddsc(cmargv[0],0,"e);
4178 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4179 && toupper(*(q+2)) == 'R' && !*(q+3);
4181 while (q && l < MAX_DCL_LINE_LENGTH) {
4183 if (j > 0 && quote) {
4189 if (ismcr && j > 1) quote = 1;
4190 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4193 if (quote || tquote) {
4199 if ((quote||tquote) && *q == '"') {
4209 store_pipelocs(); /* gets redone later */
4210 fp = safe_popen(subcmd,"wbF",&sts);
4212 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4216 static int background_process(int argc, char **argv)
4218 char command[2048] = "$";
4219 $DESCRIPTOR(value, "");
4220 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4221 static $DESCRIPTOR(null, "NLA0:");
4222 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4224 $DESCRIPTOR(pidstr, "");
4226 unsigned long int flags = 17, one = 1, retsts;
4228 strcat(command, argv[0]);
4231 strcat(command, " \"");
4232 strcat(command, *(++argv));
4233 strcat(command, "\"");
4235 value.dsc$a_pointer = command;
4236 value.dsc$w_length = strlen(value.dsc$a_pointer);
4237 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4238 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4239 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4240 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4243 _ckvmssts_noperl(retsts);
4245 #ifdef ARGPROC_DEBUG
4246 PerlIO_printf(Perl_debug_log, "%s\n", command);
4248 sprintf(pidstring, "%08X", pid);
4249 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4250 pidstr.dsc$a_pointer = pidstring;
4251 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4252 lib$set_symbol(&pidsymbol, &pidstr);
4256 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4259 /* OS-specific initialization at image activation (not thread startup) */
4260 /* Older VAXC header files lack these constants */
4261 #ifndef JPI$_RIGHTS_SIZE
4262 # define JPI$_RIGHTS_SIZE 817
4264 #ifndef KGB$M_SUBSYSTEM
4265 # define KGB$M_SUBSYSTEM 0x8
4268 /*{{{void vms_image_init(int *, char ***)*/
4270 vms_image_init(int *argcp, char ***argvp)
4272 char eqv[LNM$C_NAMLENGTH+1] = "";
4273 unsigned int len, tabct = 8, tabidx = 0;
4274 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4275 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4276 unsigned short int dummy, rlen;
4277 struct dsc$descriptor_s **tabvec;
4278 #if defined(PERL_IMPLICIT_CONTEXT)
4281 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4282 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4283 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4286 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4287 _ckvmssts_noperl(iosb[0]);
4288 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4289 if (iprv[i]) { /* Running image installed with privs? */
4290 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4295 /* Rights identifiers might trigger tainting as well. */
4296 if (!will_taint && (rlen || rsz)) {
4297 while (rlen < rsz) {
4298 /* We didn't get all the identifiers on the first pass. Allocate a
4299 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4300 * were needed to hold all identifiers at time of last call; we'll
4301 * allocate that many unsigned long ints), and go back and get 'em.
4302 * If it gave us less than it wanted to despite ample buffer space,
4303 * something's broken. Is your system missing a system identifier?
4305 if (rsz <= jpilist[1].buflen) {
4306 /* Perl_croak accvios when used this early in startup. */
4307 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4308 rsz, (unsigned long) jpilist[1].buflen,
4309 "Check your rights database for corruption.\n");
4312 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4313 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4314 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4315 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4316 _ckvmssts_noperl(iosb[0]);
4318 mask = jpilist[1].bufadr;
4319 /* Check attribute flags for each identifier (2nd longword); protected
4320 * subsystem identifiers trigger tainting.
4322 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4323 if (mask[i] & KGB$M_SUBSYSTEM) {
4328 if (mask != rlst) Safefree(mask);
4330 /* We need to use this hack to tell Perl it should run with tainting,
4331 * since its tainting flag may be part of the PL_curinterp struct, which
4332 * hasn't been allocated when vms_image_init() is called.
4336 New(1320,newap,*argcp+2,char **);
4337 newap[0] = argvp[0];
4339 Copy(argvp[1],newap[2],*argcp-1,char **);
4340 /* We orphan the old argv, since we don't know where it's come from,
4341 * so we don't know how to free it.
4343 *argcp++; argvp = newap;
4345 else { /* Did user explicitly request tainting? */
4347 char *cp, **av = *argvp;
4348 for (i = 1; i < *argcp; i++) {
4349 if (*av[i] != '-') break;
4350 for (cp = av[i]+1; *cp; cp++) {
4351 if (*cp == 'T') { will_taint = 1; break; }
4352 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4353 strchr("DFIiMmx",*cp)) break;
4355 if (will_taint) break;
4360 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4362 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4363 else if (tabidx >= tabct) {
4365 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4367 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4368 tabvec[tabidx]->dsc$w_length = 0;
4369 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4370 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4371 tabvec[tabidx]->dsc$a_pointer = NULL;
4372 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4374 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4376 getredirection(argcp,argvp);
4377 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4379 # include <reentrancy.h>
4380 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4389 * Trim Unix-style prefix off filespec, so it looks like what a shell
4390 * glob expansion would return (i.e. from specified prefix on, not
4391 * full path). Note that returned filespec is Unix-style, regardless
4392 * of whether input filespec was VMS-style or Unix-style.
4394 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4395 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4396 * vector of options; at present, only bit 0 is used, and if set tells
4397 * trim unixpath to try the current default directory as a prefix when
4398 * presented with a possibly ambiguous ... wildcard.
4400 * Returns !=0 on success, with trimmed filespec replacing contents of
4401 * fspec, and 0 on failure, with contents of fpsec unchanged.
4403 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4405 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4407 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4408 *template, *base, *end, *cp1, *cp2;
4409 register int tmplen, reslen = 0, dirs = 0;
4411 if (!wildspec || !fspec) return 0;
4412 if (strpbrk(wildspec,"]>:") != NULL) {
4413 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4414 else template = unixwild;
4416 else template = wildspec;
4417 if (strpbrk(fspec,"]>:") != NULL) {
4418 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4419 else base = unixified;
4420 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4421 * check to see that final result fits into (isn't longer than) fspec */
4422 reslen = strlen(fspec);
4426 /* No prefix or absolute path on wildcard, so nothing to remove */
4427 if (!*template || *template == '/') {
4428 if (base == fspec) return 1;
4429 tmplen = strlen(unixified);
4430 if (tmplen > reslen) return 0; /* not enough space */
4431 /* Copy unixified resultant, including trailing NUL */
4432 memmove(fspec,unixified,tmplen+1);
4436 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4437 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4438 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4439 for (cp1 = end ;cp1 >= base; cp1--)
4440 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4442 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4446 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4447 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4448 int ells = 1, totells, segdirs, match;
4449 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4450 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4452 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4454 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4455 if (ellipsis == template && opts & 1) {
4456 /* Template begins with an ellipsis. Since we can't tell how many
4457 * directory names at the front of the resultant to keep for an
4458 * arbitrary starting point, we arbitrarily choose the current
4459 * default directory as a starting point. If it's there as a prefix,
4460 * clip it off. If not, fall through and act as if the leading
4461 * ellipsis weren't there (i.e. return shortest possible path that
4462 * could match template).
4464 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4465 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4466 if (_tolower(*cp1) != _tolower(*cp2)) break;
4467 segdirs = dirs - totells; /* Min # of dirs we must have left */
4468 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4469 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4470 memcpy(fspec,cp2+1,end - cp2);
4474 /* First off, back up over constant elements at end of path */
4476 for (front = end ; front >= base; front--)
4477 if (*front == '/' && !dirs--) { front++; break; }
4479 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4480 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4481 if (cp1 != '\0') return 0; /* Path too long. */
4483 *cp2 = '\0'; /* Pick up with memcpy later */
4484 lcfront = lcres + (front - base);
4485 /* Now skip over each ellipsis and try to match the path in front of it. */
4487 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4488 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4489 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4490 if (cp1 < template) break; /* template started with an ellipsis */
4491 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4492 ellipsis = cp1; continue;
4494 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4496 for (segdirs = 0, cp2 = tpl;
4497 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4499 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4500 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4501 if (*cp2 == '/') segdirs++;
4503 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4504 /* Back up at least as many dirs as in template before matching */
4505 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4506 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4507 for (match = 0; cp1 > lcres;) {
4508 resdsc.dsc$a_pointer = cp1;
4509 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4511 if (match == 1) lcfront = cp1;
4513 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4515 if (!match) return 0; /* Can't find prefix ??? */
4516 if (match > 1 && opts & 1) {
4517 /* This ... wildcard could cover more than one set of dirs (i.e.
4518 * a set of similar dir names is repeated). If the template
4519 * contains more than 1 ..., upstream elements could resolve the
4520 * ambiguity, but it's not worth a full backtracking setup here.
4521 * As a quick heuristic, clip off the current default directory
4522 * if it's present to find the trimmed spec, else use the
4523 * shortest string that this ... could cover.
4525 char def[NAM$C_MAXRSS+1], *st;
4527 if (getcwd(def, sizeof def,0) == NULL) return 0;
4528 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4529 if (_tolower(*cp1) != _tolower(*cp2)) break;
4530 segdirs = dirs - totells; /* Min # of dirs we must have left */
4531 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4532 if (*cp1 == '\0' && *cp2 == '/') {
4533 memcpy(fspec,cp2+1,end - cp2);
4536 /* Nope -- stick with lcfront from above and keep going. */
4539 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4544 } /* end of trim_unixpath() */
4549 * VMS readdir() routines.
4550 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4552 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4553 * Minor modifications to original routines.
4556 /* Number of elements in vms_versions array */
4557 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4560 * Open a directory, return a handle for later use.
4562 /*{{{ DIR *opendir(char*name) */
4564 Perl_opendir(pTHX_ char *name)
4567 char dir[NAM$C_MAXRSS+1];
4570 if (do_tovmspath(name,dir,0) == NULL) {
4573 if (flex_stat(dir,&sb) == -1) return NULL;
4574 if (!S_ISDIR(sb.st_mode)) {
4575 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4578 if (!cando_by_name(S_IRUSR,0,dir)) {
4579 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4582 /* Get memory for the handle, and the pattern. */
4584 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4586 /* Fill in the fields; mainly playing with the descriptor. */
4587 (void)sprintf(dd->pattern, "%s*.*",dir);
4590 dd->vms_wantversions = 0;
4591 dd->pat.dsc$a_pointer = dd->pattern;
4592 dd->pat.dsc$w_length = strlen(dd->pattern);
4593 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4594 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4597 } /* end of opendir() */
4601 * Set the flag to indicate we want versions or not.
4603 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4605 vmsreaddirversions(DIR *dd, int flag)
4607 dd->vms_wantversions = flag;
4612 * Free up an opened directory.
4614 /*{{{ void closedir(DIR *dd)*/
4618 (void)lib$find_file_end(&dd->context);
4619 Safefree(dd->pattern);
4620 Safefree((char *)dd);
4625 * Collect all the version numbers for the current file.
4628 collectversions(pTHX_ DIR *dd)
4630 struct dsc$descriptor_s pat;
4631 struct dsc$descriptor_s res;
4633 char *p, *text, buff[sizeof dd->entry.d_name];
4635 unsigned long context, tmpsts;
4637 /* Convenient shorthand. */
4640 /* Add the version wildcard, ignoring the "*.*" put on before */
4641 i = strlen(dd->pattern);
4642 New(1308,text,i + e->d_namlen + 3,char);
4643 (void)strcpy(text, dd->pattern);
4644 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4646 /* Set up the pattern descriptor. */
4647 pat.dsc$a_pointer = text;
4648 pat.dsc$w_length = i + e->d_namlen - 1;
4649 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4650 pat.dsc$b_class = DSC$K_CLASS_S;
4652 /* Set up result descriptor. */
4653 res.dsc$a_pointer = buff;
4654 res.dsc$w_length = sizeof buff - 2;
4655 res.dsc$b_dtype = DSC$K_DTYPE_T;
4656 res.dsc$b_class = DSC$K_CLASS_S;
4658 /* Read files, collecting versions. */
4659 for (context = 0, e->vms_verscount = 0;
4660 e->vms_verscount < VERSIZE(e);
4661 e->vms_verscount++) {
4662 tmpsts = lib$find_file(&pat, &res, &context);
4663 if (tmpsts == RMS$_NMF || context == 0) break;
4665 buff[sizeof buff - 1] = '\0';
4666 if ((p = strchr(buff, ';')))
4667 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4669 e->vms_versions[e->vms_verscount] = -1;
4672 _ckvmssts(lib$find_file_end(&context));
4675 } /* end of collectversions() */
4678 * Read the next entry from the directory.
4680 /*{{{ struct dirent *readdir(DIR *dd)*/
4682 Perl_readdir(pTHX_ DIR *dd)
4684 struct dsc$descriptor_s res;
4685 char *p, buff[sizeof dd->entry.d_name];
4686 unsigned long int tmpsts;
4688 /* Set up result descriptor, and get next file. */
4689 res.dsc$a_pointer = buff;
4690 res.dsc$w_length = sizeof buff - 2;
4691 res.dsc$b_dtype = DSC$K_DTYPE_T;
4692 res.dsc$b_class = DSC$K_CLASS_S;
4693 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4694 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4695 if (!(tmpsts & 1)) {
4696 set_vaxc_errno(tmpsts);
4699 set_errno(EACCES); break;
4701 set_errno(ENODEV); break;
4703 set_errno(ENOTDIR); break;
4704 case RMS$_FNF: case RMS$_DNF:
4705 set_errno(ENOENT); break;
4712 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4713 buff[sizeof buff - 1] = '\0';
4714 for (p = buff; *p; p++) *p = _tolower(*p);
4715 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4718 /* Skip any directory component and just copy the name. */
4719 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4720 else (void)strcpy(dd->entry.d_name, buff);
4722 /* Clobber the version. */
4723 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4725 dd->entry.d_namlen = strlen(dd->entry.d_name);
4726 dd->entry.vms_verscount = 0;
4727 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4730 } /* end of readdir() */
4734 * Return something that can be used in a seekdir later.
4736 /*{{{ long telldir(DIR *dd)*/
4745 * Return to a spot where we used to be. Brute force.
4747 /*{{{ void seekdir(DIR *dd,long count)*/
4749 Perl_seekdir(pTHX_ DIR *dd, long count)
4751 int vms_wantversions;
4753 /* If we haven't done anything yet... */
4757 /* Remember some state, and clear it. */
4758 vms_wantversions = dd->vms_wantversions;
4759 dd->vms_wantversions = 0;
4760 _ckvmssts(lib$find_file_end(&dd->context));
4763 /* The increment is in readdir(). */
4764 for (dd->count = 0; dd->count < count; )
4767 dd->vms_wantversions = vms_wantversions;
4769 } /* end of seekdir() */
4772 /* VMS subprocess management
4774 * my_vfork() - just a vfork(), after setting a flag to record that
4775 * the current script is trying a Unix-style fork/exec.
4777 * vms_do_aexec() and vms_do_exec() are called in response to the
4778 * perl 'exec' function. If this follows a vfork call, then they
4779 * call out the the regular perl routines in doio.c which do an
4780 * execvp (for those who really want to try this under VMS).
4781 * Otherwise, they do exactly what the perl docs say exec should
4782 * do - terminate the current script and invoke a new command
4783 * (See below for notes on command syntax.)
4785 * do_aspawn() and do_spawn() implement the VMS side of the perl
4786 * 'system' function.
4788 * Note on command arguments to perl 'exec' and 'system': When handled
4789 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4790 * are concatenated to form a DCL command string. If the first arg
4791 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4792 * the the command string is handed off to DCL directly. Otherwise,
4793 * the first token of the command is taken as the filespec of an image
4794 * to run. The filespec is expanded using a default type of '.EXE' and
4795 * the process defaults for device, directory, etc., and if found, the resultant
4796 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4797 * the command string as parameters. This is perhaps a bit complicated,
4798 * but I hope it will form a happy medium between what VMS folks expect
4799 * from lib$spawn and what Unix folks expect from exec.
4802 static int vfork_called;
4804 /*{{{int my_vfork()*/
4815 vms_execfree(pTHX) {
4817 if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
4820 if (VMSCMD.dsc$a_pointer) {
4821 Safefree(VMSCMD.dsc$a_pointer);
4822 VMSCMD.dsc$w_length = 0;
4823 VMSCMD.dsc$a_pointer = Nullch;
4828 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4830 char *junk, *tmps = Nullch;
4831 register size_t cmdlen = 0;
4838 tmps = SvPV(really,rlen);
4845 for (idx++; idx <= sp; idx++) {
4847 junk = SvPVx(*idx,rlen);
4848 cmdlen += rlen ? rlen + 1 : 0;
4851 New(401,PL_Cmd,cmdlen+1,char);
4853 if (tmps && *tmps) {
4854 strcpy(PL_Cmd,tmps);
4857 else *PL_Cmd = '\0';
4858 while (++mark <= sp) {
4860 char *s = SvPVx(*mark,n_a);
4862 if (*PL_Cmd) strcat(PL_Cmd," ");
4868 } /* end of setup_argstr() */
4871 static unsigned long int
4872 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
4874 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4875 $DESCRIPTOR(defdsc,".EXE");
4876 $DESCRIPTOR(defdsc2,".");
4877 $DESCRIPTOR(resdsc,resspec);
4878 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4879 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4880 register char *s, *rest, *cp, *wordbreak;
4883 if (suggest_quote) *suggest_quote = 0;
4885 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4886 return CLI$_BUFOVF; /* continuation lines currently unsupported */
4888 while (*s && isspace(*s)) s++;
4890 if (*s == '@' || *s == '$') {
4891 vmsspec[0] = *s; rest = s + 1;
4892 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4894 else { cp = vmsspec; rest = s; }
4895 if (*rest == '.' || *rest == '/') {
4898 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4899 rest++, cp2++) *cp2 = *rest;
4901 if (do_tovmsspec(resspec,cp,0)) {
4904 for (cp2 = vmsspec + strlen(vmsspec);
4905 *rest && cp2 - vmsspec < sizeof vmsspec;
4906 rest++, cp2++) *cp2 = *rest;
4911 /* Intuit whether verb (first word of cmd) is a DCL command:
4912 * - if first nonspace char is '@', it's a DCL indirection
4914 * - if verb contains a filespec separator, it's not a DCL command
4915 * - if it doesn't, caller tells us whether to default to a DCL
4916 * command, or to a local image unless told it's DCL (by leading '$')
4920 if (suggest_quote) *suggest_quote = 1;
4922 register char *filespec = strpbrk(s,":<[.;");
4923 rest = wordbreak = strpbrk(s," \"\t/");
4924 if (!wordbreak) wordbreak = s + strlen(s);
4925 if (*s == '$') check_img = 0;
4926 if (filespec && (filespec < wordbreak)) isdcl = 0;
4927 else isdcl = !check_img;
4931 imgdsc.dsc$a_pointer = s;
4932 imgdsc.dsc$w_length = wordbreak - s;
4933 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4935 _ckvmssts(lib$find_file_end(&cxt));
4936 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4937 if (!(retsts & 1) && *s == '$') {
4938 _ckvmssts(lib$find_file_end(&cxt));
4939 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4940 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4942 _ckvmssts(lib$find_file_end(&cxt));
4943 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4947 _ckvmssts(lib$find_file_end(&cxt));
4952 while (*s && !isspace(*s)) s++;
4955 /* check that it's really not DCL with no file extension */
4956 fp = fopen(resspec,"r","ctx=bin,shr=get");
4958 char b[4] = {0,0,0,0};
4959 read(fileno(fp),b,4);
4960 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4963 if (check_img && isdcl) return RMS$_FNF;
4965 if (cando_by_name(S_IXUSR,0,resspec)) {
4966 New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4968 strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
4969 if (suggest_quote) *suggest_quote = 1;
4971 strcpy(VMSCMD.dsc$a_pointer,"@");
4972 if (suggest_quote) *suggest_quote = 1;
4974 strcat(VMSCMD.dsc$a_pointer,resspec);
4975 if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
4976 VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
4977 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4979 else retsts = RMS$_PRV;
4982 /* It's either a DCL command or we couldn't find a suitable image */
4983 VMSCMD.dsc$w_length = strlen(cmd);
4984 if (cmd == PL_Cmd) {
4985 VMSCMD.dsc$a_pointer = PL_Cmd;
4986 if (suggest_quote) *suggest_quote = 1;
4988 else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
4990 /* check if it's a symbol (for quoting purposes) */
4991 if (suggest_quote && !*suggest_quote) {
4993 char equiv[LNM$C_NAMLENGTH];
4994 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4995 eqvdsc.dsc$a_pointer = equiv;
4997 iss = lib$get_symbol(&VMSCMD,&eqvdsc);
4998 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5000 if (!(retsts & 1)) {
5001 /* just hand off status values likely to be due to user error */
5002 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5003 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5004 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5005 else { _ckvmssts(retsts); }
5008 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5010 } /* end of setup_cmddsc() */
5013 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5015 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5018 if (vfork_called) { /* this follows a vfork - act Unixish */
5020 if (vfork_called < 0) {
5021 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5024 else return do_aexec(really,mark,sp);
5026 /* no vfork - act VMSish */
5027 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5032 } /* end of vms_do_aexec() */
5035 /* {{{bool vms_do_exec(char *cmd) */
5037 Perl_vms_do_exec(pTHX_ char *cmd)
5040 if (vfork_called) { /* this follows a vfork - act Unixish */
5042 if (vfork_called < 0) {
5043 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5046 else return do_exec(cmd);
5049 { /* no vfork - act VMSish */
5050 unsigned long int retsts;
5053 TAINT_PROPER("exec");
5054 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
5055 retsts = lib$do_command(&VMSCMD);
5058 case RMS$_FNF: case RMS$_DNF:
5059 set_errno(ENOENT); break;
5061 set_errno(ENOTDIR); break;
5063 set_errno(ENODEV); break;
5065 set_errno(EACCES); break;
5067 set_errno(EINVAL); break;
5068 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5069 set_errno(E2BIG); break;
5070 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5071 _ckvmssts(retsts); /* fall through */
5072 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5075 set_vaxc_errno(retsts);
5076 if (ckWARN(WARN_EXEC)) {
5077 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
5078 VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
5085 } /* end of vms_do_exec() */
5088 unsigned long int Perl_do_spawn(pTHX_ char *);
5090 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5092 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5094 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5097 } /* end of do_aspawn() */
5100 /* {{{unsigned long int do_spawn(char *cmd) */
5102 Perl_do_spawn(pTHX_ char *cmd)
5104 unsigned long int sts, substs, hadcmd = 1;
5107 TAINT_PROPER("spawn");
5108 if (!cmd || !*cmd) {
5110 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5113 (void) safe_popen(cmd, "nW", (int *)&sts);
5119 case RMS$_FNF: case RMS$_DNF:
5120 set_errno(ENOENT); break;
5122 set_errno(ENOTDIR); break;
5124 set_errno(ENODEV); break;
5126 set_errno(EACCES); break;
5128 set_errno(EINVAL); break;
5129 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5130 set_errno(E2BIG); break;
5131 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5132 _ckvmssts(sts); /* fall through */
5133 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5136 set_vaxc_errno(sts);
5137 if (ckWARN(WARN_EXEC)) {
5138 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
5146 } /* end of do_spawn() */
5150 static unsigned int *sockflags, sockflagsize;
5153 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5154 * routines found in some versions of the CRTL can't deal with sockets.
5155 * We don't shim the other file open routines since a socket isn't
5156 * likely to be opened by a name.
5158 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5159 FILE *my_fdopen(int fd, const char *mode)
5161 FILE *fp = fdopen(fd, (char *) mode);
5164 unsigned int fdoff = fd / sizeof(unsigned int);
5165 struct stat sbuf; /* native stat; we don't need flex_stat */
5166 if (!sockflagsize || fdoff > sockflagsize) {
5167 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5168 else New (1324,sockflags,fdoff+2,unsigned int);
5169 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5170 sockflagsize = fdoff + 2;
5172 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5173 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5182 * Clear the corresponding bit when the (possibly) socket stream is closed.
5183 * There still a small hole: we miss an implicit close which might occur
5184 * via freopen(). >> Todo
5186 /*{{{ int my_fclose(FILE *fp)*/
5187 int my_fclose(FILE *fp) {
5189 unsigned int fd = fileno(fp);
5190 unsigned int fdoff = fd / sizeof(unsigned int);
5192 if (sockflagsize && fdoff <= sockflagsize)
5193 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5201 * A simple fwrite replacement which outputs itmsz*nitm chars without
5202 * introducing record boundaries every itmsz chars.
5203 * We are using fputs, which depends on a terminating null. We may
5204 * well be writing binary data, so we need to accommodate not only
5205 * data with nulls sprinkled in the middle but also data with no null
5208 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5210 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5212 register char *cp, *end, *cpd, *data;
5213 register unsigned int fd = fileno(dest);
5214 register unsigned int fdoff = fd / sizeof(unsigned int);
5216 int bufsize = itmsz * nitm + 1;
5218 if (fdoff < sockflagsize &&
5219 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5220 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5224 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5225 memcpy( data, src, itmsz*nitm );
5226 data[itmsz*nitm] = '\0';
5228 end = data + itmsz * nitm;
5229 retval = (int) nitm; /* on success return # items written */
5232 while (cpd <= end) {
5233 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5234 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5236 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5240 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5243 } /* end of my_fwrite() */
5246 /*{{{ int my_flush(FILE *fp)*/
5248 Perl_my_flush(pTHX_ FILE *fp)
5251 if ((res = fflush(fp)) == 0 && fp) {
5252 #ifdef VMS_DO_SOCKETS
5254 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5256 res = fsync(fileno(fp));
5259 * If the flush succeeded but set end-of-file, we need to clear
5260 * the error because our caller may check ferror(). BTW, this
5261 * probably means we just flushed an empty file.
5263 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5270 * Here are replacements for the following Unix routines in the VMS environment:
5271 * getpwuid Get information for a particular UIC or UID
5272 * getpwnam Get information for a named user
5273 * getpwent Get information for each user in the rights database
5274 * setpwent Reset search to the start of the rights database
5275 * endpwent Finish searching for users in the rights database
5277 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5278 * (defined in pwd.h), which contains the following fields:-
5280 * char *pw_name; Username (in lower case)
5281 * char *pw_passwd; Hashed password
5282 * unsigned int pw_uid; UIC
5283 * unsigned int pw_gid; UIC group number
5284 * char *pw_unixdir; Default device/directory (VMS-style)
5285 * char *pw_gecos; Owner name
5286 * char *pw_dir; Default device/directory (Unix-style)
5287 * char *pw_shell; Default CLI name (eg. DCL)
5289 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5291 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5292 * not the UIC member number (eg. what's returned by getuid()),
5293 * getpwuid() can accept either as input (if uid is specified, the caller's
5294 * UIC group is used), though it won't recognise gid=0.
5296 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5297 * information about other users in your group or in other groups, respectively.
5298 * If the required privilege is not available, then these routines fill only
5299 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5302 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5305 /* sizes of various UAF record fields */
5306 #define UAI$S_USERNAME 12
5307 #define UAI$S_IDENT 31
5308 #define UAI$S_OWNER 31
5309 #define UAI$S_DEFDEV 31
5310 #define UAI$S_DEFDIR 63
5311 #define UAI$S_DEFCLI 31
5314 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5315 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5316 (uic).uic$v_group != UIC$K_WILD_GROUP)
5318 static char __empty[]= "";
5319 static struct passwd __passwd_empty=
5320 {(char *) __empty, (char *) __empty, 0, 0,
5321 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5322 static int contxt= 0;
5323 static struct passwd __pwdcache;
5324 static char __pw_namecache[UAI$S_IDENT+1];
5327 * This routine does most of the work extracting the user information.
5329 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5332 unsigned char length;
5333 char pw_gecos[UAI$S_OWNER+1];
5335 static union uicdef uic;
5337 unsigned char length;
5338 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5341 unsigned char length;
5342 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5345 unsigned char length;
5346 char pw_shell[UAI$S_DEFCLI+1];
5348 static char pw_passwd[UAI$S_PWD+1];
5350 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5351 struct dsc$descriptor_s name_desc;
5352 unsigned long int sts;
5354 static struct itmlst_3 itmlst[]= {
5355 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5356 {sizeof(uic), UAI$_UIC, &uic, &luic},
5357 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5358 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5359 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5360 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5361 {0, 0, NULL, NULL}};
5363 name_desc.dsc$w_length= strlen(name);
5364 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5365 name_desc.dsc$b_class= DSC$K_CLASS_S;
5366 name_desc.dsc$a_pointer= (char *) name;
5368 /* Note that sys$getuai returns many fields as counted strings. */
5369 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5370 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5371 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5373 else { _ckvmssts(sts); }
5374 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5376 if ((int) owner.length < lowner) lowner= (int) owner.length;
5377 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5378 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5379 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5380 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5381 owner.pw_gecos[lowner]= '\0';
5382 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5383 defcli.pw_shell[ldefcli]= '\0';
5384 if (valid_uic(uic)) {
5385 pwd->pw_uid= uic.uic$l_uic;
5386 pwd->pw_gid= uic.uic$v_group;
5389 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5390 pwd->pw_passwd= pw_passwd;
5391 pwd->pw_gecos= owner.pw_gecos;
5392 pwd->pw_dir= defdev.pw_dir;
5393 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5394 pwd->pw_shell= defcli.pw_shell;
5395 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5397 ldir= strlen(pwd->pw_unixdir) - 1;
5398 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5401 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5402 __mystrtolower(pwd->pw_unixdir);
5407 * Get information for a named user.
5409 /*{{{struct passwd *getpwnam(char *name)*/
5410 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5412 struct dsc$descriptor_s name_desc;
5414 unsigned long int status, sts;
5416 __pwdcache = __passwd_empty;
5417 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5418 /* We still may be able to determine pw_uid and pw_gid */
5419 name_desc.dsc$w_length= strlen(name);
5420 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5421 name_desc.dsc$b_class= DSC$K_CLASS_S;
5422 name_desc.dsc$a_pointer= (char *) name;
5423 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5424 __pwdcache.pw_uid= uic.uic$l_uic;
5425 __pwdcache.pw_gid= uic.uic$v_group;
5428 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5429 set_vaxc_errno(sts);
5430 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5433 else { _ckvmssts(sts); }
5436 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5437 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5438 __pwdcache.pw_name= __pw_namecache;
5440 } /* end of my_getpwnam() */
5444 * Get information for a particular UIC or UID.
5445 * Called by my_getpwent with uid=-1 to list all users.
5447 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5448 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5450 const $DESCRIPTOR(name_desc,__pw_namecache);
5451 unsigned short lname;
5453 unsigned long int status;
5455 if (uid == (unsigned int) -1) {
5457 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5458 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5459 set_vaxc_errno(status);
5460 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5464 else { _ckvmssts(status); }
5465 } while (!valid_uic (uic));
5469 if (!uic.uic$v_group)
5470 uic.uic$v_group= PerlProc_getgid();
5472 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5473 else status = SS$_IVIDENT;
5474 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5475 status == RMS$_PRV) {
5476 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5479 else { _ckvmssts(status); }
5481 __pw_namecache[lname]= '\0';
5482 __mystrtolower(__pw_namecache);
5484 __pwdcache = __passwd_empty;
5485 __pwdcache.pw_name = __pw_namecache;
5487 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5488 The identifier's value is usually the UIC, but it doesn't have to be,
5489 so if we can, we let fillpasswd update this. */
5490 __pwdcache.pw_uid = uic.uic$l_uic;
5491 __pwdcache.pw_gid = uic.uic$v_group;
5493 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5496 } /* end of my_getpwuid() */
5500 * Get information for next user.
5502 /*{{{struct passwd *my_getpwent()*/
5503 struct passwd *Perl_my_getpwent(pTHX)
5505 return (my_getpwuid((unsigned int) -1));
5510 * Finish searching rights database for users.
5512 /*{{{void my_endpwent()*/
5513 void Perl_my_endpwent(pTHX)
5516 _ckvmssts(sys$finish_rdb(&contxt));
5522 #ifdef HOMEGROWN_POSIX_SIGNALS
5523 /* Signal handling routines, pulled into the core from POSIX.xs.
5525 * We need these for threads, so they've been rolled into the core,
5526 * rather than left in POSIX.xs.
5528 * (DRS, Oct 23, 1997)
5531 /* sigset_t is atomic under VMS, so these routines are easy */
5532 /*{{{int my_sigemptyset(sigset_t *) */
5533 int my_sigemptyset(sigset_t *set) {
5534 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5540 /*{{{int my_sigfillset(sigset_t *)*/
5541 int my_sigfillset(sigset_t *set) {
5543 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5544 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5550 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5551 int my_sigaddset(sigset_t *set, int sig) {
5552 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5553 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5554 *set |= (1 << (sig - 1));
5560 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5561 int my_sigdelset(sigset_t *set, int sig) {
5562 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5563 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5564 *set &= ~(1 << (sig - 1));
5570 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5571 int my_sigismember(sigset_t *set, int sig) {
5572 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5573 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5574 return *set & (1 << (sig - 1));
5579 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5580 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5583 /* If set and oset are both null, then things are badly wrong. Bail out. */
5584 if ((oset == NULL) && (set == NULL)) {
5585 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5589 /* If set's null, then we're just handling a fetch. */
5591 tempmask = sigblock(0);
5596 tempmask = sigsetmask(*set);
5599 tempmask = sigblock(*set);
5602 tempmask = sigblock(0);
5603 sigsetmask(*oset & ~tempmask);
5606 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5611 /* Did they pass us an oset? If so, stick our holding mask into it */
5618 #endif /* HOMEGROWN_POSIX_SIGNALS */
5621 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5622 * my_utime(), and flex_stat(), all of which operate on UTC unless
5623 * VMSISH_TIMES is true.
5625 /* method used to handle UTC conversions:
5626 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5628 static int gmtime_emulation_type;
5629 /* number of secs to add to UTC POSIX-style time to get local time */
5630 static long int utc_offset_secs;
5632 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5633 * in vmsish.h. #undef them here so we can call the CRTL routines
5642 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5643 * qualifier with the extern prefix pragma. This provisional
5644 * hack circumvents this prefix pragma problem in previous
5647 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5648 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5649 # pragma __extern_prefix save
5650 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5651 # define gmtime decc$__utctz_gmtime
5652 # define localtime decc$__utctz_localtime
5653 # define time decc$__utc_time
5654 # pragma __extern_prefix restore
5656 struct tm *gmtime(), *localtime();
5662 static time_t toutc_dst(time_t loc) {
5665 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5666 loc -= utc_offset_secs;
5667 if (rsltmp->tm_isdst) loc -= 3600;
5670 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5671 ((gmtime_emulation_type || my_time(NULL)), \
5672 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5673 ((secs) - utc_offset_secs))))
5675 static time_t toloc_dst(time_t utc) {
5678 utc += utc_offset_secs;
5679 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5680 if (rsltmp->tm_isdst) utc += 3600;
5683 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5684 ((gmtime_emulation_type || my_time(NULL)), \
5685 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5686 ((secs) + utc_offset_secs))))
5688 #ifndef RTL_USES_UTC
5691 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5692 DST starts on 1st sun of april at 02:00 std time
5693 ends on last sun of october at 02:00 dst time
5694 see the UCX management command reference, SET CONFIG TIMEZONE
5695 for formatting info.
5697 No, it's not as general as it should be, but then again, NOTHING
5698 will handle UK times in a sensible way.
5703 parse the DST start/end info:
5704 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5708 tz_parse_startend(char *s, struct tm *w, int *past)
5710 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5711 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5716 if (!past) return 0;
5719 if (w->tm_year % 4 == 0) ly = 1;
5720 if (w->tm_year % 100 == 0) ly = 0;
5721 if (w->tm_year+1900 % 400 == 0) ly = 1;
5724 dozjd = isdigit(*s);
5725 if (*s == 'J' || *s == 'j' || dozjd) {
5726 if (!dozjd && !isdigit(*++s)) return 0;
5729 d = d*10 + *s++ - '0';
5731 d = d*10 + *s++ - '0';
5734 if (d == 0) return 0;
5735 if (d > 366) return 0;
5737 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5740 } else if (*s == 'M' || *s == 'm') {
5741 if (!isdigit(*++s)) return 0;
5743 if (isdigit(*s)) m = 10*m + *s++ - '0';
5744 if (*s != '.') return 0;
5745 if (!isdigit(*++s)) return 0;
5747 if (n < 1 || n > 5) return 0;
5748 if (*s != '.') return 0;
5749 if (!isdigit(*++s)) return 0;
5751 if (d > 6) return 0;
5755 if (!isdigit(*++s)) return 0;
5757 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5759 if (!isdigit(*++s)) return 0;
5761 if (isdigit(*s)) min = 10*min + *s++ - '0';
5763 if (!isdigit(*++s)) return 0;
5765 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5775 if (w->tm_yday < d) goto before;
5776 if (w->tm_yday > d) goto after;
5778 if (w->tm_mon+1 < m) goto before;
5779 if (w->tm_mon+1 > m) goto after;
5781 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5782 k = d - j; /* mday of first d */
5784 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5785 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5786 if (w->tm_mday < k) goto before;
5787 if (w->tm_mday > k) goto after;
5790 if (w->tm_hour < hour) goto before;
5791 if (w->tm_hour > hour) goto after;
5792 if (w->tm_min < min) goto before;
5793 if (w->tm_min > min) goto after;
5794 if (w->tm_sec < sec) goto before;
5808 /* parse the offset: (+|-)hh[:mm[:ss]] */
5811 tz_parse_offset(char *s, int *offset)
5813 int hour = 0, min = 0, sec = 0;
5816 if (!offset) return 0;
5818 if (*s == '-') {neg++; s++;}
5820 if (!isdigit(*s)) return 0;
5822 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5823 if (hour > 24) return 0;
5825 if (!isdigit(*++s)) return 0;
5827 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5828 if (min > 59) return 0;
5830 if (!isdigit(*++s)) return 0;
5832 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5833 if (sec > 59) return 0;
5837 *offset = (hour*60+min)*60 + sec;
5838 if (neg) *offset = -*offset;
5843 input time is w, whatever type of time the CRTL localtime() uses.
5844 sets dst, the zone, and the gmtoff (seconds)
5846 caches the value of TZ and UCX$TZ env variables; note that
5847 my_setenv looks for these and sets a flag if they're changed
5850 We have to watch out for the "australian" case (dst starts in
5851 october, ends in april)...flagged by "reverse" and checked by
5852 scanning through the months of the previous year.
5857 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5862 char *dstzone, *tz, *s_start, *s_end;
5863 int std_off, dst_off, isdst;
5864 int y, dststart, dstend;
5865 static char envtz[1025]; /* longer than any logical, symbol, ... */
5866 static char ucxtz[1025];
5867 static char reversed = 0;
5873 reversed = -1; /* flag need to check */
5874 envtz[0] = ucxtz[0] = '\0';
5875 tz = my_getenv("TZ",0);
5876 if (tz) strcpy(envtz, tz);
5877 tz = my_getenv("UCX$TZ",0);
5878 if (tz) strcpy(ucxtz, tz);
5879 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5882 if (!*tz) tz = ucxtz;
5885 while (isalpha(*s)) s++;
5886 s = tz_parse_offset(s, &std_off);
5888 if (!*s) { /* no DST, hurray we're done! */
5894 while (isalpha(*s)) s++;
5895 s2 = tz_parse_offset(s, &dst_off);
5899 dst_off = std_off - 3600;
5902 if (!*s) { /* default dst start/end?? */
5903 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5904 s = strchr(ucxtz,',');
5906 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5908 if (*s != ',') return 0;
5911 when = _toutc(when); /* convert to utc */
5912 when = when - std_off; /* convert to pseudolocal time*/
5914 w2 = localtime(&when);
5917 s = tz_parse_startend(s_start,w2,&dststart);
5919 if (*s != ',') return 0;
5922 when = _toutc(when); /* convert to utc */
5923 when = when - dst_off; /* convert to pseudolocal time*/
5924 w2 = localtime(&when);
5925 if (w2->tm_year != y) { /* spans a year, just check one time */
5926 when += dst_off - std_off;
5927 w2 = localtime(&when);
5930 s = tz_parse_startend(s_end,w2,&dstend);
5933 if (reversed == -1) { /* need to check if start later than end */
5937 if (when < 2*365*86400) {
5938 when += 2*365*86400;
5942 w2 =localtime(&when);
5943 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5945 for (j = 0; j < 12; j++) {
5946 w2 =localtime(&when);
5947 (void) tz_parse_startend(s_start,w2,&ds);
5948 (void) tz_parse_startend(s_end,w2,&de);
5949 if (ds != de) break;
5953 if (de && !ds) reversed = 1;
5956 isdst = dststart && !dstend;
5957 if (reversed) isdst = dststart || !dstend;
5960 if (dst) *dst = isdst;
5961 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5962 if (isdst) tz = dstzone;
5964 while(isalpha(*tz)) *zone++ = *tz++;
5970 #endif /* !RTL_USES_UTC */
5972 /* my_time(), my_localtime(), my_gmtime()
5973 * By default traffic in UTC time values, using CRTL gmtime() or
5974 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5975 * Note: We need to use these functions even when the CRTL has working
5976 * UTC support, since they also handle C<use vmsish qw(times);>
5978 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5979 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5982 /*{{{time_t my_time(time_t *timep)*/
5983 time_t Perl_my_time(pTHX_ time_t *timep)
5988 if (gmtime_emulation_type == 0) {
5990 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5991 /* results of calls to gmtime() and localtime() */
5992 /* for same &base */
5994 gmtime_emulation_type++;
5995 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5996 char off[LNM$C_NAMLENGTH+1];;
5998 gmtime_emulation_type++;
5999 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6000 gmtime_emulation_type++;
6001 utc_offset_secs = 0;
6002 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6004 else { utc_offset_secs = atol(off); }
6006 else { /* We've got a working gmtime() */
6007 struct tm gmt, local;
6010 tm_p = localtime(&base);
6012 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6013 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6014 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6015 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6021 # ifdef RTL_USES_UTC
6022 if (VMSISH_TIME) when = _toloc(when);
6024 if (!VMSISH_TIME) when = _toutc(when);
6027 if (timep != NULL) *timep = when;
6030 } /* end of my_time() */
6034 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6036 Perl_my_gmtime(pTHX_ const time_t *timep)
6042 if (timep == NULL) {
6043 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6046 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6050 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6052 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6053 return gmtime(&when);
6055 /* CRTL localtime() wants local time as input, so does no tz correction */
6056 rsltmp = localtime(&when);
6057 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6060 } /* end of my_gmtime() */
6064 /*{{{struct tm *my_localtime(const time_t *timep)*/
6066 Perl_my_localtime(pTHX_ const time_t *timep)
6068 time_t when, whenutc;
6072 if (timep == NULL) {
6073 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6076 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6077 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6080 # ifdef RTL_USES_UTC
6082 if (VMSISH_TIME) when = _toutc(when);
6084 /* CRTL localtime() wants UTC as input, does tz correction itself */
6085 return localtime(&when);
6087 # else /* !RTL_USES_UTC */
6090 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6091 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6094 #ifndef RTL_USES_UTC
6095 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6096 when = whenutc - offset; /* pseudolocal time*/
6099 /* CRTL localtime() wants local time as input, so does no tz correction */
6100 rsltmp = localtime(&when);
6101 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6105 } /* end of my_localtime() */
6108 /* Reset definitions for later calls */
6109 #define gmtime(t) my_gmtime(t)
6110 #define localtime(t) my_localtime(t)
6111 #define time(t) my_time(t)
6114 /* my_utime - update modification time of a file
6115 * calling sequence is identical to POSIX utime(), but under
6116 * VMS only the modification time is changed; ODS-2 does not
6117 * maintain access times. Restrictions differ from the POSIX
6118 * definition in that the time can be changed as long as the
6119 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6120 * no separate checks are made to insure that the caller is the
6121 * owner of the file or has special privs enabled.
6122 * Code here is based on Joe Meadows' FILE utility.
6125 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6126 * to VMS epoch (01-JAN-1858 00:00:00.00)
6127 * in 100 ns intervals.
6129 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6131 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6132 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6135 long int bintime[2], len = 2, lowbit, unixtime,
6136 secscale = 10000000; /* seconds --> 100 ns intervals */
6137 unsigned long int chan, iosb[2], retsts;
6138 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6139 struct FAB myfab = cc$rms_fab;
6140 struct NAM mynam = cc$rms_nam;
6141 #if defined (__DECC) && defined (__VAX)
6142 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6143 * at least through VMS V6.1, which causes a type-conversion warning.
6145 # pragma message save
6146 # pragma message disable cvtdiftypes
6148 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6149 struct fibdef myfib;
6150 #if defined (__DECC) && defined (__VAX)
6151 /* This should be right after the declaration of myatr, but due
6152 * to a bug in VAX DEC C, this takes effect a statement early.
6154 # pragma message restore
6156 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6157 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6158 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6160 if (file == NULL || *file == '\0') {
6162 set_vaxc_errno(LIB$_INVARG);
6165 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6167 if (utimes != NULL) {
6168 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6169 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6170 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6171 * as input, we force the sign bit to be clear by shifting unixtime right
6172 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6174 lowbit = (utimes->modtime & 1) ? secscale : 0;
6175 unixtime = (long int) utimes->modtime;
6177 /* If input was UTC; convert to local for sys svc */
6178 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6180 unixtime >>= 1; secscale <<= 1;
6181 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6182 if (!(retsts & 1)) {
6184 set_vaxc_errno(retsts);
6187 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6188 if (!(retsts & 1)) {
6190 set_vaxc_errno(retsts);
6195 /* Just get the current time in VMS format directly */
6196 retsts = sys$gettim(bintime);
6197 if (!(retsts & 1)) {
6199 set_vaxc_errno(retsts);
6204 myfab.fab$l_fna = vmsspec;
6205 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6206 myfab.fab$l_nam = &mynam;
6207 mynam.nam$l_esa = esa;
6208 mynam.nam$b_ess = (unsigned char) sizeof esa;
6209 mynam.nam$l_rsa = rsa;
6210 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6212 /* Look for the file to be affected, letting RMS parse the file
6213 * specification for us as well. I have set errno using only
6214 * values documented in the utime() man page for VMS POSIX.
6216 retsts = sys$parse(&myfab,0,0);
6217 if (!(retsts & 1)) {
6218 set_vaxc_errno(retsts);
6219 if (retsts == RMS$_PRV) set_errno(EACCES);
6220 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6221 else set_errno(EVMSERR);
6224 retsts = sys$search(&myfab,0,0);
6225 if (!(retsts & 1)) {
6226 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6227 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6228 set_vaxc_errno(retsts);
6229 if (retsts == RMS$_PRV) set_errno(EACCES);
6230 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6231 else set_errno(EVMSERR);
6235 devdsc.dsc$w_length = mynam.nam$b_dev;
6236 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6238 retsts = sys$assign(&devdsc,&chan,0,0);
6239 if (!(retsts & 1)) {
6240 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6241 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6242 set_vaxc_errno(retsts);
6243 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6244 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6245 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6246 else set_errno(EVMSERR);
6250 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6251 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6253 memset((void *) &myfib, 0, sizeof myfib);
6254 #if defined(__DECC) || defined(__DECCXX)
6255 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6256 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6257 /* This prevents the revision time of the file being reset to the current
6258 * time as a result of our IO$_MODIFY $QIO. */
6259 myfib.fib$l_acctl = FIB$M_NORECORD;
6261 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6262 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6263 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6265 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6266 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6267 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6268 _ckvmssts(sys$dassgn(chan));
6269 if (retsts & 1) retsts = iosb[0];
6270 if (!(retsts & 1)) {
6271 set_vaxc_errno(retsts);
6272 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6273 else set_errno(EVMSERR);
6278 } /* end of my_utime() */
6282 * flex_stat, flex_fstat
6283 * basic stat, but gets it right when asked to stat
6284 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6287 /* encode_dev packs a VMS device name string into an integer to allow
6288 * simple comparisons. This can be used, for example, to check whether two
6289 * files are located on the same device, by comparing their encoded device
6290 * names. Even a string comparison would not do, because stat() reuses the
6291 * device name buffer for each call; so without encode_dev, it would be
6292 * necessary to save the buffer and use strcmp (this would mean a number of
6293 * changes to the standard Perl code, to say nothing of what a Perl script
6296 * The device lock id, if it exists, should be unique (unless perhaps compared
6297 * with lock ids transferred from other nodes). We have a lock id if the disk is
6298 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6299 * device names. Thus we use the lock id in preference, and only if that isn't
6300 * available, do we try to pack the device name into an integer (flagged by
6301 * the sign bit (LOCKID_MASK) being set).
6303 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6304 * name and its encoded form, but it seems very unlikely that we will find
6305 * two files on different disks that share the same encoded device names,
6306 * and even more remote that they will share the same file id (if the test
6307 * is to check for the same file).
6309 * A better method might be to use sys$device_scan on the first call, and to
6310 * search for the device, returning an index into the cached array.
6311 * The number returned would be more intelligable.
6312 * This is probably not worth it, and anyway would take quite a bit longer
6313 * on the first call.
6315 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6316 static mydev_t encode_dev (pTHX_ const char *dev)
6319 unsigned long int f;
6324 if (!dev || !dev[0]) return 0;
6328 struct dsc$descriptor_s dev_desc;
6329 unsigned long int status, lockid, item = DVI$_LOCKID;
6331 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6332 can try that first. */
6333 dev_desc.dsc$w_length = strlen (dev);
6334 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6335 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6336 dev_desc.dsc$a_pointer = (char *) dev;
6337 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6338 if (lockid) return (lockid & ~LOCKID_MASK);
6342 /* Otherwise we try to encode the device name */
6346 for (q = dev + strlen(dev); q--; q >= dev) {
6349 else if (isalpha (toupper (*q)))
6350 c= toupper (*q) - 'A' + (char)10;
6352 continue; /* Skip '$'s */
6354 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6356 enc += f * (unsigned long int) c;
6358 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6360 } /* end of encode_dev() */
6362 static char namecache[NAM$C_MAXRSS+1];
6365 is_null_device(name)
6368 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6369 The underscore prefix, controller letter, and unit number are
6370 independently optional; for our purposes, the colon punctuation
6371 is not. The colon can be trailed by optional directory and/or
6372 filename, but two consecutive colons indicates a nodename rather
6373 than a device. [pr] */
6374 if (*name == '_') ++name;
6375 if (tolower(*name++) != 'n') return 0;
6376 if (tolower(*name++) != 'l') return 0;
6377 if (tolower(*name) == 'a') ++name;
6378 if (*name == '0') ++name;
6379 return (*name++ == ':') && (*name != ':');
6382 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6383 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6384 * subset of the applicable information.
6387 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6389 char fname_phdev[NAM$C_MAXRSS+1];
6390 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6392 char fname[NAM$C_MAXRSS+1];
6393 unsigned long int retsts;
6394 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6395 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6397 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6398 device name on successive calls */
6399 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6400 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6401 namdsc.dsc$a_pointer = fname;
6402 namdsc.dsc$w_length = sizeof fname - 1;
6404 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6405 &namdsc,&namdsc.dsc$w_length,0,0);
6407 fname[namdsc.dsc$w_length] = '\0';
6409 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6410 * but if someone has redefined that logical, Perl gets very lost. Since
6411 * we have the physical device name from the stat buffer, just paste it on.
6413 strcpy( fname_phdev, statbufp->st_devnam );
6414 strcat( fname_phdev, strrchr(fname, ':') );
6416 return cando_by_name(bit,effective,fname_phdev);
6418 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6419 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6423 return FALSE; /* Should never get to here */
6425 } /* end of cando() */
6429 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6431 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6433 static char usrname[L_cuserid];
6434 static struct dsc$descriptor_s usrdsc =
6435 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6436 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6437 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6438 unsigned short int retlen;
6439 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6440 union prvdef curprv;
6441 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6442 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6443 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6446 if (!fname || !*fname) return FALSE;
6447 /* Make sure we expand logical names, since sys$check_access doesn't */
6448 if (!strpbrk(fname,"/]>:")) {
6449 strcpy(fileified,fname);
6450 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6453 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6454 retlen = namdsc.dsc$w_length = strlen(vmsname);
6455 namdsc.dsc$a_pointer = vmsname;
6456 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6457 vmsname[retlen-1] == ':') {
6458 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6459 namdsc.dsc$w_length = strlen(fileified);
6460 namdsc.dsc$a_pointer = fileified;
6463 if (!usrdsc.dsc$w_length) {
6465 usrdsc.dsc$w_length = strlen(usrname);
6469 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6470 access = ARM$M_EXECUTE; break;
6471 case S_IRUSR: case S_IRGRP: case S_IROTH:
6472 access = ARM$M_READ; break;
6473 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6474 access = ARM$M_WRITE; break;
6475 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6476 access = ARM$M_DELETE; break;
6481 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6482 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6483 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6484 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6485 set_vaxc_errno(retsts);
6486 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6487 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6488 else set_errno(ENOENT);
6491 if (retsts == SS$_NORMAL) {
6492 if (!privused) return TRUE;
6493 /* We can get access, but only by using privs. Do we have the
6494 necessary privs currently enabled? */
6495 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6496 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6497 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6498 !curprv.prv$v_bypass) return FALSE;
6499 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6500 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6501 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6504 if (retsts == SS$_ACCONFLICT) {
6509 return FALSE; /* Should never get here */
6511 } /* end of cando_by_name() */
6515 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6517 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6519 if (!fstat(fd,(stat_t *) statbufp)) {
6520 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6521 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6522 # ifdef RTL_USES_UTC
6525 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6526 statbufp->st_atime = _toloc(statbufp->st_atime);
6527 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6532 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6536 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6537 statbufp->st_atime = _toutc(statbufp->st_atime);
6538 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6545 } /* end of flex_fstat() */
6548 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6550 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6552 char fileified[NAM$C_MAXRSS+1];
6553 char temp_fspec[NAM$C_MAXRSS+300];
6556 if (!fspec) return retval;
6557 strcpy(temp_fspec, fspec);
6558 if (statbufp == (Stat_t *) &PL_statcache)
6559 do_tovmsspec(temp_fspec,namecache,0);
6560 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6561 memset(statbufp,0,sizeof *statbufp);
6562 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6563 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6564 statbufp->st_uid = 0x00010001;
6565 statbufp->st_gid = 0x0001;
6566 time((time_t *)&statbufp->st_mtime);
6567 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6571 /* Try for a directory name first. If fspec contains a filename without
6572 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6573 * and sea:[wine.dark]water. exist, we prefer the directory here.
6574 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6575 * not sea:[wine.dark]., if the latter exists. If the intended target is
6576 * the file with null type, specify this by calling flex_stat() with
6577 * a '.' at the end of fspec.
6579 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6580 retval = stat(fileified,(stat_t *) statbufp);
6581 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6582 strcpy(namecache,fileified);
6584 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6586 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6587 # ifdef RTL_USES_UTC
6590 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6591 statbufp->st_atime = _toloc(statbufp->st_atime);
6592 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6597 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6601 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6602 statbufp->st_atime = _toutc(statbufp->st_atime);
6603 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6609 } /* end of flex_stat() */
6613 /*{{{char *my_getlogin()*/
6614 /* VMS cuserid == Unix getlogin, except calling sequence */
6618 static char user[L_cuserid];
6619 return cuserid(user);
6624 /* rmscopy - copy a file using VMS RMS routines
6626 * Copies contents and attributes of spec_in to spec_out, except owner
6627 * and protection information. Name and type of spec_in are used as
6628 * defaults for spec_out. The third parameter specifies whether rmscopy()
6629 * should try to propagate timestamps from the input file to the output file.
6630 * If it is less than 0, no timestamps are preserved. If it is 0, then
6631 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6632 * propagated to the output file at creation iff the output file specification
6633 * did not contain an explicit name or type, and the revision date is always
6634 * updated at the end of the copy operation. If it is greater than 0, then
6635 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6636 * other than the revision date should be propagated, and bit 1 indicates
6637 * that the revision date should be propagated.
6639 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6641 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6642 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6643 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6644 * as part of the Perl standard distribution under the terms of the
6645 * GNU General Public License or the Perl Artistic License. Copies
6646 * of each may be found in the Perl standard distribution.
6648 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6650 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6652 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6653 rsa[NAM$C_MAXRSS], ubf[32256];
6654 unsigned long int i, sts, sts2;
6655 struct FAB fab_in, fab_out;
6656 struct RAB rab_in, rab_out;
6658 struct XABDAT xabdat;
6659 struct XABFHC xabfhc;
6660 struct XABRDT xabrdt;
6661 struct XABSUM xabsum;
6663 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6664 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6665 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6669 fab_in = cc$rms_fab;
6670 fab_in.fab$l_fna = vmsin;
6671 fab_in.fab$b_fns = strlen(vmsin);
6672 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6673 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6674 fab_in.fab$l_fop = FAB$M_SQO;
6675 fab_in.fab$l_nam = &nam;
6676 fab_in.fab$l_xab = (void *) &xabdat;
6679 nam.nam$l_rsa = rsa;
6680 nam.nam$b_rss = sizeof(rsa);
6681 nam.nam$l_esa = esa;
6682 nam.nam$b_ess = sizeof (esa);
6683 nam.nam$b_esl = nam.nam$b_rsl = 0;
6685 xabdat = cc$rms_xabdat; /* To get creation date */
6686 xabdat.xab$l_nxt = (void *) &xabfhc;
6688 xabfhc = cc$rms_xabfhc; /* To get record length */
6689 xabfhc.xab$l_nxt = (void *) &xabsum;
6691 xabsum = cc$rms_xabsum; /* To get key and area information */
6693 if (!((sts = sys$open(&fab_in)) & 1)) {
6694 set_vaxc_errno(sts);
6696 case RMS$_FNF: case RMS$_DNF:
6697 set_errno(ENOENT); break;
6699 set_errno(ENOTDIR); break;
6701 set_errno(ENODEV); break;
6703 set_errno(EINVAL); break;
6705 set_errno(EACCES); break;
6713 fab_out.fab$w_ifi = 0;
6714 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6715 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6716 fab_out.fab$l_fop = FAB$M_SQO;
6717 fab_out.fab$l_fna = vmsout;
6718 fab_out.fab$b_fns = strlen(vmsout);
6719 fab_out.fab$l_dna = nam.nam$l_name;
6720 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6722 if (preserve_dates == 0) { /* Act like DCL COPY */
6723 nam.nam$b_nop = NAM$M_SYNCHK;
6724 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6725 if (!((sts = sys$parse(&fab_out)) & 1)) {
6726 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6727 set_vaxc_errno(sts);
6730 fab_out.fab$l_xab = (void *) &xabdat;
6731 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6733 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6734 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6735 preserve_dates =0; /* bitmask from this point forward */
6737 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6738 if (!((sts = sys$create(&fab_out)) & 1)) {
6739 set_vaxc_errno(sts);
6742 set_errno(ENOENT); break;
6744 set_errno(ENOTDIR); break;
6746 set_errno(ENODEV); break;
6748 set_errno(EINVAL); break;
6750 set_errno(EACCES); break;
6756 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6757 if (preserve_dates & 2) {
6758 /* sys$close() will process xabrdt, not xabdat */
6759 xabrdt = cc$rms_xabrdt;
6761 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6763 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6764 * is unsigned long[2], while DECC & VAXC use a struct */
6765 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6767 fab_out.fab$l_xab = (void *) &xabrdt;
6770 rab_in = cc$rms_rab;
6771 rab_in.rab$l_fab = &fab_in;
6772 rab_in.rab$l_rop = RAB$M_BIO;
6773 rab_in.rab$l_ubf = ubf;
6774 rab_in.rab$w_usz = sizeof ubf;
6775 if (!((sts = sys$connect(&rab_in)) & 1)) {
6776 sys$close(&fab_in); sys$close(&fab_out);
6777 set_errno(EVMSERR); set_vaxc_errno(sts);
6781 rab_out = cc$rms_rab;
6782 rab_out.rab$l_fab = &fab_out;
6783 rab_out.rab$l_rbf = ubf;
6784 if (!((sts = sys$connect(&rab_out)) & 1)) {
6785 sys$close(&fab_in); sys$close(&fab_out);
6786 set_errno(EVMSERR); set_vaxc_errno(sts);
6790 while ((sts = sys$read(&rab_in))) { /* always true */
6791 if (sts == RMS$_EOF) break;
6792 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6793 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6794 sys$close(&fab_in); sys$close(&fab_out);
6795 set_errno(EVMSERR); set_vaxc_errno(sts);
6800 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6801 sys$close(&fab_in); sys$close(&fab_out);
6802 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6804 set_errno(EVMSERR); set_vaxc_errno(sts);
6810 } /* end of rmscopy() */
6814 /*** The following glue provides 'hooks' to make some of the routines
6815 * from this file available from Perl. These routines are sufficiently
6816 * basic, and are required sufficiently early in the build process,
6817 * that's it's nice to have them available to miniperl as well as the
6818 * full Perl, so they're set up here instead of in an extension. The
6819 * Perl code which handles importation of these names into a given
6820 * package lives in [.VMS]Filespec.pm in @INC.
6824 rmsexpand_fromperl(pTHX_ CV *cv)
6827 char *fspec, *defspec = NULL, *rslt;
6830 if (!items || items > 2)
6831 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6832 fspec = SvPV(ST(0),n_a);
6833 if (!fspec || !*fspec) XSRETURN_UNDEF;
6834 if (items == 2) defspec = SvPV(ST(1),n_a);
6836 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6837 ST(0) = sv_newmortal();
6838 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6843 vmsify_fromperl(pTHX_ CV *cv)
6849 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6850 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6851 ST(0) = sv_newmortal();
6852 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6857 unixify_fromperl(pTHX_ CV *cv)
6863 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6864 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6865 ST(0) = sv_newmortal();
6866 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6871 fileify_fromperl(pTHX_ CV *cv)
6877 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6878 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6879 ST(0) = sv_newmortal();
6880 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6885 pathify_fromperl(pTHX_ CV *cv)
6891 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6892 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6893 ST(0) = sv_newmortal();
6894 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6899 vmspath_fromperl(pTHX_ CV *cv)
6905 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6906 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6907 ST(0) = sv_newmortal();
6908 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6913 unixpath_fromperl(pTHX_ CV *cv)
6919 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6920 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6921 ST(0) = sv_newmortal();
6922 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6927 candelete_fromperl(pTHX_ CV *cv)
6930 char fspec[NAM$C_MAXRSS+1], *fsp;
6935 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6937 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6938 if (SvTYPE(mysv) == SVt_PVGV) {
6939 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6940 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6947 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6948 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6954 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6959 rmscopy_fromperl(pTHX_ CV *cv)
6962 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6964 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6965 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6966 unsigned long int sts;
6971 if (items < 2 || items > 3)
6972 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6974 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6975 if (SvTYPE(mysv) == SVt_PVGV) {
6976 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6977 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6984 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6985 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6990 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6991 if (SvTYPE(mysv) == SVt_PVGV) {
6992 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6993 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7000 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7001 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7006 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7008 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7014 mod2fname(pTHX_ CV *cv)
7017 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7018 workbuff[NAM$C_MAXRSS*1 + 1];
7019 int total_namelen = 3, counter, num_entries;
7020 /* ODS-5 ups this, but we want to be consistent, so... */
7021 int max_name_len = 39;
7022 AV *in_array = (AV *)SvRV(ST(0));
7024 num_entries = av_len(in_array);
7026 /* All the names start with PL_. */
7027 strcpy(ultimate_name, "PL_");
7029 /* Clean up our working buffer */
7030 Zero(work_name, sizeof(work_name), char);
7032 /* Run through the entries and build up a working name */
7033 for(counter = 0; counter <= num_entries; counter++) {
7034 /* If it's not the first name then tack on a __ */
7036 strcat(work_name, "__");
7038 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7042 /* Check to see if we actually have to bother...*/
7043 if (strlen(work_name) + 3 <= max_name_len) {
7044 strcat(ultimate_name, work_name);
7046 /* It's too darned big, so we need to go strip. We use the same */
7047 /* algorithm as xsubpp does. First, strip out doubled __ */
7048 char *source, *dest, last;
7051 for (source = work_name; *source; source++) {
7052 if (last == *source && last == '_') {
7058 /* Go put it back */
7059 strcpy(work_name, workbuff);
7060 /* Is it still too big? */
7061 if (strlen(work_name) + 3 > max_name_len) {
7062 /* Strip duplicate letters */
7065 for (source = work_name; *source; source++) {
7066 if (last == toupper(*source)) {
7070 last = toupper(*source);
7072 strcpy(work_name, workbuff);
7075 /* Is it *still* too big? */
7076 if (strlen(work_name) + 3 > max_name_len) {
7077 /* Too bad, we truncate */
7078 work_name[max_name_len - 2] = 0;
7080 strcat(ultimate_name, work_name);
7083 /* Okay, return it */
7084 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7089 hushexit_fromperl(pTHX_ CV *cv)
7094 VMSISH_HUSHED = SvTRUE(ST(0));
7096 ST(0) = boolSV(VMSISH_HUSHED);
7101 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7102 struct interp_intern *dst)
7104 memcpy(dst,src,sizeof(struct interp_intern));
7108 Perl_sys_intern_clear(pTHX)
7113 Perl_sys_intern_init(pTHX)
7121 MY_INV_RAND_MAX = 1./x;
7123 VMSCMD.dsc$a_pointer = NULL;
7124 VMSCMD.dsc$w_length = 0;
7125 VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
7126 VMSCMD.dsc$b_class = DSC$K_CLASS_S;
7133 char* file = __FILE__;
7134 char temp_buff[512];
7135 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7136 no_translate_barewords = TRUE;
7138 no_translate_barewords = FALSE;
7141 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7142 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7143 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7144 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7145 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7146 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7147 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7148 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7149 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7150 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7151 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7153 store_pipelocs(aTHX);