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 lnmdsc.dsc$w_length == (eq - environ[i]) &&
226 !strncmp(environ[i],uplnm,eq - environ[i])) {
228 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
229 if (!eqvlen) continue;
234 if (retsts != SS$_NOLOGNAM) break;
237 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
238 !str$case_blind_compare(&tmpdsc,&clisym)) {
239 if (!ivsym && !secure) {
240 unsigned short int deflen = LNM$C_NAMLENGTH;
241 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
242 /* dynamic dsc to accomodate possible long value */
243 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
244 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
247 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
249 /* Special hack--we might be called before the interpreter's */
250 /* fully initialized, in which case either thr or PL_curcop */
251 /* might be bogus. We have to check, since ckWARN needs them */
252 /* both to be valid if running threaded */
253 if (ckWARN(WARN_MISC)) {
254 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
257 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
259 _ckvmssts(lib$sfree1_dd(&eqvdsc));
260 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
261 if (retsts == LIB$_NOSUCHSYM) continue;
266 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
267 midx = my_maxidx((char *) lnm);
268 for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
269 lnmlst[1].bufadr = cp1;
271 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
272 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
273 if (retsts == SS$_NOLOGNAM) break;
274 /* PPFs have a prefix */
277 *((int *)uplnm) == *((int *)"SYS$") &&
279 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
280 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
281 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
282 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
283 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
284 memcpy(eqv,eqv+4,eqvlen-4);
290 if ((retsts == SS$_IVLOGNAM) ||
291 (retsts == SS$_NOLOGNAM)) { continue; }
294 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
295 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
296 if (retsts == SS$_NOLOGNAM) continue;
299 eqvlen = strlen(eqv);
303 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
304 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
305 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
306 retsts == SS$_NOLOGNAM) {
307 set_errno(EINVAL); set_vaxc_errno(retsts);
309 else _ckvmssts(retsts);
311 } /* end of vmstrnenv */
314 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
315 /* Define as a function so we can access statics. */
316 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
318 return vmstrnenv(lnm,eqv,idx,fildev,
319 #ifdef SECURE_INTERNAL_GETENV
320 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
329 * Note: Uses Perl temp to store result so char * can be returned to
330 * caller; this pointer will be invalidated at next Perl statement
332 * We define this as a function rather than a macro in terms of my_getenv_len()
333 * so that it'll work when PL_curinterp is undefined (and we therefore can't
336 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
338 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
340 static char *__my_getenv_eqv = NULL;
341 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
342 unsigned long int idx = 0;
343 int trnsuccess, success, secure, saverr, savvmserr;
347 midx = my_maxidx((char *) lnm) + 1;
349 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
350 /* Set up a temporary buffer for the return value; Perl will
351 * clean it up at the next statement transition */
352 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
353 if (!tmpsv) return NULL;
357 /* Assume no interpreter ==> single thread */
358 if (__my_getenv_eqv != NULL) {
359 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
362 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
364 eqv = __my_getenv_eqv;
367 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
368 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
369 getcwd(eqv,LNM$C_NAMLENGTH);
373 /* Impose security constraints only if tainting */
375 /* Impose security constraints only if tainting */
376 secure = PL_curinterp ? PL_tainting : will_taint;
377 saverr = errno; savvmserr = vaxc$errno;
384 #ifdef SECURE_INTERNAL_GETENV
385 secure ? PERL__TRNENV_SECURE : 0
391 /* For the getenv interface we combine all the equivalence names
392 * of a search list logical into one value to acquire a maximum
393 * value length of 255*128 (assuming %ENV is using logicals).
395 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
397 /* If the name contains a semicolon-delimited index, parse it
398 * off and make sure we only retrieve the equivalence name for
400 if ((cp2 = strchr(lnm,';')) != NULL) {
402 uplnm[cp2-lnm] = '\0';
403 idx = strtoul(cp2+1,NULL,0);
405 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
408 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
410 /* Discard NOLOGNAM on internal calls since we're often looking
411 * for an optional name, and this "error" often shows up as the
412 * (bogus) exit status for a die() call later on. */
413 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
414 return success ? eqv : Nullch;
417 } /* end of my_getenv() */
421 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
423 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
425 char *buf, *cp1, *cp2;
426 unsigned long idx = 0;
428 static char *__my_getenv_len_eqv = NULL;
429 int secure, saverr, savvmserr;
432 midx = my_maxidx((char *) lnm) + 1;
434 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
435 /* Set up a temporary buffer for the return value; Perl will
436 * clean it up at the next statement transition */
437 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
438 if (!tmpsv) return NULL;
442 /* Assume no interpreter ==> single thread */
443 if (__my_getenv_len_eqv != NULL) {
444 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
447 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
449 buf = __my_getenv_len_eqv;
452 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
453 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
454 getcwd(buf,LNM$C_NAMLENGTH);
460 /* Impose security constraints only if tainting */
461 secure = PL_curinterp ? PL_tainting : will_taint;
462 saverr = errno; savvmserr = vaxc$errno;
469 #ifdef SECURE_INTERNAL_GETENV
470 secure ? PERL__TRNENV_SECURE : 0
476 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
478 if ((cp2 = strchr(lnm,';')) != NULL) {
481 idx = strtoul(cp2+1,NULL,0);
483 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
486 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
488 /* Discard NOLOGNAM on internal calls since we're often looking
489 * for an optional name, and this "error" often shows up as the
490 * (bogus) exit status for a die() call later on. */
491 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
492 return *len ? buf : Nullch;
495 } /* end of my_getenv_len() */
498 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
500 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
502 /*{{{ void prime_env_iter() */
505 /* Fill the %ENV associative array with all logical names we can
506 * find, in preparation for iterating over it.
509 static int primed = 0;
510 HV *seenhv = NULL, *envhv;
512 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
513 unsigned short int chan;
514 #ifndef CLI$M_TRUSTED
515 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
517 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
518 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
520 bool have_sym = FALSE, have_lnm = FALSE;
521 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
522 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
523 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
524 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
525 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
526 #if defined(PERL_IMPLICIT_CONTEXT)
529 #if defined(USE_ITHREADS)
530 static perl_mutex primenv_mutex;
531 MUTEX_INIT(&primenv_mutex);
534 #if defined(PERL_IMPLICIT_CONTEXT)
535 /* We jump through these hoops because we can be called at */
536 /* platform-specific initialization time, which is before anything is */
537 /* set up--we can't even do a plain dTHX since that relies on the */
538 /* interpreter structure to be initialized */
540 aTHX = PERL_GET_INTERP;
546 if (primed || !PL_envgv) return;
547 MUTEX_LOCK(&primenv_mutex);
548 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
549 envhv = GvHVn(PL_envgv);
550 /* Perform a dummy fetch as an lval to insure that the hash table is
551 * set up. Otherwise, the hv_store() will turn into a nullop. */
552 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
554 for (i = 0; env_tables[i]; i++) {
555 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
556 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
557 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
559 if (have_sym || have_lnm) {
560 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
561 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
562 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
563 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
566 for (i--; i >= 0; i--) {
567 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
570 for (j = 0; environ[j]; j++) {
571 if (!(start = strchr(environ[j],'='))) {
572 if (ckWARN(WARN_INTERNAL))
573 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
577 sv = newSVpv(start,0);
579 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
584 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
585 !str$case_blind_compare(&tmpdsc,&clisym)) {
586 strcpy(cmd,"Show Symbol/Global *");
587 cmddsc.dsc$w_length = 20;
588 if (env_tables[i]->dsc$w_length == 12 &&
589 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
590 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
591 flags = defflags | CLI$M_NOLOGNAM;
594 strcpy(cmd,"Show Logical *");
595 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
596 strcat(cmd," /Table=");
597 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
598 cmddsc.dsc$w_length = strlen(cmd);
600 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
601 flags = defflags | CLI$M_NOCLISYM;
604 /* Create a new subprocess to execute each command, to exclude the
605 * remote possibility that someone could subvert a mbx or file used
606 * to write multiple commands to a single subprocess.
609 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
610 0,&riseandshine,0,0,&clidsc,&clitabdsc);
611 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
612 defflags &= ~CLI$M_TRUSTED;
613 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
615 if (!buf) Newx(buf,mbxbufsiz + 1,char);
616 if (seenhv) SvREFCNT_dec(seenhv);
619 char *cp1, *cp2, *key;
620 unsigned long int sts, iosb[2], retlen, keylen;
623 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
624 if (sts & 1) sts = iosb[0] & 0xffff;
625 if (sts == SS$_ENDOFFILE) {
627 while (substs == 0) { sys$hiber(); wakect++;}
628 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
633 retlen = iosb[0] >> 16;
634 if (!retlen) continue; /* blank line */
636 if (iosb[1] != subpid) {
638 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
642 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
643 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
645 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
646 if (*cp1 == '(' || /* Logical name table name */
647 *cp1 == '=' /* Next eqv of searchlist */) continue;
648 if (*cp1 == '"') cp1++;
649 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
650 key = cp1; keylen = cp2 - cp1;
651 if (keylen && hv_exists(seenhv,key,keylen)) continue;
652 while (*cp2 && *cp2 != '=') cp2++;
653 while (*cp2 && *cp2 == '=') cp2++;
654 while (*cp2 && *cp2 == ' ') cp2++;
655 if (*cp2 == '"') { /* String translation; may embed "" */
656 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
657 cp2++; cp1--; /* Skip "" surrounding translation */
659 else { /* Numeric translation */
660 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
661 cp1--; /* stop on last non-space char */
663 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
664 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
667 PERL_HASH(hash,key,keylen);
669 if (cp1 == cp2 && *cp2 == '.') {
670 /* A single dot usually means an unprintable character, such as a null
671 * to indicate a zero-length value. Get the actual value to make sure.
673 char lnm[LNM$C_NAMLENGTH+1];
674 char eqv[LNM$C_NAMLENGTH+1];
675 strncpy(lnm, key, keylen);
676 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
677 sv = newSVpvn(eqv, strlen(eqv));
680 sv = newSVpvn(cp2,cp1 - cp2 + 1);
684 hv_store(envhv,key,keylen,sv,hash);
685 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
687 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
688 /* get the PPFs for this process, not the subprocess */
689 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
690 char eqv[LNM$C_NAMLENGTH+1];
692 for (i = 0; ppfs[i]; i++) {
693 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
694 sv = newSVpv(eqv,trnlen);
696 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
701 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
702 if (buf) Safefree(buf);
703 if (seenhv) SvREFCNT_dec(seenhv);
704 MUTEX_UNLOCK(&primenv_mutex);
707 } /* end of prime_env_iter */
711 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
712 /* Define or delete an element in the same "environment" as
713 * vmstrnenv(). If an element is to be deleted, it's removed from
714 * the first place it's found. If it's to be set, it's set in the
715 * place designated by the first element of the table vector.
716 * Like setenv() returns 0 for success, non-zero on error.
719 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
721 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
722 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
724 unsigned long int retsts, usermode = PSL$C_USER;
725 struct itmlst_3 *ile, *ilist;
726 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
727 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
728 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
729 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
730 $DESCRIPTOR(local,"_LOCAL");
733 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
737 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
738 *cp2 = _toupper(*cp1);
739 if (cp1 - lnm > LNM$C_NAMLENGTH) {
740 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
744 lnmdsc.dsc$w_length = cp1 - lnm;
745 if (!tabvec || !*tabvec) tabvec = env_tables;
747 if (!eqv) { /* we're deleting n element */
748 for (curtab = 0; tabvec[curtab]; curtab++) {
749 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
751 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
752 if ((cp1 = strchr(environ[i],'=')) &&
753 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
754 !strncmp(environ[i],lnm,cp1 - environ[i])) {
756 return setenv(lnm,"",1) ? vaxc$errno : 0;
759 ivenv = 1; retsts = SS$_NOLOGNAM;
761 if (ckWARN(WARN_INTERNAL))
762 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
763 ivenv = 1; retsts = SS$_NOSUCHPGM;
769 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
770 !str$case_blind_compare(&tmpdsc,&clisym)) {
771 unsigned int symtype;
772 if (tabvec[curtab]->dsc$w_length == 12 &&
773 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
774 !str$case_blind_compare(&tmpdsc,&local))
775 symtype = LIB$K_CLI_LOCAL_SYM;
776 else symtype = LIB$K_CLI_GLOBAL_SYM;
777 retsts = lib$delete_symbol(&lnmdsc,&symtype);
778 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
779 if (retsts == LIB$_NOSUCHSYM) continue;
783 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
784 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
785 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
786 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
787 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
791 else { /* we're defining a value */
792 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
794 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
796 if (ckWARN(WARN_INTERNAL))
797 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
798 retsts = SS$_NOSUCHPGM;
802 eqvdsc.dsc$a_pointer = (char *)eqv;
803 eqvdsc.dsc$w_length = strlen(eqv);
804 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
805 !str$case_blind_compare(&tmpdsc,&clisym)) {
806 unsigned int symtype;
807 if (tabvec[0]->dsc$w_length == 12 &&
808 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
809 !str$case_blind_compare(&tmpdsc,&local))
810 symtype = LIB$K_CLI_LOCAL_SYM;
811 else symtype = LIB$K_CLI_GLOBAL_SYM;
812 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
815 if (!*eqv) eqvdsc.dsc$w_length = 1;
816 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
818 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
819 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
820 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
821 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
822 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
823 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
826 Newx(ilist,nseg+1,struct itmlst_3);
829 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
832 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
834 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
835 ile->itmcode = LNM$_STRING;
838 ile->buflen = strlen(c);
839 /* in case we are truncating one that's too long */
840 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
843 ile->buflen = LNM$C_NAMLENGTH;
847 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
851 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
858 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
859 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
860 set_errno(EVMSERR); break;
861 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
862 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
863 set_errno(EINVAL); break;
870 set_vaxc_errno(retsts);
871 return (int) retsts || 44; /* retsts should never be 0, but just in case */
874 /* We reset error values on success because Perl does an hv_fetch()
875 * before each hv_store(), and if the thing we're setting didn't
876 * previously exist, we've got a leftover error message. (Of course,
877 * this fails in the face of
878 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
879 * in that the error reported in $! isn't spurious,
880 * but it's right more often than not.)
882 set_errno(0); set_vaxc_errno(retsts);
886 } /* end of vmssetenv() */
889 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
890 /* This has to be a function since there's a prototype for it in proto.h */
892 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
895 int len = strlen(lnm);
899 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
900 if (!strcmp(uplnm,"DEFAULT")) {
901 if (eqv && *eqv) chdir(eqv);
906 if (len == 6 || len == 2) {
909 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
911 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
912 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
916 (void) vmssetenv(lnm,eqv,NULL);
920 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
922 * sets a user-mode logical in the process logical name table
923 * used for redirection of sys$error
926 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
928 $DESCRIPTOR(d_tab, "LNM$PROCESS");
929 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
930 unsigned long int iss, attr = LNM$M_CONFINE;
931 unsigned char acmode = PSL$C_USER;
932 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
934 d_name.dsc$a_pointer = name;
935 d_name.dsc$w_length = strlen(name);
937 lnmlst[0].buflen = strlen(eqv);
938 lnmlst[0].bufadr = eqv;
940 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
941 if (!(iss&1)) lib$signal(iss);
946 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
947 /* my_crypt - VMS password hashing
948 * my_crypt() provides an interface compatible with the Unix crypt()
949 * C library function, and uses sys$hash_password() to perform VMS
950 * password hashing. The quadword hashed password value is returned
951 * as a NUL-terminated 8 character string. my_crypt() does not change
952 * the case of its string arguments; in order to match the behavior
953 * of LOGINOUT et al., alphabetic characters in both arguments must
954 * be upcased by the caller.
957 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
959 # ifndef UAI$C_PREFERRED_ALGORITHM
960 # define UAI$C_PREFERRED_ALGORITHM 127
962 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
963 unsigned short int salt = 0;
964 unsigned long int sts;
966 unsigned short int dsc$w_length;
967 unsigned char dsc$b_type;
968 unsigned char dsc$b_class;
969 const char * dsc$a_pointer;
970 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
971 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
972 struct itmlst_3 uailst[3] = {
973 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
974 { sizeof salt, UAI$_SALT, &salt, 0},
975 { 0, 0, NULL, NULL}};
978 usrdsc.dsc$w_length = strlen(usrname);
979 usrdsc.dsc$a_pointer = usrname;
980 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
982 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
986 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
992 if (sts != RMS$_RNF) return NULL;
995 txtdsc.dsc$w_length = strlen(textpasswd);
996 txtdsc.dsc$a_pointer = textpasswd;
997 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
998 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1001 return (char *) hash;
1003 } /* end of my_crypt() */
1007 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
1008 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
1009 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
1011 /*{{{int do_rmdir(char *name)*/
1013 Perl_do_rmdir(pTHX_ char *name)
1015 char dirfile[NAM$C_MAXRSS+1];
1019 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1020 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1021 else retval = kill_file(dirfile);
1024 } /* end of do_rmdir */
1028 * Delete any file to which user has control access, regardless of whether
1029 * delete access is explicitly allowed.
1030 * Limitations: User must have write access to parent directory.
1031 * Does not block signals or ASTs; if interrupted in midstream
1032 * may leave file with an altered ACL.
1035 /*{{{int kill_file(char *name)*/
1037 Perl_kill_file(pTHX_ char *name)
1039 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1040 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1041 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1042 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1044 unsigned char myace$b_length;
1045 unsigned char myace$b_type;
1046 unsigned short int myace$w_flags;
1047 unsigned long int myace$l_access;
1048 unsigned long int myace$l_ident;
1049 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1050 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1051 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1053 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1054 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1055 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1056 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1057 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1058 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1060 /* Expand the input spec using RMS, since the CRTL remove() and
1061 * system services won't do this by themselves, so we may miss
1062 * a file "hiding" behind a logical name or search list. */
1063 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1064 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1065 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1066 /* If not, can changing protections help? */
1067 if (vaxc$errno != RMS$_PRV) return -1;
1069 /* No, so we get our own UIC to use as a rights identifier,
1070 * and the insert an ACE at the head of the ACL which allows us
1071 * to delete the file.
1073 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1074 fildsc.dsc$w_length = strlen(rspec);
1075 fildsc.dsc$a_pointer = rspec;
1077 newace.myace$l_ident = oldace.myace$l_ident;
1078 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1080 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1081 set_errno(ENOENT); break;
1083 set_errno(ENOTDIR); break;
1085 set_errno(ENODEV); break;
1086 case RMS$_SYN: case SS$_INVFILFOROP:
1087 set_errno(EINVAL); break;
1089 set_errno(EACCES); break;
1093 set_vaxc_errno(aclsts);
1096 /* Grab any existing ACEs with this identifier in case we fail */
1097 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1098 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1099 || fndsts == SS$_NOMOREACE ) {
1100 /* Add the new ACE . . . */
1101 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1103 if ((rmsts = remove(name))) {
1104 /* We blew it - dir with files in it, no write priv for
1105 * parent directory, etc. Put things back the way they were. */
1106 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1109 addlst[0].bufadr = &oldace;
1110 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1117 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1118 /* We just deleted it, so of course it's not there. Some versions of
1119 * VMS seem to return success on the unlock operation anyhow (after all
1120 * the unlock is successful), but others don't.
1122 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1123 if (aclsts & 1) aclsts = fndsts;
1124 if (!(aclsts & 1)) {
1126 set_vaxc_errno(aclsts);
1132 } /* end of kill_file() */
1136 /*{{{int my_mkdir(char *,Mode_t)*/
1138 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1140 STRLEN dirlen = strlen(dir);
1142 /* zero length string sometimes gives ACCVIO */
1143 if (dirlen == 0) return -1;
1145 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1146 * null file name/type. However, it's commonplace under Unix,
1147 * so we'll allow it for a gain in portability.
1149 if (dir[dirlen-1] == '/') {
1150 char *newdir = savepvn(dir,dirlen-1);
1151 int ret = mkdir(newdir,mode);
1155 else return mkdir(dir,mode);
1156 } /* end of my_mkdir */
1159 /*{{{int my_chdir(char *)*/
1161 Perl_my_chdir(pTHX_ char *dir)
1163 STRLEN dirlen = strlen(dir);
1165 /* zero length string sometimes gives ACCVIO */
1166 if (dirlen == 0) return -1;
1168 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1170 * null file name/type. However, it's commonplace under Unix,
1171 * so we'll allow it for a gain in portability.
1173 if (dir[dirlen-1] == '/') {
1174 char *newdir = savepvn(dir,dirlen-1);
1175 int ret = chdir(newdir);
1179 else return chdir(dir);
1180 } /* end of my_chdir */
1184 /*{{{FILE *my_tmpfile()*/
1191 if ((fp = tmpfile())) return fp;
1193 Newx(cp,L_tmpnam+24,char);
1194 strcpy(cp,"Sys$Scratch:");
1195 tmpnam(cp+strlen(cp));
1196 strcat(cp,".Perltmp");
1197 fp = fopen(cp,"w+","fop=dlt");
1204 #ifndef HOMEGROWN_POSIX_SIGNALS
1206 * The C RTL's sigaction fails to check for invalid signal numbers so we
1207 * help it out a bit. The docs are correct, but the actual routine doesn't
1208 * do what the docs say it will.
1210 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1212 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1213 struct sigaction* oact)
1215 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1216 SETERRNO(EINVAL, SS$_INVARG);
1219 return sigaction(sig, act, oact);
1224 #ifdef KILL_BY_SIGPRC
1225 #include <errnodef.h>
1227 /* We implement our own kill() using the undocumented system service
1228 sys$sigprc for one of two reasons:
1230 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1231 target process to do a sys$exit, which usually can't be handled
1232 gracefully...certainly not by Perl and the %SIG{} mechanism.
1234 2.) If the kill() in the CRTL can't be called from a signal
1235 handler without disappearing into the ether, i.e., the signal
1236 it purportedly sends is never trapped. Still true as of VMS 7.3.
1238 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1239 in the target process rather than calling sys$exit.
1241 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1242 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1243 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1244 with condition codes C$_SIG0+nsig*8, catching the exception on the
1245 target process and resignaling with appropriate arguments.
1247 But we don't have that VMS 7.0+ exception handler, so if you
1248 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1250 Also note that SIGTERM is listed in the docs as being "unimplemented",
1251 yet always seems to be signaled with a VMS condition code of 4 (and
1252 correctly handled for that code). So we hardwire it in.
1254 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1255 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1256 than signalling with an unrecognized (and unhandled by CRTL) code.
1259 #define _MY_SIG_MAX 17
1262 Perl_sig_to_vmscondition(int sig)
1264 static unsigned int sig_code[_MY_SIG_MAX+1] =
1267 SS$_HANGUP, /* 1 SIGHUP */
1268 SS$_CONTROLC, /* 2 SIGINT */
1269 SS$_CONTROLY, /* 3 SIGQUIT */
1270 SS$_RADRMOD, /* 4 SIGILL */
1271 SS$_BREAK, /* 5 SIGTRAP */
1272 SS$_OPCCUS, /* 6 SIGABRT */
1273 SS$_COMPAT, /* 7 SIGEMT */
1275 SS$_FLTOVF, /* 8 SIGFPE VAX */
1277 SS$_HPARITH, /* 8 SIGFPE AXP */
1279 SS$_ABORT, /* 9 SIGKILL */
1280 SS$_ACCVIO, /* 10 SIGBUS */
1281 SS$_ACCVIO, /* 11 SIGSEGV */
1282 SS$_BADPARAM, /* 12 SIGSYS */
1283 SS$_NOMBX, /* 13 SIGPIPE */
1284 SS$_ASTFLT, /* 14 SIGALRM */
1290 #if __VMS_VER >= 60200000
1291 static int initted = 0;
1294 sig_code[16] = C$_SIGUSR1;
1295 sig_code[17] = C$_SIGUSR2;
1299 if (sig < _SIG_MIN) return 0;
1300 if (sig > _MY_SIG_MAX) return 0;
1301 return sig_code[sig];
1306 Perl_my_kill(int pid, int sig)
1311 int sys$sigprc(unsigned int *pidadr,
1312 struct dsc$descriptor_s *prcname,
1315 code = Perl_sig_to_vmscondition(sig);
1317 if (!pid || !code) {
1321 iss = sys$sigprc((unsigned int *)&pid,0,code);
1322 if (iss&1) return 0;
1326 set_errno(EPERM); break;
1328 case SS$_NOSUCHNODE:
1329 case SS$_UNREACHABLE:
1330 set_errno(ESRCH); break;
1332 set_errno(ENOMEM); break;
1337 set_vaxc_errno(iss);
1343 /* default piping mailbox size */
1344 #define PERL_BUFSIZ 512
1348 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1350 unsigned long int mbxbufsiz;
1351 static unsigned long int syssize = 0;
1352 unsigned long int dviitm = DVI$_DEVNAM;
1353 char csize[LNM$C_NAMLENGTH+1];
1356 unsigned long syiitm = SYI$_MAXBUF;
1358 * Get the SYSGEN parameter MAXBUF
1360 * If the logical 'PERL_MBX_SIZE' is defined
1361 * use the value of the logical instead of PERL_BUFSIZ, but
1362 * keep the size between 128 and MAXBUF.
1365 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1368 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1369 mbxbufsiz = atoi(csize);
1371 mbxbufsiz = PERL_BUFSIZ;
1373 if (mbxbufsiz < 128) mbxbufsiz = 128;
1374 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1376 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1378 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1379 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1381 } /* end of create_mbx() */
1384 /*{{{ my_popen and my_pclose*/
1386 typedef struct _iosb IOSB;
1387 typedef struct _iosb* pIOSB;
1388 typedef struct _pipe Pipe;
1389 typedef struct _pipe* pPipe;
1390 typedef struct pipe_details Info;
1391 typedef struct pipe_details* pInfo;
1392 typedef struct _srqp RQE;
1393 typedef struct _srqp* pRQE;
1394 typedef struct _tochildbuf CBuf;
1395 typedef struct _tochildbuf* pCBuf;
1398 unsigned short status;
1399 unsigned short count;
1400 unsigned long dvispec;
1403 #pragma member_alignment save
1404 #pragma nomember_alignment quadword
1405 struct _srqp { /* VMS self-relative queue entry */
1406 unsigned long qptr[2];
1408 #pragma member_alignment restore
1409 static RQE RQE_ZERO = {0,0};
1411 struct _tochildbuf {
1414 unsigned short size;
1422 unsigned short chan_in;
1423 unsigned short chan_out;
1425 unsigned int bufsize;
1437 #if defined(PERL_IMPLICIT_CONTEXT)
1438 void *thx; /* Either a thread or an interpreter */
1439 /* pointer, depending on how we're built */
1447 PerlIO *fp; /* file pointer to pipe mailbox */
1448 int useFILE; /* using stdio, not perlio */
1449 int pid; /* PID of subprocess */
1450 int mode; /* == 'r' if pipe open for reading */
1451 int done; /* subprocess has completed */
1452 int waiting; /* waiting for completion/closure */
1453 int closing; /* my_pclose is closing this pipe */
1454 unsigned long completion; /* termination status of subprocess */
1455 pPipe in; /* pipe in to sub */
1456 pPipe out; /* pipe out of sub */
1457 pPipe err; /* pipe of sub's sys$error */
1458 int in_done; /* true when in pipe finished */
1463 struct exit_control_block
1465 struct exit_control_block *flink;
1466 unsigned long int (*exit_routine)();
1467 unsigned long int arg_count;
1468 unsigned long int *status_address;
1469 unsigned long int exit_status;
1472 typedef struct _closed_pipes Xpipe;
1473 typedef struct _closed_pipes* pXpipe;
1475 struct _closed_pipes {
1476 int pid; /* PID of subprocess */
1477 unsigned long completion; /* termination status of subprocess */
1479 #define NKEEPCLOSED 50
1480 static Xpipe closed_list[NKEEPCLOSED];
1481 static int closed_index = 0;
1482 static int closed_num = 0;
1484 #define RETRY_DELAY "0 ::0.20"
1485 #define MAX_RETRY 50
1487 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1488 static unsigned long mypid;
1489 static unsigned long delaytime[2];
1491 static pInfo open_pipes = NULL;
1492 static $DESCRIPTOR(nl_desc, "NL:");
1494 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1498 static unsigned long int
1499 pipe_exit_routine(pTHX)
1502 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1503 int sts, did_stuff, need_eof, j;
1506 flush any pending i/o
1512 PerlIO_flush(info->fp); /* first, flush data */
1514 fflush((FILE *)info->fp);
1520 next we try sending an EOF...ignore if doesn't work, make sure we
1528 _ckvmssts(sys$setast(0));
1529 if (info->in && !info->in->shut_on_empty) {
1530 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1535 _ckvmssts(sys$setast(1));
1539 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1541 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1546 _ckvmssts(sys$setast(0));
1547 if (info->waiting && info->done)
1549 nwait += info->waiting;
1550 _ckvmssts(sys$setast(1));
1560 _ckvmssts(sys$setast(0));
1561 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1562 sts = sys$forcex(&info->pid,0,&abort);
1563 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1566 _ckvmssts(sys$setast(1));
1570 /* again, wait for effect */
1572 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1577 _ckvmssts(sys$setast(0));
1578 if (info->waiting && info->done)
1580 nwait += info->waiting;
1581 _ckvmssts(sys$setast(1));
1590 _ckvmssts(sys$setast(0));
1591 if (!info->done) { /* We tried to be nice . . . */
1592 sts = sys$delprc(&info->pid,0);
1593 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1595 _ckvmssts(sys$setast(1));
1600 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1601 else if (!(sts & 1)) retsts = sts;
1606 static struct exit_control_block pipe_exitblock =
1607 {(struct exit_control_block *) 0,
1608 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1610 static void pipe_mbxtofd_ast(pPipe p);
1611 static void pipe_tochild1_ast(pPipe p);
1612 static void pipe_tochild2_ast(pPipe p);
1615 popen_completion_ast(pInfo info)
1617 pInfo i = open_pipes;
1621 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1622 closed_list[closed_index].pid = info->pid;
1623 closed_list[closed_index].completion = info->completion;
1625 if (closed_index == NKEEPCLOSED)
1630 if (i == info) break;
1633 if (!i) return; /* unlinked, probably freed too */
1638 Writing to subprocess ...
1639 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1641 chan_out may be waiting for "done" flag, or hung waiting
1642 for i/o completion to child...cancel the i/o. This will
1643 put it into "snarf mode" (done but no EOF yet) that discards
1646 Output from subprocess (stdout, stderr) needs to be flushed and
1647 shut down. We try sending an EOF, but if the mbx is full the pipe
1648 routine should still catch the "shut_on_empty" flag, telling it to
1649 use immediate-style reads so that "mbx empty" -> EOF.
1653 if (info->in && !info->in_done) { /* only for mode=w */
1654 if (info->in->shut_on_empty && info->in->need_wake) {
1655 info->in->need_wake = FALSE;
1656 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1658 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1662 if (info->out && !info->out_done) { /* were we also piping output? */
1663 info->out->shut_on_empty = TRUE;
1664 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1665 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1666 _ckvmssts_noperl(iss);
1669 if (info->err && !info->err_done) { /* we were piping stderr */
1670 info->err->shut_on_empty = TRUE;
1671 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1672 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1673 _ckvmssts_noperl(iss);
1675 _ckvmssts_noperl(sys$setef(pipe_ef));
1679 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1680 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1683 we actually differ from vmstrnenv since we use this to
1684 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1685 are pointing to the same thing
1688 static unsigned short
1689 popen_translate(pTHX_ char *logical, char *result)
1692 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1693 $DESCRIPTOR(d_log,"");
1695 unsigned short length;
1696 unsigned short code;
1698 unsigned short *retlenaddr;
1700 unsigned short l, ifi;
1702 d_log.dsc$a_pointer = logical;
1703 d_log.dsc$w_length = strlen(logical);
1705 itmlst[0].code = LNM$_STRING;
1706 itmlst[0].length = 255;
1707 itmlst[0].buffer_addr = result;
1708 itmlst[0].retlenaddr = &l;
1711 itmlst[1].length = 0;
1712 itmlst[1].buffer_addr = 0;
1713 itmlst[1].retlenaddr = 0;
1715 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1716 if (iss == SS$_NOLOGNAM) {
1720 if (!(iss&1)) lib$signal(iss);
1723 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1724 strip it off and return the ifi, if any
1727 if (result[0] == 0x1b && result[1] == 0x00) {
1728 memcpy(&ifi,result+2,2);
1729 strcpy(result,result+4);
1731 return ifi; /* this is the RMS internal file id */
1734 static void pipe_infromchild_ast(pPipe p);
1737 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1738 inside an AST routine without worrying about reentrancy and which Perl
1739 memory allocator is being used.
1741 We read data and queue up the buffers, then spit them out one at a
1742 time to the output mailbox when the output mailbox is ready for one.
1745 #define INITIAL_TOCHILDQUEUE 2
1748 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1752 char mbx1[64], mbx2[64];
1753 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1754 DSC$K_CLASS_S, mbx1},
1755 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1756 DSC$K_CLASS_S, mbx2};
1757 unsigned int dviitm = DVI$_DEVBUFSIZ;
1762 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1763 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1764 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1767 p->shut_on_empty = FALSE;
1768 p->need_wake = FALSE;
1771 p->iosb.status = SS$_NORMAL;
1772 p->iosb2.status = SS$_NORMAL;
1778 #ifdef PERL_IMPLICIT_CONTEXT
1782 n = sizeof(CBuf) + p->bufsize;
1784 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1785 _ckvmssts(lib$get_vm(&n, &b));
1786 b->buf = (char *) b + sizeof(CBuf);
1787 _ckvmssts(lib$insqhi(b, &p->free));
1790 pipe_tochild2_ast(p);
1791 pipe_tochild1_ast(p);
1797 /* reads the MBX Perl is writing, and queues */
1800 pipe_tochild1_ast(pPipe p)
1803 int iss = p->iosb.status;
1804 int eof = (iss == SS$_ENDOFFILE);
1805 #ifdef PERL_IMPLICIT_CONTEXT
1811 p->shut_on_empty = TRUE;
1813 _ckvmssts(sys$dassgn(p->chan_in));
1819 b->size = p->iosb.count;
1820 _ckvmssts(lib$insqhi(b, &p->wait));
1822 p->need_wake = FALSE;
1823 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1826 p->retry = 1; /* initial call */
1829 if (eof) { /* flush the free queue, return when done */
1830 int n = sizeof(CBuf) + p->bufsize;
1832 iss = lib$remqti(&p->free, &b);
1833 if (iss == LIB$_QUEWASEMP) return;
1835 _ckvmssts(lib$free_vm(&n, &b));
1839 iss = lib$remqti(&p->free, &b);
1840 if (iss == LIB$_QUEWASEMP) {
1841 int n = sizeof(CBuf) + p->bufsize;
1842 _ckvmssts(lib$get_vm(&n, &b));
1843 b->buf = (char *) b + sizeof(CBuf);
1849 iss = sys$qio(0,p->chan_in,
1850 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1852 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1853 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1858 /* writes queued buffers to output, waits for each to complete before
1862 pipe_tochild2_ast(pPipe p)
1865 int iss = p->iosb2.status;
1866 int n = sizeof(CBuf) + p->bufsize;
1867 int done = (p->info && p->info->done) ||
1868 iss == SS$_CANCEL || iss == SS$_ABORT;
1869 #if defined(PERL_IMPLICIT_CONTEXT)
1874 if (p->type) { /* type=1 has old buffer, dispose */
1875 if (p->shut_on_empty) {
1876 _ckvmssts(lib$free_vm(&n, &b));
1878 _ckvmssts(lib$insqhi(b, &p->free));
1883 iss = lib$remqti(&p->wait, &b);
1884 if (iss == LIB$_QUEWASEMP) {
1885 if (p->shut_on_empty) {
1887 _ckvmssts(sys$dassgn(p->chan_out));
1888 *p->pipe_done = TRUE;
1889 _ckvmssts(sys$setef(pipe_ef));
1891 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1892 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1896 p->need_wake = TRUE;
1906 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1907 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1909 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1910 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1919 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1922 char mbx1[64], mbx2[64];
1923 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1924 DSC$K_CLASS_S, mbx1},
1925 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1926 DSC$K_CLASS_S, mbx2};
1927 unsigned int dviitm = DVI$_DEVBUFSIZ;
1930 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1931 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1933 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1934 Newx(p->buf, p->bufsize, char);
1935 p->shut_on_empty = FALSE;
1938 p->iosb.status = SS$_NORMAL;
1939 #if defined(PERL_IMPLICIT_CONTEXT)
1942 pipe_infromchild_ast(p);
1950 pipe_infromchild_ast(pPipe p)
1952 int iss = p->iosb.status;
1953 int eof = (iss == SS$_ENDOFFILE);
1954 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1955 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1956 #if defined(PERL_IMPLICIT_CONTEXT)
1960 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1961 _ckvmssts(sys$dassgn(p->chan_out));
1966 input shutdown if EOF from self (done or shut_on_empty)
1967 output shutdown if closing flag set (my_pclose)
1968 send data/eof from child or eof from self
1969 otherwise, re-read (snarf of data from child)
1974 if (myeof && p->chan_in) { /* input shutdown */
1975 _ckvmssts(sys$dassgn(p->chan_in));
1980 if (myeof || kideof) { /* pass EOF to parent */
1981 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1982 pipe_infromchild_ast, p,
1985 } else if (eof) { /* eat EOF --- fall through to read*/
1987 } else { /* transmit data */
1988 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1989 pipe_infromchild_ast,p,
1990 p->buf, p->iosb.count, 0, 0, 0, 0));
1996 /* everything shut? flag as done */
1998 if (!p->chan_in && !p->chan_out) {
1999 *p->pipe_done = TRUE;
2000 _ckvmssts(sys$setef(pipe_ef));
2004 /* write completed (or read, if snarfing from child)
2005 if still have input active,
2006 queue read...immediate mode if shut_on_empty so we get EOF if empty
2008 check if Perl reading, generate EOFs as needed
2014 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2015 pipe_infromchild_ast,p,
2016 p->buf, p->bufsize, 0, 0, 0, 0);
2017 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2019 } else { /* send EOFs for extra reads */
2020 p->iosb.status = SS$_ENDOFFILE;
2021 p->iosb.dvispec = 0;
2022 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2024 pipe_infromchild_ast, p, 0, 0, 0, 0));
2030 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2034 unsigned long dviitm = DVI$_DEVBUFSIZ;
2036 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2037 DSC$K_CLASS_S, mbx};
2039 /* things like terminals and mbx's don't need this filter */
2040 if (fd && fstat(fd,&s) == 0) {
2041 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2042 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2043 DSC$K_CLASS_S, s.st_dev};
2045 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2046 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2047 strcpy(out, s.st_dev);
2053 p->fd_out = dup(fd);
2054 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2055 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2056 Newx(p->buf, p->bufsize+1, char);
2057 p->shut_on_empty = FALSE;
2062 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2063 pipe_mbxtofd_ast, p,
2064 p->buf, p->bufsize, 0, 0, 0, 0));
2070 pipe_mbxtofd_ast(pPipe p)
2072 int iss = p->iosb.status;
2073 int done = p->info->done;
2075 int eof = (iss == SS$_ENDOFFILE);
2076 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2077 int err = !(iss&1) && !eof;
2078 #if defined(PERL_IMPLICIT_CONTEXT)
2082 if (done && myeof) { /* end piping */
2084 sys$dassgn(p->chan_in);
2085 *p->pipe_done = TRUE;
2086 _ckvmssts(sys$setef(pipe_ef));
2090 if (!err && !eof) { /* good data to send to file */
2091 p->buf[p->iosb.count] = '\n';
2092 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2095 if (p->retry < MAX_RETRY) {
2096 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2106 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2107 pipe_mbxtofd_ast, p,
2108 p->buf, p->bufsize, 0, 0, 0, 0);
2109 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2114 typedef struct _pipeloc PLOC;
2115 typedef struct _pipeloc* pPLOC;
2119 char dir[NAM$C_MAXRSS+1];
2121 static pPLOC head_PLOC = 0;
2124 free_pipelocs(pTHX_ void *head)
2127 pPLOC *pHead = (pPLOC *)head;
2139 store_pipelocs(pTHX)
2148 char temp[NAM$C_MAXRSS+1];
2152 free_pipelocs(aTHX_ &head_PLOC);
2154 /* the . directory from @INC comes last */
2157 p->next = head_PLOC;
2159 strcpy(p->dir,"./");
2161 /* get the directory from $^X */
2163 #ifdef PERL_IMPLICIT_CONTEXT
2164 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2166 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2168 strcpy(temp, PL_origargv[0]);
2169 x = strrchr(temp,']');
2172 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2174 p->next = head_PLOC;
2176 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2177 p->dir[NAM$C_MAXRSS] = '\0';
2181 /* reverse order of @INC entries, skip "." since entered above */
2183 #ifdef PERL_IMPLICIT_CONTEXT
2186 if (PL_incgv) av = GvAVn(PL_incgv);
2188 for (i = 0; av && i <= AvFILL(av); i++) {
2189 dirsv = *av_fetch(av,i,TRUE);
2191 if (SvROK(dirsv)) continue;
2192 dir = SvPVx(dirsv,n_a);
2193 if (strcmp(dir,".") == 0) continue;
2194 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2198 p->next = head_PLOC;
2200 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2201 p->dir[NAM$C_MAXRSS] = '\0';
2204 /* most likely spot (ARCHLIB) put first in the list */
2207 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2209 p->next = head_PLOC;
2211 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2212 p->dir[NAM$C_MAXRSS] = '\0';
2221 static int vmspipe_file_status = 0;
2222 static char vmspipe_file[NAM$C_MAXRSS+1];
2224 /* already found? Check and use ... need read+execute permission */
2226 if (vmspipe_file_status == 1) {
2227 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2228 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2229 return vmspipe_file;
2231 vmspipe_file_status = 0;
2234 /* scan through stored @INC, $^X */
2236 if (vmspipe_file_status == 0) {
2237 char file[NAM$C_MAXRSS+1];
2238 pPLOC p = head_PLOC;
2241 strcpy(file, p->dir);
2242 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2243 file[NAM$C_MAXRSS] = '\0';
2246 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2248 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2249 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2250 vmspipe_file_status = 1;
2251 return vmspipe_file;
2254 vmspipe_file_status = -1; /* failed, use tempfiles */
2261 vmspipe_tempfile(pTHX)
2263 char file[NAM$C_MAXRSS+1];
2265 static int index = 0;
2268 /* create a tempfile */
2270 /* we can't go from W, shr=get to R, shr=get without
2271 an intermediate vulnerable state, so don't bother trying...
2273 and lib$spawn doesn't shr=put, so have to close the write
2275 So... match up the creation date/time and the FID to
2276 make sure we're dealing with the same file
2281 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2282 fp = fopen(file,"w");
2284 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2285 fp = fopen(file,"w");
2287 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2288 fp = fopen(file,"w");
2291 if (!fp) return 0; /* we're hosed */
2293 fprintf(fp,"$! 'f$verify(0)'\n");
2294 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2295 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2296 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2297 fprintf(fp,"$ perl_on = \"set noon\"\n");
2298 fprintf(fp,"$ perl_exit = \"exit\"\n");
2299 fprintf(fp,"$ perl_del = \"delete\"\n");
2300 fprintf(fp,"$ pif = \"if\"\n");
2301 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2302 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2303 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2304 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2305 fprintf(fp,"$! --- build command line to get max possible length\n");
2306 fprintf(fp,"$c=perl_popen_cmd0\n");
2307 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2308 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2309 fprintf(fp,"$x=perl_popen_cmd3\n");
2310 fprintf(fp,"$c=c+x\n");
2311 fprintf(fp,"$ perl_on\n");
2312 fprintf(fp,"$ 'c'\n");
2313 fprintf(fp,"$ perl_status = $STATUS\n");
2314 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2315 fprintf(fp,"$ perl_exit 'perl_status'\n");
2318 fgetname(fp, file, 1);
2319 fstat(fileno(fp), &s0);
2322 fp = fopen(file,"r","shr=get");
2324 fstat(fileno(fp), &s1);
2326 if (s0.st_ino[0] != s1.st_ino[0] ||
2327 s0.st_ino[1] != s1.st_ino[1] ||
2328 s0.st_ino[2] != s1.st_ino[2] ||
2329 s0.st_ctime != s1.st_ctime ) {
2340 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2342 static int handler_set_up = FALSE;
2343 unsigned long int sts, flags = CLI$M_NOWAIT;
2344 /* The use of a GLOBAL table (as was done previously) rendered
2345 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2346 * environment. Hence we've switched to LOCAL symbol table.
2348 unsigned int table = LIB$K_CLI_LOCAL_SYM;
2350 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2351 char in[512], out[512], err[512], mbx[512];
2353 char tfilebuf[NAM$C_MAXRSS+1];
2355 char cmd_sym_name[20];
2356 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2357 DSC$K_CLASS_S, symbol};
2358 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2360 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2361 DSC$K_CLASS_S, cmd_sym_name};
2362 struct dsc$descriptor_s *vmscmd;
2363 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2364 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2365 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2367 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2369 /* once-per-program initialization...
2370 note that the SETAST calls and the dual test of pipe_ef
2371 makes sure that only the FIRST thread through here does
2372 the initialization...all other threads wait until it's
2375 Yeah, uglier than a pthread call, it's got all the stuff inline
2376 rather than in a separate routine.
2380 _ckvmssts(sys$setast(0));
2382 unsigned long int pidcode = JPI$_PID;
2383 $DESCRIPTOR(d_delay, RETRY_DELAY);
2384 _ckvmssts(lib$get_ef(&pipe_ef));
2385 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2386 _ckvmssts(sys$bintim(&d_delay, delaytime));
2388 if (!handler_set_up) {
2389 _ckvmssts(sys$dclexh(&pipe_exitblock));
2390 handler_set_up = TRUE;
2392 _ckvmssts(sys$setast(1));
2395 /* see if we can find a VMSPIPE.COM */
2398 vmspipe = find_vmspipe(aTHX);
2400 strcpy(tfilebuf+1,vmspipe);
2401 } else { /* uh, oh...we're in tempfile hell */
2402 tpipe = vmspipe_tempfile(aTHX);
2403 if (!tpipe) { /* a fish popular in Boston */
2404 if (ckWARN(WARN_PIPE)) {
2405 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2409 fgetname(tpipe,tfilebuf+1,1);
2411 vmspipedsc.dsc$a_pointer = tfilebuf;
2412 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2414 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2417 case RMS$_FNF: case RMS$_DNF:
2418 set_errno(ENOENT); break;
2420 set_errno(ENOTDIR); break;
2422 set_errno(ENODEV); break;
2424 set_errno(EACCES); break;
2426 set_errno(EINVAL); break;
2427 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2428 set_errno(E2BIG); break;
2429 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2430 _ckvmssts(sts); /* fall through */
2431 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2434 set_vaxc_errno(sts);
2435 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2436 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2443 strcpy(mode,in_mode);
2446 info->completion = 0;
2447 info->closing = FALSE;
2454 info->in_done = TRUE;
2455 info->out_done = TRUE;
2456 info->err_done = TRUE;
2457 in[0] = out[0] = err[0] = '\0';
2459 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2463 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2468 if (*mode == 'r') { /* piping from subroutine */
2470 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2472 info->out->pipe_done = &info->out_done;
2473 info->out_done = FALSE;
2474 info->out->info = info;
2476 if (!info->useFILE) {
2477 info->fp = PerlIO_open(mbx, mode);
2479 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2480 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2483 if (!info->fp && info->out) {
2484 sys$cancel(info->out->chan_out);
2486 while (!info->out_done) {
2488 _ckvmssts(sys$setast(0));
2489 done = info->out_done;
2490 if (!done) _ckvmssts(sys$clref(pipe_ef));
2491 _ckvmssts(sys$setast(1));
2492 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2495 if (info->out->buf) Safefree(info->out->buf);
2496 Safefree(info->out);
2502 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2504 info->err->pipe_done = &info->err_done;
2505 info->err_done = FALSE;
2506 info->err->info = info;
2509 } else if (*mode == 'w') { /* piping to subroutine */
2511 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2513 info->out->pipe_done = &info->out_done;
2514 info->out_done = FALSE;
2515 info->out->info = info;
2518 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2520 info->err->pipe_done = &info->err_done;
2521 info->err_done = FALSE;
2522 info->err->info = info;
2525 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2526 if (!info->useFILE) {
2527 info->fp = PerlIO_open(mbx, mode);
2529 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2530 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2534 info->in->pipe_done = &info->in_done;
2535 info->in_done = FALSE;
2536 info->in->info = info;
2540 if (!info->fp && info->in) {
2542 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2543 0, 0, 0, 0, 0, 0, 0, 0));
2545 while (!info->in_done) {
2547 _ckvmssts(sys$setast(0));
2548 done = info->in_done;
2549 if (!done) _ckvmssts(sys$clref(pipe_ef));
2550 _ckvmssts(sys$setast(1));
2551 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2554 if (info->in->buf) Safefree(info->in->buf);
2562 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2563 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2565 info->out->pipe_done = &info->out_done;
2566 info->out_done = FALSE;
2567 info->out->info = info;
2570 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2572 info->err->pipe_done = &info->err_done;
2573 info->err_done = FALSE;
2574 info->err->info = info;
2578 symbol[MAX_DCL_SYMBOL] = '\0';
2580 strncpy(symbol, in, MAX_DCL_SYMBOL);
2581 d_symbol.dsc$w_length = strlen(symbol);
2582 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2584 strncpy(symbol, err, MAX_DCL_SYMBOL);
2585 d_symbol.dsc$w_length = strlen(symbol);
2586 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2588 strncpy(symbol, out, MAX_DCL_SYMBOL);
2589 d_symbol.dsc$w_length = strlen(symbol);
2590 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2592 p = vmscmd->dsc$a_pointer;
2593 while (*p && *p != '\n') p++;
2594 *p = '\0'; /* truncate on \n */
2595 p = vmscmd->dsc$a_pointer;
2596 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2597 if (*p == '$') p++; /* remove leading $ */
2598 while (*p == ' ' || *p == '\t') p++;
2600 for (j = 0; j < 4; j++) {
2601 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2602 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2604 strncpy(symbol, p, MAX_DCL_SYMBOL);
2605 d_symbol.dsc$w_length = strlen(symbol);
2606 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2608 if (strlen(p) > MAX_DCL_SYMBOL) {
2609 p += MAX_DCL_SYMBOL;
2614 _ckvmssts(sys$setast(0));
2615 info->next=open_pipes; /* prepend to list */
2617 _ckvmssts(sys$setast(1));
2618 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2619 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2620 * have SYS$COMMAND if we need it.
2622 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2623 0, &info->pid, &info->completion,
2624 0, popen_completion_ast,info,0,0,0));
2626 /* if we were using a tempfile, close it now */
2628 if (tpipe) fclose(tpipe);
2630 /* once the subprocess is spawned, it has copied the symbols and
2631 we can get rid of ours */
2633 for (j = 0; j < 4; j++) {
2634 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2635 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2636 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2638 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2639 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2640 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2641 vms_execfree(vmscmd);
2643 #ifdef PERL_IMPLICIT_CONTEXT
2646 PL_forkprocess = info->pid;
2651 _ckvmssts(sys$setast(0));
2653 if (!done) _ckvmssts(sys$clref(pipe_ef));
2654 _ckvmssts(sys$setast(1));
2655 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2657 *psts = info->completion;
2658 my_pclose(info->fp);
2663 } /* end of safe_popen */
2666 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2668 Perl_my_popen(pTHX_ char *cmd, char *mode)
2672 TAINT_PROPER("popen");
2673 PERL_FLUSHALL_FOR_CHILD;
2674 return safe_popen(aTHX_ cmd,mode,&sts);
2679 /*{{{ I32 my_pclose(PerlIO *fp)*/
2680 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2682 pInfo info, last = NULL;
2683 unsigned long int retsts;
2686 for (info = open_pipes; info != NULL; last = info, info = info->next)
2687 if (info->fp == fp) break;
2689 if (info == NULL) { /* no such pipe open */
2690 set_errno(ECHILD); /* quoth POSIX */
2691 set_vaxc_errno(SS$_NONEXPR);
2695 /* If we were writing to a subprocess, insure that someone reading from
2696 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2697 * produce an EOF record in the mailbox.
2699 * well, at least sometimes it *does*, so we have to watch out for
2700 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2704 PerlIO_flush(info->fp); /* first, flush data */
2706 fflush((FILE *)info->fp);
2709 _ckvmssts(sys$setast(0));
2710 info->closing = TRUE;
2711 done = info->done && info->in_done && info->out_done && info->err_done;
2712 /* hanging on write to Perl's input? cancel it */
2713 if (info->mode == 'r' && info->out && !info->out_done) {
2714 if (info->out->chan_out) {
2715 _ckvmssts(sys$cancel(info->out->chan_out));
2716 if (!info->out->chan_in) { /* EOF generation, need AST */
2717 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2721 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2722 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2724 _ckvmssts(sys$setast(1));
2727 PerlIO_close(info->fp);
2729 fclose((FILE *)info->fp);
2732 we have to wait until subprocess completes, but ALSO wait until all
2733 the i/o completes...otherwise we'll be freeing the "info" structure
2734 that the i/o ASTs could still be using...
2738 _ckvmssts(sys$setast(0));
2739 done = info->done && info->in_done && info->out_done && info->err_done;
2740 if (!done) _ckvmssts(sys$clref(pipe_ef));
2741 _ckvmssts(sys$setast(1));
2742 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2744 retsts = info->completion;
2746 /* remove from list of open pipes */
2747 _ckvmssts(sys$setast(0));
2748 if (last) last->next = info->next;
2749 else open_pipes = info->next;
2750 _ckvmssts(sys$setast(1));
2752 /* free buffers and structures */
2755 if (info->in->buf) Safefree(info->in->buf);
2759 if (info->out->buf) Safefree(info->out->buf);
2760 Safefree(info->out);
2763 if (info->err->buf) Safefree(info->err->buf);
2764 Safefree(info->err);
2770 } /* end of my_pclose() */
2772 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2773 /* Roll our own prototype because we want this regardless of whether
2774 * _VMS_WAIT is defined.
2776 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2778 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2779 created with popen(); otherwise partially emulate waitpid() unless
2780 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2781 Also check processes not considered by the CRTL waitpid().
2783 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2785 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2792 if (statusp) *statusp = 0;
2794 for (info = open_pipes; info != NULL; info = info->next)
2795 if (info->pid == pid) break;
2797 if (info != NULL) { /* we know about this child */
2798 while (!info->done) {
2799 _ckvmssts(sys$setast(0));
2801 if (!done) _ckvmssts(sys$clref(pipe_ef));
2802 _ckvmssts(sys$setast(1));
2803 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2806 if (statusp) *statusp = info->completion;
2810 /* child that already terminated? */
2812 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2813 if (closed_list[j].pid == pid) {
2814 if (statusp) *statusp = closed_list[j].completion;
2819 /* fall through if this child is not one of our own pipe children */
2821 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2823 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2824 * in 7.2 did we get a version that fills in the VMS completion
2825 * status as Perl has always tried to do.
2828 sts = __vms_waitpid( pid, statusp, flags );
2830 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2833 /* If the real waitpid tells us the child does not exist, we
2834 * fall through here to implement waiting for a child that
2835 * was created by some means other than exec() (say, spawned
2836 * from DCL) or to wait for a process that is not a subprocess
2837 * of the current process.
2840 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
2843 $DESCRIPTOR(intdsc,"0 00:00:01");
2844 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2845 unsigned long int pidcode = JPI$_PID, mypid;
2846 unsigned long int interval[2];
2847 unsigned int jpi_iosb[2];
2848 struct itmlst_3 jpilist[2] = {
2849 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2854 /* Sorry folks, we don't presently implement rooting around for
2855 the first child we can find, and we definitely don't want to
2856 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2862 /* Get the owner of the child so I can warn if it's not mine. If the
2863 * process doesn't exist or I don't have the privs to look at it,
2864 * I can go home early.
2866 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2867 if (sts & 1) sts = jpi_iosb[0];
2879 set_vaxc_errno(sts);
2883 if (ckWARN(WARN_EXEC)) {
2884 /* remind folks they are asking for non-standard waitpid behavior */
2885 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2886 if (ownerpid != mypid)
2887 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2888 "waitpid: process %x is not a child of process %x",
2892 /* simply check on it once a second until it's not there anymore. */
2894 _ckvmssts(sys$bintim(&intdsc,interval));
2895 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2896 _ckvmssts(sys$schdwk(0,0,interval,0));
2897 _ckvmssts(sys$hiber());
2899 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2904 } /* end of waitpid() */
2909 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2911 my_gconvert(double val, int ndig, int trail, char *buf)
2913 static char __gcvtbuf[DBL_DIG+1];
2916 loc = buf ? buf : __gcvtbuf;
2918 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2920 sprintf(loc,"%.*g",ndig,val);
2926 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2927 return gcvt(val,ndig,loc);
2930 loc[0] = '0'; loc[1] = '\0';
2938 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2939 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2940 * to expand file specification. Allows for a single default file
2941 * specification and a simple mask of options. If outbuf is non-NULL,
2942 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2943 * the resultant file specification is placed. If outbuf is NULL, the
2944 * resultant file specification is placed into a static buffer.
2945 * The third argument, if non-NULL, is taken to be a default file
2946 * specification string. The fourth argument is unused at present.
2947 * rmesexpand() returns the address of the resultant string if
2948 * successful, and NULL on error.
2950 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2953 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2955 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2956 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2957 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2958 struct FAB myfab = cc$rms_fab;
2959 struct NAM mynam = cc$rms_nam;
2961 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2963 if (!filespec || !*filespec) {
2964 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2968 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
2969 else outbuf = __rmsexpand_retbuf;
2971 if ((isunix = (strchr(filespec,'/') != NULL))) {
2972 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2973 filespec = vmsfspec;
2976 myfab.fab$l_fna = filespec;
2977 myfab.fab$b_fns = strlen(filespec);
2978 myfab.fab$l_nam = &mynam;
2980 if (defspec && *defspec) {
2981 if (strchr(defspec,'/') != NULL) {
2982 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2985 myfab.fab$l_dna = defspec;
2986 myfab.fab$b_dns = strlen(defspec);
2989 mynam.nam$l_esa = esa;
2990 mynam.nam$b_ess = sizeof esa;
2991 mynam.nam$l_rsa = outbuf;
2992 mynam.nam$b_rss = NAM$C_MAXRSS;
2994 retsts = sys$parse(&myfab,0,0);
2995 if (!(retsts & 1)) {
2996 mynam.nam$b_nop |= NAM$M_SYNCHK;
2997 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2998 retsts = sys$parse(&myfab,0,0);
2999 if (retsts & 1) goto expanded;
3001 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3002 (void) sys$parse(&myfab,0,0); /* Free search context */
3003 if (out) Safefree(out);
3004 set_vaxc_errno(retsts);
3005 if (retsts == RMS$_PRV) set_errno(EACCES);
3006 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3007 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3008 else set_errno(EVMSERR);
3011 retsts = sys$search(&myfab,0,0);
3012 if (!(retsts & 1) && retsts != RMS$_FNF) {
3013 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3014 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
3015 if (out) Safefree(out);
3016 set_vaxc_errno(retsts);
3017 if (retsts == RMS$_PRV) set_errno(EACCES);
3018 else set_errno(EVMSERR);
3022 /* If the input filespec contained any lowercase characters,
3023 * downcase the result for compatibility with Unix-minded code. */
3025 for (out = myfab.fab$l_fna; *out; out++)
3026 if (islower(*out)) { haslower = 1; break; }
3027 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3028 else { out = esa; speclen = mynam.nam$b_esl; }
3029 /* Trim off null fields added by $PARSE
3030 * If type > 1 char, must have been specified in original or default spec
3031 * (not true for version; $SEARCH may have added version of existing file).
3033 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3034 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3035 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3036 if (trimver || trimtype) {
3037 if (defspec && *defspec) {
3038 char defesa[NAM$C_MAXRSS];
3039 struct FAB deffab = cc$rms_fab;
3040 struct NAM defnam = cc$rms_nam;
3042 deffab.fab$l_nam = &defnam;
3043 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3044 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3045 defnam.nam$b_nop = NAM$M_SYNCHK;
3046 if (sys$parse(&deffab,0,0) & 1) {
3047 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3048 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3051 if (trimver) speclen = mynam.nam$l_ver - out;
3053 /* If we didn't already trim version, copy down */
3054 if (speclen > mynam.nam$l_ver - out)
3055 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3056 speclen - (mynam.nam$l_ver - out));
3057 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3060 /* If we just had a directory spec on input, $PARSE "helpfully"
3061 * adds an empty name and type for us */
3062 if (mynam.nam$l_name == mynam.nam$l_type &&
3063 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3064 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3065 speclen = mynam.nam$l_name - out;
3066 out[speclen] = '\0';
3067 if (haslower) __mystrtolower(out);
3069 /* Have we been working with an expanded, but not resultant, spec? */
3070 /* Also, convert back to Unix syntax if necessary. */
3071 if (!mynam.nam$b_rsl) {
3073 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3075 else strcpy(outbuf,esa);
3078 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3079 strcpy(outbuf,tmpfspec);
3081 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3082 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3083 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
3087 /* External entry points */
3088 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3089 { return do_rmsexpand(spec,buf,0,def,opt); }
3090 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3091 { return do_rmsexpand(spec,buf,1,def,opt); }
3095 ** The following routines are provided to make life easier when
3096 ** converting among VMS-style and Unix-style directory specifications.
3097 ** All will take input specifications in either VMS or Unix syntax. On
3098 ** failure, all return NULL. If successful, the routines listed below
3099 ** return a pointer to a buffer containing the appropriately
3100 ** reformatted spec (and, therefore, subsequent calls to that routine
3101 ** will clobber the result), while the routines of the same names with
3102 ** a _ts suffix appended will return a pointer to a mallocd string
3103 ** containing the appropriately reformatted spec.
3104 ** In all cases, only explicit syntax is altered; no check is made that
3105 ** the resulting string is valid or that the directory in question
3108 ** fileify_dirspec() - convert a directory spec into the name of the
3109 ** directory file (i.e. what you can stat() to see if it's a dir).
3110 ** The style (VMS or Unix) of the result is the same as the style
3111 ** of the parameter passed in.
3112 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3113 ** what you prepend to a filename to indicate what directory it's in).
3114 ** The style (VMS or Unix) of the result is the same as the style
3115 ** of the parameter passed in.
3116 ** tounixpath() - convert a directory spec into a Unix-style path.
3117 ** tovmspath() - convert a directory spec into a VMS-style path.
3118 ** tounixspec() - convert any file spec into a Unix-style file spec.
3119 ** tovmsspec() - convert any file spec into a VMS-style spec.
3121 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3122 ** Permission is given to distribute this code as part of the Perl
3123 ** standard distribution under the terms of the GNU General Public
3124 ** License or the Perl Artistic License. Copies of each may be
3125 ** found in the Perl standard distribution.
3128 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3129 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3131 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3132 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3133 char *retspec, *cp1, *cp2, *lastdir;
3134 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3135 unsigned short int trnlnm_iter_count;
3137 if (!dir || !*dir) {
3138 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3140 dirlen = strlen(dir);
3141 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3142 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3143 strcpy(trndir,"/sys$disk/000000");
3147 if (dirlen > NAM$C_MAXRSS) {
3148 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3150 if (!strpbrk(dir+1,"/]>:")) {
3151 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3152 trnlnm_iter_count = 0;
3153 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3154 trnlnm_iter_count++;
3155 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3158 dirlen = strlen(dir);
3161 strncpy(trndir,dir,dirlen);
3162 trndir[dirlen] = '\0';
3165 /* If we were handed a rooted logical name or spec, treat it like a
3166 * simple directory, so that
3167 * $ Define myroot dev:[dir.]
3168 * ... do_fileify_dirspec("myroot",buf,1) ...
3169 * does something useful.
3171 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3172 dir[--dirlen] = '\0';
3173 dir[dirlen-1] = ']';
3175 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3176 dir[--dirlen] = '\0';
3177 dir[dirlen-1] = '>';
3180 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3181 /* If we've got an explicit filename, we can just shuffle the string. */
3182 if (*(cp1+1)) hasfilename = 1;
3183 /* Similarly, we can just back up a level if we've got multiple levels
3184 of explicit directories in a VMS spec which ends with directories. */
3186 for (cp2 = cp1; cp2 > dir; cp2--) {
3188 *cp2 = *cp1; *cp1 = '\0';
3192 if (*cp2 == '[' || *cp2 == '<') break;
3197 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3198 if (dir[0] == '.') {
3199 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3200 return do_fileify_dirspec("[]",buf,ts);
3201 else if (dir[1] == '.' &&
3202 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3203 return do_fileify_dirspec("[-]",buf,ts);
3205 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3206 dirlen -= 1; /* to last element */
3207 lastdir = strrchr(dir,'/');
3209 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3210 /* If we have "/." or "/..", VMSify it and let the VMS code
3211 * below expand it, rather than repeating the code to handle
3212 * relative components of a filespec here */
3214 if (*(cp1+2) == '.') cp1++;
3215 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3216 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3217 if (strchr(vmsdir,'/') != NULL) {
3218 /* If do_tovmsspec() returned it, it must have VMS syntax
3219 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3220 * the time to check this here only so we avoid a recursion
3221 * loop; otherwise, gigo.
3223 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3225 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3226 return do_tounixspec(trndir,buf,ts);
3229 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3230 lastdir = strrchr(dir,'/');
3232 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3233 /* Ditto for specs that end in an MFD -- let the VMS code
3234 * figure out whether it's a real device or a rooted logical. */
3235 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3236 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3237 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3238 return do_tounixspec(trndir,buf,ts);
3241 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3242 !(lastdir = cp1 = strrchr(dir,']')) &&
3243 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3244 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3246 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3247 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3248 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3249 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3250 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3251 (ver || *cp3)))))) {
3253 set_vaxc_errno(RMS$_DIR);
3259 /* If we lead off with a device or rooted logical, add the MFD
3260 if we're specifying a top-level directory. */
3261 if (lastdir && *dir == '/') {
3263 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3270 retlen = dirlen + (addmfd ? 13 : 6);
3271 if (buf) retspec = buf;
3272 else if (ts) Newx(retspec,retlen+1,char);
3273 else retspec = __fileify_retbuf;
3275 dirlen = lastdir - dir;
3276 memcpy(retspec,dir,dirlen);
3277 strcpy(&retspec[dirlen],"/000000");
3278 strcpy(&retspec[dirlen+7],lastdir);
3281 memcpy(retspec,dir,dirlen);
3282 retspec[dirlen] = '\0';
3284 /* We've picked up everything up to the directory file name.
3285 Now just add the type and version, and we're set. */
3286 strcat(retspec,".dir;1");
3289 else { /* VMS-style directory spec */
3290 char esa[NAM$C_MAXRSS+1], term, *cp;
3291 unsigned long int sts, cmplen, haslower = 0;
3292 struct FAB dirfab = cc$rms_fab;
3293 struct NAM savnam, dirnam = cc$rms_nam;
3295 dirfab.fab$b_fns = strlen(dir);
3296 dirfab.fab$l_fna = dir;
3297 dirfab.fab$l_nam = &dirnam;
3298 dirfab.fab$l_dna = ".DIR;1";
3299 dirfab.fab$b_dns = 6;
3300 dirnam.nam$b_ess = NAM$C_MAXRSS;
3301 dirnam.nam$l_esa = esa;
3303 for (cp = dir; *cp; cp++)
3304 if (islower(*cp)) { haslower = 1; break; }
3305 if (!((sts = sys$parse(&dirfab))&1)) {
3306 if (dirfab.fab$l_sts == RMS$_DIR) {
3307 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3308 sts = sys$parse(&dirfab) & 1;
3312 set_vaxc_errno(dirfab.fab$l_sts);
3318 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3319 /* Yes; fake the fnb bits so we'll check type below */
3320 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3322 else { /* No; just work with potential name */
3323 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3325 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3326 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3327 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3332 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3333 cp1 = strchr(esa,']');
3334 if (!cp1) cp1 = strchr(esa,'>');
3335 if (cp1) { /* Should always be true */
3336 dirnam.nam$b_esl -= cp1 - esa - 1;
3337 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3340 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3341 /* Yep; check version while we're at it, if it's there. */
3342 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3343 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3344 /* Something other than .DIR[;1]. Bzzt. */
3345 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3346 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3348 set_vaxc_errno(RMS$_DIR);
3352 esa[dirnam.nam$b_esl] = '\0';
3353 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3354 /* They provided at least the name; we added the type, if necessary, */
3355 if (buf) retspec = buf; /* in sys$parse() */
3356 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
3357 else retspec = __fileify_retbuf;
3358 strcpy(retspec,esa);
3359 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3360 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3363 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3364 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3366 dirnam.nam$b_esl -= 9;
3368 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3369 if (cp1 == NULL) { /* should never happen */
3370 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3371 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3376 retlen = strlen(esa);
3377 if ((cp1 = strrchr(esa,'.')) != NULL) {
3378 /* There's more than one directory in the path. Just roll back. */
3380 if (buf) retspec = buf;
3381 else if (ts) Newx(retspec,retlen+7,char);
3382 else retspec = __fileify_retbuf;
3383 strcpy(retspec,esa);
3386 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3387 /* Go back and expand rooted logical name */
3388 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3389 if (!(sys$parse(&dirfab) & 1)) {
3390 dirnam.nam$l_rlf = NULL;
3391 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3393 set_vaxc_errno(dirfab.fab$l_sts);
3396 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3397 if (buf) retspec = buf;
3398 else if (ts) Newx(retspec,retlen+16,char);
3399 else retspec = __fileify_retbuf;
3400 cp1 = strstr(esa,"][");
3401 if (!cp1) cp1 = strstr(esa,"]<");
3403 memcpy(retspec,esa,dirlen);
3404 if (!strncmp(cp1+2,"000000]",7)) {
3405 retspec[dirlen-1] = '\0';
3406 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3407 if (*cp1 == '.') *cp1 = ']';
3409 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3410 memcpy(cp1+1,"000000]",7);
3414 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3415 retspec[retlen] = '\0';
3416 /* Convert last '.' to ']' */
3417 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3418 if (*cp1 == '.') *cp1 = ']';
3420 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3421 memcpy(cp1+1,"000000]",7);
3425 else { /* This is a top-level dir. Add the MFD to the path. */
3426 if (buf) retspec = buf;
3427 else if (ts) Newx(retspec,retlen+16,char);
3428 else retspec = __fileify_retbuf;
3431 while (*cp1 != ':') *(cp2++) = *(cp1++);
3432 strcpy(cp2,":[000000]");
3437 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3438 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3439 /* We've set up the string up through the filename. Add the
3440 type and version, and we're done. */
3441 strcat(retspec,".DIR;1");
3443 /* $PARSE may have upcased filespec, so convert output to lower
3444 * case if input contained any lowercase characters. */
3445 if (haslower) __mystrtolower(retspec);
3448 } /* end of do_fileify_dirspec() */
3450 /* External entry points */
3451 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3452 { return do_fileify_dirspec(dir,buf,0); }
3453 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3454 { return do_fileify_dirspec(dir,buf,1); }
3456 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3457 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3459 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3460 unsigned long int retlen;
3461 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3462 unsigned short int trnlnm_iter_count;
3465 if (!dir || !*dir) {
3466 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3469 if (*dir) strcpy(trndir,dir);
3470 else getcwd(trndir,sizeof trndir - 1);
3472 trnlnm_iter_count = 0;
3473 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3474 && my_trnlnm(trndir,trndir,0)) {
3475 trnlnm_iter_count++;
3476 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3477 trnlen = strlen(trndir);
3479 /* Trap simple rooted lnms, and return lnm:[000000] */
3480 if (!strcmp(trndir+trnlen-2,".]")) {
3481 if (buf) retpath = buf;
3482 else if (ts) Newx(retpath,strlen(dir)+10,char);
3483 else retpath = __pathify_retbuf;
3484 strcpy(retpath,dir);
3485 strcat(retpath,":[000000]");
3491 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3492 if (*dir == '.' && (*(dir+1) == '\0' ||
3493 (*(dir+1) == '.' && *(dir+2) == '\0')))
3494 retlen = 2 + (*(dir+1) != '\0');
3496 if ( !(cp1 = strrchr(dir,'/')) &&
3497 !(cp1 = strrchr(dir,']')) &&
3498 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3499 if ((cp2 = strchr(cp1,'.')) != NULL &&
3500 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3501 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3502 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3503 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3505 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3506 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3507 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3508 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3509 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3510 (ver || *cp3)))))) {
3512 set_vaxc_errno(RMS$_DIR);
3515 retlen = cp2 - dir + 1;
3517 else { /* No file type present. Treat the filename as a directory. */
3518 retlen = strlen(dir) + 1;
3521 if (buf) retpath = buf;
3522 else if (ts) Newx(retpath,retlen+1,char);
3523 else retpath = __pathify_retbuf;
3524 strncpy(retpath,dir,retlen-1);
3525 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3526 retpath[retlen-1] = '/'; /* with '/', add it. */
3527 retpath[retlen] = '\0';
3529 else retpath[retlen-1] = '\0';
3531 else { /* VMS-style directory spec */
3532 char esa[NAM$C_MAXRSS+1], *cp;
3533 unsigned long int sts, cmplen, haslower;
3534 struct FAB dirfab = cc$rms_fab;
3535 struct NAM savnam, dirnam = cc$rms_nam;
3537 /* If we've got an explicit filename, we can just shuffle the string. */
3538 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3539 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3540 if ((cp2 = strchr(cp1,'.')) != NULL) {
3542 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3543 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3544 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3545 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3546 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3547 (ver || *cp3)))))) {
3549 set_vaxc_errno(RMS$_DIR);
3553 else { /* No file type, so just draw name into directory part */
3554 for (cp2 = cp1; *cp2; cp2++) ;
3557 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3559 /* We've now got a VMS 'path'; fall through */
3561 dirfab.fab$b_fns = strlen(dir);
3562 dirfab.fab$l_fna = dir;
3563 if (dir[dirfab.fab$b_fns-1] == ']' ||
3564 dir[dirfab.fab$b_fns-1] == '>' ||
3565 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3566 if (buf) retpath = buf;
3567 else if (ts) Newx(retpath,strlen(dir)+1,char);
3568 else retpath = __pathify_retbuf;
3569 strcpy(retpath,dir);
3572 dirfab.fab$l_dna = ".DIR;1";
3573 dirfab.fab$b_dns = 6;
3574 dirfab.fab$l_nam = &dirnam;
3575 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3576 dirnam.nam$l_esa = esa;
3578 for (cp = dir; *cp; cp++)
3579 if (islower(*cp)) { haslower = 1; break; }
3581 if (!(sts = (sys$parse(&dirfab)&1))) {
3582 if (dirfab.fab$l_sts == RMS$_DIR) {
3583 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3584 sts = sys$parse(&dirfab) & 1;
3588 set_vaxc_errno(dirfab.fab$l_sts);
3594 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3595 if (dirfab.fab$l_sts != RMS$_FNF) {
3596 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3597 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3599 set_vaxc_errno(dirfab.fab$l_sts);
3602 dirnam = savnam; /* No; just work with potential name */
3605 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3606 /* Yep; check version while we're at it, if it's there. */
3607 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3608 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3609 /* Something other than .DIR[;1]. Bzzt. */
3610 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3611 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3613 set_vaxc_errno(RMS$_DIR);
3617 /* OK, the type was fine. Now pull any file name into the
3619 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3621 cp1 = strrchr(esa,'>');
3622 *dirnam.nam$l_type = '>';
3625 *(dirnam.nam$l_type + 1) = '\0';
3626 retlen = dirnam.nam$l_type - esa + 2;
3627 if (buf) retpath = buf;
3628 else if (ts) Newx(retpath,retlen,char);
3629 else retpath = __pathify_retbuf;
3630 strcpy(retpath,esa);
3631 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3632 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3633 /* $PARSE may have upcased filespec, so convert output to lower
3634 * case if input contained any lowercase characters. */
3635 if (haslower) __mystrtolower(retpath);
3639 } /* end of do_pathify_dirspec() */
3641 /* External entry points */
3642 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3643 { return do_pathify_dirspec(dir,buf,0); }
3644 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3645 { return do_pathify_dirspec(dir,buf,1); }
3647 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3648 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3650 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3651 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3652 int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
3653 int expand = 1; /* guarantee room for leading and trailing slashes */
3654 unsigned short int trnlnm_iter_count;
3656 if (spec == NULL) return NULL;
3657 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3658 if (buf) rslt = buf;
3660 retlen = strlen(spec);
3661 cp1 = strchr(spec,'[');
3662 if (!cp1) cp1 = strchr(spec,'<');
3664 for (cp1++; *cp1; cp1++) {
3665 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3666 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3667 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3670 Newx(rslt,retlen+2+2*expand,char);
3672 else rslt = __tounixspec_retbuf;
3673 if (strchr(spec,'/') != NULL) {
3680 dirend = strrchr(spec,']');
3681 if (dirend == NULL) dirend = strrchr(spec,'>');
3682 if (dirend == NULL) dirend = strchr(spec,':');
3683 if (dirend == NULL) {
3687 if (*cp2 != '[' && *cp2 != '<') {
3690 else { /* the VMS spec begins with directories */
3692 if (*cp2 == ']' || *cp2 == '>') {
3693 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3696 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3697 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3698 if (ts) Safefree(rslt);
3701 trnlnm_iter_count = 0;
3704 while (*cp3 != ':' && *cp3) cp3++;
3706 if (strchr(cp3,']') != NULL) break;
3707 trnlnm_iter_count++;
3708 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3709 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3711 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3712 retlen = devlen + dirlen;
3713 Renew(rslt,retlen+1+2*expand,char);
3719 *(cp1++) = *(cp3++);
3720 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3724 else if ( *cp2 == '.') {
3725 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3726 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3732 for (; cp2 <= dirend; cp2++) {
3735 if (*(cp2+1) == '[') cp2++;
3737 else if (*cp2 == ']' || *cp2 == '>') {
3738 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3740 else if (*cp2 == '.') {
3742 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3743 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3744 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3745 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3746 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3748 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3749 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3753 else if (*cp2 == '-') {
3754 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3755 while (*cp2 == '-') {
3757 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3759 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3760 if (ts) Safefree(rslt); /* filespecs like */
3761 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3765 else *(cp1++) = *cp2;
3767 else *(cp1++) = *cp2;
3769 while (*cp2) *(cp1++) = *(cp2++);
3774 } /* end of do_tounixspec() */
3776 /* External entry points */
3777 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3778 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3780 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3781 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3782 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3783 char *rslt, *dirend;
3784 register char *cp1, *cp2;
3785 unsigned long int infront = 0, hasdir = 1;
3787 if (path == NULL) return NULL;
3788 if (buf) rslt = buf;
3789 else if (ts) Newx(rslt,strlen(path)+9,char);
3790 else rslt = __tovmsspec_retbuf;
3791 if (strpbrk(path,"]:>") ||
3792 (dirend = strrchr(path,'/')) == NULL) {
3793 if (path[0] == '.') {
3794 if (path[1] == '\0') strcpy(rslt,"[]");
3795 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3796 else strcpy(rslt,path); /* probably garbage */
3798 else strcpy(rslt,path);
3801 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3802 if (!*(dirend+2)) dirend +=2;
3803 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3804 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3809 char trndev[NAM$C_MAXRSS+1];
3813 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3815 if (!buf & ts) Renew(rslt,18,char);
3816 strcpy(rslt,"sys$disk:[000000]");
3819 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3821 islnm = my_trnlnm(rslt,trndev,0);
3822 trnend = islnm ? strlen(trndev) - 1 : 0;
3823 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3824 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3825 /* If the first element of the path is a logical name, determine
3826 * whether it has to be translated so we can add more directories. */
3827 if (!islnm || rooted) {
3830 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3834 if (cp2 != dirend) {
3835 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3836 strcpy(rslt,trndev);
3837 cp1 = rslt + trnend;
3850 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3851 cp2 += 2; /* skip over "./" - it's redundant */
3852 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3854 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3855 *(cp1++) = '-'; /* "../" --> "-" */
3858 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3859 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3860 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3861 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3864 if (cp2 > dirend) cp2 = dirend;
3866 else *(cp1++) = '.';
3868 for (; cp2 < dirend; cp2++) {
3870 if (*(cp2-1) == '/') continue;
3871 if (*(cp1-1) != '.') *(cp1++) = '.';
3874 else if (!infront && *cp2 == '.') {
3875 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3876 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3877 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3878 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3879 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3880 else { /* back up over previous directory name */
3882 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3883 if (*(cp1-1) == '[') {
3884 memcpy(cp1,"000000.",7);
3889 if (cp2 == dirend) break;
3891 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3892 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3893 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3894 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3896 *(cp1++) = '.'; /* Simulate trailing '/' */
3897 cp2 += 2; /* for loop will incr this to == dirend */
3899 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3901 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3904 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3905 if (*cp2 == '.') *(cp1++) = '_';
3906 else *(cp1++) = *cp2;
3910 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3911 if (hasdir) *(cp1++) = ']';
3912 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3913 while (*cp2) *(cp1++) = *(cp2++);
3918 } /* end of do_tovmsspec() */
3920 /* External entry points */
3921 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3922 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3924 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3925 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3926 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3928 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3930 if (path == NULL) return NULL;
3931 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3932 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3933 if (buf) return buf;
3935 vmslen = strlen(vmsified);
3936 Newx(cp,vmslen+1,char);
3937 memcpy(cp,vmsified,vmslen);
3942 strcpy(__tovmspath_retbuf,vmsified);
3943 return __tovmspath_retbuf;
3946 } /* end of do_tovmspath() */
3948 /* External entry points */
3949 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3950 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3953 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3954 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3955 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3957 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3959 if (path == NULL) return NULL;
3960 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3961 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3962 if (buf) return buf;
3964 unixlen = strlen(unixified);
3965 Newx(cp,unixlen+1,char);
3966 memcpy(cp,unixified,unixlen);
3971 strcpy(__tounixpath_retbuf,unixified);
3972 return __tounixpath_retbuf;
3975 } /* end of do_tounixpath() */
3977 /* External entry points */
3978 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3979 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3982 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3984 *****************************************************************************
3986 * Copyright (C) 1989-1994 by *
3987 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3989 * Permission is hereby granted for the reproduction of this software, *
3990 * on condition that this copyright notice is included in the reproduction, *
3991 * and that such reproduction is not for purposes of profit or material *
3994 * 27-Aug-1994 Modified for inclusion in perl5 *
3995 * by Charles Bailey bailey@newman.upenn.edu *
3996 *****************************************************************************
4000 * getredirection() is intended to aid in porting C programs
4001 * to VMS (Vax-11 C). The native VMS environment does not support
4002 * '>' and '<' I/O redirection, or command line wild card expansion,
4003 * or a command line pipe mechanism using the '|' AND background
4004 * command execution '&'. All of these capabilities are provided to any
4005 * C program which calls this procedure as the first thing in the
4007 * The piping mechanism will probably work with almost any 'filter' type
4008 * of program. With suitable modification, it may useful for other
4009 * portability problems as well.
4011 * Author: Mark Pizzolato mark@infocomm.com
4015 struct list_item *next;
4019 static void add_item(struct list_item **head,
4020 struct list_item **tail,
4024 static void mp_expand_wild_cards(pTHX_ char *item,
4025 struct list_item **head,
4026 struct list_item **tail,
4029 static int background_process(pTHX_ int argc, char **argv);
4031 static void pipe_and_fork(pTHX_ char **cmargv);
4033 /*{{{ void getredirection(int *ac, char ***av)*/
4035 mp_getredirection(pTHX_ int *ac, char ***av)
4037 * Process vms redirection arg's. Exit if any error is seen.
4038 * If getredirection() processes an argument, it is erased
4039 * from the vector. getredirection() returns a new argc and argv value.
4040 * In the event that a background command is requested (by a trailing "&"),
4041 * this routine creates a background subprocess, and simply exits the program.
4043 * Warning: do not try to simplify the code for vms. The code
4044 * presupposes that getredirection() is called before any data is
4045 * read from stdin or written to stdout.
4047 * Normal usage is as follows:
4053 * getredirection(&argc, &argv);
4057 int argc = *ac; /* Argument Count */
4058 char **argv = *av; /* Argument Vector */
4059 char *ap; /* Argument pointer */
4060 int j; /* argv[] index */
4061 int item_count = 0; /* Count of Items in List */
4062 struct list_item *list_head = 0; /* First Item in List */
4063 struct list_item *list_tail; /* Last Item in List */
4064 char *in = NULL; /* Input File Name */
4065 char *out = NULL; /* Output File Name */
4066 char *outmode = "w"; /* Mode to Open Output File */
4067 char *err = NULL; /* Error File Name */
4068 char *errmode = "w"; /* Mode to Open Error File */
4069 int cmargc = 0; /* Piped Command Arg Count */
4070 char **cmargv = NULL;/* Piped Command Arg Vector */
4073 * First handle the case where the last thing on the line ends with
4074 * a '&'. This indicates the desire for the command to be run in a
4075 * subprocess, so we satisfy that desire.
4078 if (0 == strcmp("&", ap))
4079 exit(background_process(aTHX_ --argc, argv));
4080 if (*ap && '&' == ap[strlen(ap)-1])
4082 ap[strlen(ap)-1] = '\0';
4083 exit(background_process(aTHX_ argc, argv));
4086 * Now we handle the general redirection cases that involve '>', '>>',
4087 * '<', and pipes '|'.
4089 for (j = 0; j < argc; ++j)
4091 if (0 == strcmp("<", argv[j]))
4095 fprintf(stderr,"No input file after < on command line");
4096 exit(LIB$_WRONUMARG);
4101 if ('<' == *(ap = argv[j]))
4106 if (0 == strcmp(">", ap))
4110 fprintf(stderr,"No output file after > on command line");
4111 exit(LIB$_WRONUMARG);
4130 fprintf(stderr,"No output file after > or >> on command line");
4131 exit(LIB$_WRONUMARG);
4135 if (('2' == *ap) && ('>' == ap[1]))
4152 fprintf(stderr,"No output file after 2> or 2>> on command line");
4153 exit(LIB$_WRONUMARG);
4157 if (0 == strcmp("|", argv[j]))
4161 fprintf(stderr,"No command into which to pipe on command line");
4162 exit(LIB$_WRONUMARG);
4164 cmargc = argc-(j+1);
4165 cmargv = &argv[j+1];
4169 if ('|' == *(ap = argv[j]))
4177 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4180 * Allocate and fill in the new argument vector, Some Unix's terminate
4181 * the list with an extra null pointer.
4183 Newx(argv, item_count+1, char *);
4185 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4186 argv[j] = list_head->value;
4192 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4193 exit(LIB$_INVARGORD);
4195 pipe_and_fork(aTHX_ cmargv);
4198 /* Check for input from a pipe (mailbox) */
4200 if (in == NULL && 1 == isapipe(0))
4202 char mbxname[L_tmpnam];
4204 long int dvi_item = DVI$_DEVBUFSIZ;
4205 $DESCRIPTOR(mbxnam, "");
4206 $DESCRIPTOR(mbxdevnam, "");
4208 /* Input from a pipe, reopen it in binary mode to disable */
4209 /* carriage control processing. */
4211 fgetname(stdin, mbxname);
4212 mbxnam.dsc$a_pointer = mbxname;
4213 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4214 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4215 mbxdevnam.dsc$a_pointer = mbxname;
4216 mbxdevnam.dsc$w_length = sizeof(mbxname);
4217 dvi_item = DVI$_DEVNAM;
4218 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4219 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4222 freopen(mbxname, "rb", stdin);
4225 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4229 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4231 fprintf(stderr,"Can't open input file %s as stdin",in);
4234 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4236 fprintf(stderr,"Can't open output file %s as stdout",out);
4239 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4242 if (strcmp(err,"&1") == 0) {
4243 dup2(fileno(stdout), fileno(stderr));
4244 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4247 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4249 fprintf(stderr,"Can't open error file %s as stderr",err);
4253 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4257 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4260 #ifdef ARGPROC_DEBUG
4261 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4262 for (j = 0; j < *ac; ++j)
4263 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4265 /* Clear errors we may have hit expanding wildcards, so they don't
4266 show up in Perl's $! later */
4267 set_errno(0); set_vaxc_errno(1);
4268 } /* end of getredirection() */
4271 static void add_item(struct list_item **head,
4272 struct list_item **tail,
4278 Newx(*head,1,struct list_item);
4282 Newx((*tail)->next,1,struct list_item);
4283 *tail = (*tail)->next;
4285 (*tail)->value = value;
4289 static void mp_expand_wild_cards(pTHX_ char *item,
4290 struct list_item **head,
4291 struct list_item **tail,
4295 unsigned long int context = 0;
4302 char vmsspec[NAM$C_MAXRSS+1];
4303 $DESCRIPTOR(filespec, "");
4304 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4305 $DESCRIPTOR(resultspec, "");
4306 unsigned long int zero = 0, sts;
4308 for (cp = item; *cp; cp++) {
4309 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4310 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4312 if (!*cp || isspace(*cp))
4314 add_item(head, tail, item, count);
4319 /* "double quoted" wild card expressions pass as is */
4320 /* From DCL that means using e.g.: */
4321 /* perl program """perl.*""" */
4322 item_len = strlen(item);
4323 if ( '"' == *item && '"' == item[item_len-1] )
4326 item[item_len-2] = '\0';
4327 add_item(head, tail, item, count);
4331 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4332 resultspec.dsc$b_class = DSC$K_CLASS_D;
4333 resultspec.dsc$a_pointer = NULL;
4334 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4335 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4336 if (!isunix || !filespec.dsc$a_pointer)
4337 filespec.dsc$a_pointer = item;
4338 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4340 * Only return version specs, if the caller specified a version
4342 had_version = strchr(item, ';');
4344 * Only return device and directory specs, if the caller specifed either.
4346 had_device = strchr(item, ':');
4347 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4349 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4350 &defaultspec, 0, 0, &zero))))
4355 Newx(string,resultspec.dsc$w_length+1,char);
4356 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4357 string[resultspec.dsc$w_length] = '\0';
4358 if (NULL == had_version)
4359 *((char *)strrchr(string, ';')) = '\0';
4360 if ((!had_directory) && (had_device == NULL))
4362 if (NULL == (devdir = strrchr(string, ']')))
4363 devdir = strrchr(string, '>');
4364 strcpy(string, devdir + 1);
4367 * Be consistent with what the C RTL has already done to the rest of
4368 * the argv items and lowercase all of these names.
4370 for (c = string; *c; ++c)
4373 if (isunix) trim_unixpath(string,item,1);
4374 add_item(head, tail, string, count);
4377 if (sts != RMS$_NMF)
4379 set_vaxc_errno(sts);
4382 case RMS$_FNF: case RMS$_DNF:
4383 set_errno(ENOENT); break;
4385 set_errno(ENOTDIR); break;
4387 set_errno(ENODEV); break;
4388 case RMS$_FNM: case RMS$_SYN:
4389 set_errno(EINVAL); break;
4391 set_errno(EACCES); break;
4393 _ckvmssts_noperl(sts);
4397 add_item(head, tail, item, count);
4398 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4399 _ckvmssts_noperl(lib$find_file_end(&context));
4402 static int child_st[2];/* Event Flag set when child process completes */
4404 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4406 static unsigned long int exit_handler(int *status)
4410 if (0 == child_st[0])
4412 #ifdef ARGPROC_DEBUG
4413 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4415 fflush(stdout); /* Have to flush pipe for binary data to */
4416 /* terminate properly -- <tp@mccall.com> */
4417 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4418 sys$dassgn(child_chan);
4420 sys$synch(0, child_st);
4425 static void sig_child(int chan)
4427 #ifdef ARGPROC_DEBUG
4428 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4430 if (child_st[0] == 0)
4434 static struct exit_control_block exit_block =
4439 &exit_block.exit_status,
4444 pipe_and_fork(pTHX_ char **cmargv)
4447 struct dsc$descriptor_s *vmscmd;
4448 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4449 int sts, j, l, ismcr, quote, tquote = 0;
4451 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4452 vms_execfree(vmscmd);
4457 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4458 && toupper(*(q+2)) == 'R' && !*(q+3);
4460 while (q && l < MAX_DCL_LINE_LENGTH) {
4462 if (j > 0 && quote) {
4468 if (ismcr && j > 1) quote = 1;
4469 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4472 if (quote || tquote) {
4478 if ((quote||tquote) && *q == '"') {
4488 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4490 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4494 static int background_process(pTHX_ int argc, char **argv)
4496 char command[2048] = "$";
4497 $DESCRIPTOR(value, "");
4498 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4499 static $DESCRIPTOR(null, "NLA0:");
4500 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4502 $DESCRIPTOR(pidstr, "");
4504 unsigned long int flags = 17, one = 1, retsts;
4506 strcat(command, argv[0]);
4509 strcat(command, " \"");
4510 strcat(command, *(++argv));
4511 strcat(command, "\"");
4513 value.dsc$a_pointer = command;
4514 value.dsc$w_length = strlen(value.dsc$a_pointer);
4515 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4516 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4517 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4518 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4521 _ckvmssts_noperl(retsts);
4523 #ifdef ARGPROC_DEBUG
4524 PerlIO_printf(Perl_debug_log, "%s\n", command);
4526 sprintf(pidstring, "%08X", pid);
4527 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4528 pidstr.dsc$a_pointer = pidstring;
4529 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4530 lib$set_symbol(&pidsymbol, &pidstr);
4534 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4537 /* OS-specific initialization at image activation (not thread startup) */
4538 /* Older VAXC header files lack these constants */
4539 #ifndef JPI$_RIGHTS_SIZE
4540 # define JPI$_RIGHTS_SIZE 817
4542 #ifndef KGB$M_SUBSYSTEM
4543 # define KGB$M_SUBSYSTEM 0x8
4546 /*{{{void vms_image_init(int *, char ***)*/
4548 vms_image_init(int *argcp, char ***argvp)
4550 char eqv[LNM$C_NAMLENGTH+1] = "";
4551 unsigned int len, tabct = 8, tabidx = 0;
4552 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4553 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4554 unsigned short int dummy, rlen;
4555 struct dsc$descriptor_s **tabvec;
4556 #if defined(PERL_IMPLICIT_CONTEXT)
4559 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4560 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4561 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4564 #ifdef KILL_BY_SIGPRC
4565 (void) Perl_csighandler_init();
4568 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4569 _ckvmssts_noperl(iosb[0]);
4570 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4571 if (iprv[i]) { /* Running image installed with privs? */
4572 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4577 /* Rights identifiers might trigger tainting as well. */
4578 if (!will_taint && (rlen || rsz)) {
4579 while (rlen < rsz) {
4580 /* We didn't get all the identifiers on the first pass. Allocate a
4581 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4582 * were needed to hold all identifiers at time of last call; we'll
4583 * allocate that many unsigned long ints), and go back and get 'em.
4584 * If it gave us less than it wanted to despite ample buffer space,
4585 * something's broken. Is your system missing a system identifier?
4587 if (rsz <= jpilist[1].buflen) {
4588 /* Perl_croak accvios when used this early in startup. */
4589 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4590 rsz, (unsigned long) jpilist[1].buflen,
4591 "Check your rights database for corruption.\n");
4594 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4595 jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
4596 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4597 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4598 _ckvmssts_noperl(iosb[0]);
4600 mask = jpilist[1].bufadr;
4601 /* Check attribute flags for each identifier (2nd longword); protected
4602 * subsystem identifiers trigger tainting.
4604 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4605 if (mask[i] & KGB$M_SUBSYSTEM) {
4610 if (mask != rlst) Safefree(mask);
4612 /* We need to use this hack to tell Perl it should run with tainting,
4613 * since its tainting flag may be part of the PL_curinterp struct, which
4614 * hasn't been allocated when vms_image_init() is called.
4617 char **newargv, **oldargv;
4619 Newx(newargv,(*argcp)+2,char *);
4620 newargv[0] = oldargv[0];
4621 Newx(newargv[1],3,char);
4622 strcpy(newargv[1], "-T");
4623 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4625 newargv[*argcp] = NULL;
4626 /* We orphan the old argv, since we don't know where it's come from,
4627 * so we don't know how to free it.
4631 else { /* Did user explicitly request tainting? */
4633 char *cp, **av = *argvp;
4634 for (i = 1; i < *argcp; i++) {
4635 if (*av[i] != '-') break;
4636 for (cp = av[i]+1; *cp; cp++) {
4637 if (*cp == 'T') { will_taint = 1; break; }
4638 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4639 strchr("DFIiMmx",*cp)) break;
4641 if (will_taint) break;
4646 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4648 if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
4649 else if (tabidx >= tabct) {
4651 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4653 Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
4654 tabvec[tabidx]->dsc$w_length = 0;
4655 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4656 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4657 tabvec[tabidx]->dsc$a_pointer = NULL;
4658 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4660 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4662 getredirection(argcp,argvp);
4663 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4665 # include <reentrancy.h>
4666 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4675 * Trim Unix-style prefix off filespec, so it looks like what a shell
4676 * glob expansion would return (i.e. from specified prefix on, not
4677 * full path). Note that returned filespec is Unix-style, regardless
4678 * of whether input filespec was VMS-style or Unix-style.
4680 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4681 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4682 * vector of options; at present, only bit 0 is used, and if set tells
4683 * trim unixpath to try the current default directory as a prefix when
4684 * presented with a possibly ambiguous ... wildcard.
4686 * Returns !=0 on success, with trimmed filespec replacing contents of
4687 * fspec, and 0 on failure, with contents of fpsec unchanged.
4689 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4691 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4693 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4694 *template, *base, *end, *cp1, *cp2;
4695 register int tmplen, reslen = 0, dirs = 0;
4697 if (!wildspec || !fspec) return 0;
4698 if (strpbrk(wildspec,"]>:") != NULL) {
4699 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4700 else template = unixwild;
4702 else template = wildspec;
4703 if (strpbrk(fspec,"]>:") != NULL) {
4704 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4705 else base = unixified;
4706 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4707 * check to see that final result fits into (isn't longer than) fspec */
4708 reslen = strlen(fspec);
4712 /* No prefix or absolute path on wildcard, so nothing to remove */
4713 if (!*template || *template == '/') {
4714 if (base == fspec) return 1;
4715 tmplen = strlen(unixified);
4716 if (tmplen > reslen) return 0; /* not enough space */
4717 /* Copy unixified resultant, including trailing NUL */
4718 memmove(fspec,unixified,tmplen+1);
4722 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4723 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4724 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4725 for (cp1 = end ;cp1 >= base; cp1--)
4726 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4728 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4732 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4733 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4734 int ells = 1, totells, segdirs, match;
4735 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4736 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4738 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4740 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4741 if (ellipsis == template && opts & 1) {
4742 /* Template begins with an ellipsis. Since we can't tell how many
4743 * directory names at the front of the resultant to keep for an
4744 * arbitrary starting point, we arbitrarily choose the current
4745 * default directory as a starting point. If it's there as a prefix,
4746 * clip it off. If not, fall through and act as if the leading
4747 * ellipsis weren't there (i.e. return shortest possible path that
4748 * could match template).
4750 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4751 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4752 if (_tolower(*cp1) != _tolower(*cp2)) break;
4753 segdirs = dirs - totells; /* Min # of dirs we must have left */
4754 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4755 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4756 memcpy(fspec,cp2+1,end - cp2);
4760 /* First off, back up over constant elements at end of path */
4762 for (front = end ; front >= base; front--)
4763 if (*front == '/' && !dirs--) { front++; break; }
4765 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4766 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4767 if (cp1 != '\0') return 0; /* Path too long. */
4769 *cp2 = '\0'; /* Pick up with memcpy later */
4770 lcfront = lcres + (front - base);
4771 /* Now skip over each ellipsis and try to match the path in front of it. */
4773 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4774 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4775 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4776 if (cp1 < template) break; /* template started with an ellipsis */
4777 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4778 ellipsis = cp1; continue;
4780 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4782 for (segdirs = 0, cp2 = tpl;
4783 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4785 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4786 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4787 if (*cp2 == '/') segdirs++;
4789 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4790 /* Back up at least as many dirs as in template before matching */
4791 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4792 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4793 for (match = 0; cp1 > lcres;) {
4794 resdsc.dsc$a_pointer = cp1;
4795 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4797 if (match == 1) lcfront = cp1;
4799 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4801 if (!match) return 0; /* Can't find prefix ??? */
4802 if (match > 1 && opts & 1) {
4803 /* This ... wildcard could cover more than one set of dirs (i.e.
4804 * a set of similar dir names is repeated). If the template
4805 * contains more than 1 ..., upstream elements could resolve the
4806 * ambiguity, but it's not worth a full backtracking setup here.
4807 * As a quick heuristic, clip off the current default directory
4808 * if it's present to find the trimmed spec, else use the
4809 * shortest string that this ... could cover.
4811 char def[NAM$C_MAXRSS+1], *st;
4813 if (getcwd(def, sizeof def,0) == NULL) return 0;
4814 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4815 if (_tolower(*cp1) != _tolower(*cp2)) break;
4816 segdirs = dirs - totells; /* Min # of dirs we must have left */
4817 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4818 if (*cp1 == '\0' && *cp2 == '/') {
4819 memcpy(fspec,cp2+1,end - cp2);
4822 /* Nope -- stick with lcfront from above and keep going. */
4825 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4830 } /* end of trim_unixpath() */
4835 * VMS readdir() routines.
4836 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4838 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4839 * Minor modifications to original routines.
4842 /* readdir may have been redefined by reentr.h, so make sure we get
4843 * the local version for what we do here.
4848 #if !defined(PERL_IMPLICIT_CONTEXT)
4849 # define readdir Perl_readdir
4851 # define readdir(a) Perl_readdir(aTHX_ a)
4854 /* Number of elements in vms_versions array */
4855 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4858 * Open a directory, return a handle for later use.
4860 /*{{{ DIR *opendir(char*name) */
4862 Perl_opendir(pTHX_ char *name)
4865 char dir[NAM$C_MAXRSS+1];
4868 if (do_tovmspath(name,dir,0) == NULL) {
4871 /* Check access before stat; otherwise stat does not
4872 * accurately report whether it's a directory.
4874 if (!cando_by_name(S_IRUSR,0,dir)) {
4875 /* cando_by_name has already set errno */
4878 if (flex_stat(dir,&sb) == -1) return NULL;
4879 if (!S_ISDIR(sb.st_mode)) {
4880 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4883 /* Get memory for the handle, and the pattern. */
4885 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4887 /* Fill in the fields; mainly playing with the descriptor. */
4888 (void)sprintf(dd->pattern, "%s*.*",dir);
4891 dd->vms_wantversions = 0;
4892 dd->pat.dsc$a_pointer = dd->pattern;
4893 dd->pat.dsc$w_length = strlen(dd->pattern);
4894 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4895 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4896 #if defined(USE_ITHREADS)
4897 Newx(dd->mutex,1,perl_mutex);
4898 MUTEX_INIT( (perl_mutex *) dd->mutex );
4904 } /* end of opendir() */
4908 * Set the flag to indicate we want versions or not.
4910 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4912 vmsreaddirversions(DIR *dd, int flag)
4914 dd->vms_wantversions = flag;
4919 * Free up an opened directory.
4921 /*{{{ void closedir(DIR *dd)*/
4925 (void)lib$find_file_end(&dd->context);
4926 Safefree(dd->pattern);
4927 #if defined(USE_ITHREADS)
4928 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4929 Safefree(dd->mutex);
4931 Safefree((char *)dd);
4936 * Collect all the version numbers for the current file.
4939 collectversions(pTHX_ DIR *dd)
4941 struct dsc$descriptor_s pat;
4942 struct dsc$descriptor_s res;
4944 char *p, *text, buff[sizeof dd->entry.d_name];
4946 unsigned long context, tmpsts;
4948 /* Convenient shorthand. */
4951 /* Add the version wildcard, ignoring the "*.*" put on before */
4952 i = strlen(dd->pattern);
4953 Newx(text,i + e->d_namlen + 3,char);
4954 (void)strcpy(text, dd->pattern);
4955 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4957 /* Set up the pattern descriptor. */
4958 pat.dsc$a_pointer = text;
4959 pat.dsc$w_length = i + e->d_namlen - 1;
4960 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4961 pat.dsc$b_class = DSC$K_CLASS_S;
4963 /* Set up result descriptor. */
4964 res.dsc$a_pointer = buff;
4965 res.dsc$w_length = sizeof buff - 2;
4966 res.dsc$b_dtype = DSC$K_DTYPE_T;
4967 res.dsc$b_class = DSC$K_CLASS_S;
4969 /* Read files, collecting versions. */
4970 for (context = 0, e->vms_verscount = 0;
4971 e->vms_verscount < VERSIZE(e);
4972 e->vms_verscount++) {
4973 tmpsts = lib$find_file(&pat, &res, &context);
4974 if (tmpsts == RMS$_NMF || context == 0) break;
4976 buff[sizeof buff - 1] = '\0';
4977 if ((p = strchr(buff, ';')))
4978 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4980 e->vms_versions[e->vms_verscount] = -1;
4983 _ckvmssts(lib$find_file_end(&context));
4986 } /* end of collectversions() */
4989 * Read the next entry from the directory.
4991 /*{{{ struct dirent *readdir(DIR *dd)*/
4993 Perl_readdir(pTHX_ DIR *dd)
4995 struct dsc$descriptor_s res;
4996 char *p, buff[sizeof dd->entry.d_name];
4997 unsigned long int tmpsts;
4999 /* Set up result descriptor, and get next file. */
5000 res.dsc$a_pointer = buff;
5001 res.dsc$w_length = sizeof buff - 2;
5002 res.dsc$b_dtype = DSC$K_DTYPE_T;
5003 res.dsc$b_class = DSC$K_CLASS_S;
5004 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5005 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
5006 if (!(tmpsts & 1)) {
5007 set_vaxc_errno(tmpsts);
5010 set_errno(EACCES); break;
5012 set_errno(ENODEV); break;
5014 set_errno(ENOTDIR); break;
5015 case RMS$_FNF: case RMS$_DNF:
5016 set_errno(ENOENT); break;
5023 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5024 buff[sizeof buff - 1] = '\0';
5025 for (p = buff; *p; p++) *p = _tolower(*p);
5026 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5029 /* Skip any directory component and just copy the name. */
5030 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5031 else (void)strcpy(dd->entry.d_name, buff);
5033 /* Clobber the version. */
5034 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5036 dd->entry.d_namlen = strlen(dd->entry.d_name);
5037 dd->entry.vms_verscount = 0;
5038 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5041 } /* end of readdir() */
5045 * Read the next entry from the directory -- thread-safe version.
5047 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5049 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5053 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5055 entry = readdir(dd);
5057 retval = ( *result == NULL ? errno : 0 );
5059 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5063 } /* end of readdir_r() */
5067 * Return something that can be used in a seekdir later.
5069 /*{{{ long telldir(DIR *dd)*/
5078 * Return to a spot where we used to be. Brute force.
5080 /*{{{ void seekdir(DIR *dd,long count)*/
5082 Perl_seekdir(pTHX_ DIR *dd, long count)
5084 int vms_wantversions;
5086 /* If we haven't done anything yet... */
5090 /* Remember some state, and clear it. */
5091 vms_wantversions = dd->vms_wantversions;
5092 dd->vms_wantversions = 0;
5093 _ckvmssts(lib$find_file_end(&dd->context));
5096 /* The increment is in readdir(). */
5097 for (dd->count = 0; dd->count < count; )
5100 dd->vms_wantversions = vms_wantversions;
5102 } /* end of seekdir() */
5105 /* VMS subprocess management
5107 * my_vfork() - just a vfork(), after setting a flag to record that
5108 * the current script is trying a Unix-style fork/exec.
5110 * vms_do_aexec() and vms_do_exec() are called in response to the
5111 * perl 'exec' function. If this follows a vfork call, then they
5112 * call out the regular perl routines in doio.c which do an
5113 * execvp (for those who really want to try this under VMS).
5114 * Otherwise, they do exactly what the perl docs say exec should
5115 * do - terminate the current script and invoke a new command
5116 * (See below for notes on command syntax.)
5118 * do_aspawn() and do_spawn() implement the VMS side of the perl
5119 * 'system' function.
5121 * Note on command arguments to perl 'exec' and 'system': When handled
5122 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5123 * are concatenated to form a DCL command string. If the first arg
5124 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5125 * the command string is handed off to DCL directly. Otherwise,
5126 * the first token of the command is taken as the filespec of an image
5127 * to run. The filespec is expanded using a default type of '.EXE' and
5128 * the process defaults for device, directory, etc., and if found, the resultant
5129 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5130 * the command string as parameters. This is perhaps a bit complicated,
5131 * but I hope it will form a happy medium between what VMS folks expect
5132 * from lib$spawn and what Unix folks expect from exec.
5135 static int vfork_called;
5137 /*{{{int my_vfork()*/
5148 vms_execfree(struct dsc$descriptor_s *vmscmd)
5151 if (vmscmd->dsc$a_pointer) {
5152 Safefree(vmscmd->dsc$a_pointer);
5159 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5161 char *junk, *tmps = Nullch;
5162 register size_t cmdlen = 0;
5169 tmps = SvPV(really,rlen);
5176 for (idx++; idx <= sp; idx++) {
5178 junk = SvPVx(*idx,rlen);
5179 cmdlen += rlen ? rlen + 1 : 0;
5182 Newx(PL_Cmd,cmdlen+1,char);
5184 if (tmps && *tmps) {
5185 strcpy(PL_Cmd,tmps);
5188 else *PL_Cmd = '\0';
5189 while (++mark <= sp) {
5191 char *s = SvPVx(*mark,n_a);
5193 if (*PL_Cmd) strcat(PL_Cmd," ");
5199 } /* end of setup_argstr() */
5202 static unsigned long int
5203 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5204 struct dsc$descriptor_s **pvmscmd)
5206 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5207 $DESCRIPTOR(defdsc,".EXE");
5208 $DESCRIPTOR(defdsc2,".");
5209 $DESCRIPTOR(resdsc,resspec);
5210 struct dsc$descriptor_s *vmscmd;
5211 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5212 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5213 register char *s, *rest, *cp, *wordbreak;
5216 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5217 vmscmd->dsc$a_pointer = NULL;
5218 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5219 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5220 vmscmd->dsc$w_length = 0;
5221 if (pvmscmd) *pvmscmd = vmscmd;
5223 if (suggest_quote) *suggest_quote = 0;
5225 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5226 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5228 while (*s && isspace(*s)) s++;
5230 if (*s == '@' || *s == '$') {
5231 vmsspec[0] = *s; rest = s + 1;
5232 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5234 else { cp = vmsspec; rest = s; }
5235 if (*rest == '.' || *rest == '/') {
5238 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5239 rest++, cp2++) *cp2 = *rest;
5241 if (do_tovmsspec(resspec,cp,0)) {
5244 for (cp2 = vmsspec + strlen(vmsspec);
5245 *rest && cp2 - vmsspec < sizeof vmsspec;
5246 rest++, cp2++) *cp2 = *rest;
5251 /* Intuit whether verb (first word of cmd) is a DCL command:
5252 * - if first nonspace char is '@', it's a DCL indirection
5254 * - if verb contains a filespec separator, it's not a DCL command
5255 * - if it doesn't, caller tells us whether to default to a DCL
5256 * command, or to a local image unless told it's DCL (by leading '$')
5260 if (suggest_quote) *suggest_quote = 1;
5262 register char *filespec = strpbrk(s,":<[.;");
5263 rest = wordbreak = strpbrk(s," \"\t/");
5264 if (!wordbreak) wordbreak = s + strlen(s);
5265 if (*s == '$') check_img = 0;
5266 if (filespec && (filespec < wordbreak)) isdcl = 0;
5267 else isdcl = !check_img;
5271 imgdsc.dsc$a_pointer = s;
5272 imgdsc.dsc$w_length = wordbreak - s;
5273 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5275 _ckvmssts(lib$find_file_end(&cxt));
5276 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5277 if (!(retsts & 1) && *s == '$') {
5278 _ckvmssts(lib$find_file_end(&cxt));
5279 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5280 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5282 _ckvmssts(lib$find_file_end(&cxt));
5283 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5287 _ckvmssts(lib$find_file_end(&cxt));
5292 while (*s && !isspace(*s)) s++;
5295 /* check that it's really not DCL with no file extension */
5296 fp = fopen(resspec,"r","ctx=bin","shr=get");
5298 char b[4] = {0,0,0,0};
5299 read(fileno(fp),b,4);
5300 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5303 if (check_img && isdcl) return RMS$_FNF;
5305 if (cando_by_name(S_IXUSR,0,resspec)) {
5306 Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5308 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5309 if (suggest_quote) *suggest_quote = 1;
5311 strcpy(vmscmd->dsc$a_pointer,"@");
5312 if (suggest_quote) *suggest_quote = 1;
5314 strcat(vmscmd->dsc$a_pointer,resspec);
5315 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5316 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5317 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5319 else retsts = RMS$_PRV;
5322 /* It's either a DCL command or we couldn't find a suitable image */
5323 vmscmd->dsc$w_length = strlen(cmd);
5324 /* if (cmd == PL_Cmd) {
5325 vmscmd->dsc$a_pointer = PL_Cmd;
5326 if (suggest_quote) *suggest_quote = 1;
5329 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5331 /* check if it's a symbol (for quoting purposes) */
5332 if (suggest_quote && !*suggest_quote) {
5334 char equiv[LNM$C_NAMLENGTH];
5335 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5336 eqvdsc.dsc$a_pointer = equiv;
5338 iss = lib$get_symbol(vmscmd,&eqvdsc);
5339 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5341 if (!(retsts & 1)) {
5342 /* just hand off status values likely to be due to user error */
5343 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5344 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5345 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5346 else { _ckvmssts(retsts); }
5349 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5351 } /* end of setup_cmddsc() */
5354 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5356 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5359 if (vfork_called) { /* this follows a vfork - act Unixish */
5361 if (vfork_called < 0) {
5362 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5365 else return do_aexec(really,mark,sp);
5367 /* no vfork - act VMSish */
5368 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5373 } /* end of vms_do_aexec() */
5376 /* {{{bool vms_do_exec(char *cmd) */
5378 Perl_vms_do_exec(pTHX_ char *cmd)
5380 struct dsc$descriptor_s *vmscmd;
5382 if (vfork_called) { /* this follows a vfork - act Unixish */
5384 if (vfork_called < 0) {
5385 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5388 else return do_exec(cmd);
5391 { /* no vfork - act VMSish */
5392 unsigned long int retsts;
5395 TAINT_PROPER("exec");
5396 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5397 retsts = lib$do_command(vmscmd);
5400 case RMS$_FNF: case RMS$_DNF:
5401 set_errno(ENOENT); break;
5403 set_errno(ENOTDIR); break;
5405 set_errno(ENODEV); break;
5407 set_errno(EACCES); break;
5409 set_errno(EINVAL); break;
5410 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5411 set_errno(E2BIG); break;
5412 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5413 _ckvmssts(retsts); /* fall through */
5414 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5417 set_vaxc_errno(retsts);
5418 if (ckWARN(WARN_EXEC)) {
5419 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5420 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5422 vms_execfree(vmscmd);
5427 } /* end of vms_do_exec() */
5430 unsigned long int Perl_do_spawn(pTHX_ char *);
5432 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5434 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5436 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5439 } /* end of do_aspawn() */
5442 /* {{{unsigned long int do_spawn(char *cmd) */
5444 Perl_do_spawn(pTHX_ char *cmd)
5446 unsigned long int sts, substs;
5449 TAINT_PROPER("spawn");
5450 if (!cmd || !*cmd) {
5451 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5454 case RMS$_FNF: case RMS$_DNF:
5455 set_errno(ENOENT); break;
5457 set_errno(ENOTDIR); break;
5459 set_errno(ENODEV); break;
5461 set_errno(EACCES); break;
5463 set_errno(EINVAL); break;
5464 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5465 set_errno(E2BIG); break;
5466 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5467 _ckvmssts(sts); /* fall through */
5468 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5471 set_vaxc_errno(sts);
5472 if (ckWARN(WARN_EXEC)) {
5473 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5480 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5483 } /* end of do_spawn() */
5487 static unsigned int *sockflags, sockflagsize;
5490 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5491 * routines found in some versions of the CRTL can't deal with sockets.
5492 * We don't shim the other file open routines since a socket isn't
5493 * likely to be opened by a name.
5495 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5496 FILE *my_fdopen(int fd, const char *mode)
5498 FILE *fp = fdopen(fd, (char *) mode);
5501 unsigned int fdoff = fd / sizeof(unsigned int);
5502 struct stat sbuf; /* native stat; we don't need flex_stat */
5503 if (!sockflagsize || fdoff > sockflagsize) {
5504 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5505 else Newx (sockflags,fdoff+2,unsigned int);
5506 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5507 sockflagsize = fdoff + 2;
5509 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5510 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5519 * Clear the corresponding bit when the (possibly) socket stream is closed.
5520 * There still a small hole: we miss an implicit close which might occur
5521 * via freopen(). >> Todo
5523 /*{{{ int my_fclose(FILE *fp)*/
5524 int my_fclose(FILE *fp) {
5526 unsigned int fd = fileno(fp);
5527 unsigned int fdoff = fd / sizeof(unsigned int);
5529 if (sockflagsize && fdoff <= sockflagsize)
5530 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5538 * A simple fwrite replacement which outputs itmsz*nitm chars without
5539 * introducing record boundaries every itmsz chars.
5540 * We are using fputs, which depends on a terminating null. We may
5541 * well be writing binary data, so we need to accommodate not only
5542 * data with nulls sprinkled in the middle but also data with no null
5545 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5547 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5549 register char *cp, *end, *cpd, *data;
5550 register unsigned int fd = fileno(dest);
5551 register unsigned int fdoff = fd / sizeof(unsigned int);
5553 int bufsize = itmsz * nitm + 1;
5555 if (fdoff < sockflagsize &&
5556 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5557 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5561 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5562 memcpy( data, src, itmsz*nitm );
5563 data[itmsz*nitm] = '\0';
5565 end = data + itmsz * nitm;
5566 retval = (int) nitm; /* on success return # items written */
5569 while (cpd <= end) {
5570 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5571 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5573 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5577 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5580 } /* end of my_fwrite() */
5583 /*{{{ int my_flush(FILE *fp)*/
5585 Perl_my_flush(pTHX_ FILE *fp)
5588 if ((res = fflush(fp)) == 0 && fp) {
5589 #ifdef VMS_DO_SOCKETS
5591 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5593 res = fsync(fileno(fp));
5596 * If the flush succeeded but set end-of-file, we need to clear
5597 * the error because our caller may check ferror(). BTW, this
5598 * probably means we just flushed an empty file.
5600 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5607 * Here are replacements for the following Unix routines in the VMS environment:
5608 * getpwuid Get information for a particular UIC or UID
5609 * getpwnam Get information for a named user
5610 * getpwent Get information for each user in the rights database
5611 * setpwent Reset search to the start of the rights database
5612 * endpwent Finish searching for users in the rights database
5614 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5615 * (defined in pwd.h), which contains the following fields:-
5617 * char *pw_name; Username (in lower case)
5618 * char *pw_passwd; Hashed password
5619 * unsigned int pw_uid; UIC
5620 * unsigned int pw_gid; UIC group number
5621 * char *pw_unixdir; Default device/directory (VMS-style)
5622 * char *pw_gecos; Owner name
5623 * char *pw_dir; Default device/directory (Unix-style)
5624 * char *pw_shell; Default CLI name (eg. DCL)
5626 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5628 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5629 * not the UIC member number (eg. what's returned by getuid()),
5630 * getpwuid() can accept either as input (if uid is specified, the caller's
5631 * UIC group is used), though it won't recognise gid=0.
5633 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5634 * information about other users in your group or in other groups, respectively.
5635 * If the required privilege is not available, then these routines fill only
5636 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5639 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5642 /* sizes of various UAF record fields */
5643 #define UAI$S_USERNAME 12
5644 #define UAI$S_IDENT 31
5645 #define UAI$S_OWNER 31
5646 #define UAI$S_DEFDEV 31
5647 #define UAI$S_DEFDIR 63
5648 #define UAI$S_DEFCLI 31
5651 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5652 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5653 (uic).uic$v_group != UIC$K_WILD_GROUP)
5655 static char __empty[]= "";
5656 static struct passwd __passwd_empty=
5657 {(char *) __empty, (char *) __empty, 0, 0,
5658 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5659 static int contxt= 0;
5660 static struct passwd __pwdcache;
5661 static char __pw_namecache[UAI$S_IDENT+1];
5664 * This routine does most of the work extracting the user information.
5666 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5669 unsigned char length;
5670 char pw_gecos[UAI$S_OWNER+1];
5672 static union uicdef uic;
5674 unsigned char length;
5675 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5678 unsigned char length;
5679 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5682 unsigned char length;
5683 char pw_shell[UAI$S_DEFCLI+1];
5685 static char pw_passwd[UAI$S_PWD+1];
5687 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5688 struct dsc$descriptor_s name_desc;
5689 unsigned long int sts;
5691 static struct itmlst_3 itmlst[]= {
5692 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5693 {sizeof(uic), UAI$_UIC, &uic, &luic},
5694 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5695 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5696 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5697 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5698 {0, 0, NULL, NULL}};
5700 name_desc.dsc$w_length= strlen(name);
5701 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5702 name_desc.dsc$b_class= DSC$K_CLASS_S;
5703 name_desc.dsc$a_pointer= (char *) name;
5705 /* Note that sys$getuai returns many fields as counted strings. */
5706 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5707 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5708 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5710 else { _ckvmssts(sts); }
5711 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5713 if ((int) owner.length < lowner) lowner= (int) owner.length;
5714 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5715 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5716 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5717 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5718 owner.pw_gecos[lowner]= '\0';
5719 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5720 defcli.pw_shell[ldefcli]= '\0';
5721 if (valid_uic(uic)) {
5722 pwd->pw_uid= uic.uic$l_uic;
5723 pwd->pw_gid= uic.uic$v_group;
5726 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5727 pwd->pw_passwd= pw_passwd;
5728 pwd->pw_gecos= owner.pw_gecos;
5729 pwd->pw_dir= defdev.pw_dir;
5730 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5731 pwd->pw_shell= defcli.pw_shell;
5732 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5734 ldir= strlen(pwd->pw_unixdir) - 1;
5735 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5738 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5739 __mystrtolower(pwd->pw_unixdir);
5744 * Get information for a named user.
5746 /*{{{struct passwd *getpwnam(char *name)*/
5747 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5749 struct dsc$descriptor_s name_desc;
5751 unsigned long int status, sts;
5753 __pwdcache = __passwd_empty;
5754 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5755 /* We still may be able to determine pw_uid and pw_gid */
5756 name_desc.dsc$w_length= strlen(name);
5757 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5758 name_desc.dsc$b_class= DSC$K_CLASS_S;
5759 name_desc.dsc$a_pointer= (char *) name;
5760 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5761 __pwdcache.pw_uid= uic.uic$l_uic;
5762 __pwdcache.pw_gid= uic.uic$v_group;
5765 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5766 set_vaxc_errno(sts);
5767 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5770 else { _ckvmssts(sts); }
5773 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5774 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5775 __pwdcache.pw_name= __pw_namecache;
5777 } /* end of my_getpwnam() */
5781 * Get information for a particular UIC or UID.
5782 * Called by my_getpwent with uid=-1 to list all users.
5784 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5785 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5787 const $DESCRIPTOR(name_desc,__pw_namecache);
5788 unsigned short lname;
5790 unsigned long int status;
5792 if (uid == (unsigned int) -1) {
5794 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5795 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5796 set_vaxc_errno(status);
5797 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5801 else { _ckvmssts(status); }
5802 } while (!valid_uic (uic));
5806 if (!uic.uic$v_group)
5807 uic.uic$v_group= PerlProc_getgid();
5809 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5810 else status = SS$_IVIDENT;
5811 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5812 status == RMS$_PRV) {
5813 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5816 else { _ckvmssts(status); }
5818 __pw_namecache[lname]= '\0';
5819 __mystrtolower(__pw_namecache);
5821 __pwdcache = __passwd_empty;
5822 __pwdcache.pw_name = __pw_namecache;
5824 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5825 The identifier's value is usually the UIC, but it doesn't have to be,
5826 so if we can, we let fillpasswd update this. */
5827 __pwdcache.pw_uid = uic.uic$l_uic;
5828 __pwdcache.pw_gid = uic.uic$v_group;
5830 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5833 } /* end of my_getpwuid() */
5837 * Get information for next user.
5839 /*{{{struct passwd *my_getpwent()*/
5840 struct passwd *Perl_my_getpwent(pTHX)
5842 return (my_getpwuid((unsigned int) -1));
5847 * Finish searching rights database for users.
5849 /*{{{void my_endpwent()*/
5850 void Perl_my_endpwent(pTHX)
5853 _ckvmssts(sys$finish_rdb(&contxt));
5859 #ifdef HOMEGROWN_POSIX_SIGNALS
5860 /* Signal handling routines, pulled into the core from POSIX.xs.
5862 * We need these for threads, so they've been rolled into the core,
5863 * rather than left in POSIX.xs.
5865 * (DRS, Oct 23, 1997)
5868 /* sigset_t is atomic under VMS, so these routines are easy */
5869 /*{{{int my_sigemptyset(sigset_t *) */
5870 int my_sigemptyset(sigset_t *set) {
5871 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5877 /*{{{int my_sigfillset(sigset_t *)*/
5878 int my_sigfillset(sigset_t *set) {
5880 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5881 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5887 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5888 int my_sigaddset(sigset_t *set, int sig) {
5889 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5890 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5891 *set |= (1 << (sig - 1));
5897 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5898 int my_sigdelset(sigset_t *set, int sig) {
5899 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5900 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5901 *set &= ~(1 << (sig - 1));
5907 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5908 int my_sigismember(sigset_t *set, int sig) {
5909 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5910 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5911 return *set & (1 << (sig - 1));
5916 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5917 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5920 /* If set and oset are both null, then things are badly wrong. Bail out. */
5921 if ((oset == NULL) && (set == NULL)) {
5922 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5926 /* If set's null, then we're just handling a fetch. */
5928 tempmask = sigblock(0);
5933 tempmask = sigsetmask(*set);
5936 tempmask = sigblock(*set);
5939 tempmask = sigblock(0);
5940 sigsetmask(*oset & ~tempmask);
5943 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5948 /* Did they pass us an oset? If so, stick our holding mask into it */
5955 #endif /* HOMEGROWN_POSIX_SIGNALS */
5958 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5959 * my_utime(), and flex_stat(), all of which operate on UTC unless
5960 * VMSISH_TIMES is true.
5962 /* method used to handle UTC conversions:
5963 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5965 static int gmtime_emulation_type;
5966 /* number of secs to add to UTC POSIX-style time to get local time */
5967 static long int utc_offset_secs;
5969 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5970 * in vmsish.h. #undef them here so we can call the CRTL routines
5979 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5980 * qualifier with the extern prefix pragma. This provisional
5981 * hack circumvents this prefix pragma problem in previous
5984 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5985 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5986 # pragma __extern_prefix save
5987 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5988 # define gmtime decc$__utctz_gmtime
5989 # define localtime decc$__utctz_localtime
5990 # define time decc$__utc_time
5991 # pragma __extern_prefix restore
5993 struct tm *gmtime(), *localtime();
5999 static time_t toutc_dst(time_t loc) {
6002 if ((rsltmp = localtime(&loc)) == NULL) return -1;
6003 loc -= utc_offset_secs;
6004 if (rsltmp->tm_isdst) loc -= 3600;
6007 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6008 ((gmtime_emulation_type || my_time(NULL)), \
6009 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6010 ((secs) - utc_offset_secs))))
6012 static time_t toloc_dst(time_t utc) {
6015 utc += utc_offset_secs;
6016 if ((rsltmp = localtime(&utc)) == NULL) return -1;
6017 if (rsltmp->tm_isdst) utc += 3600;
6020 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6021 ((gmtime_emulation_type || my_time(NULL)), \
6022 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6023 ((secs) + utc_offset_secs))))
6025 #ifndef RTL_USES_UTC
6028 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6029 DST starts on 1st sun of april at 02:00 std time
6030 ends on last sun of october at 02:00 dst time
6031 see the UCX management command reference, SET CONFIG TIMEZONE
6032 for formatting info.
6034 No, it's not as general as it should be, but then again, NOTHING
6035 will handle UK times in a sensible way.
6040 parse the DST start/end info:
6041 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6045 tz_parse_startend(char *s, struct tm *w, int *past)
6047 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6048 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6053 if (!past) return 0;
6056 if (w->tm_year % 4 == 0) ly = 1;
6057 if (w->tm_year % 100 == 0) ly = 0;
6058 if (w->tm_year+1900 % 400 == 0) ly = 1;
6061 dozjd = isdigit(*s);
6062 if (*s == 'J' || *s == 'j' || dozjd) {
6063 if (!dozjd && !isdigit(*++s)) return 0;
6066 d = d*10 + *s++ - '0';
6068 d = d*10 + *s++ - '0';
6071 if (d == 0) return 0;
6072 if (d > 366) return 0;
6074 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6077 } else if (*s == 'M' || *s == 'm') {
6078 if (!isdigit(*++s)) return 0;
6080 if (isdigit(*s)) m = 10*m + *s++ - '0';
6081 if (*s != '.') return 0;
6082 if (!isdigit(*++s)) return 0;
6084 if (n < 1 || n > 5) return 0;
6085 if (*s != '.') return 0;
6086 if (!isdigit(*++s)) return 0;
6088 if (d > 6) return 0;
6092 if (!isdigit(*++s)) return 0;
6094 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6096 if (!isdigit(*++s)) return 0;
6098 if (isdigit(*s)) min = 10*min + *s++ - '0';
6100 if (!isdigit(*++s)) return 0;
6102 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6112 if (w->tm_yday < d) goto before;
6113 if (w->tm_yday > d) goto after;
6115 if (w->tm_mon+1 < m) goto before;
6116 if (w->tm_mon+1 > m) goto after;
6118 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6119 k = d - j; /* mday of first d */
6121 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6122 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6123 if (w->tm_mday < k) goto before;
6124 if (w->tm_mday > k) goto after;
6127 if (w->tm_hour < hour) goto before;
6128 if (w->tm_hour > hour) goto after;
6129 if (w->tm_min < min) goto before;
6130 if (w->tm_min > min) goto after;
6131 if (w->tm_sec < sec) goto before;
6145 /* parse the offset: (+|-)hh[:mm[:ss]] */
6148 tz_parse_offset(char *s, int *offset)
6150 int hour = 0, min = 0, sec = 0;
6153 if (!offset) return 0;
6155 if (*s == '-') {neg++; s++;}
6157 if (!isdigit(*s)) return 0;
6159 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6160 if (hour > 24) return 0;
6162 if (!isdigit(*++s)) return 0;
6164 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6165 if (min > 59) return 0;
6167 if (!isdigit(*++s)) return 0;
6169 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6170 if (sec > 59) return 0;
6174 *offset = (hour*60+min)*60 + sec;
6175 if (neg) *offset = -*offset;
6180 input time is w, whatever type of time the CRTL localtime() uses.
6181 sets dst, the zone, and the gmtoff (seconds)
6183 caches the value of TZ and UCX$TZ env variables; note that
6184 my_setenv looks for these and sets a flag if they're changed
6187 We have to watch out for the "australian" case (dst starts in
6188 october, ends in april)...flagged by "reverse" and checked by
6189 scanning through the months of the previous year.
6194 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6199 char *dstzone, *tz, *s_start, *s_end;
6200 int std_off, dst_off, isdst;
6201 int y, dststart, dstend;
6202 static char envtz[1025]; /* longer than any logical, symbol, ... */
6203 static char ucxtz[1025];
6204 static char reversed = 0;
6210 reversed = -1; /* flag need to check */
6211 envtz[0] = ucxtz[0] = '\0';
6212 tz = my_getenv("TZ",0);
6213 if (tz) strcpy(envtz, tz);
6214 tz = my_getenv("UCX$TZ",0);
6215 if (tz) strcpy(ucxtz, tz);
6216 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6219 if (!*tz) tz = ucxtz;
6222 while (isalpha(*s)) s++;
6223 s = tz_parse_offset(s, &std_off);
6225 if (!*s) { /* no DST, hurray we're done! */
6231 while (isalpha(*s)) s++;
6232 s2 = tz_parse_offset(s, &dst_off);
6236 dst_off = std_off - 3600;
6239 if (!*s) { /* default dst start/end?? */
6240 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6241 s = strchr(ucxtz,',');
6243 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6245 if (*s != ',') return 0;
6248 when = _toutc(when); /* convert to utc */
6249 when = when - std_off; /* convert to pseudolocal time*/
6251 w2 = localtime(&when);
6254 s = tz_parse_startend(s_start,w2,&dststart);
6256 if (*s != ',') return 0;
6259 when = _toutc(when); /* convert to utc */
6260 when = when - dst_off; /* convert to pseudolocal time*/
6261 w2 = localtime(&when);
6262 if (w2->tm_year != y) { /* spans a year, just check one time */
6263 when += dst_off - std_off;
6264 w2 = localtime(&when);
6267 s = tz_parse_startend(s_end,w2,&dstend);
6270 if (reversed == -1) { /* need to check if start later than end */
6274 if (when < 2*365*86400) {
6275 when += 2*365*86400;
6279 w2 =localtime(&when);
6280 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6282 for (j = 0; j < 12; j++) {
6283 w2 =localtime(&when);
6284 (void) tz_parse_startend(s_start,w2,&ds);
6285 (void) tz_parse_startend(s_end,w2,&de);
6286 if (ds != de) break;
6290 if (de && !ds) reversed = 1;
6293 isdst = dststart && !dstend;
6294 if (reversed) isdst = dststart || !dstend;
6297 if (dst) *dst = isdst;
6298 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6299 if (isdst) tz = dstzone;
6301 while(isalpha(*tz)) *zone++ = *tz++;
6307 #endif /* !RTL_USES_UTC */
6309 /* my_time(), my_localtime(), my_gmtime()
6310 * By default traffic in UTC time values, using CRTL gmtime() or
6311 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6312 * Note: We need to use these functions even when the CRTL has working
6313 * UTC support, since they also handle C<use vmsish qw(times);>
6315 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6316 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6319 /*{{{time_t my_time(time_t *timep)*/
6320 time_t Perl_my_time(pTHX_ time_t *timep)
6325 if (gmtime_emulation_type == 0) {
6327 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6328 /* results of calls to gmtime() and localtime() */
6329 /* for same &base */
6331 gmtime_emulation_type++;
6332 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6333 char off[LNM$C_NAMLENGTH+1];;
6335 gmtime_emulation_type++;
6336 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6337 gmtime_emulation_type++;
6338 utc_offset_secs = 0;
6339 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6341 else { utc_offset_secs = atol(off); }
6343 else { /* We've got a working gmtime() */
6344 struct tm gmt, local;
6347 tm_p = localtime(&base);
6349 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6350 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6351 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6352 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6358 # ifdef RTL_USES_UTC
6359 if (VMSISH_TIME) when = _toloc(when);
6361 if (!VMSISH_TIME) when = _toutc(when);
6364 if (timep != NULL) *timep = when;
6367 } /* end of my_time() */
6371 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6373 Perl_my_gmtime(pTHX_ const time_t *timep)
6379 if (timep == NULL) {
6380 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6383 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6387 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6389 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6390 return gmtime(&when);
6392 /* CRTL localtime() wants local time as input, so does no tz correction */
6393 rsltmp = localtime(&when);
6394 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6397 } /* end of my_gmtime() */
6401 /*{{{struct tm *my_localtime(const time_t *timep)*/
6403 Perl_my_localtime(pTHX_ const time_t *timep)
6405 time_t when, whenutc;
6409 if (timep == NULL) {
6410 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6413 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6414 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6417 # ifdef RTL_USES_UTC
6419 if (VMSISH_TIME) when = _toutc(when);
6421 /* CRTL localtime() wants UTC as input, does tz correction itself */
6422 return localtime(&when);
6424 # else /* !RTL_USES_UTC */
6427 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6428 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6431 #ifndef RTL_USES_UTC
6432 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6433 when = whenutc - offset; /* pseudolocal time*/
6436 /* CRTL localtime() wants local time as input, so does no tz correction */
6437 rsltmp = localtime(&when);
6438 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6442 } /* end of my_localtime() */
6445 /* Reset definitions for later calls */
6446 #define gmtime(t) my_gmtime(t)
6447 #define localtime(t) my_localtime(t)
6448 #define time(t) my_time(t)
6451 /* my_utime - update modification time of a file
6452 * calling sequence is identical to POSIX utime(), but under
6453 * VMS only the modification time is changed; ODS-2 does not
6454 * maintain access times. Restrictions differ from the POSIX
6455 * definition in that the time can be changed as long as the
6456 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6457 * no separate checks are made to insure that the caller is the
6458 * owner of the file or has special privs enabled.
6459 * Code here is based on Joe Meadows' FILE utility.
6462 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6463 * to VMS epoch (01-JAN-1858 00:00:00.00)
6464 * in 100 ns intervals.
6466 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6468 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
6469 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
6472 long int bintime[2], len = 2, lowbit, unixtime,
6473 secscale = 10000000; /* seconds --> 100 ns intervals */
6474 unsigned long int chan, iosb[2], retsts;
6475 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6476 struct FAB myfab = cc$rms_fab;
6477 struct NAM mynam = cc$rms_nam;
6478 #if defined (__DECC) && defined (__VAX)
6479 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6480 * at least through VMS V6.1, which causes a type-conversion warning.
6482 # pragma message save
6483 # pragma message disable cvtdiftypes
6485 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6486 struct fibdef myfib;
6487 #if defined (__DECC) && defined (__VAX)
6488 /* This should be right after the declaration of myatr, but due
6489 * to a bug in VAX DEC C, this takes effect a statement early.
6491 # pragma message restore
6493 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6494 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6495 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6497 if (file == NULL || *file == '\0') {
6499 set_vaxc_errno(LIB$_INVARG);
6502 if (do_tovmsspec((char *)file,vmsspec,0) == NULL) return -1;
6504 if (utimes != NULL) {
6505 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6506 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6507 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6508 * as input, we force the sign bit to be clear by shifting unixtime right
6509 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6511 lowbit = (utimes->modtime & 1) ? secscale : 0;
6512 unixtime = (long int) utimes->modtime;
6514 /* If input was UTC; convert to local for sys svc */
6515 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6517 unixtime >>= 1; secscale <<= 1;
6518 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6519 if (!(retsts & 1)) {
6521 set_vaxc_errno(retsts);
6524 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6525 if (!(retsts & 1)) {
6527 set_vaxc_errno(retsts);
6532 /* Just get the current time in VMS format directly */
6533 retsts = sys$gettim(bintime);
6534 if (!(retsts & 1)) {
6536 set_vaxc_errno(retsts);
6541 myfab.fab$l_fna = vmsspec;
6542 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6543 myfab.fab$l_nam = &mynam;
6544 mynam.nam$l_esa = esa;
6545 mynam.nam$b_ess = (unsigned char) sizeof esa;
6546 mynam.nam$l_rsa = rsa;
6547 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6549 /* Look for the file to be affected, letting RMS parse the file
6550 * specification for us as well. I have set errno using only
6551 * values documented in the utime() man page for VMS POSIX.
6553 retsts = sys$parse(&myfab,0,0);
6554 if (!(retsts & 1)) {
6555 set_vaxc_errno(retsts);
6556 if (retsts == RMS$_PRV) set_errno(EACCES);
6557 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6558 else set_errno(EVMSERR);
6561 retsts = sys$search(&myfab,0,0);
6562 if (!(retsts & 1)) {
6563 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6564 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6565 set_vaxc_errno(retsts);
6566 if (retsts == RMS$_PRV) set_errno(EACCES);
6567 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6568 else set_errno(EVMSERR);
6572 devdsc.dsc$w_length = mynam.nam$b_dev;
6573 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6575 retsts = sys$assign(&devdsc,&chan,0,0);
6576 if (!(retsts & 1)) {
6577 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6578 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6579 set_vaxc_errno(retsts);
6580 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6581 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6582 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6583 else set_errno(EVMSERR);
6587 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6588 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6590 memset((void *) &myfib, 0, sizeof myfib);
6591 #if defined(__DECC) || defined(__DECCXX)
6592 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6593 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6594 /* This prevents the revision time of the file being reset to the current
6595 * time as a result of our IO$_MODIFY $QIO. */
6596 myfib.fib$l_acctl = FIB$M_NORECORD;
6598 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6599 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6600 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6602 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6603 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6604 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6605 _ckvmssts(sys$dassgn(chan));
6606 if (retsts & 1) retsts = iosb[0];
6607 if (!(retsts & 1)) {
6608 set_vaxc_errno(retsts);
6609 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6610 else set_errno(EVMSERR);
6615 } /* end of my_utime() */
6619 * flex_stat, flex_fstat
6620 * basic stat, but gets it right when asked to stat
6621 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6624 /* encode_dev packs a VMS device name string into an integer to allow
6625 * simple comparisons. This can be used, for example, to check whether two
6626 * files are located on the same device, by comparing their encoded device
6627 * names. Even a string comparison would not do, because stat() reuses the
6628 * device name buffer for each call; so without encode_dev, it would be
6629 * necessary to save the buffer and use strcmp (this would mean a number of
6630 * changes to the standard Perl code, to say nothing of what a Perl script
6633 * The device lock id, if it exists, should be unique (unless perhaps compared
6634 * with lock ids transferred from other nodes). We have a lock id if the disk is
6635 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6636 * device names. Thus we use the lock id in preference, and only if that isn't
6637 * available, do we try to pack the device name into an integer (flagged by
6638 * the sign bit (LOCKID_MASK) being set).
6640 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6641 * name and its encoded form, but it seems very unlikely that we will find
6642 * two files on different disks that share the same encoded device names,
6643 * and even more remote that they will share the same file id (if the test
6644 * is to check for the same file).
6646 * A better method might be to use sys$device_scan on the first call, and to
6647 * search for the device, returning an index into the cached array.
6648 * The number returned would be more intelligable.
6649 * This is probably not worth it, and anyway would take quite a bit longer
6650 * on the first call.
6652 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6653 static mydev_t encode_dev (pTHX_ const char *dev)
6656 unsigned long int f;
6661 if (!dev || !dev[0]) return 0;
6665 struct dsc$descriptor_s dev_desc;
6666 unsigned long int status, lockid, item = DVI$_LOCKID;
6668 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6669 can try that first. */
6670 dev_desc.dsc$w_length = strlen (dev);
6671 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6672 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6673 dev_desc.dsc$a_pointer = (char *) dev;
6674 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6675 if (lockid) return (lockid & ~LOCKID_MASK);
6679 /* Otherwise we try to encode the device name */
6683 for (q = dev + strlen(dev); q--; q >= dev) {
6686 else if (isalpha (toupper (*q)))
6687 c= toupper (*q) - 'A' + (char)10;
6689 continue; /* Skip '$'s */
6691 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6693 enc += f * (unsigned long int) c;
6695 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6697 } /* end of encode_dev() */
6699 static char namecache[NAM$C_MAXRSS+1];
6702 is_null_device(name)
6705 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6706 The underscore prefix, controller letter, and unit number are
6707 independently optional; for our purposes, the colon punctuation
6708 is not. The colon can be trailed by optional directory and/or
6709 filename, but two consecutive colons indicates a nodename rather
6710 than a device. [pr] */
6711 if (*name == '_') ++name;
6712 if (tolower(*name++) != 'n') return 0;
6713 if (tolower(*name++) != 'l') return 0;
6714 if (tolower(*name) == 'a') ++name;
6715 if (*name == '0') ++name;
6716 return (*name++ == ':') && (*name != ':');
6719 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6720 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6721 * subset of the applicable information.
6724 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
6726 char fname_phdev[NAM$C_MAXRSS+1];
6727 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6729 char fname[NAM$C_MAXRSS+1];
6730 unsigned long int retsts;
6731 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6732 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6734 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6735 device name on successive calls */
6736 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6737 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6738 namdsc.dsc$a_pointer = fname;
6739 namdsc.dsc$w_length = sizeof fname - 1;
6741 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6742 &namdsc,&namdsc.dsc$w_length,0,0);
6744 fname[namdsc.dsc$w_length] = '\0';
6746 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6747 * but if someone has redefined that logical, Perl gets very lost. Since
6748 * we have the physical device name from the stat buffer, just paste it on.
6750 strcpy( fname_phdev, statbufp->st_devnam );
6751 strcat( fname_phdev, strrchr(fname, ':') );
6753 return cando_by_name(bit,effective,fname_phdev);
6755 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6756 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6760 return FALSE; /* Should never get to here */
6762 } /* end of cando() */
6766 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6768 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6770 static char usrname[L_cuserid];
6771 static struct dsc$descriptor_s usrdsc =
6772 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6773 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6774 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6775 unsigned short int retlen, trnlnm_iter_count;
6776 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6777 union prvdef curprv;
6778 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6779 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6780 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6781 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6783 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6785 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6787 if (!fname || !*fname) return FALSE;
6788 /* Make sure we expand logical names, since sys$check_access doesn't */
6789 if (!strpbrk(fname,"/]>:")) {
6790 strcpy(fileified,fname);
6791 trnlnm_iter_count = 0;
6792 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6793 trnlnm_iter_count++;
6794 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6798 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6799 retlen = namdsc.dsc$w_length = strlen(vmsname);
6800 namdsc.dsc$a_pointer = vmsname;
6801 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6802 vmsname[retlen-1] == ':') {
6803 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6804 namdsc.dsc$w_length = strlen(fileified);
6805 namdsc.dsc$a_pointer = fileified;
6809 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6810 access = ARM$M_EXECUTE; break;
6811 case S_IRUSR: case S_IRGRP: case S_IROTH:
6812 access = ARM$M_READ; break;
6813 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6814 access = ARM$M_WRITE; break;
6815 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6816 access = ARM$M_DELETE; break;
6821 /* Before we call $check_access, create a user profile with the current
6822 * process privs since otherwise it just uses the default privs from the
6823 * UAF and might give false positives or negatives. This only works on
6824 * VMS versions v6.0 and later since that's when sys$create_user_profile
6828 /* get current process privs and username */
6829 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6832 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6834 /* find out the space required for the profile */
6835 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6836 &usrprodsc.dsc$w_length,0));
6838 /* allocate space for the profile and get it filled in */
6839 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6840 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6841 &usrprodsc.dsc$w_length,0));
6843 /* use the profile to check access to the file; free profile & analyze results */
6844 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6845 Safefree(usrprodsc.dsc$a_pointer);
6846 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6850 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6854 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6855 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6856 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6857 set_vaxc_errno(retsts);
6858 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6859 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6860 else set_errno(ENOENT);
6863 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6868 return FALSE; /* Should never get here */
6870 } /* end of cando_by_name() */
6874 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6876 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6878 if (!fstat(fd,(stat_t *) statbufp)) {
6879 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6880 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6881 # ifdef RTL_USES_UTC
6884 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6885 statbufp->st_atime = _toloc(statbufp->st_atime);
6886 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6891 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6895 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6896 statbufp->st_atime = _toutc(statbufp->st_atime);
6897 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6904 } /* end of flex_fstat() */
6907 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6909 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6911 char fileified[NAM$C_MAXRSS+1];
6912 char temp_fspec[NAM$C_MAXRSS+300];
6914 int saved_errno, saved_vaxc_errno;
6916 if (!fspec) return retval;
6917 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6918 strcpy(temp_fspec, fspec);
6919 if (statbufp == (Stat_t *) &PL_statcache)
6920 do_tovmsspec(temp_fspec,namecache,0);
6921 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6922 memset(statbufp,0,sizeof *statbufp);
6923 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6924 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6925 statbufp->st_uid = 0x00010001;
6926 statbufp->st_gid = 0x0001;
6927 time((time_t *)&statbufp->st_mtime);
6928 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6932 /* Try for a directory name first. If fspec contains a filename without
6933 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6934 * and sea:[wine.dark]water. exist, we prefer the directory here.
6935 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6936 * not sea:[wine.dark]., if the latter exists. If the intended target is
6937 * the file with null type, specify this by calling flex_stat() with
6938 * a '.' at the end of fspec.
6940 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6941 retval = stat(fileified,(stat_t *) statbufp);
6942 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6943 strcpy(namecache,fileified);
6945 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6947 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6948 # ifdef RTL_USES_UTC
6951 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6952 statbufp->st_atime = _toloc(statbufp->st_atime);
6953 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6958 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6962 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6963 statbufp->st_atime = _toutc(statbufp->st_atime);
6964 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6968 /* If we were successful, leave errno where we found it */
6969 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6972 } /* end of flex_stat() */
6976 /*{{{char *my_getlogin()*/
6977 /* VMS cuserid == Unix getlogin, except calling sequence */
6981 static char user[L_cuserid];
6982 return cuserid(user);
6987 /* rmscopy - copy a file using VMS RMS routines
6989 * Copies contents and attributes of spec_in to spec_out, except owner
6990 * and protection information. Name and type of spec_in are used as
6991 * defaults for spec_out. The third parameter specifies whether rmscopy()
6992 * should try to propagate timestamps from the input file to the output file.
6993 * If it is less than 0, no timestamps are preserved. If it is 0, then
6994 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6995 * propagated to the output file at creation iff the output file specification
6996 * did not contain an explicit name or type, and the revision date is always
6997 * updated at the end of the copy operation. If it is greater than 0, then
6998 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6999 * other than the revision date should be propagated, and bit 1 indicates
7000 * that the revision date should be propagated.
7002 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7004 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7005 * Incorporates, with permission, some code from EZCOPY by Tim Adye
7006 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
7007 * as part of the Perl standard distribution under the terms of the
7008 * GNU General Public License or the Perl Artistic License. Copies
7009 * of each may be found in the Perl standard distribution.
7011 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7013 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
7015 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7016 rsa[NAM$C_MAXRSS], ubf[32256];
7017 unsigned long int i, sts, sts2;
7018 struct FAB fab_in, fab_out;
7019 struct RAB rab_in, rab_out;
7021 struct XABDAT xabdat;
7022 struct XABFHC xabfhc;
7023 struct XABRDT xabrdt;
7024 struct XABSUM xabsum;
7026 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7027 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7028 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7032 fab_in = cc$rms_fab;
7033 fab_in.fab$l_fna = vmsin;
7034 fab_in.fab$b_fns = strlen(vmsin);
7035 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7036 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7037 fab_in.fab$l_fop = FAB$M_SQO;
7038 fab_in.fab$l_nam = &nam;
7039 fab_in.fab$l_xab = (void *) &xabdat;
7042 nam.nam$l_rsa = rsa;
7043 nam.nam$b_rss = sizeof(rsa);
7044 nam.nam$l_esa = esa;
7045 nam.nam$b_ess = sizeof (esa);
7046 nam.nam$b_esl = nam.nam$b_rsl = 0;
7048 xabdat = cc$rms_xabdat; /* To get creation date */
7049 xabdat.xab$l_nxt = (void *) &xabfhc;
7051 xabfhc = cc$rms_xabfhc; /* To get record length */
7052 xabfhc.xab$l_nxt = (void *) &xabsum;
7054 xabsum = cc$rms_xabsum; /* To get key and area information */
7056 if (!((sts = sys$open(&fab_in)) & 1)) {
7057 set_vaxc_errno(sts);
7059 case RMS$_FNF: case RMS$_DNF:
7060 set_errno(ENOENT); break;
7062 set_errno(ENOTDIR); break;
7064 set_errno(ENODEV); break;
7066 set_errno(EINVAL); break;
7068 set_errno(EACCES); break;
7076 fab_out.fab$w_ifi = 0;
7077 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7078 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7079 fab_out.fab$l_fop = FAB$M_SQO;
7080 fab_out.fab$l_fna = vmsout;
7081 fab_out.fab$b_fns = strlen(vmsout);
7082 fab_out.fab$l_dna = nam.nam$l_name;
7083 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7085 if (preserve_dates == 0) { /* Act like DCL COPY */
7086 nam.nam$b_nop = NAM$M_SYNCHK;
7087 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7088 if (!((sts = sys$parse(&fab_out)) & 1)) {
7089 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7090 set_vaxc_errno(sts);
7093 fab_out.fab$l_xab = (void *) &xabdat;
7094 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7096 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7097 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7098 preserve_dates =0; /* bitmask from this point forward */
7100 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7101 if (!((sts = sys$create(&fab_out)) & 1)) {
7102 set_vaxc_errno(sts);
7105 set_errno(ENOENT); break;
7107 set_errno(ENOTDIR); break;
7109 set_errno(ENODEV); break;
7111 set_errno(EINVAL); break;
7113 set_errno(EACCES); break;
7119 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7120 if (preserve_dates & 2) {
7121 /* sys$close() will process xabrdt, not xabdat */
7122 xabrdt = cc$rms_xabrdt;
7124 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7126 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7127 * is unsigned long[2], while DECC & VAXC use a struct */
7128 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7130 fab_out.fab$l_xab = (void *) &xabrdt;
7133 rab_in = cc$rms_rab;
7134 rab_in.rab$l_fab = &fab_in;
7135 rab_in.rab$l_rop = RAB$M_BIO;
7136 rab_in.rab$l_ubf = ubf;
7137 rab_in.rab$w_usz = sizeof ubf;
7138 if (!((sts = sys$connect(&rab_in)) & 1)) {
7139 sys$close(&fab_in); sys$close(&fab_out);
7140 set_errno(EVMSERR); set_vaxc_errno(sts);
7144 rab_out = cc$rms_rab;
7145 rab_out.rab$l_fab = &fab_out;
7146 rab_out.rab$l_rbf = ubf;
7147 if (!((sts = sys$connect(&rab_out)) & 1)) {
7148 sys$close(&fab_in); sys$close(&fab_out);
7149 set_errno(EVMSERR); set_vaxc_errno(sts);
7153 while ((sts = sys$read(&rab_in))) { /* always true */
7154 if (sts == RMS$_EOF) break;
7155 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7156 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7157 sys$close(&fab_in); sys$close(&fab_out);
7158 set_errno(EVMSERR); set_vaxc_errno(sts);
7163 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7164 sys$close(&fab_in); sys$close(&fab_out);
7165 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7167 set_errno(EVMSERR); set_vaxc_errno(sts);
7173 } /* end of rmscopy() */
7177 /*** The following glue provides 'hooks' to make some of the routines
7178 * from this file available from Perl. These routines are sufficiently
7179 * basic, and are required sufficiently early in the build process,
7180 * that's it's nice to have them available to miniperl as well as the
7181 * full Perl, so they're set up here instead of in an extension. The
7182 * Perl code which handles importation of these names into a given
7183 * package lives in [.VMS]Filespec.pm in @INC.
7187 rmsexpand_fromperl(pTHX_ CV *cv)
7190 char *fspec, *defspec = NULL, *rslt;
7193 if (!items || items > 2)
7194 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7195 fspec = SvPV(ST(0),n_a);
7196 if (!fspec || !*fspec) XSRETURN_UNDEF;
7197 if (items == 2) defspec = SvPV(ST(1),n_a);
7199 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7200 ST(0) = sv_newmortal();
7201 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7206 vmsify_fromperl(pTHX_ CV *cv)
7212 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7213 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7214 ST(0) = sv_newmortal();
7215 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7220 unixify_fromperl(pTHX_ CV *cv)
7226 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7227 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7228 ST(0) = sv_newmortal();
7229 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7234 fileify_fromperl(pTHX_ CV *cv)
7240 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7241 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7242 ST(0) = sv_newmortal();
7243 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7248 pathify_fromperl(pTHX_ CV *cv)
7254 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7255 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7256 ST(0) = sv_newmortal();
7257 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7262 vmspath_fromperl(pTHX_ CV *cv)
7268 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7269 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7270 ST(0) = sv_newmortal();
7271 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7276 unixpath_fromperl(pTHX_ CV *cv)
7282 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7283 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7284 ST(0) = sv_newmortal();
7285 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7290 candelete_fromperl(pTHX_ CV *cv)
7293 char fspec[NAM$C_MAXRSS+1], *fsp;
7298 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7300 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7301 if (SvTYPE(mysv) == SVt_PVGV) {
7302 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7303 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7310 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7311 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7317 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7322 rmscopy_fromperl(pTHX_ CV *cv)
7325 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7327 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7328 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7329 unsigned long int sts;
7334 if (items < 2 || items > 3)
7335 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7337 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7338 if (SvTYPE(mysv) == SVt_PVGV) {
7339 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7340 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7347 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7348 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7353 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7354 if (SvTYPE(mysv) == SVt_PVGV) {
7355 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7356 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7363 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7364 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7369 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7371 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7377 mod2fname(pTHX_ CV *cv)
7380 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7381 workbuff[NAM$C_MAXRSS*1 + 1];
7382 int total_namelen = 3, counter, num_entries;
7383 /* ODS-5 ups this, but we want to be consistent, so... */
7384 int max_name_len = 39;
7385 AV *in_array = (AV *)SvRV(ST(0));
7387 num_entries = av_len(in_array);
7389 /* All the names start with PL_. */
7390 strcpy(ultimate_name, "PL_");
7392 /* Clean up our working buffer */
7393 Zero(work_name, sizeof(work_name), char);
7395 /* Run through the entries and build up a working name */
7396 for(counter = 0; counter <= num_entries; counter++) {
7397 /* If it's not the first name then tack on a __ */
7399 strcat(work_name, "__");
7401 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7405 /* Check to see if we actually have to bother...*/
7406 if (strlen(work_name) + 3 <= max_name_len) {
7407 strcat(ultimate_name, work_name);
7409 /* It's too darned big, so we need to go strip. We use the same */
7410 /* algorithm as xsubpp does. First, strip out doubled __ */
7411 char *source, *dest, last;
7414 for (source = work_name; *source; source++) {
7415 if (last == *source && last == '_') {
7421 /* Go put it back */
7422 strcpy(work_name, workbuff);
7423 /* Is it still too big? */
7424 if (strlen(work_name) + 3 > max_name_len) {
7425 /* Strip duplicate letters */
7428 for (source = work_name; *source; source++) {
7429 if (last == toupper(*source)) {
7433 last = toupper(*source);
7435 strcpy(work_name, workbuff);
7438 /* Is it *still* too big? */
7439 if (strlen(work_name) + 3 > max_name_len) {
7440 /* Too bad, we truncate */
7441 work_name[max_name_len - 2] = 0;
7443 strcat(ultimate_name, work_name);
7446 /* Okay, return it */
7447 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7452 hushexit_fromperl(pTHX_ CV *cv)
7457 VMSISH_HUSHED = SvTRUE(ST(0));
7459 ST(0) = boolSV(VMSISH_HUSHED);
7464 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7465 struct interp_intern *dst)
7467 memcpy(dst,src,sizeof(struct interp_intern));
7471 Perl_sys_intern_clear(pTHX)
7476 Perl_sys_intern_init(pTHX)
7478 unsigned int ix = RAND_MAX;
7484 MY_INV_RAND_MAX = 1./x;
7491 char* file = __FILE__;
7492 char temp_buff[512];
7493 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7494 no_translate_barewords = TRUE;
7496 no_translate_barewords = FALSE;
7499 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7500 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7501 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7502 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7503 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7504 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7505 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7506 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7507 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7508 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7509 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7511 store_pipelocs(aTHX); /* will redo any earlier attempts */