3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
18 #include <climsgdef.h>
28 #include <libclidef.h>
30 #include <lib$routines.h>
40 #include <str$routines.h>
45 /* Older versions of ssdef.h don't have these */
46 #ifndef SS$_INVFILFOROP
47 # define SS$_INVFILFOROP 3930
49 #ifndef SS$_NOSUCHOBJECT
50 # define SS$_NOSUCHOBJECT 2696
53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
54 #define PERLIO_NOT_STDIO 0
56 /* Don't replace system definitions of vfork, getenv, and stat,
57 * code below needs to get to the underlying CRTL routines. */
58 #define DONT_MASK_RTL_CALLS
62 /* Anticipating future expansion in lexical warnings . . . */
64 # define WARN_INTERNAL WARN_MISC
67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
68 # define RTL_USES_UTC 1
72 /* gcc's header files don't #define direct access macros
73 * corresponding to VAXC's variant structs */
75 # define uic$v_format uic$r_uic_form.uic$v_format
76 # define uic$v_group uic$r_uic_form.uic$v_group
77 # define uic$v_member uic$r_uic_form.uic$v_member
78 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
79 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
80 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
81 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
84 #if defined(NEED_AN_H_ERRNO)
89 unsigned short int buflen;
90 unsigned short int itmcode;
92 unsigned short int *retlen;
95 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
96 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
97 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
98 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
99 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
100 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
101 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
102 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
103 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
106 #define PERL_LNM_MAX_ALLOWED_INDEX 127
108 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
109 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
112 #define PERL_LNM_MAX_ITER 10
114 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
115 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
117 static char *__mystrtolower(char *str)
119 if (str) for (; *str; ++str) *str= tolower(*str);
123 static struct dsc$descriptor_s fildevdsc =
124 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
125 static struct dsc$descriptor_s crtlenvdsc =
126 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
127 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
128 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
129 static struct dsc$descriptor_s **env_tables = defenv;
130 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
132 /* True if we shouldn't treat barewords as logicals during directory */
134 static int no_translate_barewords;
137 static int tz_updated = 1;
141 * Routine to retrieve the maximum equivalence index for an input
142 * logical name. Some calls to this routine have no knowledge if
143 * the variable is a logical or not. So on error we return a max
146 /*{{{int my_maxidx(char *lnm) */
152 int attr = LNM$M_CASE_BLIND;
153 struct dsc$descriptor lnmdsc;
154 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
157 lnmdsc.dsc$w_length = strlen(lnm);
158 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
159 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
160 lnmdsc.dsc$a_pointer = lnm;
162 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
163 if ((status & 1) == 0)
170 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
172 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
173 struct dsc$descriptor_s **tabvec, unsigned long int flags)
175 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
176 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
177 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
179 unsigned char acmode;
180 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
181 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
182 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
183 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
185 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
186 #if defined(PERL_IMPLICIT_CONTEXT)
189 aTHX = PERL_GET_INTERP;
195 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
196 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
198 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
199 *cp2 = _toupper(*cp1);
200 if (cp1 - lnm > LNM$C_NAMLENGTH) {
201 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
205 lnmdsc.dsc$w_length = cp1 - lnm;
206 lnmdsc.dsc$a_pointer = uplnm;
207 uplnm[lnmdsc.dsc$w_length] = '\0';
208 secure = flags & PERL__TRNENV_SECURE;
209 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
210 if (!tabvec || !*tabvec) tabvec = env_tables;
212 for (curtab = 0; tabvec[curtab]; curtab++) {
213 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
214 if (!ivenv && !secure) {
219 Perl_warn(aTHX_ "Can't read CRTL environ\n");
222 retsts = SS$_NOLOGNAM;
223 for (i = 0; environ[i]; i++) {
224 if ((eq = strchr(environ[i],'=')) &&
225 !strncmp(environ[i],uplnm,eq - environ[i])) {
227 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
228 if (!eqvlen) continue;
233 if (retsts != SS$_NOLOGNAM) break;
236 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
237 !str$case_blind_compare(&tmpdsc,&clisym)) {
238 if (!ivsym && !secure) {
239 unsigned short int deflen = LNM$C_NAMLENGTH;
240 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
241 /* dynamic dsc to accomodate possible long value */
242 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
243 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
246 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
248 /* Special hack--we might be called before the interpreter's */
249 /* fully initialized, in which case either thr or PL_curcop */
250 /* might be bogus. We have to check, since ckWARN needs them */
251 /* both to be valid if running threaded */
252 if (ckWARN(WARN_MISC)) {
253 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
256 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
258 _ckvmssts(lib$sfree1_dd(&eqvdsc));
259 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
260 if (retsts == LIB$_NOSUCHSYM) continue;
265 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
266 midx = my_maxidx((char *) lnm);
267 for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
268 lnmlst[1].bufadr = cp1;
270 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
271 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
272 if (retsts == SS$_NOLOGNAM) break;
273 /* PPFs have a prefix */
276 *((int *)uplnm) == *((int *)"SYS$") &&
278 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
279 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
280 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
281 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
282 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
283 memcpy(eqv,eqv+4,eqvlen-4);
289 if ((retsts == SS$_IVLOGNAM) ||
290 (retsts == SS$_NOLOGNAM)) { continue; }
293 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
294 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
295 if (retsts == SS$_NOLOGNAM) continue;
298 eqvlen = strlen(eqv);
302 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
303 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
304 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
305 retsts == SS$_NOLOGNAM) {
306 set_errno(EINVAL); set_vaxc_errno(retsts);
308 else _ckvmssts(retsts);
310 } /* end of vmstrnenv */
313 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
314 /* Define as a function so we can access statics. */
315 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
317 return vmstrnenv(lnm,eqv,idx,fildev,
318 #ifdef SECURE_INTERNAL_GETENV
319 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
328 * Note: Uses Perl temp to store result so char * can be returned to
329 * caller; this pointer will be invalidated at next Perl statement
331 * We define this as a function rather than a macro in terms of my_getenv_len()
332 * so that it'll work when PL_curinterp is undefined (and we therefore can't
335 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
337 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
339 static char *__my_getenv_eqv = NULL;
340 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
341 unsigned long int idx = 0;
342 int trnsuccess, success, secure, saverr, savvmserr;
346 midx = my_maxidx((char *) lnm) + 1;
348 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
349 /* Set up a temporary buffer for the return value; Perl will
350 * clean it up at the next statement transition */
351 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
352 if (!tmpsv) return NULL;
356 /* Assume no interpreter ==> single thread */
357 if (__my_getenv_eqv != NULL) {
358 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
361 New(1380,__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
363 eqv = __my_getenv_eqv;
366 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
367 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
368 getcwd(eqv,LNM$C_NAMLENGTH);
372 /* Impose security constraints only if tainting */
374 /* Impose security constraints only if tainting */
375 secure = PL_curinterp ? PL_tainting : will_taint;
376 saverr = errno; savvmserr = vaxc$errno;
383 #ifdef SECURE_INTERNAL_GETENV
384 secure ? PERL__TRNENV_SECURE : 0
390 /* For the getenv interface we combine all the equivalence names
391 * of a search list logical into one value to acquire a maximum
392 * value length of 255*128 (assuming %ENV is using logicals).
394 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
396 /* If the name contains a semicolon-delimited index, parse it
397 * off and make sure we only retrieve the equivalence name for
399 if ((cp2 = strchr(lnm,';')) != NULL) {
401 uplnm[cp2-lnm] = '\0';
402 idx = strtoul(cp2+1,NULL,0);
404 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
407 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
409 /* Discard NOLOGNAM on internal calls since we're often looking
410 * for an optional name, and this "error" often shows up as the
411 * (bogus) exit status for a die() call later on. */
412 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
413 return success ? eqv : Nullch;
416 } /* end of my_getenv() */
420 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
422 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
424 char *buf, *cp1, *cp2;
425 unsigned long idx = 0;
427 static char *__my_getenv_len_eqv = NULL;
428 int secure, saverr, savvmserr;
431 midx = my_maxidx((char *) lnm) + 1;
433 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
434 /* Set up a temporary buffer for the return value; Perl will
435 * clean it up at the next statement transition */
436 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
437 if (!tmpsv) return NULL;
441 /* Assume no interpreter ==> single thread */
442 if (__my_getenv_len_eqv != NULL) {
443 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
446 New(1381,__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
448 buf = __my_getenv_len_eqv;
451 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
452 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
453 getcwd(buf,LNM$C_NAMLENGTH);
459 /* Impose security constraints only if tainting */
460 secure = PL_curinterp ? PL_tainting : will_taint;
461 saverr = errno; savvmserr = vaxc$errno;
468 #ifdef SECURE_INTERNAL_GETENV
469 secure ? PERL__TRNENV_SECURE : 0
475 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
477 if ((cp2 = strchr(lnm,';')) != NULL) {
480 idx = strtoul(cp2+1,NULL,0);
482 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
485 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
487 /* Discard NOLOGNAM on internal calls since we're often looking
488 * for an optional name, and this "error" often shows up as the
489 * (bogus) exit status for a die() call later on. */
490 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
491 return *len ? buf : Nullch;
494 } /* end of my_getenv_len() */
497 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
499 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
501 /*{{{ void prime_env_iter() */
504 /* Fill the %ENV associative array with all logical names we can
505 * find, in preparation for iterating over it.
508 static int primed = 0;
509 HV *seenhv = NULL, *envhv;
511 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
512 unsigned short int chan;
513 #ifndef CLI$M_TRUSTED
514 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
516 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
517 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
519 bool have_sym = FALSE, have_lnm = FALSE;
520 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
521 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
522 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
523 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
524 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
525 #if defined(PERL_IMPLICIT_CONTEXT)
528 #if defined(USE_ITHREADS)
529 static perl_mutex primenv_mutex;
530 MUTEX_INIT(&primenv_mutex);
533 #if defined(PERL_IMPLICIT_CONTEXT)
534 /* We jump through these hoops because we can be called at */
535 /* platform-specific initialization time, which is before anything is */
536 /* set up--we can't even do a plain dTHX since that relies on the */
537 /* interpreter structure to be initialized */
539 aTHX = PERL_GET_INTERP;
545 if (primed || !PL_envgv) return;
546 MUTEX_LOCK(&primenv_mutex);
547 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
548 envhv = GvHVn(PL_envgv);
549 /* Perform a dummy fetch as an lval to insure that the hash table is
550 * set up. Otherwise, the hv_store() will turn into a nullop. */
551 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
553 for (i = 0; env_tables[i]; i++) {
554 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
555 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
556 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
558 if (have_sym || have_lnm) {
559 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
560 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
561 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
562 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
565 for (i--; i >= 0; i--) {
566 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
569 for (j = 0; environ[j]; j++) {
570 if (!(start = strchr(environ[j],'='))) {
571 if (ckWARN(WARN_INTERNAL))
572 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
576 sv = newSVpv(start,0);
578 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
583 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
584 !str$case_blind_compare(&tmpdsc,&clisym)) {
585 strcpy(cmd,"Show Symbol/Global *");
586 cmddsc.dsc$w_length = 20;
587 if (env_tables[i]->dsc$w_length == 12 &&
588 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
589 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
590 flags = defflags | CLI$M_NOLOGNAM;
593 strcpy(cmd,"Show Logical *");
594 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
595 strcat(cmd," /Table=");
596 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
597 cmddsc.dsc$w_length = strlen(cmd);
599 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
600 flags = defflags | CLI$M_NOCLISYM;
603 /* Create a new subprocess to execute each command, to exclude the
604 * remote possibility that someone could subvert a mbx or file used
605 * to write multiple commands to a single subprocess.
608 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
609 0,&riseandshine,0,0,&clidsc,&clitabdsc);
610 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
611 defflags &= ~CLI$M_TRUSTED;
612 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
614 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
615 if (seenhv) SvREFCNT_dec(seenhv);
618 char *cp1, *cp2, *key;
619 unsigned long int sts, iosb[2], retlen, keylen;
622 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
623 if (sts & 1) sts = iosb[0] & 0xffff;
624 if (sts == SS$_ENDOFFILE) {
626 while (substs == 0) { sys$hiber(); wakect++;}
627 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
632 retlen = iosb[0] >> 16;
633 if (!retlen) continue; /* blank line */
635 if (iosb[1] != subpid) {
637 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
641 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
642 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
644 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
645 if (*cp1 == '(' || /* Logical name table name */
646 *cp1 == '=' /* Next eqv of searchlist */) continue;
647 if (*cp1 == '"') cp1++;
648 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
649 key = cp1; keylen = cp2 - cp1;
650 if (keylen && hv_exists(seenhv,key,keylen)) continue;
651 while (*cp2 && *cp2 != '=') cp2++;
652 while (*cp2 && *cp2 == '=') cp2++;
653 while (*cp2 && *cp2 == ' ') cp2++;
654 if (*cp2 == '"') { /* String translation; may embed "" */
655 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
656 cp2++; cp1--; /* Skip "" surrounding translation */
658 else { /* Numeric translation */
659 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
660 cp1--; /* stop on last non-space char */
662 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
663 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
666 PERL_HASH(hash,key,keylen);
667 sv = newSVpvn(cp2,cp1 - cp2 + 1);
669 hv_store(envhv,key,keylen,sv,hash);
670 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
672 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
673 /* get the PPFs for this process, not the subprocess */
674 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
675 char eqv[LNM$C_NAMLENGTH+1];
677 for (i = 0; ppfs[i]; i++) {
678 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
679 sv = newSVpv(eqv,trnlen);
681 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
686 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
687 if (buf) Safefree(buf);
688 if (seenhv) SvREFCNT_dec(seenhv);
689 MUTEX_UNLOCK(&primenv_mutex);
692 } /* end of prime_env_iter */
696 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
697 /* Define or delete an element in the same "environment" as
698 * vmstrnenv(). If an element is to be deleted, it's removed from
699 * the first place it's found. If it's to be set, it's set in the
700 * place designated by the first element of the table vector.
701 * Like setenv() returns 0 for success, non-zero on error.
704 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
706 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
707 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
709 unsigned long int retsts, usermode = PSL$C_USER;
710 struct itmlst_3 *ile, *ilist;
711 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
712 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
713 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
714 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
715 $DESCRIPTOR(local,"_LOCAL");
717 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
718 *cp2 = _toupper(*cp1);
719 if (cp1 - lnm > LNM$C_NAMLENGTH) {
720 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
724 lnmdsc.dsc$w_length = cp1 - lnm;
725 if (!tabvec || !*tabvec) tabvec = env_tables;
727 if (!eqv) { /* we're deleting n element */
728 for (curtab = 0; tabvec[curtab]; curtab++) {
729 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
731 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
732 if ((cp1 = strchr(environ[i],'=')) &&
733 !strncmp(environ[i],lnm,cp1 - environ[i])) {
735 return setenv(lnm,"",1) ? vaxc$errno : 0;
738 ivenv = 1; retsts = SS$_NOLOGNAM;
740 if (ckWARN(WARN_INTERNAL))
741 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
742 ivenv = 1; retsts = SS$_NOSUCHPGM;
748 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
749 !str$case_blind_compare(&tmpdsc,&clisym)) {
750 unsigned int symtype;
751 if (tabvec[curtab]->dsc$w_length == 12 &&
752 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
753 !str$case_blind_compare(&tmpdsc,&local))
754 symtype = LIB$K_CLI_LOCAL_SYM;
755 else symtype = LIB$K_CLI_GLOBAL_SYM;
756 retsts = lib$delete_symbol(&lnmdsc,&symtype);
757 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
758 if (retsts == LIB$_NOSUCHSYM) continue;
762 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
763 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
764 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
765 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
766 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
770 else { /* we're defining a value */
771 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
773 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
775 if (ckWARN(WARN_INTERNAL))
776 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
777 retsts = SS$_NOSUCHPGM;
781 eqvdsc.dsc$a_pointer = eqv;
782 eqvdsc.dsc$w_length = strlen(eqv);
783 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
784 !str$case_blind_compare(&tmpdsc,&clisym)) {
785 unsigned int symtype;
786 if (tabvec[0]->dsc$w_length == 12 &&
787 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
788 !str$case_blind_compare(&tmpdsc,&local))
789 symtype = LIB$K_CLI_LOCAL_SYM;
790 else symtype = LIB$K_CLI_GLOBAL_SYM;
791 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
794 if (!*eqv) eqvdsc.dsc$w_length = 1;
795 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
797 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
798 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
799 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
800 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
801 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
802 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
805 New(1382,ilist,nseg+1,struct itmlst_3);
808 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
811 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
813 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
814 ile->itmcode = LNM$_STRING;
817 ile->buflen = strlen(c);
818 /* in case we are truncating one that's too long */
819 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
822 ile->buflen = LNM$C_NAMLENGTH;
826 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
830 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
837 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
838 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
839 set_errno(EVMSERR); break;
840 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
841 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
842 set_errno(EINVAL); break;
849 set_vaxc_errno(retsts);
850 return (int) retsts || 44; /* retsts should never be 0, but just in case */
853 /* We reset error values on success because Perl does an hv_fetch()
854 * before each hv_store(), and if the thing we're setting didn't
855 * previously exist, we've got a leftover error message. (Of course,
856 * this fails in the face of
857 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
858 * in that the error reported in $! isn't spurious,
859 * but it's right more often than not.)
861 set_errno(0); set_vaxc_errno(retsts);
865 } /* end of vmssetenv() */
868 /*{{{ void my_setenv(char *lnm, char *eqv)*/
869 /* This has to be a function since there's a prototype for it in proto.h */
871 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
874 int len = strlen(lnm);
878 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
879 if (!strcmp(uplnm,"DEFAULT")) {
880 if (eqv && *eqv) chdir(eqv);
885 if (len == 6 || len == 2) {
888 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
890 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
891 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
895 (void) vmssetenv(lnm,eqv,NULL);
899 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
901 * sets a user-mode logical in the process logical name table
902 * used for redirection of sys$error
905 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
907 $DESCRIPTOR(d_tab, "LNM$PROCESS");
908 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
909 unsigned long int iss, attr = LNM$M_CONFINE;
910 unsigned char acmode = PSL$C_USER;
911 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
913 d_name.dsc$a_pointer = name;
914 d_name.dsc$w_length = strlen(name);
916 lnmlst[0].buflen = strlen(eqv);
917 lnmlst[0].bufadr = eqv;
919 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
920 if (!(iss&1)) lib$signal(iss);
925 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
926 /* my_crypt - VMS password hashing
927 * my_crypt() provides an interface compatible with the Unix crypt()
928 * C library function, and uses sys$hash_password() to perform VMS
929 * password hashing. The quadword hashed password value is returned
930 * as a NUL-terminated 8 character string. my_crypt() does not change
931 * the case of its string arguments; in order to match the behavior
932 * of LOGINOUT et al., alphabetic characters in both arguments must
933 * be upcased by the caller.
936 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
938 # ifndef UAI$C_PREFERRED_ALGORITHM
939 # define UAI$C_PREFERRED_ALGORITHM 127
941 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
942 unsigned short int salt = 0;
943 unsigned long int sts;
945 unsigned short int dsc$w_length;
946 unsigned char dsc$b_type;
947 unsigned char dsc$b_class;
948 const char * dsc$a_pointer;
949 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
950 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
951 struct itmlst_3 uailst[3] = {
952 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
953 { sizeof salt, UAI$_SALT, &salt, 0},
954 { 0, 0, NULL, NULL}};
957 usrdsc.dsc$w_length = strlen(usrname);
958 usrdsc.dsc$a_pointer = usrname;
959 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
961 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
965 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
971 if (sts != RMS$_RNF) return NULL;
974 txtdsc.dsc$w_length = strlen(textpasswd);
975 txtdsc.dsc$a_pointer = textpasswd;
976 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
977 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
980 return (char *) hash;
982 } /* end of my_crypt() */
986 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
987 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
988 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
990 /*{{{int do_rmdir(char *name)*/
992 Perl_do_rmdir(pTHX_ char *name)
994 char dirfile[NAM$C_MAXRSS+1];
998 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
999 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1000 else retval = kill_file(dirfile);
1003 } /* end of do_rmdir */
1007 * Delete any file to which user has control access, regardless of whether
1008 * delete access is explicitly allowed.
1009 * Limitations: User must have write access to parent directory.
1010 * Does not block signals or ASTs; if interrupted in midstream
1011 * may leave file with an altered ACL.
1014 /*{{{int kill_file(char *name)*/
1016 Perl_kill_file(pTHX_ char *name)
1018 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1019 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1020 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1021 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1023 unsigned char myace$b_length;
1024 unsigned char myace$b_type;
1025 unsigned short int myace$w_flags;
1026 unsigned long int myace$l_access;
1027 unsigned long int myace$l_ident;
1028 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1029 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1030 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1032 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1033 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1034 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1035 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1036 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1037 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1039 /* Expand the input spec using RMS, since the CRTL remove() and
1040 * system services won't do this by themselves, so we may miss
1041 * a file "hiding" behind a logical name or search list. */
1042 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1043 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1044 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1045 /* If not, can changing protections help? */
1046 if (vaxc$errno != RMS$_PRV) return -1;
1048 /* No, so we get our own UIC to use as a rights identifier,
1049 * and the insert an ACE at the head of the ACL which allows us
1050 * to delete the file.
1052 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1053 fildsc.dsc$w_length = strlen(rspec);
1054 fildsc.dsc$a_pointer = rspec;
1056 newace.myace$l_ident = oldace.myace$l_ident;
1057 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1059 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1060 set_errno(ENOENT); break;
1062 set_errno(ENOTDIR); break;
1064 set_errno(ENODEV); break;
1065 case RMS$_SYN: case SS$_INVFILFOROP:
1066 set_errno(EINVAL); break;
1068 set_errno(EACCES); break;
1072 set_vaxc_errno(aclsts);
1075 /* Grab any existing ACEs with this identifier in case we fail */
1076 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1077 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1078 || fndsts == SS$_NOMOREACE ) {
1079 /* Add the new ACE . . . */
1080 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1082 if ((rmsts = remove(name))) {
1083 /* We blew it - dir with files in it, no write priv for
1084 * parent directory, etc. Put things back the way they were. */
1085 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1088 addlst[0].bufadr = &oldace;
1089 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1096 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1097 /* We just deleted it, so of course it's not there. Some versions of
1098 * VMS seem to return success on the unlock operation anyhow (after all
1099 * the unlock is successful), but others don't.
1101 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1102 if (aclsts & 1) aclsts = fndsts;
1103 if (!(aclsts & 1)) {
1105 set_vaxc_errno(aclsts);
1111 } /* end of kill_file() */
1115 /*{{{int my_mkdir(char *,Mode_t)*/
1117 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1119 STRLEN dirlen = strlen(dir);
1121 /* zero length string sometimes gives ACCVIO */
1122 if (dirlen == 0) return -1;
1124 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1125 * null file name/type. However, it's commonplace under Unix,
1126 * so we'll allow it for a gain in portability.
1128 if (dir[dirlen-1] == '/') {
1129 char *newdir = savepvn(dir,dirlen-1);
1130 int ret = mkdir(newdir,mode);
1134 else return mkdir(dir,mode);
1135 } /* end of my_mkdir */
1138 /*{{{int my_chdir(char *)*/
1140 Perl_my_chdir(pTHX_ char *dir)
1142 STRLEN dirlen = strlen(dir);
1144 /* zero length string sometimes gives ACCVIO */
1145 if (dirlen == 0) return -1;
1147 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1149 * null file name/type. However, it's commonplace under Unix,
1150 * so we'll allow it for a gain in portability.
1152 if (dir[dirlen-1] == '/') {
1153 char *newdir = savepvn(dir,dirlen-1);
1154 int ret = chdir(newdir);
1158 else return chdir(dir);
1159 } /* end of my_chdir */
1163 /*{{{FILE *my_tmpfile()*/
1170 if ((fp = tmpfile())) return fp;
1172 New(1323,cp,L_tmpnam+24,char);
1173 strcpy(cp,"Sys$Scratch:");
1174 tmpnam(cp+strlen(cp));
1175 strcat(cp,".Perltmp");
1176 fp = fopen(cp,"w+","fop=dlt");
1183 #ifndef HOMEGROWN_POSIX_SIGNALS
1185 * The C RTL's sigaction fails to check for invalid signal numbers so we
1186 * help it out a bit. The docs are correct, but the actual routine doesn't
1187 * do what the docs say it will.
1189 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1191 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1192 struct sigaction* oact)
1194 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1195 SETERRNO(EINVAL, SS$_INVARG);
1198 return sigaction(sig, act, oact);
1203 #ifdef KILL_BY_SIGPRC
1204 #include <errnodef.h>
1206 /* We implement our own kill() using the undocumented system service
1207 sys$sigprc for one of two reasons:
1209 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1210 target process to do a sys$exit, which usually can't be handled
1211 gracefully...certainly not by Perl and the %SIG{} mechanism.
1213 2.) If the kill() in the CRTL can't be called from a signal
1214 handler without disappearing into the ether, i.e., the signal
1215 it purportedly sends is never trapped. Still true as of VMS 7.3.
1217 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1218 in the target process rather than calling sys$exit.
1220 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1221 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1222 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1223 with condition codes C$_SIG0+nsig*8, catching the exception on the
1224 target process and resignaling with appropriate arguments.
1226 But we don't have that VMS 7.0+ exception handler, so if you
1227 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1229 Also note that SIGTERM is listed in the docs as being "unimplemented",
1230 yet always seems to be signaled with a VMS condition code of 4 (and
1231 correctly handled for that code). So we hardwire it in.
1233 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1234 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1235 than signalling with an unrecognized (and unhandled by CRTL) code.
1238 #define _MY_SIG_MAX 17
1241 Perl_sig_to_vmscondition(int sig)
1243 static unsigned int sig_code[_MY_SIG_MAX+1] =
1246 SS$_HANGUP, /* 1 SIGHUP */
1247 SS$_CONTROLC, /* 2 SIGINT */
1248 SS$_CONTROLY, /* 3 SIGQUIT */
1249 SS$_RADRMOD, /* 4 SIGILL */
1250 SS$_BREAK, /* 5 SIGTRAP */
1251 SS$_OPCCUS, /* 6 SIGABRT */
1252 SS$_COMPAT, /* 7 SIGEMT */
1254 SS$_FLTOVF, /* 8 SIGFPE VAX */
1256 SS$_HPARITH, /* 8 SIGFPE AXP */
1258 SS$_ABORT, /* 9 SIGKILL */
1259 SS$_ACCVIO, /* 10 SIGBUS */
1260 SS$_ACCVIO, /* 11 SIGSEGV */
1261 SS$_BADPARAM, /* 12 SIGSYS */
1262 SS$_NOMBX, /* 13 SIGPIPE */
1263 SS$_ASTFLT, /* 14 SIGALRM */
1269 #if __VMS_VER >= 60200000
1270 static int initted = 0;
1273 sig_code[16] = C$_SIGUSR1;
1274 sig_code[17] = C$_SIGUSR2;
1278 if (sig < _SIG_MIN) return 0;
1279 if (sig > _MY_SIG_MAX) return 0;
1280 return sig_code[sig];
1285 Perl_my_kill(int pid, int sig)
1290 int sys$sigprc(unsigned int *pidadr,
1291 struct dsc$descriptor_s *prcname,
1294 code = Perl_sig_to_vmscondition(sig);
1296 if (!pid || !code) {
1300 iss = sys$sigprc((unsigned int *)&pid,0,code);
1301 if (iss&1) return 0;
1305 set_errno(EPERM); break;
1307 case SS$_NOSUCHNODE:
1308 case SS$_UNREACHABLE:
1309 set_errno(ESRCH); break;
1311 set_errno(ENOMEM); break;
1316 set_vaxc_errno(iss);
1322 /* default piping mailbox size */
1323 #define PERL_BUFSIZ 512
1327 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1329 unsigned long int mbxbufsiz;
1330 static unsigned long int syssize = 0;
1331 unsigned long int dviitm = DVI$_DEVNAM;
1332 char csize[LNM$C_NAMLENGTH+1];
1335 unsigned long syiitm = SYI$_MAXBUF;
1337 * Get the SYSGEN parameter MAXBUF
1339 * If the logical 'PERL_MBX_SIZE' is defined
1340 * use the value of the logical instead of PERL_BUFSIZ, but
1341 * keep the size between 128 and MAXBUF.
1344 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1347 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1348 mbxbufsiz = atoi(csize);
1350 mbxbufsiz = PERL_BUFSIZ;
1352 if (mbxbufsiz < 128) mbxbufsiz = 128;
1353 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1355 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1357 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1358 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1360 } /* end of create_mbx() */
1363 /*{{{ my_popen and my_pclose*/
1365 typedef struct _iosb IOSB;
1366 typedef struct _iosb* pIOSB;
1367 typedef struct _pipe Pipe;
1368 typedef struct _pipe* pPipe;
1369 typedef struct pipe_details Info;
1370 typedef struct pipe_details* pInfo;
1371 typedef struct _srqp RQE;
1372 typedef struct _srqp* pRQE;
1373 typedef struct _tochildbuf CBuf;
1374 typedef struct _tochildbuf* pCBuf;
1377 unsigned short status;
1378 unsigned short count;
1379 unsigned long dvispec;
1382 #pragma member_alignment save
1383 #pragma nomember_alignment quadword
1384 struct _srqp { /* VMS self-relative queue entry */
1385 unsigned long qptr[2];
1387 #pragma member_alignment restore
1388 static RQE RQE_ZERO = {0,0};
1390 struct _tochildbuf {
1393 unsigned short size;
1401 unsigned short chan_in;
1402 unsigned short chan_out;
1404 unsigned int bufsize;
1416 #if defined(PERL_IMPLICIT_CONTEXT)
1417 void *thx; /* Either a thread or an interpreter */
1418 /* pointer, depending on how we're built */
1426 PerlIO *fp; /* file pointer to pipe mailbox */
1427 int useFILE; /* using stdio, not perlio */
1428 int pid; /* PID of subprocess */
1429 int mode; /* == 'r' if pipe open for reading */
1430 int done; /* subprocess has completed */
1431 int waiting; /* waiting for completion/closure */
1432 int closing; /* my_pclose is closing this pipe */
1433 unsigned long completion; /* termination status of subprocess */
1434 pPipe in; /* pipe in to sub */
1435 pPipe out; /* pipe out of sub */
1436 pPipe err; /* pipe of sub's sys$error */
1437 int in_done; /* true when in pipe finished */
1442 struct exit_control_block
1444 struct exit_control_block *flink;
1445 unsigned long int (*exit_routine)();
1446 unsigned long int arg_count;
1447 unsigned long int *status_address;
1448 unsigned long int exit_status;
1451 typedef struct _closed_pipes Xpipe;
1452 typedef struct _closed_pipes* pXpipe;
1454 struct _closed_pipes {
1455 int pid; /* PID of subprocess */
1456 unsigned long completion; /* termination status of subprocess */
1458 #define NKEEPCLOSED 50
1459 static Xpipe closed_list[NKEEPCLOSED];
1460 static int closed_index = 0;
1461 static int closed_num = 0;
1463 #define RETRY_DELAY "0 ::0.20"
1464 #define MAX_RETRY 50
1466 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1467 static unsigned long mypid;
1468 static unsigned long delaytime[2];
1470 static pInfo open_pipes = NULL;
1471 static $DESCRIPTOR(nl_desc, "NL:");
1473 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1477 static unsigned long int
1478 pipe_exit_routine(pTHX)
1481 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1482 int sts, did_stuff, need_eof, j;
1485 flush any pending i/o
1491 PerlIO_flush(info->fp); /* first, flush data */
1493 fflush((FILE *)info->fp);
1499 next we try sending an EOF...ignore if doesn't work, make sure we
1507 _ckvmssts(sys$setast(0));
1508 if (info->in && !info->in->shut_on_empty) {
1509 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1514 _ckvmssts(sys$setast(1));
1518 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1520 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1525 _ckvmssts(sys$setast(0));
1526 if (info->waiting && info->done)
1528 nwait += info->waiting;
1529 _ckvmssts(sys$setast(1));
1539 _ckvmssts(sys$setast(0));
1540 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1541 sts = sys$forcex(&info->pid,0,&abort);
1542 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1545 _ckvmssts(sys$setast(1));
1549 /* again, wait for effect */
1551 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1556 _ckvmssts(sys$setast(0));
1557 if (info->waiting && info->done)
1559 nwait += info->waiting;
1560 _ckvmssts(sys$setast(1));
1569 _ckvmssts(sys$setast(0));
1570 if (!info->done) { /* We tried to be nice . . . */
1571 sts = sys$delprc(&info->pid,0);
1572 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1574 _ckvmssts(sys$setast(1));
1579 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1580 else if (!(sts & 1)) retsts = sts;
1585 static struct exit_control_block pipe_exitblock =
1586 {(struct exit_control_block *) 0,
1587 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1589 static void pipe_mbxtofd_ast(pPipe p);
1590 static void pipe_tochild1_ast(pPipe p);
1591 static void pipe_tochild2_ast(pPipe p);
1594 popen_completion_ast(pInfo info)
1596 pInfo i = open_pipes;
1600 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1601 closed_list[closed_index].pid = info->pid;
1602 closed_list[closed_index].completion = info->completion;
1604 if (closed_index == NKEEPCLOSED)
1609 if (i == info) break;
1612 if (!i) return; /* unlinked, probably freed too */
1617 Writing to subprocess ...
1618 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1620 chan_out may be waiting for "done" flag, or hung waiting
1621 for i/o completion to child...cancel the i/o. This will
1622 put it into "snarf mode" (done but no EOF yet) that discards
1625 Output from subprocess (stdout, stderr) needs to be flushed and
1626 shut down. We try sending an EOF, but if the mbx is full the pipe
1627 routine should still catch the "shut_on_empty" flag, telling it to
1628 use immediate-style reads so that "mbx empty" -> EOF.
1632 if (info->in && !info->in_done) { /* only for mode=w */
1633 if (info->in->shut_on_empty && info->in->need_wake) {
1634 info->in->need_wake = FALSE;
1635 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1637 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1641 if (info->out && !info->out_done) { /* were we also piping output? */
1642 info->out->shut_on_empty = TRUE;
1643 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1644 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1645 _ckvmssts_noperl(iss);
1648 if (info->err && !info->err_done) { /* we were piping stderr */
1649 info->err->shut_on_empty = TRUE;
1650 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1651 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1652 _ckvmssts_noperl(iss);
1654 _ckvmssts_noperl(sys$setef(pipe_ef));
1658 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1659 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1662 we actually differ from vmstrnenv since we use this to
1663 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1664 are pointing to the same thing
1667 static unsigned short
1668 popen_translate(pTHX_ char *logical, char *result)
1671 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1672 $DESCRIPTOR(d_log,"");
1674 unsigned short length;
1675 unsigned short code;
1677 unsigned short *retlenaddr;
1679 unsigned short l, ifi;
1681 d_log.dsc$a_pointer = logical;
1682 d_log.dsc$w_length = strlen(logical);
1684 itmlst[0].code = LNM$_STRING;
1685 itmlst[0].length = 255;
1686 itmlst[0].buffer_addr = result;
1687 itmlst[0].retlenaddr = &l;
1690 itmlst[1].length = 0;
1691 itmlst[1].buffer_addr = 0;
1692 itmlst[1].retlenaddr = 0;
1694 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1695 if (iss == SS$_NOLOGNAM) {
1699 if (!(iss&1)) lib$signal(iss);
1702 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1703 strip it off and return the ifi, if any
1706 if (result[0] == 0x1b && result[1] == 0x00) {
1707 memcpy(&ifi,result+2,2);
1708 strcpy(result,result+4);
1710 return ifi; /* this is the RMS internal file id */
1713 static void pipe_infromchild_ast(pPipe p);
1716 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1717 inside an AST routine without worrying about reentrancy and which Perl
1718 memory allocator is being used.
1720 We read data and queue up the buffers, then spit them out one at a
1721 time to the output mailbox when the output mailbox is ready for one.
1724 #define INITIAL_TOCHILDQUEUE 2
1727 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1731 char mbx1[64], mbx2[64];
1732 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1733 DSC$K_CLASS_S, mbx1},
1734 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1735 DSC$K_CLASS_S, mbx2};
1736 unsigned int dviitm = DVI$_DEVBUFSIZ;
1739 New(1368, p, 1, Pipe);
1741 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1742 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1743 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1746 p->shut_on_empty = FALSE;
1747 p->need_wake = FALSE;
1750 p->iosb.status = SS$_NORMAL;
1751 p->iosb2.status = SS$_NORMAL;
1757 #ifdef PERL_IMPLICIT_CONTEXT
1761 n = sizeof(CBuf) + p->bufsize;
1763 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1764 _ckvmssts(lib$get_vm(&n, &b));
1765 b->buf = (char *) b + sizeof(CBuf);
1766 _ckvmssts(lib$insqhi(b, &p->free));
1769 pipe_tochild2_ast(p);
1770 pipe_tochild1_ast(p);
1776 /* reads the MBX Perl is writing, and queues */
1779 pipe_tochild1_ast(pPipe p)
1782 int iss = p->iosb.status;
1783 int eof = (iss == SS$_ENDOFFILE);
1784 #ifdef PERL_IMPLICIT_CONTEXT
1790 p->shut_on_empty = TRUE;
1792 _ckvmssts(sys$dassgn(p->chan_in));
1798 b->size = p->iosb.count;
1799 _ckvmssts(lib$insqhi(b, &p->wait));
1801 p->need_wake = FALSE;
1802 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1805 p->retry = 1; /* initial call */
1808 if (eof) { /* flush the free queue, return when done */
1809 int n = sizeof(CBuf) + p->bufsize;
1811 iss = lib$remqti(&p->free, &b);
1812 if (iss == LIB$_QUEWASEMP) return;
1814 _ckvmssts(lib$free_vm(&n, &b));
1818 iss = lib$remqti(&p->free, &b);
1819 if (iss == LIB$_QUEWASEMP) {
1820 int n = sizeof(CBuf) + p->bufsize;
1821 _ckvmssts(lib$get_vm(&n, &b));
1822 b->buf = (char *) b + sizeof(CBuf);
1828 iss = sys$qio(0,p->chan_in,
1829 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1831 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1832 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1837 /* writes queued buffers to output, waits for each to complete before
1841 pipe_tochild2_ast(pPipe p)
1844 int iss = p->iosb2.status;
1845 int n = sizeof(CBuf) + p->bufsize;
1846 int done = (p->info && p->info->done) ||
1847 iss == SS$_CANCEL || iss == SS$_ABORT;
1848 #if defined(PERL_IMPLICIT_CONTEXT)
1853 if (p->type) { /* type=1 has old buffer, dispose */
1854 if (p->shut_on_empty) {
1855 _ckvmssts(lib$free_vm(&n, &b));
1857 _ckvmssts(lib$insqhi(b, &p->free));
1862 iss = lib$remqti(&p->wait, &b);
1863 if (iss == LIB$_QUEWASEMP) {
1864 if (p->shut_on_empty) {
1866 _ckvmssts(sys$dassgn(p->chan_out));
1867 *p->pipe_done = TRUE;
1868 _ckvmssts(sys$setef(pipe_ef));
1870 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1871 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1875 p->need_wake = TRUE;
1885 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1886 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1888 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1889 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1898 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1901 char mbx1[64], mbx2[64];
1902 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1903 DSC$K_CLASS_S, mbx1},
1904 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1905 DSC$K_CLASS_S, mbx2};
1906 unsigned int dviitm = DVI$_DEVBUFSIZ;
1908 New(1367, p, 1, Pipe);
1909 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1910 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1912 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1913 New(1367, p->buf, p->bufsize, char);
1914 p->shut_on_empty = FALSE;
1917 p->iosb.status = SS$_NORMAL;
1918 #if defined(PERL_IMPLICIT_CONTEXT)
1921 pipe_infromchild_ast(p);
1929 pipe_infromchild_ast(pPipe p)
1931 int iss = p->iosb.status;
1932 int eof = (iss == SS$_ENDOFFILE);
1933 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1934 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1935 #if defined(PERL_IMPLICIT_CONTEXT)
1939 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1940 _ckvmssts(sys$dassgn(p->chan_out));
1945 input shutdown if EOF from self (done or shut_on_empty)
1946 output shutdown if closing flag set (my_pclose)
1947 send data/eof from child or eof from self
1948 otherwise, re-read (snarf of data from child)
1953 if (myeof && p->chan_in) { /* input shutdown */
1954 _ckvmssts(sys$dassgn(p->chan_in));
1959 if (myeof || kideof) { /* pass EOF to parent */
1960 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1961 pipe_infromchild_ast, p,
1964 } else if (eof) { /* eat EOF --- fall through to read*/
1966 } else { /* transmit data */
1967 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1968 pipe_infromchild_ast,p,
1969 p->buf, p->iosb.count, 0, 0, 0, 0));
1975 /* everything shut? flag as done */
1977 if (!p->chan_in && !p->chan_out) {
1978 *p->pipe_done = TRUE;
1979 _ckvmssts(sys$setef(pipe_ef));
1983 /* write completed (or read, if snarfing from child)
1984 if still have input active,
1985 queue read...immediate mode if shut_on_empty so we get EOF if empty
1987 check if Perl reading, generate EOFs as needed
1993 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1994 pipe_infromchild_ast,p,
1995 p->buf, p->bufsize, 0, 0, 0, 0);
1996 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1998 } else { /* send EOFs for extra reads */
1999 p->iosb.status = SS$_ENDOFFILE;
2000 p->iosb.dvispec = 0;
2001 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2003 pipe_infromchild_ast, p, 0, 0, 0, 0));
2009 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2013 unsigned long dviitm = DVI$_DEVBUFSIZ;
2015 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2016 DSC$K_CLASS_S, mbx};
2018 /* things like terminals and mbx's don't need this filter */
2019 if (fd && fstat(fd,&s) == 0) {
2020 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2021 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2022 DSC$K_CLASS_S, s.st_dev};
2024 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2025 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2026 strcpy(out, s.st_dev);
2031 New(1366, p, 1, Pipe);
2032 p->fd_out = dup(fd);
2033 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2034 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2035 New(1366, p->buf, p->bufsize+1, char);
2036 p->shut_on_empty = FALSE;
2041 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2042 pipe_mbxtofd_ast, p,
2043 p->buf, p->bufsize, 0, 0, 0, 0));
2049 pipe_mbxtofd_ast(pPipe p)
2051 int iss = p->iosb.status;
2052 int done = p->info->done;
2054 int eof = (iss == SS$_ENDOFFILE);
2055 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2056 int err = !(iss&1) && !eof;
2057 #if defined(PERL_IMPLICIT_CONTEXT)
2061 if (done && myeof) { /* end piping */
2063 sys$dassgn(p->chan_in);
2064 *p->pipe_done = TRUE;
2065 _ckvmssts(sys$setef(pipe_ef));
2069 if (!err && !eof) { /* good data to send to file */
2070 p->buf[p->iosb.count] = '\n';
2071 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2074 if (p->retry < MAX_RETRY) {
2075 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2085 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2086 pipe_mbxtofd_ast, p,
2087 p->buf, p->bufsize, 0, 0, 0, 0);
2088 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2093 typedef struct _pipeloc PLOC;
2094 typedef struct _pipeloc* pPLOC;
2098 char dir[NAM$C_MAXRSS+1];
2100 static pPLOC head_PLOC = 0;
2103 free_pipelocs(pTHX_ void *head)
2106 pPLOC *pHead = (pPLOC *)head;
2118 store_pipelocs(pTHX)
2127 char temp[NAM$C_MAXRSS+1];
2131 free_pipelocs(aTHX_ &head_PLOC);
2133 /* the . directory from @INC comes last */
2136 p->next = head_PLOC;
2138 strcpy(p->dir,"./");
2140 /* get the directory from $^X */
2142 #ifdef PERL_IMPLICIT_CONTEXT
2143 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2145 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2147 strcpy(temp, PL_origargv[0]);
2148 x = strrchr(temp,']');
2151 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2153 p->next = head_PLOC;
2155 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2156 p->dir[NAM$C_MAXRSS] = '\0';
2160 /* reverse order of @INC entries, skip "." since entered above */
2162 #ifdef PERL_IMPLICIT_CONTEXT
2165 if (PL_incgv) av = GvAVn(PL_incgv);
2167 for (i = 0; av && i <= AvFILL(av); i++) {
2168 dirsv = *av_fetch(av,i,TRUE);
2170 if (SvROK(dirsv)) continue;
2171 dir = SvPVx(dirsv,n_a);
2172 if (strcmp(dir,".") == 0) continue;
2173 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2177 p->next = head_PLOC;
2179 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2180 p->dir[NAM$C_MAXRSS] = '\0';
2183 /* most likely spot (ARCHLIB) put first in the list */
2186 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2188 p->next = head_PLOC;
2190 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2191 p->dir[NAM$C_MAXRSS] = '\0';
2200 static int vmspipe_file_status = 0;
2201 static char vmspipe_file[NAM$C_MAXRSS+1];
2203 /* already found? Check and use ... need read+execute permission */
2205 if (vmspipe_file_status == 1) {
2206 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2207 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2208 return vmspipe_file;
2210 vmspipe_file_status = 0;
2213 /* scan through stored @INC, $^X */
2215 if (vmspipe_file_status == 0) {
2216 char file[NAM$C_MAXRSS+1];
2217 pPLOC p = head_PLOC;
2220 strcpy(file, p->dir);
2221 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2222 file[NAM$C_MAXRSS] = '\0';
2225 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2227 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2228 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2229 vmspipe_file_status = 1;
2230 return vmspipe_file;
2233 vmspipe_file_status = -1; /* failed, use tempfiles */
2240 vmspipe_tempfile(pTHX)
2242 char file[NAM$C_MAXRSS+1];
2244 static int index = 0;
2247 /* create a tempfile */
2249 /* we can't go from W, shr=get to R, shr=get without
2250 an intermediate vulnerable state, so don't bother trying...
2252 and lib$spawn doesn't shr=put, so have to close the write
2254 So... match up the creation date/time and the FID to
2255 make sure we're dealing with the same file
2260 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2261 fp = fopen(file,"w");
2263 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2264 fp = fopen(file,"w");
2266 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2267 fp = fopen(file,"w");
2270 if (!fp) return 0; /* we're hosed */
2272 fprintf(fp,"$! 'f$verify(0)\n");
2273 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2274 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2275 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2276 fprintf(fp,"$ perl_on = \"set noon\"\n");
2277 fprintf(fp,"$ perl_exit = \"exit\"\n");
2278 fprintf(fp,"$ perl_del = \"delete\"\n");
2279 fprintf(fp,"$ pif = \"if\"\n");
2280 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2281 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2282 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2283 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2284 fprintf(fp,"$! --- build command line to get max possible length\n");
2285 fprintf(fp,"$c=perl_popen_cmd0\n");
2286 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2287 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2288 fprintf(fp,"$x=perl_popen_cmd3\n");
2289 fprintf(fp,"$c=c+x\n");
2290 fprintf(fp,"$! --- get rid of global symbols\n");
2291 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2292 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2293 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2294 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2295 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2296 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2297 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2298 fprintf(fp,"$ perl_on\n");
2299 fprintf(fp,"$ 'c\n");
2300 fprintf(fp,"$ perl_status = $STATUS\n");
2301 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2302 fprintf(fp,"$ perl_exit 'perl_status'\n");
2305 fgetname(fp, file, 1);
2306 fstat(fileno(fp), &s0);
2309 fp = fopen(file,"r","shr=get");
2311 fstat(fileno(fp), &s1);
2313 if (s0.st_ino[0] != s1.st_ino[0] ||
2314 s0.st_ino[1] != s1.st_ino[1] ||
2315 s0.st_ino[2] != s1.st_ino[2] ||
2316 s0.st_ctime != s1.st_ctime ) {
2327 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2329 static int handler_set_up = FALSE;
2330 unsigned long int sts, flags = CLI$M_NOWAIT;
2331 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2333 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2334 char in[512], out[512], err[512], mbx[512];
2336 char tfilebuf[NAM$C_MAXRSS+1];
2338 char cmd_sym_name[20];
2339 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2340 DSC$K_CLASS_S, symbol};
2341 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2343 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2344 DSC$K_CLASS_S, cmd_sym_name};
2345 struct dsc$descriptor_s *vmscmd;
2346 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2347 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2348 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2350 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2352 /* once-per-program initialization...
2353 note that the SETAST calls and the dual test of pipe_ef
2354 makes sure that only the FIRST thread through here does
2355 the initialization...all other threads wait until it's
2358 Yeah, uglier than a pthread call, it's got all the stuff inline
2359 rather than in a separate routine.
2363 _ckvmssts(sys$setast(0));
2365 unsigned long int pidcode = JPI$_PID;
2366 $DESCRIPTOR(d_delay, RETRY_DELAY);
2367 _ckvmssts(lib$get_ef(&pipe_ef));
2368 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2369 _ckvmssts(sys$bintim(&d_delay, delaytime));
2371 if (!handler_set_up) {
2372 _ckvmssts(sys$dclexh(&pipe_exitblock));
2373 handler_set_up = TRUE;
2375 _ckvmssts(sys$setast(1));
2378 /* see if we can find a VMSPIPE.COM */
2381 vmspipe = find_vmspipe(aTHX);
2383 strcpy(tfilebuf+1,vmspipe);
2384 } else { /* uh, oh...we're in tempfile hell */
2385 tpipe = vmspipe_tempfile(aTHX);
2386 if (!tpipe) { /* a fish popular in Boston */
2387 if (ckWARN(WARN_PIPE)) {
2388 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2392 fgetname(tpipe,tfilebuf+1,1);
2394 vmspipedsc.dsc$a_pointer = tfilebuf;
2395 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2397 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2400 case RMS$_FNF: case RMS$_DNF:
2401 set_errno(ENOENT); break;
2403 set_errno(ENOTDIR); break;
2405 set_errno(ENODEV); break;
2407 set_errno(EACCES); break;
2409 set_errno(EINVAL); break;
2410 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2411 set_errno(E2BIG); break;
2412 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2413 _ckvmssts(sts); /* fall through */
2414 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2417 set_vaxc_errno(sts);
2418 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2419 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2424 New(1301,info,1,Info);
2426 strcpy(mode,in_mode);
2429 info->completion = 0;
2430 info->closing = FALSE;
2437 info->in_done = TRUE;
2438 info->out_done = TRUE;
2439 info->err_done = TRUE;
2440 in[0] = out[0] = err[0] = '\0';
2442 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2446 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2451 if (*mode == 'r') { /* piping from subroutine */
2453 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2455 info->out->pipe_done = &info->out_done;
2456 info->out_done = FALSE;
2457 info->out->info = info;
2459 if (!info->useFILE) {
2460 info->fp = PerlIO_open(mbx, mode);
2462 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2463 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2466 if (!info->fp && info->out) {
2467 sys$cancel(info->out->chan_out);
2469 while (!info->out_done) {
2471 _ckvmssts(sys$setast(0));
2472 done = info->out_done;
2473 if (!done) _ckvmssts(sys$clref(pipe_ef));
2474 _ckvmssts(sys$setast(1));
2475 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2478 if (info->out->buf) Safefree(info->out->buf);
2479 Safefree(info->out);
2485 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2487 info->err->pipe_done = &info->err_done;
2488 info->err_done = FALSE;
2489 info->err->info = info;
2492 } else if (*mode == 'w') { /* piping to subroutine */
2494 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2496 info->out->pipe_done = &info->out_done;
2497 info->out_done = FALSE;
2498 info->out->info = info;
2501 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2503 info->err->pipe_done = &info->err_done;
2504 info->err_done = FALSE;
2505 info->err->info = info;
2508 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2509 if (!info->useFILE) {
2510 info->fp = PerlIO_open(mbx, mode);
2512 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2513 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2517 info->in->pipe_done = &info->in_done;
2518 info->in_done = FALSE;
2519 info->in->info = info;
2523 if (!info->fp && info->in) {
2525 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2526 0, 0, 0, 0, 0, 0, 0, 0));
2528 while (!info->in_done) {
2530 _ckvmssts(sys$setast(0));
2531 done = info->in_done;
2532 if (!done) _ckvmssts(sys$clref(pipe_ef));
2533 _ckvmssts(sys$setast(1));
2534 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2537 if (info->in->buf) Safefree(info->in->buf);
2545 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2546 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2548 info->out->pipe_done = &info->out_done;
2549 info->out_done = FALSE;
2550 info->out->info = info;
2553 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2555 info->err->pipe_done = &info->err_done;
2556 info->err_done = FALSE;
2557 info->err->info = info;
2561 symbol[MAX_DCL_SYMBOL] = '\0';
2563 strncpy(symbol, in, MAX_DCL_SYMBOL);
2564 d_symbol.dsc$w_length = strlen(symbol);
2565 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2567 strncpy(symbol, err, MAX_DCL_SYMBOL);
2568 d_symbol.dsc$w_length = strlen(symbol);
2569 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2571 strncpy(symbol, out, MAX_DCL_SYMBOL);
2572 d_symbol.dsc$w_length = strlen(symbol);
2573 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2575 p = vmscmd->dsc$a_pointer;
2576 while (*p && *p != '\n') p++;
2577 *p = '\0'; /* truncate on \n */
2578 p = vmscmd->dsc$a_pointer;
2579 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2580 if (*p == '$') p++; /* remove leading $ */
2581 while (*p == ' ' || *p == '\t') p++;
2583 for (j = 0; j < 4; j++) {
2584 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2585 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2587 strncpy(symbol, p, MAX_DCL_SYMBOL);
2588 d_symbol.dsc$w_length = strlen(symbol);
2589 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2591 if (strlen(p) > MAX_DCL_SYMBOL) {
2592 p += MAX_DCL_SYMBOL;
2597 _ckvmssts(sys$setast(0));
2598 info->next=open_pipes; /* prepend to list */
2600 _ckvmssts(sys$setast(1));
2601 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2602 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2603 * have SYS$COMMAND if we need it.
2605 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2606 0, &info->pid, &info->completion,
2607 0, popen_completion_ast,info,0,0,0));
2609 /* if we were using a tempfile, close it now */
2611 if (tpipe) fclose(tpipe);
2613 /* once the subprocess is spawned, it has copied the symbols and
2614 we can get rid of ours */
2616 for (j = 0; j < 4; j++) {
2617 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2618 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2619 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2621 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2622 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2623 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2624 vms_execfree(vmscmd);
2626 #ifdef PERL_IMPLICIT_CONTEXT
2629 PL_forkprocess = info->pid;
2634 _ckvmssts(sys$setast(0));
2636 if (!done) _ckvmssts(sys$clref(pipe_ef));
2637 _ckvmssts(sys$setast(1));
2638 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2640 *psts = info->completion;
2641 my_pclose(info->fp);
2646 } /* end of safe_popen */
2649 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2651 Perl_my_popen(pTHX_ char *cmd, char *mode)
2655 TAINT_PROPER("popen");
2656 PERL_FLUSHALL_FOR_CHILD;
2657 return safe_popen(aTHX_ cmd,mode,&sts);
2662 /*{{{ I32 my_pclose(PerlIO *fp)*/
2663 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2665 pInfo info, last = NULL;
2666 unsigned long int retsts;
2669 for (info = open_pipes; info != NULL; last = info, info = info->next)
2670 if (info->fp == fp) break;
2672 if (info == NULL) { /* no such pipe open */
2673 set_errno(ECHILD); /* quoth POSIX */
2674 set_vaxc_errno(SS$_NONEXPR);
2678 /* If we were writing to a subprocess, insure that someone reading from
2679 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2680 * produce an EOF record in the mailbox.
2682 * well, at least sometimes it *does*, so we have to watch out for
2683 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2687 PerlIO_flush(info->fp); /* first, flush data */
2689 fflush((FILE *)info->fp);
2692 _ckvmssts(sys$setast(0));
2693 info->closing = TRUE;
2694 done = info->done && info->in_done && info->out_done && info->err_done;
2695 /* hanging on write to Perl's input? cancel it */
2696 if (info->mode == 'r' && info->out && !info->out_done) {
2697 if (info->out->chan_out) {
2698 _ckvmssts(sys$cancel(info->out->chan_out));
2699 if (!info->out->chan_in) { /* EOF generation, need AST */
2700 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2704 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2705 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2707 _ckvmssts(sys$setast(1));
2710 PerlIO_close(info->fp);
2712 fclose((FILE *)info->fp);
2715 we have to wait until subprocess completes, but ALSO wait until all
2716 the i/o completes...otherwise we'll be freeing the "info" structure
2717 that the i/o ASTs could still be using...
2721 _ckvmssts(sys$setast(0));
2722 done = info->done && info->in_done && info->out_done && info->err_done;
2723 if (!done) _ckvmssts(sys$clref(pipe_ef));
2724 _ckvmssts(sys$setast(1));
2725 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2727 retsts = info->completion;
2729 /* remove from list of open pipes */
2730 _ckvmssts(sys$setast(0));
2731 if (last) last->next = info->next;
2732 else open_pipes = info->next;
2733 _ckvmssts(sys$setast(1));
2735 /* free buffers and structures */
2738 if (info->in->buf) Safefree(info->in->buf);
2742 if (info->out->buf) Safefree(info->out->buf);
2743 Safefree(info->out);
2746 if (info->err->buf) Safefree(info->err->buf);
2747 Safefree(info->err);
2753 } /* end of my_pclose() */
2755 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2756 /* Roll our own prototype because we want this regardless of whether
2757 * _VMS_WAIT is defined.
2759 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2761 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2762 created with popen(); otherwise partially emulate waitpid() unless
2763 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2764 Also check processes not considered by the CRTL waitpid().
2766 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2768 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2775 if (statusp) *statusp = 0;
2777 for (info = open_pipes; info != NULL; info = info->next)
2778 if (info->pid == pid) break;
2780 if (info != NULL) { /* we know about this child */
2781 while (!info->done) {
2782 _ckvmssts(sys$setast(0));
2784 if (!done) _ckvmssts(sys$clref(pipe_ef));
2785 _ckvmssts(sys$setast(1));
2786 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2789 if (statusp) *statusp = info->completion;
2793 /* child that already terminated? */
2795 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2796 if (closed_list[j].pid == pid) {
2797 if (statusp) *statusp = closed_list[j].completion;
2802 /* fall through if this child is not one of our own pipe children */
2804 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2806 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2807 * in 7.2 did we get a version that fills in the VMS completion
2808 * status as Perl has always tried to do.
2811 sts = __vms_waitpid( pid, statusp, flags );
2813 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2816 /* If the real waitpid tells us the child does not exist, we
2817 * fall through here to implement waiting for a child that
2818 * was created by some means other than exec() (say, spawned
2819 * from DCL) or to wait for a process that is not a subprocess
2820 * of the current process.
2823 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
2826 $DESCRIPTOR(intdsc,"0 00:00:01");
2827 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2828 unsigned long int pidcode = JPI$_PID, mypid;
2829 unsigned long int interval[2];
2830 unsigned int jpi_iosb[2];
2831 struct itmlst_3 jpilist[2] = {
2832 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2837 /* Sorry folks, we don't presently implement rooting around for
2838 the first child we can find, and we definitely don't want to
2839 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2845 /* Get the owner of the child so I can warn if it's not mine. If the
2846 * process doesn't exist or I don't have the privs to look at it,
2847 * I can go home early.
2849 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2850 if (sts & 1) sts = jpi_iosb[0];
2862 set_vaxc_errno(sts);
2866 if (ckWARN(WARN_EXEC)) {
2867 /* remind folks they are asking for non-standard waitpid behavior */
2868 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2869 if (ownerpid != mypid)
2870 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2871 "waitpid: process %x is not a child of process %x",
2875 /* simply check on it once a second until it's not there anymore. */
2877 _ckvmssts(sys$bintim(&intdsc,interval));
2878 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2879 _ckvmssts(sys$schdwk(0,0,interval,0));
2880 _ckvmssts(sys$hiber());
2882 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2887 } /* end of waitpid() */
2892 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2894 my_gconvert(double val, int ndig, int trail, char *buf)
2896 static char __gcvtbuf[DBL_DIG+1];
2899 loc = buf ? buf : __gcvtbuf;
2901 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2903 sprintf(loc,"%.*g",ndig,val);
2909 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2910 return gcvt(val,ndig,loc);
2913 loc[0] = '0'; loc[1] = '\0';
2921 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2922 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2923 * to expand file specification. Allows for a single default file
2924 * specification and a simple mask of options. If outbuf is non-NULL,
2925 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2926 * the resultant file specification is placed. If outbuf is NULL, the
2927 * resultant file specification is placed into a static buffer.
2928 * The third argument, if non-NULL, is taken to be a default file
2929 * specification string. The fourth argument is unused at present.
2930 * rmesexpand() returns the address of the resultant string if
2931 * successful, and NULL on error.
2933 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2936 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2938 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2939 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2940 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2941 struct FAB myfab = cc$rms_fab;
2942 struct NAM mynam = cc$rms_nam;
2944 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2946 if (!filespec || !*filespec) {
2947 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2951 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2952 else outbuf = __rmsexpand_retbuf;
2954 if ((isunix = (strchr(filespec,'/') != NULL))) {
2955 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2956 filespec = vmsfspec;
2959 myfab.fab$l_fna = filespec;
2960 myfab.fab$b_fns = strlen(filespec);
2961 myfab.fab$l_nam = &mynam;
2963 if (defspec && *defspec) {
2964 if (strchr(defspec,'/') != NULL) {
2965 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2968 myfab.fab$l_dna = defspec;
2969 myfab.fab$b_dns = strlen(defspec);
2972 mynam.nam$l_esa = esa;
2973 mynam.nam$b_ess = sizeof esa;
2974 mynam.nam$l_rsa = outbuf;
2975 mynam.nam$b_rss = NAM$C_MAXRSS;
2977 retsts = sys$parse(&myfab,0,0);
2978 if (!(retsts & 1)) {
2979 mynam.nam$b_nop |= NAM$M_SYNCHK;
2980 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2981 retsts = sys$parse(&myfab,0,0);
2982 if (retsts & 1) goto expanded;
2984 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2985 (void) sys$parse(&myfab,0,0); /* Free search context */
2986 if (out) Safefree(out);
2987 set_vaxc_errno(retsts);
2988 if (retsts == RMS$_PRV) set_errno(EACCES);
2989 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2990 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2991 else set_errno(EVMSERR);
2994 retsts = sys$search(&myfab,0,0);
2995 if (!(retsts & 1) && retsts != RMS$_FNF) {
2996 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2997 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2998 if (out) Safefree(out);
2999 set_vaxc_errno(retsts);
3000 if (retsts == RMS$_PRV) set_errno(EACCES);
3001 else set_errno(EVMSERR);
3005 /* If the input filespec contained any lowercase characters,
3006 * downcase the result for compatibility with Unix-minded code. */
3008 for (out = myfab.fab$l_fna; *out; out++)
3009 if (islower(*out)) { haslower = 1; break; }
3010 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3011 else { out = esa; speclen = mynam.nam$b_esl; }
3012 /* Trim off null fields added by $PARSE
3013 * If type > 1 char, must have been specified in original or default spec
3014 * (not true for version; $SEARCH may have added version of existing file).
3016 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3017 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3018 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3019 if (trimver || trimtype) {
3020 if (defspec && *defspec) {
3021 char defesa[NAM$C_MAXRSS];
3022 struct FAB deffab = cc$rms_fab;
3023 struct NAM defnam = cc$rms_nam;
3025 deffab.fab$l_nam = &defnam;
3026 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3027 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3028 defnam.nam$b_nop = NAM$M_SYNCHK;
3029 if (sys$parse(&deffab,0,0) & 1) {
3030 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3031 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3034 if (trimver) speclen = mynam.nam$l_ver - out;
3036 /* If we didn't already trim version, copy down */
3037 if (speclen > mynam.nam$l_ver - out)
3038 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3039 speclen - (mynam.nam$l_ver - out));
3040 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3043 /* If we just had a directory spec on input, $PARSE "helpfully"
3044 * adds an empty name and type for us */
3045 if (mynam.nam$l_name == mynam.nam$l_type &&
3046 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3047 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3048 speclen = mynam.nam$l_name - out;
3049 out[speclen] = '\0';
3050 if (haslower) __mystrtolower(out);
3052 /* Have we been working with an expanded, but not resultant, spec? */
3053 /* Also, convert back to Unix syntax if necessary. */
3054 if (!mynam.nam$b_rsl) {
3056 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3058 else strcpy(outbuf,esa);
3061 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3062 strcpy(outbuf,tmpfspec);
3064 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3065 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3066 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
3070 /* External entry points */
3071 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3072 { return do_rmsexpand(spec,buf,0,def,opt); }
3073 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3074 { return do_rmsexpand(spec,buf,1,def,opt); }
3078 ** The following routines are provided to make life easier when
3079 ** converting among VMS-style and Unix-style directory specifications.
3080 ** All will take input specifications in either VMS or Unix syntax. On
3081 ** failure, all return NULL. If successful, the routines listed below
3082 ** return a pointer to a buffer containing the appropriately
3083 ** reformatted spec (and, therefore, subsequent calls to that routine
3084 ** will clobber the result), while the routines of the same names with
3085 ** a _ts suffix appended will return a pointer to a mallocd string
3086 ** containing the appropriately reformatted spec.
3087 ** In all cases, only explicit syntax is altered; no check is made that
3088 ** the resulting string is valid or that the directory in question
3091 ** fileify_dirspec() - convert a directory spec into the name of the
3092 ** directory file (i.e. what you can stat() to see if it's a dir).
3093 ** The style (VMS or Unix) of the result is the same as the style
3094 ** of the parameter passed in.
3095 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3096 ** what you prepend to a filename to indicate what directory it's in).
3097 ** The style (VMS or Unix) of the result is the same as the style
3098 ** of the parameter passed in.
3099 ** tounixpath() - convert a directory spec into a Unix-style path.
3100 ** tovmspath() - convert a directory spec into a VMS-style path.
3101 ** tounixspec() - convert any file spec into a Unix-style file spec.
3102 ** tovmsspec() - convert any file spec into a VMS-style spec.
3104 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3105 ** Permission is given to distribute this code as part of the Perl
3106 ** standard distribution under the terms of the GNU General Public
3107 ** License or the Perl Artistic License. Copies of each may be
3108 ** found in the Perl standard distribution.
3111 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3112 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3114 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3115 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3116 char *retspec, *cp1, *cp2, *lastdir;
3117 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3118 unsigned short int trnlnm_iter_count;
3120 if (!dir || !*dir) {
3121 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3123 dirlen = strlen(dir);
3124 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3125 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3126 strcpy(trndir,"/sys$disk/000000");
3130 if (dirlen > NAM$C_MAXRSS) {
3131 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3133 if (!strpbrk(dir+1,"/]>:")) {
3134 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3135 trnlnm_iter_count = 0;
3136 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3137 trnlnm_iter_count++;
3138 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3141 dirlen = strlen(dir);
3144 strncpy(trndir,dir,dirlen);
3145 trndir[dirlen] = '\0';
3148 /* If we were handed a rooted logical name or spec, treat it like a
3149 * simple directory, so that
3150 * $ Define myroot dev:[dir.]
3151 * ... do_fileify_dirspec("myroot",buf,1) ...
3152 * does something useful.
3154 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3155 dir[--dirlen] = '\0';
3156 dir[dirlen-1] = ']';
3158 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3159 dir[--dirlen] = '\0';
3160 dir[dirlen-1] = '>';
3163 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3164 /* If we've got an explicit filename, we can just shuffle the string. */
3165 if (*(cp1+1)) hasfilename = 1;
3166 /* Similarly, we can just back up a level if we've got multiple levels
3167 of explicit directories in a VMS spec which ends with directories. */
3169 for (cp2 = cp1; cp2 > dir; cp2--) {
3171 *cp2 = *cp1; *cp1 = '\0';
3175 if (*cp2 == '[' || *cp2 == '<') break;
3180 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3181 if (dir[0] == '.') {
3182 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3183 return do_fileify_dirspec("[]",buf,ts);
3184 else if (dir[1] == '.' &&
3185 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3186 return do_fileify_dirspec("[-]",buf,ts);
3188 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3189 dirlen -= 1; /* to last element */
3190 lastdir = strrchr(dir,'/');
3192 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3193 /* If we have "/." or "/..", VMSify it and let the VMS code
3194 * below expand it, rather than repeating the code to handle
3195 * relative components of a filespec here */
3197 if (*(cp1+2) == '.') cp1++;
3198 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3199 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3200 if (strchr(vmsdir,'/') != NULL) {
3201 /* If do_tovmsspec() returned it, it must have VMS syntax
3202 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3203 * the time to check this here only so we avoid a recursion
3204 * loop; otherwise, gigo.
3206 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3208 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3209 return do_tounixspec(trndir,buf,ts);
3212 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3213 lastdir = strrchr(dir,'/');
3215 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3216 /* Ditto for specs that end in an MFD -- let the VMS code
3217 * figure out whether it's a real device or a rooted logical. */
3218 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3219 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3220 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3221 return do_tounixspec(trndir,buf,ts);
3224 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3225 !(lastdir = cp1 = strrchr(dir,']')) &&
3226 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3227 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3229 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3230 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3231 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3232 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3233 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3234 (ver || *cp3)))))) {
3236 set_vaxc_errno(RMS$_DIR);
3242 /* If we lead off with a device or rooted logical, add the MFD
3243 if we're specifying a top-level directory. */
3244 if (lastdir && *dir == '/') {
3246 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3253 retlen = dirlen + (addmfd ? 13 : 6);
3254 if (buf) retspec = buf;
3255 else if (ts) New(1309,retspec,retlen+1,char);
3256 else retspec = __fileify_retbuf;
3258 dirlen = lastdir - dir;
3259 memcpy(retspec,dir,dirlen);
3260 strcpy(&retspec[dirlen],"/000000");
3261 strcpy(&retspec[dirlen+7],lastdir);
3264 memcpy(retspec,dir,dirlen);
3265 retspec[dirlen] = '\0';
3267 /* We've picked up everything up to the directory file name.
3268 Now just add the type and version, and we're set. */
3269 strcat(retspec,".dir;1");
3272 else { /* VMS-style directory spec */
3273 char esa[NAM$C_MAXRSS+1], term, *cp;
3274 unsigned long int sts, cmplen, haslower = 0;
3275 struct FAB dirfab = cc$rms_fab;
3276 struct NAM savnam, dirnam = cc$rms_nam;
3278 dirfab.fab$b_fns = strlen(dir);
3279 dirfab.fab$l_fna = dir;
3280 dirfab.fab$l_nam = &dirnam;
3281 dirfab.fab$l_dna = ".DIR;1";
3282 dirfab.fab$b_dns = 6;
3283 dirnam.nam$b_ess = NAM$C_MAXRSS;
3284 dirnam.nam$l_esa = esa;
3286 for (cp = dir; *cp; cp++)
3287 if (islower(*cp)) { haslower = 1; break; }
3288 if (!((sts = sys$parse(&dirfab))&1)) {
3289 if (dirfab.fab$l_sts == RMS$_DIR) {
3290 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3291 sts = sys$parse(&dirfab) & 1;
3295 set_vaxc_errno(dirfab.fab$l_sts);
3301 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3302 /* Yes; fake the fnb bits so we'll check type below */
3303 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3305 else { /* No; just work with potential name */
3306 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3308 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3309 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3310 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3315 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3316 cp1 = strchr(esa,']');
3317 if (!cp1) cp1 = strchr(esa,'>');
3318 if (cp1) { /* Should always be true */
3319 dirnam.nam$b_esl -= cp1 - esa - 1;
3320 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3323 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3324 /* Yep; check version while we're at it, if it's there. */
3325 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3326 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3327 /* Something other than .DIR[;1]. Bzzt. */
3328 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3329 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3331 set_vaxc_errno(RMS$_DIR);
3335 esa[dirnam.nam$b_esl] = '\0';
3336 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3337 /* They provided at least the name; we added the type, if necessary, */
3338 if (buf) retspec = buf; /* in sys$parse() */
3339 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3340 else retspec = __fileify_retbuf;
3341 strcpy(retspec,esa);
3342 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3343 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3346 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3347 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3349 dirnam.nam$b_esl -= 9;
3351 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3352 if (cp1 == NULL) { /* should never happen */
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);
3359 retlen = strlen(esa);
3360 if ((cp1 = strrchr(esa,'.')) != NULL) {
3361 /* There's more than one directory in the path. Just roll back. */
3363 if (buf) retspec = buf;
3364 else if (ts) New(1311,retspec,retlen+7,char);
3365 else retspec = __fileify_retbuf;
3366 strcpy(retspec,esa);
3369 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3370 /* Go back and expand rooted logical name */
3371 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3372 if (!(sys$parse(&dirfab) & 1)) {
3373 dirnam.nam$l_rlf = NULL;
3374 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3376 set_vaxc_errno(dirfab.fab$l_sts);
3379 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3380 if (buf) retspec = buf;
3381 else if (ts) New(1312,retspec,retlen+16,char);
3382 else retspec = __fileify_retbuf;
3383 cp1 = strstr(esa,"][");
3384 if (!cp1) cp1 = strstr(esa,"]<");
3386 memcpy(retspec,esa,dirlen);
3387 if (!strncmp(cp1+2,"000000]",7)) {
3388 retspec[dirlen-1] = '\0';
3389 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3390 if (*cp1 == '.') *cp1 = ']';
3392 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3393 memcpy(cp1+1,"000000]",7);
3397 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3398 retspec[retlen] = '\0';
3399 /* Convert last '.' to ']' */
3400 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3401 if (*cp1 == '.') *cp1 = ']';
3403 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3404 memcpy(cp1+1,"000000]",7);
3408 else { /* This is a top-level dir. Add the MFD to the path. */
3409 if (buf) retspec = buf;
3410 else if (ts) New(1312,retspec,retlen+16,char);
3411 else retspec = __fileify_retbuf;
3414 while (*cp1 != ':') *(cp2++) = *(cp1++);
3415 strcpy(cp2,":[000000]");
3420 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3421 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3422 /* We've set up the string up through the filename. Add the
3423 type and version, and we're done. */
3424 strcat(retspec,".DIR;1");
3426 /* $PARSE may have upcased filespec, so convert output to lower
3427 * case if input contained any lowercase characters. */
3428 if (haslower) __mystrtolower(retspec);
3431 } /* end of do_fileify_dirspec() */
3433 /* External entry points */
3434 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3435 { return do_fileify_dirspec(dir,buf,0); }
3436 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3437 { return do_fileify_dirspec(dir,buf,1); }
3439 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3440 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3442 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3443 unsigned long int retlen;
3444 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3445 unsigned short int trnlnm_iter_count;
3448 if (!dir || !*dir) {
3449 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3452 if (*dir) strcpy(trndir,dir);
3453 else getcwd(trndir,sizeof trndir - 1);
3455 trnlnm_iter_count = 0;
3456 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3457 && my_trnlnm(trndir,trndir,0)) {
3458 trnlnm_iter_count++;
3459 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3460 trnlen = strlen(trndir);
3462 /* Trap simple rooted lnms, and return lnm:[000000] */
3463 if (!strcmp(trndir+trnlen-2,".]")) {
3464 if (buf) retpath = buf;
3465 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3466 else retpath = __pathify_retbuf;
3467 strcpy(retpath,dir);
3468 strcat(retpath,":[000000]");
3474 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3475 if (*dir == '.' && (*(dir+1) == '\0' ||
3476 (*(dir+1) == '.' && *(dir+2) == '\0')))
3477 retlen = 2 + (*(dir+1) != '\0');
3479 if ( !(cp1 = strrchr(dir,'/')) &&
3480 !(cp1 = strrchr(dir,']')) &&
3481 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3482 if ((cp2 = strchr(cp1,'.')) != NULL &&
3483 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3484 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3485 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3486 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3488 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3489 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3490 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3491 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3492 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3493 (ver || *cp3)))))) {
3495 set_vaxc_errno(RMS$_DIR);
3498 retlen = cp2 - dir + 1;
3500 else { /* No file type present. Treat the filename as a directory. */
3501 retlen = strlen(dir) + 1;
3504 if (buf) retpath = buf;
3505 else if (ts) New(1313,retpath,retlen+1,char);
3506 else retpath = __pathify_retbuf;
3507 strncpy(retpath,dir,retlen-1);
3508 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3509 retpath[retlen-1] = '/'; /* with '/', add it. */
3510 retpath[retlen] = '\0';
3512 else retpath[retlen-1] = '\0';
3514 else { /* VMS-style directory spec */
3515 char esa[NAM$C_MAXRSS+1], *cp;
3516 unsigned long int sts, cmplen, haslower;
3517 struct FAB dirfab = cc$rms_fab;
3518 struct NAM savnam, dirnam = cc$rms_nam;
3520 /* If we've got an explicit filename, we can just shuffle the string. */
3521 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3522 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3523 if ((cp2 = strchr(cp1,'.')) != NULL) {
3525 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3526 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3527 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3528 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3529 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3530 (ver || *cp3)))))) {
3532 set_vaxc_errno(RMS$_DIR);
3536 else { /* No file type, so just draw name into directory part */
3537 for (cp2 = cp1; *cp2; cp2++) ;
3540 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3542 /* We've now got a VMS 'path'; fall through */
3544 dirfab.fab$b_fns = strlen(dir);
3545 dirfab.fab$l_fna = dir;
3546 if (dir[dirfab.fab$b_fns-1] == ']' ||
3547 dir[dirfab.fab$b_fns-1] == '>' ||
3548 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3549 if (buf) retpath = buf;
3550 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3551 else retpath = __pathify_retbuf;
3552 strcpy(retpath,dir);
3555 dirfab.fab$l_dna = ".DIR;1";
3556 dirfab.fab$b_dns = 6;
3557 dirfab.fab$l_nam = &dirnam;
3558 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3559 dirnam.nam$l_esa = esa;
3561 for (cp = dir; *cp; cp++)
3562 if (islower(*cp)) { haslower = 1; break; }
3564 if (!(sts = (sys$parse(&dirfab)&1))) {
3565 if (dirfab.fab$l_sts == RMS$_DIR) {
3566 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3567 sts = sys$parse(&dirfab) & 1;
3571 set_vaxc_errno(dirfab.fab$l_sts);
3577 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3578 if (dirfab.fab$l_sts != RMS$_FNF) {
3579 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3580 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3582 set_vaxc_errno(dirfab.fab$l_sts);
3585 dirnam = savnam; /* No; just work with potential name */
3588 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3589 /* Yep; check version while we're at it, if it's there. */
3590 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3591 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3592 /* Something other than .DIR[;1]. Bzzt. */
3593 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3594 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3596 set_vaxc_errno(RMS$_DIR);
3600 /* OK, the type was fine. Now pull any file name into the
3602 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3604 cp1 = strrchr(esa,'>');
3605 *dirnam.nam$l_type = '>';
3608 *(dirnam.nam$l_type + 1) = '\0';
3609 retlen = dirnam.nam$l_type - esa + 2;
3610 if (buf) retpath = buf;
3611 else if (ts) New(1314,retpath,retlen,char);
3612 else retpath = __pathify_retbuf;
3613 strcpy(retpath,esa);
3614 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3615 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3616 /* $PARSE may have upcased filespec, so convert output to lower
3617 * case if input contained any lowercase characters. */
3618 if (haslower) __mystrtolower(retpath);
3622 } /* end of do_pathify_dirspec() */
3624 /* External entry points */
3625 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3626 { return do_pathify_dirspec(dir,buf,0); }
3627 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3628 { return do_pathify_dirspec(dir,buf,1); }
3630 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3631 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3633 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3634 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3635 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3636 unsigned short int trnlnm_iter_count;
3638 if (spec == NULL) return NULL;
3639 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3640 if (buf) rslt = buf;
3642 retlen = strlen(spec);
3643 cp1 = strchr(spec,'[');
3644 if (!cp1) cp1 = strchr(spec,'<');
3646 for (cp1++; *cp1; cp1++) {
3647 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3648 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3649 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3652 New(1315,rslt,retlen+2+2*expand,char);
3654 else rslt = __tounixspec_retbuf;
3655 if (strchr(spec,'/') != NULL) {
3662 dirend = strrchr(spec,']');
3663 if (dirend == NULL) dirend = strrchr(spec,'>');
3664 if (dirend == NULL) dirend = strchr(spec,':');
3665 if (dirend == NULL) {
3669 if (*cp2 != '[' && *cp2 != '<') {
3672 else { /* the VMS spec begins with directories */
3674 if (*cp2 == ']' || *cp2 == '>') {
3675 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3678 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3679 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3680 if (ts) Safefree(rslt);
3683 trnlnm_iter_count = 0;
3686 while (*cp3 != ':' && *cp3) cp3++;
3688 if (strchr(cp3,']') != NULL) break;
3689 trnlnm_iter_count++;
3690 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3691 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3693 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3694 retlen = devlen + dirlen;
3695 Renew(rslt,retlen+1+2*expand,char);
3701 *(cp1++) = *(cp3++);
3702 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3706 else if ( *cp2 == '.') {
3707 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3708 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3714 for (; cp2 <= dirend; cp2++) {
3717 if (*(cp2+1) == '[') cp2++;
3719 else if (*cp2 == ']' || *cp2 == '>') {
3720 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3722 else if (*cp2 == '.') {
3724 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3725 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3726 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3727 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3728 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3730 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3731 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3735 else if (*cp2 == '-') {
3736 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3737 while (*cp2 == '-') {
3739 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3741 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3742 if (ts) Safefree(rslt); /* filespecs like */
3743 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3747 else *(cp1++) = *cp2;
3749 else *(cp1++) = *cp2;
3751 while (*cp2) *(cp1++) = *(cp2++);
3756 } /* end of do_tounixspec() */
3758 /* External entry points */
3759 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3760 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3762 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3763 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3764 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3765 char *rslt, *dirend;
3766 register char *cp1, *cp2;
3767 unsigned long int infront = 0, hasdir = 1;
3769 if (path == NULL) return NULL;
3770 if (buf) rslt = buf;
3771 else if (ts) New(1316,rslt,strlen(path)+9,char);
3772 else rslt = __tovmsspec_retbuf;
3773 if (strpbrk(path,"]:>") ||
3774 (dirend = strrchr(path,'/')) == NULL) {
3775 if (path[0] == '.') {
3776 if (path[1] == '\0') strcpy(rslt,"[]");
3777 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3778 else strcpy(rslt,path); /* probably garbage */
3780 else strcpy(rslt,path);
3783 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3784 if (!*(dirend+2)) dirend +=2;
3785 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3786 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3791 char trndev[NAM$C_MAXRSS+1];
3795 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3797 if (!buf & ts) Renew(rslt,18,char);
3798 strcpy(rslt,"sys$disk:[000000]");
3801 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3803 islnm = my_trnlnm(rslt,trndev,0);
3804 trnend = islnm ? strlen(trndev) - 1 : 0;
3805 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3806 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3807 /* If the first element of the path is a logical name, determine
3808 * whether it has to be translated so we can add more directories. */
3809 if (!islnm || rooted) {
3812 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3816 if (cp2 != dirend) {
3817 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3818 strcpy(rslt,trndev);
3819 cp1 = rslt + trnend;
3832 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3833 cp2 += 2; /* skip over "./" - it's redundant */
3834 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3836 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3837 *(cp1++) = '-'; /* "../" --> "-" */
3840 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3841 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3842 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3843 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3846 if (cp2 > dirend) cp2 = dirend;
3848 else *(cp1++) = '.';
3850 for (; cp2 < dirend; cp2++) {
3852 if (*(cp2-1) == '/') continue;
3853 if (*(cp1-1) != '.') *(cp1++) = '.';
3856 else if (!infront && *cp2 == '.') {
3857 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3858 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3859 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3860 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3861 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3862 else { /* back up over previous directory name */
3864 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3865 if (*(cp1-1) == '[') {
3866 memcpy(cp1,"000000.",7);
3871 if (cp2 == dirend) break;
3873 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3874 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3875 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3876 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3878 *(cp1++) = '.'; /* Simulate trailing '/' */
3879 cp2 += 2; /* for loop will incr this to == dirend */
3881 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3883 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3886 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3887 if (*cp2 == '.') *(cp1++) = '_';
3888 else *(cp1++) = *cp2;
3892 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3893 if (hasdir) *(cp1++) = ']';
3894 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3895 while (*cp2) *(cp1++) = *(cp2++);
3900 } /* end of do_tovmsspec() */
3902 /* External entry points */
3903 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3904 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3906 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3907 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3908 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3910 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3912 if (path == NULL) return NULL;
3913 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3914 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3915 if (buf) return buf;
3917 vmslen = strlen(vmsified);
3918 New(1317,cp,vmslen+1,char);
3919 memcpy(cp,vmsified,vmslen);
3924 strcpy(__tovmspath_retbuf,vmsified);
3925 return __tovmspath_retbuf;
3928 } /* end of do_tovmspath() */
3930 /* External entry points */
3931 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3932 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3935 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3936 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3937 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3939 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3941 if (path == NULL) return NULL;
3942 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3943 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3944 if (buf) return buf;
3946 unixlen = strlen(unixified);
3947 New(1317,cp,unixlen+1,char);
3948 memcpy(cp,unixified,unixlen);
3953 strcpy(__tounixpath_retbuf,unixified);
3954 return __tounixpath_retbuf;
3957 } /* end of do_tounixpath() */
3959 /* External entry points */
3960 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3961 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3964 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3966 *****************************************************************************
3968 * Copyright (C) 1989-1994 by *
3969 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3971 * Permission is hereby granted for the reproduction of this software, *
3972 * on condition that this copyright notice is included in the reproduction, *
3973 * and that such reproduction is not for purposes of profit or material *
3976 * 27-Aug-1994 Modified for inclusion in perl5 *
3977 * by Charles Bailey bailey@newman.upenn.edu *
3978 *****************************************************************************
3982 * getredirection() is intended to aid in porting C programs
3983 * to VMS (Vax-11 C). The native VMS environment does not support
3984 * '>' and '<' I/O redirection, or command line wild card expansion,
3985 * or a command line pipe mechanism using the '|' AND background
3986 * command execution '&'. All of these capabilities are provided to any
3987 * C program which calls this procedure as the first thing in the
3989 * The piping mechanism will probably work with almost any 'filter' type
3990 * of program. With suitable modification, it may useful for other
3991 * portability problems as well.
3993 * Author: Mark Pizzolato mark@infocomm.com
3997 struct list_item *next;
4001 static void add_item(struct list_item **head,
4002 struct list_item **tail,
4006 static void mp_expand_wild_cards(pTHX_ char *item,
4007 struct list_item **head,
4008 struct list_item **tail,
4011 static int background_process(pTHX_ int argc, char **argv);
4013 static void pipe_and_fork(pTHX_ char **cmargv);
4015 /*{{{ void getredirection(int *ac, char ***av)*/
4017 mp_getredirection(pTHX_ int *ac, char ***av)
4019 * Process vms redirection arg's. Exit if any error is seen.
4020 * If getredirection() processes an argument, it is erased
4021 * from the vector. getredirection() returns a new argc and argv value.
4022 * In the event that a background command is requested (by a trailing "&"),
4023 * this routine creates a background subprocess, and simply exits the program.
4025 * Warning: do not try to simplify the code for vms. The code
4026 * presupposes that getredirection() is called before any data is
4027 * read from stdin or written to stdout.
4029 * Normal usage is as follows:
4035 * getredirection(&argc, &argv);
4039 int argc = *ac; /* Argument Count */
4040 char **argv = *av; /* Argument Vector */
4041 char *ap; /* Argument pointer */
4042 int j; /* argv[] index */
4043 int item_count = 0; /* Count of Items in List */
4044 struct list_item *list_head = 0; /* First Item in List */
4045 struct list_item *list_tail; /* Last Item in List */
4046 char *in = NULL; /* Input File Name */
4047 char *out = NULL; /* Output File Name */
4048 char *outmode = "w"; /* Mode to Open Output File */
4049 char *err = NULL; /* Error File Name */
4050 char *errmode = "w"; /* Mode to Open Error File */
4051 int cmargc = 0; /* Piped Command Arg Count */
4052 char **cmargv = NULL;/* Piped Command Arg Vector */
4055 * First handle the case where the last thing on the line ends with
4056 * a '&'. This indicates the desire for the command to be run in a
4057 * subprocess, so we satisfy that desire.
4060 if (0 == strcmp("&", ap))
4061 exit(background_process(aTHX_ --argc, argv));
4062 if (*ap && '&' == ap[strlen(ap)-1])
4064 ap[strlen(ap)-1] = '\0';
4065 exit(background_process(aTHX_ argc, argv));
4068 * Now we handle the general redirection cases that involve '>', '>>',
4069 * '<', and pipes '|'.
4071 for (j = 0; j < argc; ++j)
4073 if (0 == strcmp("<", argv[j]))
4077 fprintf(stderr,"No input file after < on command line");
4078 exit(LIB$_WRONUMARG);
4083 if ('<' == *(ap = argv[j]))
4088 if (0 == strcmp(">", ap))
4092 fprintf(stderr,"No output file after > on command line");
4093 exit(LIB$_WRONUMARG);
4112 fprintf(stderr,"No output file after > or >> on command line");
4113 exit(LIB$_WRONUMARG);
4117 if (('2' == *ap) && ('>' == ap[1]))
4134 fprintf(stderr,"No output file after 2> or 2>> on command line");
4135 exit(LIB$_WRONUMARG);
4139 if (0 == strcmp("|", argv[j]))
4143 fprintf(stderr,"No command into which to pipe on command line");
4144 exit(LIB$_WRONUMARG);
4146 cmargc = argc-(j+1);
4147 cmargv = &argv[j+1];
4151 if ('|' == *(ap = argv[j]))
4159 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4162 * Allocate and fill in the new argument vector, Some Unix's terminate
4163 * the list with an extra null pointer.
4165 New(1302, argv, item_count+1, char *);
4167 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4168 argv[j] = list_head->value;
4174 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4175 exit(LIB$_INVARGORD);
4177 pipe_and_fork(aTHX_ cmargv);
4180 /* Check for input from a pipe (mailbox) */
4182 if (in == NULL && 1 == isapipe(0))
4184 char mbxname[L_tmpnam];
4186 long int dvi_item = DVI$_DEVBUFSIZ;
4187 $DESCRIPTOR(mbxnam, "");
4188 $DESCRIPTOR(mbxdevnam, "");
4190 /* Input from a pipe, reopen it in binary mode to disable */
4191 /* carriage control processing. */
4193 fgetname(stdin, mbxname);
4194 mbxnam.dsc$a_pointer = mbxname;
4195 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4196 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4197 mbxdevnam.dsc$a_pointer = mbxname;
4198 mbxdevnam.dsc$w_length = sizeof(mbxname);
4199 dvi_item = DVI$_DEVNAM;
4200 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4201 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4204 freopen(mbxname, "rb", stdin);
4207 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4211 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4213 fprintf(stderr,"Can't open input file %s as stdin",in);
4216 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4218 fprintf(stderr,"Can't open output file %s as stdout",out);
4221 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4224 if (strcmp(err,"&1") == 0) {
4225 dup2(fileno(stdout), fileno(stderr));
4226 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4229 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4231 fprintf(stderr,"Can't open error file %s as stderr",err);
4235 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4239 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4242 #ifdef ARGPROC_DEBUG
4243 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4244 for (j = 0; j < *ac; ++j)
4245 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4247 /* Clear errors we may have hit expanding wildcards, so they don't
4248 show up in Perl's $! later */
4249 set_errno(0); set_vaxc_errno(1);
4250 } /* end of getredirection() */
4253 static void add_item(struct list_item **head,
4254 struct list_item **tail,
4260 New(1303,*head,1,struct list_item);
4264 New(1304,(*tail)->next,1,struct list_item);
4265 *tail = (*tail)->next;
4267 (*tail)->value = value;
4271 static void mp_expand_wild_cards(pTHX_ char *item,
4272 struct list_item **head,
4273 struct list_item **tail,
4277 unsigned long int context = 0;
4284 char vmsspec[NAM$C_MAXRSS+1];
4285 $DESCRIPTOR(filespec, "");
4286 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4287 $DESCRIPTOR(resultspec, "");
4288 unsigned long int zero = 0, sts;
4290 for (cp = item; *cp; cp++) {
4291 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4292 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4294 if (!*cp || isspace(*cp))
4296 add_item(head, tail, item, count);
4301 /* "double quoted" wild card expressions pass as is */
4302 /* From DCL that means using e.g.: */
4303 /* perl program """perl.*""" */
4304 item_len = strlen(item);
4305 if ( '"' == *item && '"' == item[item_len-1] )
4308 item[item_len-2] = '\0';
4309 add_item(head, tail, item, count);
4313 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4314 resultspec.dsc$b_class = DSC$K_CLASS_D;
4315 resultspec.dsc$a_pointer = NULL;
4316 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4317 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4318 if (!isunix || !filespec.dsc$a_pointer)
4319 filespec.dsc$a_pointer = item;
4320 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4322 * Only return version specs, if the caller specified a version
4324 had_version = strchr(item, ';');
4326 * Only return device and directory specs, if the caller specifed either.
4328 had_device = strchr(item, ':');
4329 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4331 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4332 &defaultspec, 0, 0, &zero))))
4337 New(1305,string,resultspec.dsc$w_length+1,char);
4338 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4339 string[resultspec.dsc$w_length] = '\0';
4340 if (NULL == had_version)
4341 *((char *)strrchr(string, ';')) = '\0';
4342 if ((!had_directory) && (had_device == NULL))
4344 if (NULL == (devdir = strrchr(string, ']')))
4345 devdir = strrchr(string, '>');
4346 strcpy(string, devdir + 1);
4349 * Be consistent with what the C RTL has already done to the rest of
4350 * the argv items and lowercase all of these names.
4352 for (c = string; *c; ++c)
4355 if (isunix) trim_unixpath(string,item,1);
4356 add_item(head, tail, string, count);
4359 if (sts != RMS$_NMF)
4361 set_vaxc_errno(sts);
4364 case RMS$_FNF: case RMS$_DNF:
4365 set_errno(ENOENT); break;
4367 set_errno(ENOTDIR); break;
4369 set_errno(ENODEV); break;
4370 case RMS$_FNM: case RMS$_SYN:
4371 set_errno(EINVAL); break;
4373 set_errno(EACCES); break;
4375 _ckvmssts_noperl(sts);
4379 add_item(head, tail, item, count);
4380 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4381 _ckvmssts_noperl(lib$find_file_end(&context));
4384 static int child_st[2];/* Event Flag set when child process completes */
4386 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4388 static unsigned long int exit_handler(int *status)
4392 if (0 == child_st[0])
4394 #ifdef ARGPROC_DEBUG
4395 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4397 fflush(stdout); /* Have to flush pipe for binary data to */
4398 /* terminate properly -- <tp@mccall.com> */
4399 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4400 sys$dassgn(child_chan);
4402 sys$synch(0, child_st);
4407 static void sig_child(int chan)
4409 #ifdef ARGPROC_DEBUG
4410 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4412 if (child_st[0] == 0)
4416 static struct exit_control_block exit_block =
4421 &exit_block.exit_status,
4426 pipe_and_fork(pTHX_ char **cmargv)
4429 struct dsc$descriptor_s *vmscmd;
4430 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4431 int sts, j, l, ismcr, quote, tquote = 0;
4433 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4434 vms_execfree(vmscmd);
4439 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4440 && toupper(*(q+2)) == 'R' && !*(q+3);
4442 while (q && l < MAX_DCL_LINE_LENGTH) {
4444 if (j > 0 && quote) {
4450 if (ismcr && j > 1) quote = 1;
4451 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4454 if (quote || tquote) {
4460 if ((quote||tquote) && *q == '"') {
4470 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4472 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4476 static int background_process(pTHX_ int argc, char **argv)
4478 char command[2048] = "$";
4479 $DESCRIPTOR(value, "");
4480 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4481 static $DESCRIPTOR(null, "NLA0:");
4482 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4484 $DESCRIPTOR(pidstr, "");
4486 unsigned long int flags = 17, one = 1, retsts;
4488 strcat(command, argv[0]);
4491 strcat(command, " \"");
4492 strcat(command, *(++argv));
4493 strcat(command, "\"");
4495 value.dsc$a_pointer = command;
4496 value.dsc$w_length = strlen(value.dsc$a_pointer);
4497 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4498 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4499 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4500 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4503 _ckvmssts_noperl(retsts);
4505 #ifdef ARGPROC_DEBUG
4506 PerlIO_printf(Perl_debug_log, "%s\n", command);
4508 sprintf(pidstring, "%08X", pid);
4509 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4510 pidstr.dsc$a_pointer = pidstring;
4511 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4512 lib$set_symbol(&pidsymbol, &pidstr);
4516 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4519 /* OS-specific initialization at image activation (not thread startup) */
4520 /* Older VAXC header files lack these constants */
4521 #ifndef JPI$_RIGHTS_SIZE
4522 # define JPI$_RIGHTS_SIZE 817
4524 #ifndef KGB$M_SUBSYSTEM
4525 # define KGB$M_SUBSYSTEM 0x8
4528 /*{{{void vms_image_init(int *, char ***)*/
4530 vms_image_init(int *argcp, char ***argvp)
4532 char eqv[LNM$C_NAMLENGTH+1] = "";
4533 unsigned int len, tabct = 8, tabidx = 0;
4534 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4535 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4536 unsigned short int dummy, rlen;
4537 struct dsc$descriptor_s **tabvec;
4538 #if defined(PERL_IMPLICIT_CONTEXT)
4541 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4542 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4543 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4546 #ifdef KILL_BY_SIGPRC
4547 (void) Perl_csighandler_init();
4550 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4551 _ckvmssts_noperl(iosb[0]);
4552 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4553 if (iprv[i]) { /* Running image installed with privs? */
4554 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4559 /* Rights identifiers might trigger tainting as well. */
4560 if (!will_taint && (rlen || rsz)) {
4561 while (rlen < rsz) {
4562 /* We didn't get all the identifiers on the first pass. Allocate a
4563 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4564 * were needed to hold all identifiers at time of last call; we'll
4565 * allocate that many unsigned long ints), and go back and get 'em.
4566 * If it gave us less than it wanted to despite ample buffer space,
4567 * something's broken. Is your system missing a system identifier?
4569 if (rsz <= jpilist[1].buflen) {
4570 /* Perl_croak accvios when used this early in startup. */
4571 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4572 rsz, (unsigned long) jpilist[1].buflen,
4573 "Check your rights database for corruption.\n");
4576 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4577 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4578 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4579 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4580 _ckvmssts_noperl(iosb[0]);
4582 mask = jpilist[1].bufadr;
4583 /* Check attribute flags for each identifier (2nd longword); protected
4584 * subsystem identifiers trigger tainting.
4586 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4587 if (mask[i] & KGB$M_SUBSYSTEM) {
4592 if (mask != rlst) Safefree(mask);
4594 /* We need to use this hack to tell Perl it should run with tainting,
4595 * since its tainting flag may be part of the PL_curinterp struct, which
4596 * hasn't been allocated when vms_image_init() is called.
4599 char **newargv, **oldargv;
4601 New(1320,newargv,(*argcp)+2,char *);
4602 newargv[0] = oldargv[0];
4603 New(1320,newargv[1],3,char);
4604 strcpy(newargv[1], "-T");
4605 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4607 newargv[*argcp] = NULL;
4608 /* We orphan the old argv, since we don't know where it's come from,
4609 * so we don't know how to free it.
4613 else { /* Did user explicitly request tainting? */
4615 char *cp, **av = *argvp;
4616 for (i = 1; i < *argcp; i++) {
4617 if (*av[i] != '-') break;
4618 for (cp = av[i]+1; *cp; cp++) {
4619 if (*cp == 'T') { will_taint = 1; break; }
4620 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4621 strchr("DFIiMmx",*cp)) break;
4623 if (will_taint) break;
4628 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4630 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4631 else if (tabidx >= tabct) {
4633 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4635 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4636 tabvec[tabidx]->dsc$w_length = 0;
4637 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4638 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4639 tabvec[tabidx]->dsc$a_pointer = NULL;
4640 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4642 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4644 getredirection(argcp,argvp);
4645 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4647 # include <reentrancy.h>
4648 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4657 * Trim Unix-style prefix off filespec, so it looks like what a shell
4658 * glob expansion would return (i.e. from specified prefix on, not
4659 * full path). Note that returned filespec is Unix-style, regardless
4660 * of whether input filespec was VMS-style or Unix-style.
4662 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4663 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4664 * vector of options; at present, only bit 0 is used, and if set tells
4665 * trim unixpath to try the current default directory as a prefix when
4666 * presented with a possibly ambiguous ... wildcard.
4668 * Returns !=0 on success, with trimmed filespec replacing contents of
4669 * fspec, and 0 on failure, with contents of fpsec unchanged.
4671 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4673 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4675 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4676 *template, *base, *end, *cp1, *cp2;
4677 register int tmplen, reslen = 0, dirs = 0;
4679 if (!wildspec || !fspec) return 0;
4680 if (strpbrk(wildspec,"]>:") != NULL) {
4681 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4682 else template = unixwild;
4684 else template = wildspec;
4685 if (strpbrk(fspec,"]>:") != NULL) {
4686 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4687 else base = unixified;
4688 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4689 * check to see that final result fits into (isn't longer than) fspec */
4690 reslen = strlen(fspec);
4694 /* No prefix or absolute path on wildcard, so nothing to remove */
4695 if (!*template || *template == '/') {
4696 if (base == fspec) return 1;
4697 tmplen = strlen(unixified);
4698 if (tmplen > reslen) return 0; /* not enough space */
4699 /* Copy unixified resultant, including trailing NUL */
4700 memmove(fspec,unixified,tmplen+1);
4704 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4705 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4706 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4707 for (cp1 = end ;cp1 >= base; cp1--)
4708 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4710 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4714 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4715 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4716 int ells = 1, totells, segdirs, match;
4717 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4718 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4720 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4722 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4723 if (ellipsis == template && opts & 1) {
4724 /* Template begins with an ellipsis. Since we can't tell how many
4725 * directory names at the front of the resultant to keep for an
4726 * arbitrary starting point, we arbitrarily choose the current
4727 * default directory as a starting point. If it's there as a prefix,
4728 * clip it off. If not, fall through and act as if the leading
4729 * ellipsis weren't there (i.e. return shortest possible path that
4730 * could match template).
4732 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4733 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4734 if (_tolower(*cp1) != _tolower(*cp2)) break;
4735 segdirs = dirs - totells; /* Min # of dirs we must have left */
4736 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4737 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4738 memcpy(fspec,cp2+1,end - cp2);
4742 /* First off, back up over constant elements at end of path */
4744 for (front = end ; front >= base; front--)
4745 if (*front == '/' && !dirs--) { front++; break; }
4747 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4748 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4749 if (cp1 != '\0') return 0; /* Path too long. */
4751 *cp2 = '\0'; /* Pick up with memcpy later */
4752 lcfront = lcres + (front - base);
4753 /* Now skip over each ellipsis and try to match the path in front of it. */
4755 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4756 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4757 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4758 if (cp1 < template) break; /* template started with an ellipsis */
4759 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4760 ellipsis = cp1; continue;
4762 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4764 for (segdirs = 0, cp2 = tpl;
4765 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4767 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4768 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4769 if (*cp2 == '/') segdirs++;
4771 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4772 /* Back up at least as many dirs as in template before matching */
4773 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4774 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4775 for (match = 0; cp1 > lcres;) {
4776 resdsc.dsc$a_pointer = cp1;
4777 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4779 if (match == 1) lcfront = cp1;
4781 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4783 if (!match) return 0; /* Can't find prefix ??? */
4784 if (match > 1 && opts & 1) {
4785 /* This ... wildcard could cover more than one set of dirs (i.e.
4786 * a set of similar dir names is repeated). If the template
4787 * contains more than 1 ..., upstream elements could resolve the
4788 * ambiguity, but it's not worth a full backtracking setup here.
4789 * As a quick heuristic, clip off the current default directory
4790 * if it's present to find the trimmed spec, else use the
4791 * shortest string that this ... could cover.
4793 char def[NAM$C_MAXRSS+1], *st;
4795 if (getcwd(def, sizeof def,0) == NULL) return 0;
4796 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4797 if (_tolower(*cp1) != _tolower(*cp2)) break;
4798 segdirs = dirs - totells; /* Min # of dirs we must have left */
4799 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4800 if (*cp1 == '\0' && *cp2 == '/') {
4801 memcpy(fspec,cp2+1,end - cp2);
4804 /* Nope -- stick with lcfront from above and keep going. */
4807 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4812 } /* end of trim_unixpath() */
4817 * VMS readdir() routines.
4818 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4820 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4821 * Minor modifications to original routines.
4824 /* readdir may have been redefined by reentr.h, so make sure we get
4825 * the local version for what we do here.
4830 #if !defined(PERL_IMPLICIT_CONTEXT)
4831 # define readdir Perl_readdir
4833 # define readdir(a) Perl_readdir(aTHX_ a)
4836 /* Number of elements in vms_versions array */
4837 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4840 * Open a directory, return a handle for later use.
4842 /*{{{ DIR *opendir(char*name) */
4844 Perl_opendir(pTHX_ char *name)
4847 char dir[NAM$C_MAXRSS+1];
4850 if (do_tovmspath(name,dir,0) == NULL) {
4853 /* Check access before stat; otherwise stat does not
4854 * accurately report whether it's a directory.
4856 if (!cando_by_name(S_IRUSR,0,dir)) {
4857 /* cando_by_name has already set errno */
4860 if (flex_stat(dir,&sb) == -1) return NULL;
4861 if (!S_ISDIR(sb.st_mode)) {
4862 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4865 /* Get memory for the handle, and the pattern. */
4867 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4869 /* Fill in the fields; mainly playing with the descriptor. */
4870 (void)sprintf(dd->pattern, "%s*.*",dir);
4873 dd->vms_wantversions = 0;
4874 dd->pat.dsc$a_pointer = dd->pattern;
4875 dd->pat.dsc$w_length = strlen(dd->pattern);
4876 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4877 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4878 #if defined(USE_ITHREADS)
4879 New(1308,dd->mutex,1,perl_mutex);
4880 MUTEX_INIT( (perl_mutex *) dd->mutex );
4886 } /* end of opendir() */
4890 * Set the flag to indicate we want versions or not.
4892 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4894 vmsreaddirversions(DIR *dd, int flag)
4896 dd->vms_wantversions = flag;
4901 * Free up an opened directory.
4903 /*{{{ void closedir(DIR *dd)*/
4907 (void)lib$find_file_end(&dd->context);
4908 Safefree(dd->pattern);
4909 #if defined(USE_ITHREADS)
4910 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4911 Safefree(dd->mutex);
4913 Safefree((char *)dd);
4918 * Collect all the version numbers for the current file.
4921 collectversions(pTHX_ DIR *dd)
4923 struct dsc$descriptor_s pat;
4924 struct dsc$descriptor_s res;
4926 char *p, *text, buff[sizeof dd->entry.d_name];
4928 unsigned long context, tmpsts;
4930 /* Convenient shorthand. */
4933 /* Add the version wildcard, ignoring the "*.*" put on before */
4934 i = strlen(dd->pattern);
4935 New(1308,text,i + e->d_namlen + 3,char);
4936 (void)strcpy(text, dd->pattern);
4937 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4939 /* Set up the pattern descriptor. */
4940 pat.dsc$a_pointer = text;
4941 pat.dsc$w_length = i + e->d_namlen - 1;
4942 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4943 pat.dsc$b_class = DSC$K_CLASS_S;
4945 /* Set up result descriptor. */
4946 res.dsc$a_pointer = buff;
4947 res.dsc$w_length = sizeof buff - 2;
4948 res.dsc$b_dtype = DSC$K_DTYPE_T;
4949 res.dsc$b_class = DSC$K_CLASS_S;
4951 /* Read files, collecting versions. */
4952 for (context = 0, e->vms_verscount = 0;
4953 e->vms_verscount < VERSIZE(e);
4954 e->vms_verscount++) {
4955 tmpsts = lib$find_file(&pat, &res, &context);
4956 if (tmpsts == RMS$_NMF || context == 0) break;
4958 buff[sizeof buff - 1] = '\0';
4959 if ((p = strchr(buff, ';')))
4960 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4962 e->vms_versions[e->vms_verscount] = -1;
4965 _ckvmssts(lib$find_file_end(&context));
4968 } /* end of collectversions() */
4971 * Read the next entry from the directory.
4973 /*{{{ struct dirent *readdir(DIR *dd)*/
4975 Perl_readdir(pTHX_ DIR *dd)
4977 struct dsc$descriptor_s res;
4978 char *p, buff[sizeof dd->entry.d_name];
4979 unsigned long int tmpsts;
4981 /* Set up result descriptor, and get next file. */
4982 res.dsc$a_pointer = buff;
4983 res.dsc$w_length = sizeof buff - 2;
4984 res.dsc$b_dtype = DSC$K_DTYPE_T;
4985 res.dsc$b_class = DSC$K_CLASS_S;
4986 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4987 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4988 if (!(tmpsts & 1)) {
4989 set_vaxc_errno(tmpsts);
4992 set_errno(EACCES); break;
4994 set_errno(ENODEV); break;
4996 set_errno(ENOTDIR); break;
4997 case RMS$_FNF: case RMS$_DNF:
4998 set_errno(ENOENT); break;
5005 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5006 buff[sizeof buff - 1] = '\0';
5007 for (p = buff; *p; p++) *p = _tolower(*p);
5008 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5011 /* Skip any directory component and just copy the name. */
5012 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5013 else (void)strcpy(dd->entry.d_name, buff);
5015 /* Clobber the version. */
5016 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5018 dd->entry.d_namlen = strlen(dd->entry.d_name);
5019 dd->entry.vms_verscount = 0;
5020 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5023 } /* end of readdir() */
5027 * Read the next entry from the directory -- thread-safe version.
5029 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5031 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5035 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5037 entry = readdir(dd);
5039 retval = ( *result == NULL ? errno : 0 );
5041 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5045 } /* end of readdir_r() */
5049 * Return something that can be used in a seekdir later.
5051 /*{{{ long telldir(DIR *dd)*/
5060 * Return to a spot where we used to be. Brute force.
5062 /*{{{ void seekdir(DIR *dd,long count)*/
5064 Perl_seekdir(pTHX_ DIR *dd, long count)
5066 int vms_wantversions;
5068 /* If we haven't done anything yet... */
5072 /* Remember some state, and clear it. */
5073 vms_wantversions = dd->vms_wantversions;
5074 dd->vms_wantversions = 0;
5075 _ckvmssts(lib$find_file_end(&dd->context));
5078 /* The increment is in readdir(). */
5079 for (dd->count = 0; dd->count < count; )
5082 dd->vms_wantversions = vms_wantversions;
5084 } /* end of seekdir() */
5087 /* VMS subprocess management
5089 * my_vfork() - just a vfork(), after setting a flag to record that
5090 * the current script is trying a Unix-style fork/exec.
5092 * vms_do_aexec() and vms_do_exec() are called in response to the
5093 * perl 'exec' function. If this follows a vfork call, then they
5094 * call out the regular perl routines in doio.c which do an
5095 * execvp (for those who really want to try this under VMS).
5096 * Otherwise, they do exactly what the perl docs say exec should
5097 * do - terminate the current script and invoke a new command
5098 * (See below for notes on command syntax.)
5100 * do_aspawn() and do_spawn() implement the VMS side of the perl
5101 * 'system' function.
5103 * Note on command arguments to perl 'exec' and 'system': When handled
5104 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5105 * are concatenated to form a DCL command string. If the first arg
5106 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5107 * the command string is handed off to DCL directly. Otherwise,
5108 * the first token of the command is taken as the filespec of an image
5109 * to run. The filespec is expanded using a default type of '.EXE' and
5110 * the process defaults for device, directory, etc., and if found, the resultant
5111 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5112 * the command string as parameters. This is perhaps a bit complicated,
5113 * but I hope it will form a happy medium between what VMS folks expect
5114 * from lib$spawn and what Unix folks expect from exec.
5117 static int vfork_called;
5119 /*{{{int my_vfork()*/
5130 vms_execfree(struct dsc$descriptor_s *vmscmd)
5133 if (vmscmd->dsc$a_pointer) {
5134 Safefree(vmscmd->dsc$a_pointer);
5141 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5143 char *junk, *tmps = Nullch;
5144 register size_t cmdlen = 0;
5151 tmps = SvPV(really,rlen);
5158 for (idx++; idx <= sp; idx++) {
5160 junk = SvPVx(*idx,rlen);
5161 cmdlen += rlen ? rlen + 1 : 0;
5164 New(401,PL_Cmd,cmdlen+1,char);
5166 if (tmps && *tmps) {
5167 strcpy(PL_Cmd,tmps);
5170 else *PL_Cmd = '\0';
5171 while (++mark <= sp) {
5173 char *s = SvPVx(*mark,n_a);
5175 if (*PL_Cmd) strcat(PL_Cmd," ");
5181 } /* end of setup_argstr() */
5184 static unsigned long int
5185 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5186 struct dsc$descriptor_s **pvmscmd)
5188 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5189 $DESCRIPTOR(defdsc,".EXE");
5190 $DESCRIPTOR(defdsc2,".");
5191 $DESCRIPTOR(resdsc,resspec);
5192 struct dsc$descriptor_s *vmscmd;
5193 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5194 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5195 register char *s, *rest, *cp, *wordbreak;
5198 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5199 vmscmd->dsc$a_pointer = NULL;
5200 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5201 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5202 vmscmd->dsc$w_length = 0;
5203 if (pvmscmd) *pvmscmd = vmscmd;
5205 if (suggest_quote) *suggest_quote = 0;
5207 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5208 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5210 while (*s && isspace(*s)) s++;
5212 if (*s == '@' || *s == '$') {
5213 vmsspec[0] = *s; rest = s + 1;
5214 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5216 else { cp = vmsspec; rest = s; }
5217 if (*rest == '.' || *rest == '/') {
5220 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5221 rest++, cp2++) *cp2 = *rest;
5223 if (do_tovmsspec(resspec,cp,0)) {
5226 for (cp2 = vmsspec + strlen(vmsspec);
5227 *rest && cp2 - vmsspec < sizeof vmsspec;
5228 rest++, cp2++) *cp2 = *rest;
5233 /* Intuit whether verb (first word of cmd) is a DCL command:
5234 * - if first nonspace char is '@', it's a DCL indirection
5236 * - if verb contains a filespec separator, it's not a DCL command
5237 * - if it doesn't, caller tells us whether to default to a DCL
5238 * command, or to a local image unless told it's DCL (by leading '$')
5242 if (suggest_quote) *suggest_quote = 1;
5244 register char *filespec = strpbrk(s,":<[.;");
5245 rest = wordbreak = strpbrk(s," \"\t/");
5246 if (!wordbreak) wordbreak = s + strlen(s);
5247 if (*s == '$') check_img = 0;
5248 if (filespec && (filespec < wordbreak)) isdcl = 0;
5249 else isdcl = !check_img;
5253 imgdsc.dsc$a_pointer = s;
5254 imgdsc.dsc$w_length = wordbreak - s;
5255 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5257 _ckvmssts(lib$find_file_end(&cxt));
5258 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5259 if (!(retsts & 1) && *s == '$') {
5260 _ckvmssts(lib$find_file_end(&cxt));
5261 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5262 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5264 _ckvmssts(lib$find_file_end(&cxt));
5265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5269 _ckvmssts(lib$find_file_end(&cxt));
5274 while (*s && !isspace(*s)) s++;
5277 /* check that it's really not DCL with no file extension */
5278 fp = fopen(resspec,"r","ctx=bin,shr=get");
5280 char b[4] = {0,0,0,0};
5281 read(fileno(fp),b,4);
5282 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5285 if (check_img && isdcl) return RMS$_FNF;
5287 if (cando_by_name(S_IXUSR,0,resspec)) {
5288 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5290 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5291 if (suggest_quote) *suggest_quote = 1;
5293 strcpy(vmscmd->dsc$a_pointer,"@");
5294 if (suggest_quote) *suggest_quote = 1;
5296 strcat(vmscmd->dsc$a_pointer,resspec);
5297 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5298 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5299 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5301 else retsts = RMS$_PRV;
5304 /* It's either a DCL command or we couldn't find a suitable image */
5305 vmscmd->dsc$w_length = strlen(cmd);
5306 /* if (cmd == PL_Cmd) {
5307 vmscmd->dsc$a_pointer = PL_Cmd;
5308 if (suggest_quote) *suggest_quote = 1;
5311 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5313 /* check if it's a symbol (for quoting purposes) */
5314 if (suggest_quote && !*suggest_quote) {
5316 char equiv[LNM$C_NAMLENGTH];
5317 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5318 eqvdsc.dsc$a_pointer = equiv;
5320 iss = lib$get_symbol(vmscmd,&eqvdsc);
5321 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5323 if (!(retsts & 1)) {
5324 /* just hand off status values likely to be due to user error */
5325 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5326 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5327 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5328 else { _ckvmssts(retsts); }
5331 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5333 } /* end of setup_cmddsc() */
5336 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5338 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5341 if (vfork_called) { /* this follows a vfork - act Unixish */
5343 if (vfork_called < 0) {
5344 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5347 else return do_aexec(really,mark,sp);
5349 /* no vfork - act VMSish */
5350 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5355 } /* end of vms_do_aexec() */
5358 /* {{{bool vms_do_exec(char *cmd) */
5360 Perl_vms_do_exec(pTHX_ char *cmd)
5362 struct dsc$descriptor_s *vmscmd;
5364 if (vfork_called) { /* this follows a vfork - act Unixish */
5366 if (vfork_called < 0) {
5367 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5370 else return do_exec(cmd);
5373 { /* no vfork - act VMSish */
5374 unsigned long int retsts;
5377 TAINT_PROPER("exec");
5378 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5379 retsts = lib$do_command(vmscmd);
5382 case RMS$_FNF: case RMS$_DNF:
5383 set_errno(ENOENT); break;
5385 set_errno(ENOTDIR); break;
5387 set_errno(ENODEV); break;
5389 set_errno(EACCES); break;
5391 set_errno(EINVAL); break;
5392 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5393 set_errno(E2BIG); break;
5394 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5395 _ckvmssts(retsts); /* fall through */
5396 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5399 set_vaxc_errno(retsts);
5400 if (ckWARN(WARN_EXEC)) {
5401 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5402 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5404 vms_execfree(vmscmd);
5409 } /* end of vms_do_exec() */
5412 unsigned long int Perl_do_spawn(pTHX_ char *);
5414 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5416 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5418 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5421 } /* end of do_aspawn() */
5424 /* {{{unsigned long int do_spawn(char *cmd) */
5426 Perl_do_spawn(pTHX_ char *cmd)
5428 unsigned long int sts, substs;
5431 TAINT_PROPER("spawn");
5432 if (!cmd || !*cmd) {
5433 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5436 case RMS$_FNF: case RMS$_DNF:
5437 set_errno(ENOENT); break;
5439 set_errno(ENOTDIR); break;
5441 set_errno(ENODEV); break;
5443 set_errno(EACCES); break;
5445 set_errno(EINVAL); break;
5446 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5447 set_errno(E2BIG); break;
5448 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5449 _ckvmssts(sts); /* fall through */
5450 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5453 set_vaxc_errno(sts);
5454 if (ckWARN(WARN_EXEC)) {
5455 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5462 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5465 } /* end of do_spawn() */
5469 static unsigned int *sockflags, sockflagsize;
5472 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5473 * routines found in some versions of the CRTL can't deal with sockets.
5474 * We don't shim the other file open routines since a socket isn't
5475 * likely to be opened by a name.
5477 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5478 FILE *my_fdopen(int fd, const char *mode)
5480 FILE *fp = fdopen(fd, (char *) mode);
5483 unsigned int fdoff = fd / sizeof(unsigned int);
5484 struct stat sbuf; /* native stat; we don't need flex_stat */
5485 if (!sockflagsize || fdoff > sockflagsize) {
5486 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5487 else New (1324,sockflags,fdoff+2,unsigned int);
5488 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5489 sockflagsize = fdoff + 2;
5491 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5492 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5501 * Clear the corresponding bit when the (possibly) socket stream is closed.
5502 * There still a small hole: we miss an implicit close which might occur
5503 * via freopen(). >> Todo
5505 /*{{{ int my_fclose(FILE *fp)*/
5506 int my_fclose(FILE *fp) {
5508 unsigned int fd = fileno(fp);
5509 unsigned int fdoff = fd / sizeof(unsigned int);
5511 if (sockflagsize && fdoff <= sockflagsize)
5512 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5520 * A simple fwrite replacement which outputs itmsz*nitm chars without
5521 * introducing record boundaries every itmsz chars.
5522 * We are using fputs, which depends on a terminating null. We may
5523 * well be writing binary data, so we need to accommodate not only
5524 * data with nulls sprinkled in the middle but also data with no null
5527 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5529 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5531 register char *cp, *end, *cpd, *data;
5532 register unsigned int fd = fileno(dest);
5533 register unsigned int fdoff = fd / sizeof(unsigned int);
5535 int bufsize = itmsz * nitm + 1;
5537 if (fdoff < sockflagsize &&
5538 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5539 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5543 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5544 memcpy( data, src, itmsz*nitm );
5545 data[itmsz*nitm] = '\0';
5547 end = data + itmsz * nitm;
5548 retval = (int) nitm; /* on success return # items written */
5551 while (cpd <= end) {
5552 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5553 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5555 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5559 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5562 } /* end of my_fwrite() */
5565 /*{{{ int my_flush(FILE *fp)*/
5567 Perl_my_flush(pTHX_ FILE *fp)
5570 if ((res = fflush(fp)) == 0 && fp) {
5571 #ifdef VMS_DO_SOCKETS
5573 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5575 res = fsync(fileno(fp));
5578 * If the flush succeeded but set end-of-file, we need to clear
5579 * the error because our caller may check ferror(). BTW, this
5580 * probably means we just flushed an empty file.
5582 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5589 * Here are replacements for the following Unix routines in the VMS environment:
5590 * getpwuid Get information for a particular UIC or UID
5591 * getpwnam Get information for a named user
5592 * getpwent Get information for each user in the rights database
5593 * setpwent Reset search to the start of the rights database
5594 * endpwent Finish searching for users in the rights database
5596 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5597 * (defined in pwd.h), which contains the following fields:-
5599 * char *pw_name; Username (in lower case)
5600 * char *pw_passwd; Hashed password
5601 * unsigned int pw_uid; UIC
5602 * unsigned int pw_gid; UIC group number
5603 * char *pw_unixdir; Default device/directory (VMS-style)
5604 * char *pw_gecos; Owner name
5605 * char *pw_dir; Default device/directory (Unix-style)
5606 * char *pw_shell; Default CLI name (eg. DCL)
5608 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5610 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5611 * not the UIC member number (eg. what's returned by getuid()),
5612 * getpwuid() can accept either as input (if uid is specified, the caller's
5613 * UIC group is used), though it won't recognise gid=0.
5615 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5616 * information about other users in your group or in other groups, respectively.
5617 * If the required privilege is not available, then these routines fill only
5618 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5621 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5624 /* sizes of various UAF record fields */
5625 #define UAI$S_USERNAME 12
5626 #define UAI$S_IDENT 31
5627 #define UAI$S_OWNER 31
5628 #define UAI$S_DEFDEV 31
5629 #define UAI$S_DEFDIR 63
5630 #define UAI$S_DEFCLI 31
5633 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5634 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5635 (uic).uic$v_group != UIC$K_WILD_GROUP)
5637 static char __empty[]= "";
5638 static struct passwd __passwd_empty=
5639 {(char *) __empty, (char *) __empty, 0, 0,
5640 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5641 static int contxt= 0;
5642 static struct passwd __pwdcache;
5643 static char __pw_namecache[UAI$S_IDENT+1];
5646 * This routine does most of the work extracting the user information.
5648 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5651 unsigned char length;
5652 char pw_gecos[UAI$S_OWNER+1];
5654 static union uicdef uic;
5656 unsigned char length;
5657 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5660 unsigned char length;
5661 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5664 unsigned char length;
5665 char pw_shell[UAI$S_DEFCLI+1];
5667 static char pw_passwd[UAI$S_PWD+1];
5669 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5670 struct dsc$descriptor_s name_desc;
5671 unsigned long int sts;
5673 static struct itmlst_3 itmlst[]= {
5674 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5675 {sizeof(uic), UAI$_UIC, &uic, &luic},
5676 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5677 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5678 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5679 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5680 {0, 0, NULL, NULL}};
5682 name_desc.dsc$w_length= strlen(name);
5683 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5684 name_desc.dsc$b_class= DSC$K_CLASS_S;
5685 name_desc.dsc$a_pointer= (char *) name;
5687 /* Note that sys$getuai returns many fields as counted strings. */
5688 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5689 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5690 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5692 else { _ckvmssts(sts); }
5693 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5695 if ((int) owner.length < lowner) lowner= (int) owner.length;
5696 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5697 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5698 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5699 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5700 owner.pw_gecos[lowner]= '\0';
5701 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5702 defcli.pw_shell[ldefcli]= '\0';
5703 if (valid_uic(uic)) {
5704 pwd->pw_uid= uic.uic$l_uic;
5705 pwd->pw_gid= uic.uic$v_group;
5708 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5709 pwd->pw_passwd= pw_passwd;
5710 pwd->pw_gecos= owner.pw_gecos;
5711 pwd->pw_dir= defdev.pw_dir;
5712 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5713 pwd->pw_shell= defcli.pw_shell;
5714 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5716 ldir= strlen(pwd->pw_unixdir) - 1;
5717 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5720 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5721 __mystrtolower(pwd->pw_unixdir);
5726 * Get information for a named user.
5728 /*{{{struct passwd *getpwnam(char *name)*/
5729 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5731 struct dsc$descriptor_s name_desc;
5733 unsigned long int status, sts;
5735 __pwdcache = __passwd_empty;
5736 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5737 /* We still may be able to determine pw_uid and pw_gid */
5738 name_desc.dsc$w_length= strlen(name);
5739 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5740 name_desc.dsc$b_class= DSC$K_CLASS_S;
5741 name_desc.dsc$a_pointer= (char *) name;
5742 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5743 __pwdcache.pw_uid= uic.uic$l_uic;
5744 __pwdcache.pw_gid= uic.uic$v_group;
5747 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5748 set_vaxc_errno(sts);
5749 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5752 else { _ckvmssts(sts); }
5755 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5756 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5757 __pwdcache.pw_name= __pw_namecache;
5759 } /* end of my_getpwnam() */
5763 * Get information for a particular UIC or UID.
5764 * Called by my_getpwent with uid=-1 to list all users.
5766 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5767 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5769 const $DESCRIPTOR(name_desc,__pw_namecache);
5770 unsigned short lname;
5772 unsigned long int status;
5774 if (uid == (unsigned int) -1) {
5776 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5777 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5778 set_vaxc_errno(status);
5779 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5783 else { _ckvmssts(status); }
5784 } while (!valid_uic (uic));
5788 if (!uic.uic$v_group)
5789 uic.uic$v_group= PerlProc_getgid();
5791 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5792 else status = SS$_IVIDENT;
5793 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5794 status == RMS$_PRV) {
5795 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5798 else { _ckvmssts(status); }
5800 __pw_namecache[lname]= '\0';
5801 __mystrtolower(__pw_namecache);
5803 __pwdcache = __passwd_empty;
5804 __pwdcache.pw_name = __pw_namecache;
5806 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5807 The identifier's value is usually the UIC, but it doesn't have to be,
5808 so if we can, we let fillpasswd update this. */
5809 __pwdcache.pw_uid = uic.uic$l_uic;
5810 __pwdcache.pw_gid = uic.uic$v_group;
5812 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5815 } /* end of my_getpwuid() */
5819 * Get information for next user.
5821 /*{{{struct passwd *my_getpwent()*/
5822 struct passwd *Perl_my_getpwent(pTHX)
5824 return (my_getpwuid((unsigned int) -1));
5829 * Finish searching rights database for users.
5831 /*{{{void my_endpwent()*/
5832 void Perl_my_endpwent(pTHX)
5835 _ckvmssts(sys$finish_rdb(&contxt));
5841 #ifdef HOMEGROWN_POSIX_SIGNALS
5842 /* Signal handling routines, pulled into the core from POSIX.xs.
5844 * We need these for threads, so they've been rolled into the core,
5845 * rather than left in POSIX.xs.
5847 * (DRS, Oct 23, 1997)
5850 /* sigset_t is atomic under VMS, so these routines are easy */
5851 /*{{{int my_sigemptyset(sigset_t *) */
5852 int my_sigemptyset(sigset_t *set) {
5853 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5859 /*{{{int my_sigfillset(sigset_t *)*/
5860 int my_sigfillset(sigset_t *set) {
5862 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5863 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5869 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5870 int my_sigaddset(sigset_t *set, int sig) {
5871 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5872 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5873 *set |= (1 << (sig - 1));
5879 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5880 int my_sigdelset(sigset_t *set, int sig) {
5881 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5882 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5883 *set &= ~(1 << (sig - 1));
5889 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5890 int my_sigismember(sigset_t *set, int sig) {
5891 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5892 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5893 return *set & (1 << (sig - 1));
5898 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5899 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5902 /* If set and oset are both null, then things are badly wrong. Bail out. */
5903 if ((oset == NULL) && (set == NULL)) {
5904 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5908 /* If set's null, then we're just handling a fetch. */
5910 tempmask = sigblock(0);
5915 tempmask = sigsetmask(*set);
5918 tempmask = sigblock(*set);
5921 tempmask = sigblock(0);
5922 sigsetmask(*oset & ~tempmask);
5925 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5930 /* Did they pass us an oset? If so, stick our holding mask into it */
5937 #endif /* HOMEGROWN_POSIX_SIGNALS */
5940 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5941 * my_utime(), and flex_stat(), all of which operate on UTC unless
5942 * VMSISH_TIMES is true.
5944 /* method used to handle UTC conversions:
5945 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5947 static int gmtime_emulation_type;
5948 /* number of secs to add to UTC POSIX-style time to get local time */
5949 static long int utc_offset_secs;
5951 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5952 * in vmsish.h. #undef them here so we can call the CRTL routines
5961 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5962 * qualifier with the extern prefix pragma. This provisional
5963 * hack circumvents this prefix pragma problem in previous
5966 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5967 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5968 # pragma __extern_prefix save
5969 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5970 # define gmtime decc$__utctz_gmtime
5971 # define localtime decc$__utctz_localtime
5972 # define time decc$__utc_time
5973 # pragma __extern_prefix restore
5975 struct tm *gmtime(), *localtime();
5981 static time_t toutc_dst(time_t loc) {
5984 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5985 loc -= utc_offset_secs;
5986 if (rsltmp->tm_isdst) loc -= 3600;
5989 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5990 ((gmtime_emulation_type || my_time(NULL)), \
5991 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5992 ((secs) - utc_offset_secs))))
5994 static time_t toloc_dst(time_t utc) {
5997 utc += utc_offset_secs;
5998 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5999 if (rsltmp->tm_isdst) utc += 3600;
6002 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6003 ((gmtime_emulation_type || my_time(NULL)), \
6004 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6005 ((secs) + utc_offset_secs))))
6007 #ifndef RTL_USES_UTC
6010 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6011 DST starts on 1st sun of april at 02:00 std time
6012 ends on last sun of october at 02:00 dst time
6013 see the UCX management command reference, SET CONFIG TIMEZONE
6014 for formatting info.
6016 No, it's not as general as it should be, but then again, NOTHING
6017 will handle UK times in a sensible way.
6022 parse the DST start/end info:
6023 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6027 tz_parse_startend(char *s, struct tm *w, int *past)
6029 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6030 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6035 if (!past) return 0;
6038 if (w->tm_year % 4 == 0) ly = 1;
6039 if (w->tm_year % 100 == 0) ly = 0;
6040 if (w->tm_year+1900 % 400 == 0) ly = 1;
6043 dozjd = isdigit(*s);
6044 if (*s == 'J' || *s == 'j' || dozjd) {
6045 if (!dozjd && !isdigit(*++s)) return 0;
6048 d = d*10 + *s++ - '0';
6050 d = d*10 + *s++ - '0';
6053 if (d == 0) return 0;
6054 if (d > 366) return 0;
6056 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6059 } else if (*s == 'M' || *s == 'm') {
6060 if (!isdigit(*++s)) return 0;
6062 if (isdigit(*s)) m = 10*m + *s++ - '0';
6063 if (*s != '.') return 0;
6064 if (!isdigit(*++s)) return 0;
6066 if (n < 1 || n > 5) return 0;
6067 if (*s != '.') return 0;
6068 if (!isdigit(*++s)) return 0;
6070 if (d > 6) return 0;
6074 if (!isdigit(*++s)) return 0;
6076 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6078 if (!isdigit(*++s)) return 0;
6080 if (isdigit(*s)) min = 10*min + *s++ - '0';
6082 if (!isdigit(*++s)) return 0;
6084 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6094 if (w->tm_yday < d) goto before;
6095 if (w->tm_yday > d) goto after;
6097 if (w->tm_mon+1 < m) goto before;
6098 if (w->tm_mon+1 > m) goto after;
6100 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6101 k = d - j; /* mday of first d */
6103 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6104 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6105 if (w->tm_mday < k) goto before;
6106 if (w->tm_mday > k) goto after;
6109 if (w->tm_hour < hour) goto before;
6110 if (w->tm_hour > hour) goto after;
6111 if (w->tm_min < min) goto before;
6112 if (w->tm_min > min) goto after;
6113 if (w->tm_sec < sec) goto before;
6127 /* parse the offset: (+|-)hh[:mm[:ss]] */
6130 tz_parse_offset(char *s, int *offset)
6132 int hour = 0, min = 0, sec = 0;
6135 if (!offset) return 0;
6137 if (*s == '-') {neg++; s++;}
6139 if (!isdigit(*s)) return 0;
6141 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6142 if (hour > 24) return 0;
6144 if (!isdigit(*++s)) return 0;
6146 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6147 if (min > 59) return 0;
6149 if (!isdigit(*++s)) return 0;
6151 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6152 if (sec > 59) return 0;
6156 *offset = (hour*60+min)*60 + sec;
6157 if (neg) *offset = -*offset;
6162 input time is w, whatever type of time the CRTL localtime() uses.
6163 sets dst, the zone, and the gmtoff (seconds)
6165 caches the value of TZ and UCX$TZ env variables; note that
6166 my_setenv looks for these and sets a flag if they're changed
6169 We have to watch out for the "australian" case (dst starts in
6170 october, ends in april)...flagged by "reverse" and checked by
6171 scanning through the months of the previous year.
6176 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6181 char *dstzone, *tz, *s_start, *s_end;
6182 int std_off, dst_off, isdst;
6183 int y, dststart, dstend;
6184 static char envtz[1025]; /* longer than any logical, symbol, ... */
6185 static char ucxtz[1025];
6186 static char reversed = 0;
6192 reversed = -1; /* flag need to check */
6193 envtz[0] = ucxtz[0] = '\0';
6194 tz = my_getenv("TZ",0);
6195 if (tz) strcpy(envtz, tz);
6196 tz = my_getenv("UCX$TZ",0);
6197 if (tz) strcpy(ucxtz, tz);
6198 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6201 if (!*tz) tz = ucxtz;
6204 while (isalpha(*s)) s++;
6205 s = tz_parse_offset(s, &std_off);
6207 if (!*s) { /* no DST, hurray we're done! */
6213 while (isalpha(*s)) s++;
6214 s2 = tz_parse_offset(s, &dst_off);
6218 dst_off = std_off - 3600;
6221 if (!*s) { /* default dst start/end?? */
6222 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6223 s = strchr(ucxtz,',');
6225 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6227 if (*s != ',') return 0;
6230 when = _toutc(when); /* convert to utc */
6231 when = when - std_off; /* convert to pseudolocal time*/
6233 w2 = localtime(&when);
6236 s = tz_parse_startend(s_start,w2,&dststart);
6238 if (*s != ',') return 0;
6241 when = _toutc(when); /* convert to utc */
6242 when = when - dst_off; /* convert to pseudolocal time*/
6243 w2 = localtime(&when);
6244 if (w2->tm_year != y) { /* spans a year, just check one time */
6245 when += dst_off - std_off;
6246 w2 = localtime(&when);
6249 s = tz_parse_startend(s_end,w2,&dstend);
6252 if (reversed == -1) { /* need to check if start later than end */
6256 if (when < 2*365*86400) {
6257 when += 2*365*86400;
6261 w2 =localtime(&when);
6262 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6264 for (j = 0; j < 12; j++) {
6265 w2 =localtime(&when);
6266 (void) tz_parse_startend(s_start,w2,&ds);
6267 (void) tz_parse_startend(s_end,w2,&de);
6268 if (ds != de) break;
6272 if (de && !ds) reversed = 1;
6275 isdst = dststart && !dstend;
6276 if (reversed) isdst = dststart || !dstend;
6279 if (dst) *dst = isdst;
6280 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6281 if (isdst) tz = dstzone;
6283 while(isalpha(*tz)) *zone++ = *tz++;
6289 #endif /* !RTL_USES_UTC */
6291 /* my_time(), my_localtime(), my_gmtime()
6292 * By default traffic in UTC time values, using CRTL gmtime() or
6293 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6294 * Note: We need to use these functions even when the CRTL has working
6295 * UTC support, since they also handle C<use vmsish qw(times);>
6297 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6298 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6301 /*{{{time_t my_time(time_t *timep)*/
6302 time_t Perl_my_time(pTHX_ time_t *timep)
6307 if (gmtime_emulation_type == 0) {
6309 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6310 /* results of calls to gmtime() and localtime() */
6311 /* for same &base */
6313 gmtime_emulation_type++;
6314 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6315 char off[LNM$C_NAMLENGTH+1];;
6317 gmtime_emulation_type++;
6318 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6319 gmtime_emulation_type++;
6320 utc_offset_secs = 0;
6321 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6323 else { utc_offset_secs = atol(off); }
6325 else { /* We've got a working gmtime() */
6326 struct tm gmt, local;
6329 tm_p = localtime(&base);
6331 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6332 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6333 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6334 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6340 # ifdef RTL_USES_UTC
6341 if (VMSISH_TIME) when = _toloc(when);
6343 if (!VMSISH_TIME) when = _toutc(when);
6346 if (timep != NULL) *timep = when;
6349 } /* end of my_time() */
6353 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6355 Perl_my_gmtime(pTHX_ const time_t *timep)
6361 if (timep == NULL) {
6362 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6365 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6369 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6371 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6372 return gmtime(&when);
6374 /* CRTL localtime() wants local time as input, so does no tz correction */
6375 rsltmp = localtime(&when);
6376 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6379 } /* end of my_gmtime() */
6383 /*{{{struct tm *my_localtime(const time_t *timep)*/
6385 Perl_my_localtime(pTHX_ const time_t *timep)
6387 time_t when, whenutc;
6391 if (timep == NULL) {
6392 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6395 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6396 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6399 # ifdef RTL_USES_UTC
6401 if (VMSISH_TIME) when = _toutc(when);
6403 /* CRTL localtime() wants UTC as input, does tz correction itself */
6404 return localtime(&when);
6406 # else /* !RTL_USES_UTC */
6409 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6410 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6413 #ifndef RTL_USES_UTC
6414 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6415 when = whenutc - offset; /* pseudolocal time*/
6418 /* CRTL localtime() wants local time as input, so does no tz correction */
6419 rsltmp = localtime(&when);
6420 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6424 } /* end of my_localtime() */
6427 /* Reset definitions for later calls */
6428 #define gmtime(t) my_gmtime(t)
6429 #define localtime(t) my_localtime(t)
6430 #define time(t) my_time(t)
6433 /* my_utime - update modification time of a file
6434 * calling sequence is identical to POSIX utime(), but under
6435 * VMS only the modification time is changed; ODS-2 does not
6436 * maintain access times. Restrictions differ from the POSIX
6437 * definition in that the time can be changed as long as the
6438 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6439 * no separate checks are made to insure that the caller is the
6440 * owner of the file or has special privs enabled.
6441 * Code here is based on Joe Meadows' FILE utility.
6444 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6445 * to VMS epoch (01-JAN-1858 00:00:00.00)
6446 * in 100 ns intervals.
6448 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6450 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6451 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6454 long int bintime[2], len = 2, lowbit, unixtime,
6455 secscale = 10000000; /* seconds --> 100 ns intervals */
6456 unsigned long int chan, iosb[2], retsts;
6457 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6458 struct FAB myfab = cc$rms_fab;
6459 struct NAM mynam = cc$rms_nam;
6460 #if defined (__DECC) && defined (__VAX)
6461 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6462 * at least through VMS V6.1, which causes a type-conversion warning.
6464 # pragma message save
6465 # pragma message disable cvtdiftypes
6467 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6468 struct fibdef myfib;
6469 #if defined (__DECC) && defined (__VAX)
6470 /* This should be right after the declaration of myatr, but due
6471 * to a bug in VAX DEC C, this takes effect a statement early.
6473 # pragma message restore
6475 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6476 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6477 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6479 if (file == NULL || *file == '\0') {
6481 set_vaxc_errno(LIB$_INVARG);
6484 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6486 if (utimes != NULL) {
6487 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6488 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6489 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6490 * as input, we force the sign bit to be clear by shifting unixtime right
6491 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6493 lowbit = (utimes->modtime & 1) ? secscale : 0;
6494 unixtime = (long int) utimes->modtime;
6496 /* If input was UTC; convert to local for sys svc */
6497 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6499 unixtime >>= 1; secscale <<= 1;
6500 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6501 if (!(retsts & 1)) {
6503 set_vaxc_errno(retsts);
6506 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6507 if (!(retsts & 1)) {
6509 set_vaxc_errno(retsts);
6514 /* Just get the current time in VMS format directly */
6515 retsts = sys$gettim(bintime);
6516 if (!(retsts & 1)) {
6518 set_vaxc_errno(retsts);
6523 myfab.fab$l_fna = vmsspec;
6524 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6525 myfab.fab$l_nam = &mynam;
6526 mynam.nam$l_esa = esa;
6527 mynam.nam$b_ess = (unsigned char) sizeof esa;
6528 mynam.nam$l_rsa = rsa;
6529 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6531 /* Look for the file to be affected, letting RMS parse the file
6532 * specification for us as well. I have set errno using only
6533 * values documented in the utime() man page for VMS POSIX.
6535 retsts = sys$parse(&myfab,0,0);
6536 if (!(retsts & 1)) {
6537 set_vaxc_errno(retsts);
6538 if (retsts == RMS$_PRV) set_errno(EACCES);
6539 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6540 else set_errno(EVMSERR);
6543 retsts = sys$search(&myfab,0,0);
6544 if (!(retsts & 1)) {
6545 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6546 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6547 set_vaxc_errno(retsts);
6548 if (retsts == RMS$_PRV) set_errno(EACCES);
6549 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6550 else set_errno(EVMSERR);
6554 devdsc.dsc$w_length = mynam.nam$b_dev;
6555 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6557 retsts = sys$assign(&devdsc,&chan,0,0);
6558 if (!(retsts & 1)) {
6559 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6560 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6561 set_vaxc_errno(retsts);
6562 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6563 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6564 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6565 else set_errno(EVMSERR);
6569 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6570 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6572 memset((void *) &myfib, 0, sizeof myfib);
6573 #if defined(__DECC) || defined(__DECCXX)
6574 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6575 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6576 /* This prevents the revision time of the file being reset to the current
6577 * time as a result of our IO$_MODIFY $QIO. */
6578 myfib.fib$l_acctl = FIB$M_NORECORD;
6580 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6581 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6582 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6584 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6585 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6586 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6587 _ckvmssts(sys$dassgn(chan));
6588 if (retsts & 1) retsts = iosb[0];
6589 if (!(retsts & 1)) {
6590 set_vaxc_errno(retsts);
6591 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6592 else set_errno(EVMSERR);
6597 } /* end of my_utime() */
6601 * flex_stat, flex_fstat
6602 * basic stat, but gets it right when asked to stat
6603 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6606 /* encode_dev packs a VMS device name string into an integer to allow
6607 * simple comparisons. This can be used, for example, to check whether two
6608 * files are located on the same device, by comparing their encoded device
6609 * names. Even a string comparison would not do, because stat() reuses the
6610 * device name buffer for each call; so without encode_dev, it would be
6611 * necessary to save the buffer and use strcmp (this would mean a number of
6612 * changes to the standard Perl code, to say nothing of what a Perl script
6615 * The device lock id, if it exists, should be unique (unless perhaps compared
6616 * with lock ids transferred from other nodes). We have a lock id if the disk is
6617 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6618 * device names. Thus we use the lock id in preference, and only if that isn't
6619 * available, do we try to pack the device name into an integer (flagged by
6620 * the sign bit (LOCKID_MASK) being set).
6622 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6623 * name and its encoded form, but it seems very unlikely that we will find
6624 * two files on different disks that share the same encoded device names,
6625 * and even more remote that they will share the same file id (if the test
6626 * is to check for the same file).
6628 * A better method might be to use sys$device_scan on the first call, and to
6629 * search for the device, returning an index into the cached array.
6630 * The number returned would be more intelligable.
6631 * This is probably not worth it, and anyway would take quite a bit longer
6632 * on the first call.
6634 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6635 static mydev_t encode_dev (pTHX_ const char *dev)
6638 unsigned long int f;
6643 if (!dev || !dev[0]) return 0;
6647 struct dsc$descriptor_s dev_desc;
6648 unsigned long int status, lockid, item = DVI$_LOCKID;
6650 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6651 can try that first. */
6652 dev_desc.dsc$w_length = strlen (dev);
6653 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6654 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6655 dev_desc.dsc$a_pointer = (char *) dev;
6656 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6657 if (lockid) return (lockid & ~LOCKID_MASK);
6661 /* Otherwise we try to encode the device name */
6665 for (q = dev + strlen(dev); q--; q >= dev) {
6668 else if (isalpha (toupper (*q)))
6669 c= toupper (*q) - 'A' + (char)10;
6671 continue; /* Skip '$'s */
6673 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6675 enc += f * (unsigned long int) c;
6677 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6679 } /* end of encode_dev() */
6681 static char namecache[NAM$C_MAXRSS+1];
6684 is_null_device(name)
6687 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6688 The underscore prefix, controller letter, and unit number are
6689 independently optional; for our purposes, the colon punctuation
6690 is not. The colon can be trailed by optional directory and/or
6691 filename, but two consecutive colons indicates a nodename rather
6692 than a device. [pr] */
6693 if (*name == '_') ++name;
6694 if (tolower(*name++) != 'n') return 0;
6695 if (tolower(*name++) != 'l') return 0;
6696 if (tolower(*name) == 'a') ++name;
6697 if (*name == '0') ++name;
6698 return (*name++ == ':') && (*name != ':');
6701 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6702 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6703 * subset of the applicable information.
6706 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6708 char fname_phdev[NAM$C_MAXRSS+1];
6709 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6711 char fname[NAM$C_MAXRSS+1];
6712 unsigned long int retsts;
6713 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6714 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6716 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6717 device name on successive calls */
6718 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6719 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6720 namdsc.dsc$a_pointer = fname;
6721 namdsc.dsc$w_length = sizeof fname - 1;
6723 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6724 &namdsc,&namdsc.dsc$w_length,0,0);
6726 fname[namdsc.dsc$w_length] = '\0';
6728 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6729 * but if someone has redefined that logical, Perl gets very lost. Since
6730 * we have the physical device name from the stat buffer, just paste it on.
6732 strcpy( fname_phdev, statbufp->st_devnam );
6733 strcat( fname_phdev, strrchr(fname, ':') );
6735 return cando_by_name(bit,effective,fname_phdev);
6737 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6738 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6742 return FALSE; /* Should never get to here */
6744 } /* end of cando() */
6748 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6750 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6752 static char usrname[L_cuserid];
6753 static struct dsc$descriptor_s usrdsc =
6754 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6755 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6756 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6757 unsigned short int retlen, trnlnm_iter_count;
6758 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6759 union prvdef curprv;
6760 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6761 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6762 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6763 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6765 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6767 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6769 if (!fname || !*fname) return FALSE;
6770 /* Make sure we expand logical names, since sys$check_access doesn't */
6771 if (!strpbrk(fname,"/]>:")) {
6772 strcpy(fileified,fname);
6773 trnlnm_iter_count = 0;
6774 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6775 trnlnm_iter_count++;
6776 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6780 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6781 retlen = namdsc.dsc$w_length = strlen(vmsname);
6782 namdsc.dsc$a_pointer = vmsname;
6783 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6784 vmsname[retlen-1] == ':') {
6785 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6786 namdsc.dsc$w_length = strlen(fileified);
6787 namdsc.dsc$a_pointer = fileified;
6791 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6792 access = ARM$M_EXECUTE; break;
6793 case S_IRUSR: case S_IRGRP: case S_IROTH:
6794 access = ARM$M_READ; break;
6795 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6796 access = ARM$M_WRITE; break;
6797 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6798 access = ARM$M_DELETE; break;
6803 /* Before we call $check_access, create a user profile with the current
6804 * process privs since otherwise it just uses the default privs from the
6805 * UAF and might give false positives or negatives. This only works on
6806 * VMS versions v6.0 and later since that's when sys$create_user_profile
6810 /* get current process privs and username */
6811 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6814 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6816 /* find out the space required for the profile */
6817 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6818 &usrprodsc.dsc$w_length,0));
6820 /* allocate space for the profile and get it filled in */
6821 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6822 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6823 &usrprodsc.dsc$w_length,0));
6825 /* use the profile to check access to the file; free profile & analyze results */
6826 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6827 Safefree(usrprodsc.dsc$a_pointer);
6828 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6832 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6836 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6837 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6838 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6839 set_vaxc_errno(retsts);
6840 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6841 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6842 else set_errno(ENOENT);
6845 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6850 return FALSE; /* Should never get here */
6852 } /* end of cando_by_name() */
6856 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6858 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6860 if (!fstat(fd,(stat_t *) statbufp)) {
6861 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6862 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6863 # ifdef RTL_USES_UTC
6866 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6867 statbufp->st_atime = _toloc(statbufp->st_atime);
6868 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6873 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6877 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6878 statbufp->st_atime = _toutc(statbufp->st_atime);
6879 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6886 } /* end of flex_fstat() */
6889 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6891 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6893 char fileified[NAM$C_MAXRSS+1];
6894 char temp_fspec[NAM$C_MAXRSS+300];
6896 int saved_errno, saved_vaxc_errno;
6898 if (!fspec) return retval;
6899 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6900 strcpy(temp_fspec, fspec);
6901 if (statbufp == (Stat_t *) &PL_statcache)
6902 do_tovmsspec(temp_fspec,namecache,0);
6903 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6904 memset(statbufp,0,sizeof *statbufp);
6905 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6906 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6907 statbufp->st_uid = 0x00010001;
6908 statbufp->st_gid = 0x0001;
6909 time((time_t *)&statbufp->st_mtime);
6910 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6914 /* Try for a directory name first. If fspec contains a filename without
6915 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6916 * and sea:[wine.dark]water. exist, we prefer the directory here.
6917 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6918 * not sea:[wine.dark]., if the latter exists. If the intended target is
6919 * the file with null type, specify this by calling flex_stat() with
6920 * a '.' at the end of fspec.
6922 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6923 retval = stat(fileified,(stat_t *) statbufp);
6924 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6925 strcpy(namecache,fileified);
6927 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6929 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6930 # ifdef RTL_USES_UTC
6933 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6934 statbufp->st_atime = _toloc(statbufp->st_atime);
6935 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6940 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6944 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6945 statbufp->st_atime = _toutc(statbufp->st_atime);
6946 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6950 /* If we were successful, leave errno where we found it */
6951 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6954 } /* end of flex_stat() */
6958 /*{{{char *my_getlogin()*/
6959 /* VMS cuserid == Unix getlogin, except calling sequence */
6963 static char user[L_cuserid];
6964 return cuserid(user);
6969 /* rmscopy - copy a file using VMS RMS routines
6971 * Copies contents and attributes of spec_in to spec_out, except owner
6972 * and protection information. Name and type of spec_in are used as
6973 * defaults for spec_out. The third parameter specifies whether rmscopy()
6974 * should try to propagate timestamps from the input file to the output file.
6975 * If it is less than 0, no timestamps are preserved. If it is 0, then
6976 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6977 * propagated to the output file at creation iff the output file specification
6978 * did not contain an explicit name or type, and the revision date is always
6979 * updated at the end of the copy operation. If it is greater than 0, then
6980 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6981 * other than the revision date should be propagated, and bit 1 indicates
6982 * that the revision date should be propagated.
6984 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6986 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6987 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6988 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6989 * as part of the Perl standard distribution under the terms of the
6990 * GNU General Public License or the Perl Artistic License. Copies
6991 * of each may be found in the Perl standard distribution.
6993 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6995 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6997 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6998 rsa[NAM$C_MAXRSS], ubf[32256];
6999 unsigned long int i, sts, sts2;
7000 struct FAB fab_in, fab_out;
7001 struct RAB rab_in, rab_out;
7003 struct XABDAT xabdat;
7004 struct XABFHC xabfhc;
7005 struct XABRDT xabrdt;
7006 struct XABSUM xabsum;
7008 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7009 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7010 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7014 fab_in = cc$rms_fab;
7015 fab_in.fab$l_fna = vmsin;
7016 fab_in.fab$b_fns = strlen(vmsin);
7017 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7018 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7019 fab_in.fab$l_fop = FAB$M_SQO;
7020 fab_in.fab$l_nam = &nam;
7021 fab_in.fab$l_xab = (void *) &xabdat;
7024 nam.nam$l_rsa = rsa;
7025 nam.nam$b_rss = sizeof(rsa);
7026 nam.nam$l_esa = esa;
7027 nam.nam$b_ess = sizeof (esa);
7028 nam.nam$b_esl = nam.nam$b_rsl = 0;
7030 xabdat = cc$rms_xabdat; /* To get creation date */
7031 xabdat.xab$l_nxt = (void *) &xabfhc;
7033 xabfhc = cc$rms_xabfhc; /* To get record length */
7034 xabfhc.xab$l_nxt = (void *) &xabsum;
7036 xabsum = cc$rms_xabsum; /* To get key and area information */
7038 if (!((sts = sys$open(&fab_in)) & 1)) {
7039 set_vaxc_errno(sts);
7041 case RMS$_FNF: case RMS$_DNF:
7042 set_errno(ENOENT); break;
7044 set_errno(ENOTDIR); break;
7046 set_errno(ENODEV); break;
7048 set_errno(EINVAL); break;
7050 set_errno(EACCES); break;
7058 fab_out.fab$w_ifi = 0;
7059 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7060 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7061 fab_out.fab$l_fop = FAB$M_SQO;
7062 fab_out.fab$l_fna = vmsout;
7063 fab_out.fab$b_fns = strlen(vmsout);
7064 fab_out.fab$l_dna = nam.nam$l_name;
7065 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7067 if (preserve_dates == 0) { /* Act like DCL COPY */
7068 nam.nam$b_nop = NAM$M_SYNCHK;
7069 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7070 if (!((sts = sys$parse(&fab_out)) & 1)) {
7071 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7072 set_vaxc_errno(sts);
7075 fab_out.fab$l_xab = (void *) &xabdat;
7076 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7078 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7079 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7080 preserve_dates =0; /* bitmask from this point forward */
7082 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7083 if (!((sts = sys$create(&fab_out)) & 1)) {
7084 set_vaxc_errno(sts);
7087 set_errno(ENOENT); break;
7089 set_errno(ENOTDIR); break;
7091 set_errno(ENODEV); break;
7093 set_errno(EINVAL); break;
7095 set_errno(EACCES); break;
7101 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7102 if (preserve_dates & 2) {
7103 /* sys$close() will process xabrdt, not xabdat */
7104 xabrdt = cc$rms_xabrdt;
7106 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7108 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7109 * is unsigned long[2], while DECC & VAXC use a struct */
7110 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7112 fab_out.fab$l_xab = (void *) &xabrdt;
7115 rab_in = cc$rms_rab;
7116 rab_in.rab$l_fab = &fab_in;
7117 rab_in.rab$l_rop = RAB$M_BIO;
7118 rab_in.rab$l_ubf = ubf;
7119 rab_in.rab$w_usz = sizeof ubf;
7120 if (!((sts = sys$connect(&rab_in)) & 1)) {
7121 sys$close(&fab_in); sys$close(&fab_out);
7122 set_errno(EVMSERR); set_vaxc_errno(sts);
7126 rab_out = cc$rms_rab;
7127 rab_out.rab$l_fab = &fab_out;
7128 rab_out.rab$l_rbf = ubf;
7129 if (!((sts = sys$connect(&rab_out)) & 1)) {
7130 sys$close(&fab_in); sys$close(&fab_out);
7131 set_errno(EVMSERR); set_vaxc_errno(sts);
7135 while ((sts = sys$read(&rab_in))) { /* always true */
7136 if (sts == RMS$_EOF) break;
7137 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7138 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7139 sys$close(&fab_in); sys$close(&fab_out);
7140 set_errno(EVMSERR); set_vaxc_errno(sts);
7145 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7146 sys$close(&fab_in); sys$close(&fab_out);
7147 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7149 set_errno(EVMSERR); set_vaxc_errno(sts);
7155 } /* end of rmscopy() */
7159 /*** The following glue provides 'hooks' to make some of the routines
7160 * from this file available from Perl. These routines are sufficiently
7161 * basic, and are required sufficiently early in the build process,
7162 * that's it's nice to have them available to miniperl as well as the
7163 * full Perl, so they're set up here instead of in an extension. The
7164 * Perl code which handles importation of these names into a given
7165 * package lives in [.VMS]Filespec.pm in @INC.
7169 rmsexpand_fromperl(pTHX_ CV *cv)
7172 char *fspec, *defspec = NULL, *rslt;
7175 if (!items || items > 2)
7176 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7177 fspec = SvPV(ST(0),n_a);
7178 if (!fspec || !*fspec) XSRETURN_UNDEF;
7179 if (items == 2) defspec = SvPV(ST(1),n_a);
7181 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7182 ST(0) = sv_newmortal();
7183 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7188 vmsify_fromperl(pTHX_ CV *cv)
7194 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7195 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7196 ST(0) = sv_newmortal();
7197 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7202 unixify_fromperl(pTHX_ CV *cv)
7208 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7209 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7210 ST(0) = sv_newmortal();
7211 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7216 fileify_fromperl(pTHX_ CV *cv)
7222 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7223 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7224 ST(0) = sv_newmortal();
7225 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7230 pathify_fromperl(pTHX_ CV *cv)
7236 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7237 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7238 ST(0) = sv_newmortal();
7239 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7244 vmspath_fromperl(pTHX_ CV *cv)
7250 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7251 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7252 ST(0) = sv_newmortal();
7253 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7258 unixpath_fromperl(pTHX_ CV *cv)
7264 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7265 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7266 ST(0) = sv_newmortal();
7267 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7272 candelete_fromperl(pTHX_ CV *cv)
7275 char fspec[NAM$C_MAXRSS+1], *fsp;
7280 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7282 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7283 if (SvTYPE(mysv) == SVt_PVGV) {
7284 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7285 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7292 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7293 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7299 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7304 rmscopy_fromperl(pTHX_ CV *cv)
7307 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7309 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7310 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7311 unsigned long int sts;
7316 if (items < 2 || items > 3)
7317 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7319 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7320 if (SvTYPE(mysv) == SVt_PVGV) {
7321 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7322 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7329 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7330 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7335 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7336 if (SvTYPE(mysv) == SVt_PVGV) {
7337 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7338 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7345 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7346 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7351 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7353 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7359 mod2fname(pTHX_ CV *cv)
7362 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7363 workbuff[NAM$C_MAXRSS*1 + 1];
7364 int total_namelen = 3, counter, num_entries;
7365 /* ODS-5 ups this, but we want to be consistent, so... */
7366 int max_name_len = 39;
7367 AV *in_array = (AV *)SvRV(ST(0));
7369 num_entries = av_len(in_array);
7371 /* All the names start with PL_. */
7372 strcpy(ultimate_name, "PL_");
7374 /* Clean up our working buffer */
7375 Zero(work_name, sizeof(work_name), char);
7377 /* Run through the entries and build up a working name */
7378 for(counter = 0; counter <= num_entries; counter++) {
7379 /* If it's not the first name then tack on a __ */
7381 strcat(work_name, "__");
7383 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7387 /* Check to see if we actually have to bother...*/
7388 if (strlen(work_name) + 3 <= max_name_len) {
7389 strcat(ultimate_name, work_name);
7391 /* It's too darned big, so we need to go strip. We use the same */
7392 /* algorithm as xsubpp does. First, strip out doubled __ */
7393 char *source, *dest, last;
7396 for (source = work_name; *source; source++) {
7397 if (last == *source && last == '_') {
7403 /* Go put it back */
7404 strcpy(work_name, workbuff);
7405 /* Is it still too big? */
7406 if (strlen(work_name) + 3 > max_name_len) {
7407 /* Strip duplicate letters */
7410 for (source = work_name; *source; source++) {
7411 if (last == toupper(*source)) {
7415 last = toupper(*source);
7417 strcpy(work_name, workbuff);
7420 /* Is it *still* too big? */
7421 if (strlen(work_name) + 3 > max_name_len) {
7422 /* Too bad, we truncate */
7423 work_name[max_name_len - 2] = 0;
7425 strcat(ultimate_name, work_name);
7428 /* Okay, return it */
7429 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7434 hushexit_fromperl(pTHX_ CV *cv)
7439 VMSISH_HUSHED = SvTRUE(ST(0));
7441 ST(0) = boolSV(VMSISH_HUSHED);
7446 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7447 struct interp_intern *dst)
7449 memcpy(dst,src,sizeof(struct interp_intern));
7453 Perl_sys_intern_clear(pTHX)
7458 Perl_sys_intern_init(pTHX)
7460 unsigned int ix = RAND_MAX;
7466 MY_INV_RAND_MAX = 1./x;
7473 char* file = __FILE__;
7474 char temp_buff[512];
7475 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7476 no_translate_barewords = TRUE;
7478 no_translate_barewords = FALSE;
7481 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7482 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7483 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7484 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7485 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7486 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7487 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7488 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7489 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7490 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7491 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7493 store_pipelocs(aTHX); /* will redo any earlier attempts */