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_ const char *, char *, int);
1009 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1011 /*{{{int do_rmdir(char *name)*/
1013 Perl_do_rmdir(pTHX_ const 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_ const 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_ const 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_ const 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_ const 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_ const 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 */
3146 if (dirlen > NAM$C_MAXRSS) {
3147 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3149 if (!strpbrk(dir+1,"/]>:")) {
3150 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3151 trnlnm_iter_count = 0;
3152 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3153 trnlnm_iter_count++;
3154 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3156 dirlen = strlen(trndir);
3159 strncpy(trndir,dir,dirlen);
3160 trndir[dirlen] = '\0';
3163 /* At this point we are done with *dir and use *trndir which is a
3164 * copy that can be modified. *dir must not be modified.
3167 /* If we were handed a rooted logical name or spec, treat it like a
3168 * simple directory, so that
3169 * $ Define myroot dev:[dir.]
3170 * ... do_fileify_dirspec("myroot",buf,1) ...
3171 * does something useful.
3173 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
3174 trndir[--dirlen] = '\0';
3175 trndir[dirlen-1] = ']';
3177 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
3178 trndir[--dirlen] = '\0';
3179 trndir[dirlen-1] = '>';
3182 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
3183 /* If we've got an explicit filename, we can just shuffle the string. */
3184 if (*(cp1+1)) hasfilename = 1;
3185 /* Similarly, we can just back up a level if we've got multiple levels
3186 of explicit directories in a VMS spec which ends with directories. */
3188 for (cp2 = cp1; cp2 > trndir; cp2--) {
3190 *cp2 = *cp1; *cp1 = '\0';
3194 if (*cp2 == '[' || *cp2 == '<') break;
3199 if (hasfilename || !strpbrk(trndir,"]:>")) { /* Unix-style path or filename */
3200 if (trndir[0] == '.') {
3201 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
3202 return do_fileify_dirspec("[]",buf,ts);
3203 else if (trndir[1] == '.' &&
3204 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
3205 return do_fileify_dirspec("[-]",buf,ts);
3207 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3208 dirlen -= 1; /* to last element */
3209 lastdir = strrchr(trndir,'/');
3211 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
3212 /* If we have "/." or "/..", VMSify it and let the VMS code
3213 * below expand it, rather than repeating the code to handle
3214 * relative components of a filespec here */
3216 if (*(cp1+2) == '.') cp1++;
3217 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3218 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3219 if (strchr(vmsdir,'/') != NULL) {
3220 /* If do_tovmsspec() returned it, it must have VMS syntax
3221 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3222 * the time to check this here only so we avoid a recursion
3223 * loop; otherwise, gigo.
3225 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3227 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3228 return do_tounixspec(trndir,buf,ts);
3231 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3232 lastdir = strrchr(trndir,'/');
3234 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
3235 /* Ditto for specs that end in an MFD -- let the VMS code
3236 * figure out whether it's a real device or a rooted logical. */
3237 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
3238 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
3239 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3240 return do_tounixspec(trndir,buf,ts);
3243 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
3244 !(lastdir = cp1 = strrchr(trndir,']')) &&
3245 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
3246 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3248 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3249 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3250 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3251 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3252 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3253 (ver || *cp3)))))) {
3255 set_vaxc_errno(RMS$_DIR);
3258 dirlen = cp2 - trndir;
3261 /* If we lead off with a device or rooted logical, add the MFD
3262 if we're specifying a top-level directory. */
3263 if (lastdir && *trndir == '/') {
3265 for (cp1 = lastdir - 1; cp1 > trndir; cp1--) {
3272 retlen = dirlen + (addmfd ? 13 : 6);
3273 if (buf) retspec = buf;
3274 else if (ts) Newx(retspec,retlen+1,char);
3275 else retspec = __fileify_retbuf;
3277 dirlen = lastdir - trndir;
3278 memcpy(retspec,trndir,dirlen);
3279 strcpy(&retspec[dirlen],"/000000");
3280 strcpy(&retspec[dirlen+7],lastdir);
3283 memcpy(retspec,trndir,dirlen);
3284 retspec[dirlen] = '\0';
3286 /* We've picked up everything up to the directory file name.
3287 Now just add the type and version, and we're set. */
3288 strcat(retspec,".dir;1");
3291 else { /* VMS-style directory spec */
3292 char esa[NAM$C_MAXRSS+1], term, *cp;
3293 unsigned long int sts, cmplen, haslower = 0;
3294 struct FAB dirfab = cc$rms_fab;
3295 struct NAM savnam, dirnam = cc$rms_nam;
3297 dirfab.fab$b_fns = strlen(dir);
3298 dirfab.fab$l_fna = trndir;
3299 dirfab.fab$l_nam = &dirnam;
3300 dirfab.fab$l_dna = ".DIR;1";
3301 dirfab.fab$b_dns = 6;
3302 dirnam.nam$b_ess = NAM$C_MAXRSS;
3303 dirnam.nam$l_esa = esa;
3305 for (cp = trndir; *cp; cp++)
3306 if (islower(*cp)) { haslower = 1; break; }
3307 if (!((sts = sys$parse(&dirfab))&1)) {
3308 if (dirfab.fab$l_sts == RMS$_DIR) {
3309 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3310 sts = sys$parse(&dirfab) & 1;
3314 set_vaxc_errno(dirfab.fab$l_sts);
3320 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3321 /* Yes; fake the fnb bits so we'll check type below */
3322 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3324 else { /* No; just work with potential name */
3325 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3327 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3328 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3329 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3334 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3335 cp1 = strchr(esa,']');
3336 if (!cp1) cp1 = strchr(esa,'>');
3337 if (cp1) { /* Should always be true */
3338 dirnam.nam$b_esl -= cp1 - esa - 1;
3339 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3342 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3343 /* Yep; check version while we're at it, if it's there. */
3344 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3345 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3346 /* Something other than .DIR[;1]. Bzzt. */
3347 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3348 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3350 set_vaxc_errno(RMS$_DIR);
3354 esa[dirnam.nam$b_esl] = '\0';
3355 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3356 /* They provided at least the name; we added the type, if necessary, */
3357 if (buf) retspec = buf; /* in sys$parse() */
3358 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
3359 else retspec = __fileify_retbuf;
3360 strcpy(retspec,esa);
3361 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3362 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3365 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3366 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3368 dirnam.nam$b_esl -= 9;
3370 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3371 if (cp1 == NULL) { /* should never happen */
3372 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3373 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3378 retlen = strlen(esa);
3379 if ((cp1 = strrchr(esa,'.')) != NULL) {
3380 /* There's more than one directory in the path. Just roll back. */
3382 if (buf) retspec = buf;
3383 else if (ts) Newx(retspec,retlen+7,char);
3384 else retspec = __fileify_retbuf;
3385 strcpy(retspec,esa);
3388 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3389 /* Go back and expand rooted logical name */
3390 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3391 if (!(sys$parse(&dirfab) & 1)) {
3392 dirnam.nam$l_rlf = NULL;
3393 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3395 set_vaxc_errno(dirfab.fab$l_sts);
3398 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3399 if (buf) retspec = buf;
3400 else if (ts) Newx(retspec,retlen+16,char);
3401 else retspec = __fileify_retbuf;
3402 cp1 = strstr(esa,"][");
3403 if (!cp1) cp1 = strstr(esa,"]<");
3405 memcpy(retspec,esa,dirlen);
3406 if (!strncmp(cp1+2,"000000]",7)) {
3407 retspec[dirlen-1] = '\0';
3408 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3409 if (*cp1 == '.') *cp1 = ']';
3411 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3412 memcpy(cp1+1,"000000]",7);
3416 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3417 retspec[retlen] = '\0';
3418 /* Convert last '.' to ']' */
3419 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3420 if (*cp1 == '.') *cp1 = ']';
3422 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3423 memcpy(cp1+1,"000000]",7);
3427 else { /* This is a top-level dir. Add the MFD to the path. */
3428 if (buf) retspec = buf;
3429 else if (ts) Newx(retspec,retlen+16,char);
3430 else retspec = __fileify_retbuf;
3433 while (*cp1 != ':') *(cp2++) = *(cp1++);
3434 strcpy(cp2,":[000000]");
3439 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3440 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3441 /* We've set up the string up through the filename. Add the
3442 type and version, and we're done. */
3443 strcat(retspec,".DIR;1");
3445 /* $PARSE may have upcased filespec, so convert output to lower
3446 * case if input contained any lowercase characters. */
3447 if (haslower) __mystrtolower(retspec);
3450 } /* end of do_fileify_dirspec() */
3452 /* External entry points */
3453 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
3454 { return do_fileify_dirspec(dir,buf,0); }
3455 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
3456 { return do_fileify_dirspec(dir,buf,1); }
3458 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3459 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
3461 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3462 unsigned long int retlen;
3463 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3464 unsigned short int trnlnm_iter_count;
3467 if (!dir || !*dir) {
3468 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3471 if (*dir) strcpy(trndir,dir);
3472 else getcwd(trndir,sizeof trndir - 1);
3474 trnlnm_iter_count = 0;
3475 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3476 && my_trnlnm(trndir,trndir,0)) {
3477 trnlnm_iter_count++;
3478 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3479 trnlen = strlen(trndir);
3481 /* Trap simple rooted lnms, and return lnm:[000000] */
3482 if (!strcmp(trndir+trnlen-2,".]")) {
3483 if (buf) retpath = buf;
3484 else if (ts) Newx(retpath,strlen(dir)+10,char);
3485 else retpath = __pathify_retbuf;
3486 strcpy(retpath,dir);
3487 strcat(retpath,":[000000]");
3492 /* At this point we do not work with *dir, but the copy in
3493 * *trndir that is modifiable.
3496 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
3497 if (*trndir == '.' && (*(trndir+1) == '\0' ||
3498 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
3499 retlen = 2 + (*(trndir+1) != '\0');
3501 if ( !(cp1 = strrchr(trndir,'/')) &&
3502 !(cp1 = strrchr(trndir,']')) &&
3503 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
3504 if ((cp2 = strchr(cp1,'.')) != NULL &&
3505 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3506 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3507 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3508 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3510 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3511 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3512 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3513 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3514 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3515 (ver || *cp3)))))) {
3517 set_vaxc_errno(RMS$_DIR);
3520 retlen = cp2 - trndir + 1;
3522 else { /* No file type present. Treat the filename as a directory. */
3523 retlen = strlen(trndir) + 1;
3526 if (buf) retpath = buf;
3527 else if (ts) Newx(retpath,retlen+1,char);
3528 else retpath = __pathify_retbuf;
3529 strncpy(retpath, trndir, retlen-1);
3530 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3531 retpath[retlen-1] = '/'; /* with '/', add it. */
3532 retpath[retlen] = '\0';
3534 else retpath[retlen-1] = '\0';
3536 else { /* VMS-style directory spec */
3537 char esa[NAM$C_MAXRSS+1], *cp;
3538 unsigned long int sts, cmplen, haslower;
3539 struct FAB dirfab = cc$rms_fab;
3540 struct NAM savnam, dirnam = cc$rms_nam;
3542 /* If we've got an explicit filename, we can just shuffle the string. */
3543 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
3544 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
3545 if ((cp2 = strchr(cp1,'.')) != NULL) {
3547 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3548 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3549 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3550 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3551 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3552 (ver || *cp3)))))) {
3554 set_vaxc_errno(RMS$_DIR);
3558 else { /* No file type, so just draw name into directory part */
3559 for (cp2 = cp1; *cp2; cp2++) ;
3562 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3564 /* We've now got a VMS 'path'; fall through */
3566 dirfab.fab$b_fns = strlen(trndir);
3567 dirfab.fab$l_fna = trndir;
3568 if (dir[dirfab.fab$b_fns-1] == ']' ||
3569 dir[dirfab.fab$b_fns-1] == '>' ||
3570 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3571 if (buf) retpath = buf;
3572 else if (ts) Newx(retpath,strlen(dir)+1,char);
3573 else retpath = __pathify_retbuf;
3574 strcpy(retpath,trndir);
3577 dirfab.fab$l_dna = ".DIR;1";
3578 dirfab.fab$b_dns = 6;
3579 dirfab.fab$l_nam = &dirnam;
3580 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3581 dirnam.nam$l_esa = esa;
3583 for (cp = trndir; *cp; cp++)
3584 if (islower(*cp)) { haslower = 1; break; }
3586 if (!(sts = (sys$parse(&dirfab)&1))) {
3587 if (dirfab.fab$l_sts == RMS$_DIR) {
3588 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3589 sts = sys$parse(&dirfab) & 1;
3593 set_vaxc_errno(dirfab.fab$l_sts);
3599 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3600 if (dirfab.fab$l_sts != RMS$_FNF) {
3601 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3602 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3604 set_vaxc_errno(dirfab.fab$l_sts);
3607 dirnam = savnam; /* No; just work with potential name */
3610 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3611 /* Yep; check version while we're at it, if it's there. */
3612 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3613 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3614 /* Something other than .DIR[;1]. Bzzt. */
3615 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3616 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3618 set_vaxc_errno(RMS$_DIR);
3622 /* OK, the type was fine. Now pull any file name into the
3624 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3626 cp1 = strrchr(esa,'>');
3627 *dirnam.nam$l_type = '>';
3630 *(dirnam.nam$l_type + 1) = '\0';
3631 retlen = dirnam.nam$l_type - esa + 2;
3632 if (buf) retpath = buf;
3633 else if (ts) Newx(retpath,retlen,char);
3634 else retpath = __pathify_retbuf;
3635 strcpy(retpath,esa);
3636 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3637 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3638 /* $PARSE may have upcased filespec, so convert output to lower
3639 * case if input contained any lowercase characters. */
3640 if (haslower) __mystrtolower(retpath);
3644 } /* end of do_pathify_dirspec() */
3646 /* External entry points */
3647 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
3648 { return do_pathify_dirspec(dir,buf,0); }
3649 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
3650 { return do_pathify_dirspec(dir,buf,1); }
3652 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3653 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
3655 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3656 char *dirend, *rslt, *cp1, *cp3, tmp[NAM$C_MAXRSS+1];
3658 int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
3659 int expand = 1; /* guarantee room for leading and trailing slashes */
3660 unsigned short int trnlnm_iter_count;
3662 if (spec == NULL) return NULL;
3663 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3664 if (buf) rslt = buf;
3666 retlen = strlen(spec);
3667 cp1 = strchr(spec,'[');
3668 if (!cp1) cp1 = strchr(spec,'<');
3670 for (cp1++; *cp1; cp1++) {
3671 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3672 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3673 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3676 Newx(rslt,retlen+2+2*expand,char);
3678 else rslt = __tounixspec_retbuf;
3679 if (strchr(spec,'/') != NULL) {
3686 dirend = strrchr(spec,']');
3687 if (dirend == NULL) dirend = strrchr(spec,'>');
3688 if (dirend == NULL) dirend = strchr(spec,':');
3689 if (dirend == NULL) {
3693 if (*cp2 != '[' && *cp2 != '<') {
3696 else { /* the VMS spec begins with directories */
3698 if (*cp2 == ']' || *cp2 == '>') {
3699 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3702 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3703 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3704 if (ts) Safefree(rslt);
3707 trnlnm_iter_count = 0;
3710 while (*cp3 != ':' && *cp3) cp3++;
3712 if (strchr(cp3,']') != NULL) break;
3713 trnlnm_iter_count++;
3714 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3715 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3717 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3718 retlen = devlen + dirlen;
3719 Renew(rslt,retlen+1+2*expand,char);
3725 *(cp1++) = *(cp3++);
3726 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3730 else if ( *cp2 == '.') {
3731 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3732 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3738 for (; cp2 <= dirend; cp2++) {
3741 if (*(cp2+1) == '[') cp2++;
3743 else if (*cp2 == ']' || *cp2 == '>') {
3744 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3746 else if (*cp2 == '.') {
3748 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3749 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3750 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3751 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3752 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3754 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3755 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3759 else if (*cp2 == '-') {
3760 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3761 while (*cp2 == '-') {
3763 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3765 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3766 if (ts) Safefree(rslt); /* filespecs like */
3767 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3771 else *(cp1++) = *cp2;
3773 else *(cp1++) = *cp2;
3775 while (*cp2) *(cp1++) = *(cp2++);
3780 } /* end of do_tounixspec() */
3782 /* External entry points */
3783 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3784 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3786 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3787 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
3788 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3789 char *rslt, *dirend;
3792 unsigned long int infront = 0, hasdir = 1;
3794 if (path == NULL) return NULL;
3795 if (buf) rslt = buf;
3796 else if (ts) Newx(rslt,strlen(path)+9,char);
3797 else rslt = __tovmsspec_retbuf;
3798 if (strpbrk(path,"]:>") ||
3799 (dirend = strrchr(path,'/')) == NULL) {
3800 if (path[0] == '.') {
3801 if (path[1] == '\0') strcpy(rslt,"[]");
3802 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3803 else strcpy(rslt,path); /* probably garbage */
3805 else strcpy(rslt,path);
3808 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3809 if (!*(dirend+2)) dirend +=2;
3810 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3811 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3816 char trndev[NAM$C_MAXRSS+1];
3820 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3822 if (!buf & ts) Renew(rslt,18,char);
3823 strcpy(rslt,"sys$disk:[000000]");
3826 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3828 islnm = my_trnlnm(rslt,trndev,0);
3829 trnend = islnm ? strlen(trndev) - 1 : 0;
3830 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3831 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3832 /* If the first element of the path is a logical name, determine
3833 * whether it has to be translated so we can add more directories. */
3834 if (!islnm || rooted) {
3837 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3841 if (cp2 != dirend) {
3842 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3843 strcpy(rslt,trndev);
3844 cp1 = rslt + trnend;
3859 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3860 cp2 += 2; /* skip over "./" - it's redundant */
3861 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3863 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3864 *(cp1++) = '-'; /* "../" --> "-" */
3867 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3868 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3869 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3870 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3873 if (cp2 > dirend) cp2 = dirend;
3875 else *(cp1++) = '.';
3877 for (; cp2 < dirend; cp2++) {
3879 if (*(cp2-1) == '/') continue;
3880 if (*(cp1-1) != '.') *(cp1++) = '.';
3883 else if (!infront && *cp2 == '.') {
3884 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3885 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3886 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3887 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3888 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3889 else { /* back up over previous directory name */
3891 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3892 if (*(cp1-1) == '[') {
3893 memcpy(cp1,"000000.",7);
3898 if (cp2 == dirend) break;
3900 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3901 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3902 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3903 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3905 *(cp1++) = '.'; /* Simulate trailing '/' */
3906 cp2 += 2; /* for loop will incr this to == dirend */
3908 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3910 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3913 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3914 if (*cp2 == '.') *(cp1++) = '_';
3915 else *(cp1++) = *cp2;
3919 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3920 if (hasdir) *(cp1++) = ']';
3921 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3922 while (*cp2) *(cp1++) = *(cp2++);
3927 } /* end of do_tovmsspec() */
3929 /* External entry points */
3930 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3931 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3933 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3934 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
3935 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3937 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3939 if (path == NULL) return NULL;
3940 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3941 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3942 if (buf) return buf;
3944 vmslen = strlen(vmsified);
3945 Newx(cp,vmslen+1,char);
3946 memcpy(cp,vmsified,vmslen);
3951 strcpy(__tovmspath_retbuf,vmsified);
3952 return __tovmspath_retbuf;
3955 } /* end of do_tovmspath() */
3957 /* External entry points */
3958 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
3959 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
3962 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3963 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
3964 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3966 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3968 if (path == NULL) return NULL;
3969 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3970 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3971 if (buf) return buf;
3973 unixlen = strlen(unixified);
3974 Newx(cp,unixlen+1,char);
3975 memcpy(cp,unixified,unixlen);
3980 strcpy(__tounixpath_retbuf,unixified);
3981 return __tounixpath_retbuf;
3984 } /* end of do_tounixpath() */
3986 /* External entry points */
3987 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
3988 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
3991 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3993 *****************************************************************************
3995 * Copyright (C) 1989-1994 by *
3996 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3998 * Permission is hereby granted for the reproduction of this software, *
3999 * on condition that this copyright notice is included in the reproduction, *
4000 * and that such reproduction is not for purposes of profit or material *
4003 * 27-Aug-1994 Modified for inclusion in perl5 *
4004 * by Charles Bailey bailey@newman.upenn.edu *
4005 *****************************************************************************
4009 * getredirection() is intended to aid in porting C programs
4010 * to VMS (Vax-11 C). The native VMS environment does not support
4011 * '>' and '<' I/O redirection, or command line wild card expansion,
4012 * or a command line pipe mechanism using the '|' AND background
4013 * command execution '&'. All of these capabilities are provided to any
4014 * C program which calls this procedure as the first thing in the
4016 * The piping mechanism will probably work with almost any 'filter' type
4017 * of program. With suitable modification, it may useful for other
4018 * portability problems as well.
4020 * Author: Mark Pizzolato mark@infocomm.com
4024 struct list_item *next;
4028 static void add_item(struct list_item **head,
4029 struct list_item **tail,
4033 static void mp_expand_wild_cards(pTHX_ char *item,
4034 struct list_item **head,
4035 struct list_item **tail,
4038 static int background_process(pTHX_ int argc, char **argv);
4040 static void pipe_and_fork(pTHX_ char **cmargv);
4042 /*{{{ void getredirection(int *ac, char ***av)*/
4044 mp_getredirection(pTHX_ int *ac, char ***av)
4046 * Process vms redirection arg's. Exit if any error is seen.
4047 * If getredirection() processes an argument, it is erased
4048 * from the vector. getredirection() returns a new argc and argv value.
4049 * In the event that a background command is requested (by a trailing "&"),
4050 * this routine creates a background subprocess, and simply exits the program.
4052 * Warning: do not try to simplify the code for vms. The code
4053 * presupposes that getredirection() is called before any data is
4054 * read from stdin or written to stdout.
4056 * Normal usage is as follows:
4062 * getredirection(&argc, &argv);
4066 int argc = *ac; /* Argument Count */
4067 char **argv = *av; /* Argument Vector */
4068 char *ap; /* Argument pointer */
4069 int j; /* argv[] index */
4070 int item_count = 0; /* Count of Items in List */
4071 struct list_item *list_head = 0; /* First Item in List */
4072 struct list_item *list_tail; /* Last Item in List */
4073 char *in = NULL; /* Input File Name */
4074 char *out = NULL; /* Output File Name */
4075 char *outmode = "w"; /* Mode to Open Output File */
4076 char *err = NULL; /* Error File Name */
4077 char *errmode = "w"; /* Mode to Open Error File */
4078 int cmargc = 0; /* Piped Command Arg Count */
4079 char **cmargv = NULL;/* Piped Command Arg Vector */
4082 * First handle the case where the last thing on the line ends with
4083 * a '&'. This indicates the desire for the command to be run in a
4084 * subprocess, so we satisfy that desire.
4087 if (0 == strcmp("&", ap))
4088 exit(background_process(aTHX_ --argc, argv));
4089 if (*ap && '&' == ap[strlen(ap)-1])
4091 ap[strlen(ap)-1] = '\0';
4092 exit(background_process(aTHX_ argc, argv));
4095 * Now we handle the general redirection cases that involve '>', '>>',
4096 * '<', and pipes '|'.
4098 for (j = 0; j < argc; ++j)
4100 if (0 == strcmp("<", argv[j]))
4104 fprintf(stderr,"No input file after < on command line");
4105 exit(LIB$_WRONUMARG);
4110 if ('<' == *(ap = argv[j]))
4115 if (0 == strcmp(">", ap))
4119 fprintf(stderr,"No output file after > on command line");
4120 exit(LIB$_WRONUMARG);
4139 fprintf(stderr,"No output file after > or >> on command line");
4140 exit(LIB$_WRONUMARG);
4144 if (('2' == *ap) && ('>' == ap[1]))
4161 fprintf(stderr,"No output file after 2> or 2>> on command line");
4162 exit(LIB$_WRONUMARG);
4166 if (0 == strcmp("|", argv[j]))
4170 fprintf(stderr,"No command into which to pipe on command line");
4171 exit(LIB$_WRONUMARG);
4173 cmargc = argc-(j+1);
4174 cmargv = &argv[j+1];
4178 if ('|' == *(ap = argv[j]))
4186 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4189 * Allocate and fill in the new argument vector, Some Unix's terminate
4190 * the list with an extra null pointer.
4192 Newx(argv, item_count+1, char *);
4194 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4195 argv[j] = list_head->value;
4201 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4202 exit(LIB$_INVARGORD);
4204 pipe_and_fork(aTHX_ cmargv);
4207 /* Check for input from a pipe (mailbox) */
4209 if (in == NULL && 1 == isapipe(0))
4211 char mbxname[L_tmpnam];
4213 long int dvi_item = DVI$_DEVBUFSIZ;
4214 $DESCRIPTOR(mbxnam, "");
4215 $DESCRIPTOR(mbxdevnam, "");
4217 /* Input from a pipe, reopen it in binary mode to disable */
4218 /* carriage control processing. */
4220 fgetname(stdin, mbxname);
4221 mbxnam.dsc$a_pointer = mbxname;
4222 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4223 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4224 mbxdevnam.dsc$a_pointer = mbxname;
4225 mbxdevnam.dsc$w_length = sizeof(mbxname);
4226 dvi_item = DVI$_DEVNAM;
4227 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4228 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4231 freopen(mbxname, "rb", stdin);
4234 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4238 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4240 fprintf(stderr,"Can't open input file %s as stdin",in);
4243 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4245 fprintf(stderr,"Can't open output file %s as stdout",out);
4248 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4251 if (strcmp(err,"&1") == 0) {
4252 dup2(fileno(stdout), fileno(stderr));
4253 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4256 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4258 fprintf(stderr,"Can't open error file %s as stderr",err);
4262 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4266 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4269 #ifdef ARGPROC_DEBUG
4270 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4271 for (j = 0; j < *ac; ++j)
4272 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4274 /* Clear errors we may have hit expanding wildcards, so they don't
4275 show up in Perl's $! later */
4276 set_errno(0); set_vaxc_errno(1);
4277 } /* end of getredirection() */
4280 static void add_item(struct list_item **head,
4281 struct list_item **tail,
4287 Newx(*head,1,struct list_item);
4291 Newx((*tail)->next,1,struct list_item);
4292 *tail = (*tail)->next;
4294 (*tail)->value = value;
4298 static void mp_expand_wild_cards(pTHX_ char *item,
4299 struct list_item **head,
4300 struct list_item **tail,
4304 unsigned long int context = 0;
4311 char vmsspec[NAM$C_MAXRSS+1];
4312 $DESCRIPTOR(filespec, "");
4313 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4314 $DESCRIPTOR(resultspec, "");
4315 unsigned long int zero = 0, sts;
4317 for (cp = item; *cp; cp++) {
4318 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4319 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4321 if (!*cp || isspace(*cp))
4323 add_item(head, tail, item, count);
4328 /* "double quoted" wild card expressions pass as is */
4329 /* From DCL that means using e.g.: */
4330 /* perl program """perl.*""" */
4331 item_len = strlen(item);
4332 if ( '"' == *item && '"' == item[item_len-1] )
4335 item[item_len-2] = '\0';
4336 add_item(head, tail, item, count);
4340 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4341 resultspec.dsc$b_class = DSC$K_CLASS_D;
4342 resultspec.dsc$a_pointer = NULL;
4343 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4344 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4345 if (!isunix || !filespec.dsc$a_pointer)
4346 filespec.dsc$a_pointer = item;
4347 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4349 * Only return version specs, if the caller specified a version
4351 had_version = strchr(item, ';');
4353 * Only return device and directory specs, if the caller specifed either.
4355 had_device = strchr(item, ':');
4356 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4358 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4359 &defaultspec, 0, 0, &zero))))
4364 Newx(string,resultspec.dsc$w_length+1,char);
4365 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4366 string[resultspec.dsc$w_length] = '\0';
4367 if (NULL == had_version)
4368 *((char *)strrchr(string, ';')) = '\0';
4369 if ((!had_directory) && (had_device == NULL))
4371 if (NULL == (devdir = strrchr(string, ']')))
4372 devdir = strrchr(string, '>');
4373 strcpy(string, devdir + 1);
4376 * Be consistent with what the C RTL has already done to the rest of
4377 * the argv items and lowercase all of these names.
4379 for (c = string; *c; ++c)
4382 if (isunix) trim_unixpath(string,item,1);
4383 add_item(head, tail, string, count);
4386 if (sts != RMS$_NMF)
4388 set_vaxc_errno(sts);
4391 case RMS$_FNF: case RMS$_DNF:
4392 set_errno(ENOENT); break;
4394 set_errno(ENOTDIR); break;
4396 set_errno(ENODEV); break;
4397 case RMS$_FNM: case RMS$_SYN:
4398 set_errno(EINVAL); break;
4400 set_errno(EACCES); break;
4402 _ckvmssts_noperl(sts);
4406 add_item(head, tail, item, count);
4407 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4408 _ckvmssts_noperl(lib$find_file_end(&context));
4411 static int child_st[2];/* Event Flag set when child process completes */
4413 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4415 static unsigned long int exit_handler(int *status)
4419 if (0 == child_st[0])
4421 #ifdef ARGPROC_DEBUG
4422 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4424 fflush(stdout); /* Have to flush pipe for binary data to */
4425 /* terminate properly -- <tp@mccall.com> */
4426 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4427 sys$dassgn(child_chan);
4429 sys$synch(0, child_st);
4434 static void sig_child(int chan)
4436 #ifdef ARGPROC_DEBUG
4437 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4439 if (child_st[0] == 0)
4443 static struct exit_control_block exit_block =
4448 &exit_block.exit_status,
4453 pipe_and_fork(pTHX_ char **cmargv)
4456 struct dsc$descriptor_s *vmscmd;
4457 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4458 int sts, j, l, ismcr, quote, tquote = 0;
4460 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4461 vms_execfree(vmscmd);
4466 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4467 && toupper(*(q+2)) == 'R' && !*(q+3);
4469 while (q && l < MAX_DCL_LINE_LENGTH) {
4471 if (j > 0 && quote) {
4477 if (ismcr && j > 1) quote = 1;
4478 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4481 if (quote || tquote) {
4487 if ((quote||tquote) && *q == '"') {
4497 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4499 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4503 static int background_process(pTHX_ int argc, char **argv)
4505 char command[2048] = "$";
4506 $DESCRIPTOR(value, "");
4507 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4508 static $DESCRIPTOR(null, "NLA0:");
4509 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4511 $DESCRIPTOR(pidstr, "");
4513 unsigned long int flags = 17, one = 1, retsts;
4515 strcat(command, argv[0]);
4518 strcat(command, " \"");
4519 strcat(command, *(++argv));
4520 strcat(command, "\"");
4522 value.dsc$a_pointer = command;
4523 value.dsc$w_length = strlen(value.dsc$a_pointer);
4524 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4525 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4526 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4527 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4530 _ckvmssts_noperl(retsts);
4532 #ifdef ARGPROC_DEBUG
4533 PerlIO_printf(Perl_debug_log, "%s\n", command);
4535 sprintf(pidstring, "%08X", pid);
4536 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4537 pidstr.dsc$a_pointer = pidstring;
4538 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4539 lib$set_symbol(&pidsymbol, &pidstr);
4543 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4546 /* OS-specific initialization at image activation (not thread startup) */
4547 /* Older VAXC header files lack these constants */
4548 #ifndef JPI$_RIGHTS_SIZE
4549 # define JPI$_RIGHTS_SIZE 817
4551 #ifndef KGB$M_SUBSYSTEM
4552 # define KGB$M_SUBSYSTEM 0x8
4555 /*{{{void vms_image_init(int *, char ***)*/
4557 vms_image_init(int *argcp, char ***argvp)
4559 char eqv[LNM$C_NAMLENGTH+1] = "";
4560 unsigned int len, tabct = 8, tabidx = 0;
4561 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4562 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4563 unsigned short int dummy, rlen;
4564 struct dsc$descriptor_s **tabvec;
4565 #if defined(PERL_IMPLICIT_CONTEXT)
4568 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4569 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4570 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4573 #ifdef KILL_BY_SIGPRC
4574 (void) Perl_csighandler_init();
4577 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4578 _ckvmssts_noperl(iosb[0]);
4579 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4580 if (iprv[i]) { /* Running image installed with privs? */
4581 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4586 /* Rights identifiers might trigger tainting as well. */
4587 if (!will_taint && (rlen || rsz)) {
4588 while (rlen < rsz) {
4589 /* We didn't get all the identifiers on the first pass. Allocate a
4590 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4591 * were needed to hold all identifiers at time of last call; we'll
4592 * allocate that many unsigned long ints), and go back and get 'em.
4593 * If it gave us less than it wanted to despite ample buffer space,
4594 * something's broken. Is your system missing a system identifier?
4596 if (rsz <= jpilist[1].buflen) {
4597 /* Perl_croak accvios when used this early in startup. */
4598 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4599 rsz, (unsigned long) jpilist[1].buflen,
4600 "Check your rights database for corruption.\n");
4603 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4604 jpilist[1].bufadr = Newx(mask,rsz,unsigned long int);
4605 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4606 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4607 _ckvmssts_noperl(iosb[0]);
4609 mask = jpilist[1].bufadr;
4610 /* Check attribute flags for each identifier (2nd longword); protected
4611 * subsystem identifiers trigger tainting.
4613 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4614 if (mask[i] & KGB$M_SUBSYSTEM) {
4619 if (mask != rlst) Safefree(mask);
4621 /* We need to use this hack to tell Perl it should run with tainting,
4622 * since its tainting flag may be part of the PL_curinterp struct, which
4623 * hasn't been allocated when vms_image_init() is called.
4626 char **newargv, **oldargv;
4628 Newx(newargv,(*argcp)+2,char *);
4629 newargv[0] = oldargv[0];
4630 Newx(newargv[1],3,char);
4631 strcpy(newargv[1], "-T");
4632 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4634 newargv[*argcp] = NULL;
4635 /* We orphan the old argv, since we don't know where it's come from,
4636 * so we don't know how to free it.
4640 else { /* Did user explicitly request tainting? */
4642 char *cp, **av = *argvp;
4643 for (i = 1; i < *argcp; i++) {
4644 if (*av[i] != '-') break;
4645 for (cp = av[i]+1; *cp; cp++) {
4646 if (*cp == 'T') { will_taint = 1; break; }
4647 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4648 strchr("DFIiMmx",*cp)) break;
4650 if (will_taint) break;
4655 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4657 if (!tabidx) Newx(tabvec,tabct,struct dsc$descriptor_s *);
4658 else if (tabidx >= tabct) {
4660 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4662 Newx(tabvec[tabidx],1,struct dsc$descriptor_s);
4663 tabvec[tabidx]->dsc$w_length = 0;
4664 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4665 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4666 tabvec[tabidx]->dsc$a_pointer = NULL;
4667 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4669 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4671 getredirection(argcp,argvp);
4672 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4674 # include <reentrancy.h>
4675 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4684 * Trim Unix-style prefix off filespec, so it looks like what a shell
4685 * glob expansion would return (i.e. from specified prefix on, not
4686 * full path). Note that returned filespec is Unix-style, regardless
4687 * of whether input filespec was VMS-style or Unix-style.
4689 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4690 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4691 * vector of options; at present, only bit 0 is used, and if set tells
4692 * trim unixpath to try the current default directory as a prefix when
4693 * presented with a possibly ambiguous ... wildcard.
4695 * Returns !=0 on success, with trimmed filespec replacing contents of
4696 * fspec, and 0 on failure, with contents of fpsec unchanged.
4698 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4700 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4702 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4703 *template, *base, *end, *cp1, *cp2;
4704 register int tmplen, reslen = 0, dirs = 0;
4706 if (!wildspec || !fspec) return 0;
4707 if (strpbrk(wildspec,"]>:") != NULL) {
4708 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4709 else template = unixwild;
4711 else template = wildspec;
4712 if (strpbrk(fspec,"]>:") != NULL) {
4713 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4714 else base = unixified;
4715 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4716 * check to see that final result fits into (isn't longer than) fspec */
4717 reslen = strlen(fspec);
4721 /* No prefix or absolute path on wildcard, so nothing to remove */
4722 if (!*template || *template == '/') {
4723 if (base == fspec) return 1;
4724 tmplen = strlen(unixified);
4725 if (tmplen > reslen) return 0; /* not enough space */
4726 /* Copy unixified resultant, including trailing NUL */
4727 memmove(fspec,unixified,tmplen+1);
4731 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4732 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4733 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4734 for (cp1 = end ;cp1 >= base; cp1--)
4735 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4737 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4741 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4742 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4743 int ells = 1, totells, segdirs, match;
4744 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4745 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4747 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4749 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4750 if (ellipsis == template && opts & 1) {
4751 /* Template begins with an ellipsis. Since we can't tell how many
4752 * directory names at the front of the resultant to keep for an
4753 * arbitrary starting point, we arbitrarily choose the current
4754 * default directory as a starting point. If it's there as a prefix,
4755 * clip it off. If not, fall through and act as if the leading
4756 * ellipsis weren't there (i.e. return shortest possible path that
4757 * could match template).
4759 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4760 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4761 if (_tolower(*cp1) != _tolower(*cp2)) break;
4762 segdirs = dirs - totells; /* Min # of dirs we must have left */
4763 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4764 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4765 memcpy(fspec,cp2+1,end - cp2);
4769 /* First off, back up over constant elements at end of path */
4771 for (front = end ; front >= base; front--)
4772 if (*front == '/' && !dirs--) { front++; break; }
4774 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4775 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4776 if (cp1 != '\0') return 0; /* Path too long. */
4778 *cp2 = '\0'; /* Pick up with memcpy later */
4779 lcfront = lcres + (front - base);
4780 /* Now skip over each ellipsis and try to match the path in front of it. */
4782 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4783 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4784 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4785 if (cp1 < template) break; /* template started with an ellipsis */
4786 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4787 ellipsis = cp1; continue;
4789 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4791 for (segdirs = 0, cp2 = tpl;
4792 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4794 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4795 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4796 if (*cp2 == '/') segdirs++;
4798 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4799 /* Back up at least as many dirs as in template before matching */
4800 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4801 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4802 for (match = 0; cp1 > lcres;) {
4803 resdsc.dsc$a_pointer = cp1;
4804 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4806 if (match == 1) lcfront = cp1;
4808 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4810 if (!match) return 0; /* Can't find prefix ??? */
4811 if (match > 1 && opts & 1) {
4812 /* This ... wildcard could cover more than one set of dirs (i.e.
4813 * a set of similar dir names is repeated). If the template
4814 * contains more than 1 ..., upstream elements could resolve the
4815 * ambiguity, but it's not worth a full backtracking setup here.
4816 * As a quick heuristic, clip off the current default directory
4817 * if it's present to find the trimmed spec, else use the
4818 * shortest string that this ... could cover.
4820 char def[NAM$C_MAXRSS+1], *st;
4822 if (getcwd(def, sizeof def,0) == NULL) return 0;
4823 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4824 if (_tolower(*cp1) != _tolower(*cp2)) break;
4825 segdirs = dirs - totells; /* Min # of dirs we must have left */
4826 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4827 if (*cp1 == '\0' && *cp2 == '/') {
4828 memcpy(fspec,cp2+1,end - cp2);
4831 /* Nope -- stick with lcfront from above and keep going. */
4834 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4839 } /* end of trim_unixpath() */
4844 * VMS readdir() routines.
4845 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4847 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4848 * Minor modifications to original routines.
4851 /* readdir may have been redefined by reentr.h, so make sure we get
4852 * the local version for what we do here.
4857 #if !defined(PERL_IMPLICIT_CONTEXT)
4858 # define readdir Perl_readdir
4860 # define readdir(a) Perl_readdir(aTHX_ a)
4863 /* Number of elements in vms_versions array */
4864 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4867 * Open a directory, return a handle for later use.
4869 /*{{{ DIR *opendir(char*name) */
4871 Perl_opendir(pTHX_ const char *name)
4874 char dir[NAM$C_MAXRSS+1];
4877 if (do_tovmspath(name,dir,0) == NULL) {
4880 /* Check access before stat; otherwise stat does not
4881 * accurately report whether it's a directory.
4883 if (!cando_by_name(S_IRUSR,0,dir)) {
4884 /* cando_by_name has already set errno */
4887 if (flex_stat(dir,&sb) == -1) return NULL;
4888 if (!S_ISDIR(sb.st_mode)) {
4889 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4892 /* Get memory for the handle, and the pattern. */
4894 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4896 /* Fill in the fields; mainly playing with the descriptor. */
4897 (void)sprintf(dd->pattern, "%s*.*",dir);
4900 dd->vms_wantversions = 0;
4901 dd->pat.dsc$a_pointer = dd->pattern;
4902 dd->pat.dsc$w_length = strlen(dd->pattern);
4903 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4904 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4905 #if defined(USE_ITHREADS)
4906 Newx(dd->mutex,1,perl_mutex);
4907 MUTEX_INIT( (perl_mutex *) dd->mutex );
4913 } /* end of opendir() */
4917 * Set the flag to indicate we want versions or not.
4919 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4921 vmsreaddirversions(DIR *dd, int flag)
4923 dd->vms_wantversions = flag;
4928 * Free up an opened directory.
4930 /*{{{ void closedir(DIR *dd)*/
4934 (void)lib$find_file_end(&dd->context);
4935 Safefree(dd->pattern);
4936 #if defined(USE_ITHREADS)
4937 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4938 Safefree(dd->mutex);
4940 Safefree((char *)dd);
4945 * Collect all the version numbers for the current file.
4948 collectversions(pTHX_ DIR *dd)
4950 struct dsc$descriptor_s pat;
4951 struct dsc$descriptor_s res;
4953 char *p, *text, buff[sizeof dd->entry.d_name];
4955 unsigned long context, tmpsts;
4957 /* Convenient shorthand. */
4960 /* Add the version wildcard, ignoring the "*.*" put on before */
4961 i = strlen(dd->pattern);
4962 Newx(text,i + e->d_namlen + 3,char);
4963 (void)strcpy(text, dd->pattern);
4964 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4966 /* Set up the pattern descriptor. */
4967 pat.dsc$a_pointer = text;
4968 pat.dsc$w_length = i + e->d_namlen - 1;
4969 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4970 pat.dsc$b_class = DSC$K_CLASS_S;
4972 /* Set up result descriptor. */
4973 res.dsc$a_pointer = buff;
4974 res.dsc$w_length = sizeof buff - 2;
4975 res.dsc$b_dtype = DSC$K_DTYPE_T;
4976 res.dsc$b_class = DSC$K_CLASS_S;
4978 /* Read files, collecting versions. */
4979 for (context = 0, e->vms_verscount = 0;
4980 e->vms_verscount < VERSIZE(e);
4981 e->vms_verscount++) {
4982 tmpsts = lib$find_file(&pat, &res, &context);
4983 if (tmpsts == RMS$_NMF || context == 0) break;
4985 buff[sizeof buff - 1] = '\0';
4986 if ((p = strchr(buff, ';')))
4987 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4989 e->vms_versions[e->vms_verscount] = -1;
4992 _ckvmssts(lib$find_file_end(&context));
4995 } /* end of collectversions() */
4998 * Read the next entry from the directory.
5000 /*{{{ struct dirent *readdir(DIR *dd)*/
5002 Perl_readdir(pTHX_ DIR *dd)
5004 struct dsc$descriptor_s res;
5005 char *p, buff[sizeof dd->entry.d_name];
5006 unsigned long int tmpsts;
5008 /* Set up result descriptor, and get next file. */
5009 res.dsc$a_pointer = buff;
5010 res.dsc$w_length = sizeof buff - 2;
5011 res.dsc$b_dtype = DSC$K_DTYPE_T;
5012 res.dsc$b_class = DSC$K_CLASS_S;
5013 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
5014 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
5015 if (!(tmpsts & 1)) {
5016 set_vaxc_errno(tmpsts);
5019 set_errno(EACCES); break;
5021 set_errno(ENODEV); break;
5023 set_errno(ENOTDIR); break;
5024 case RMS$_FNF: case RMS$_DNF:
5025 set_errno(ENOENT); break;
5032 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5033 buff[sizeof buff - 1] = '\0';
5034 for (p = buff; *p; p++) *p = _tolower(*p);
5035 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5038 /* Skip any directory component and just copy the name. */
5039 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5040 else (void)strcpy(dd->entry.d_name, buff);
5042 /* Clobber the version. */
5043 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5045 dd->entry.d_namlen = strlen(dd->entry.d_name);
5046 dd->entry.vms_verscount = 0;
5047 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5050 } /* end of readdir() */
5054 * Read the next entry from the directory -- thread-safe version.
5056 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5058 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5062 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5064 entry = readdir(dd);
5066 retval = ( *result == NULL ? errno : 0 );
5068 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5072 } /* end of readdir_r() */
5076 * Return something that can be used in a seekdir later.
5078 /*{{{ long telldir(DIR *dd)*/
5087 * Return to a spot where we used to be. Brute force.
5089 /*{{{ void seekdir(DIR *dd,long count)*/
5091 Perl_seekdir(pTHX_ DIR *dd, long count)
5093 int vms_wantversions;
5095 /* If we haven't done anything yet... */
5099 /* Remember some state, and clear it. */
5100 vms_wantversions = dd->vms_wantversions;
5101 dd->vms_wantversions = 0;
5102 _ckvmssts(lib$find_file_end(&dd->context));
5105 /* The increment is in readdir(). */
5106 for (dd->count = 0; dd->count < count; )
5109 dd->vms_wantversions = vms_wantversions;
5111 } /* end of seekdir() */
5114 /* VMS subprocess management
5116 * my_vfork() - just a vfork(), after setting a flag to record that
5117 * the current script is trying a Unix-style fork/exec.
5119 * vms_do_aexec() and vms_do_exec() are called in response to the
5120 * perl 'exec' function. If this follows a vfork call, then they
5121 * call out the regular perl routines in doio.c which do an
5122 * execvp (for those who really want to try this under VMS).
5123 * Otherwise, they do exactly what the perl docs say exec should
5124 * do - terminate the current script and invoke a new command
5125 * (See below for notes on command syntax.)
5127 * do_aspawn() and do_spawn() implement the VMS side of the perl
5128 * 'system' function.
5130 * Note on command arguments to perl 'exec' and 'system': When handled
5131 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5132 * are concatenated to form a DCL command string. If the first arg
5133 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5134 * the command string is handed off to DCL directly. Otherwise,
5135 * the first token of the command is taken as the filespec of an image
5136 * to run. The filespec is expanded using a default type of '.EXE' and
5137 * the process defaults for device, directory, etc., and if found, the resultant
5138 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5139 * the command string as parameters. This is perhaps a bit complicated,
5140 * but I hope it will form a happy medium between what VMS folks expect
5141 * from lib$spawn and what Unix folks expect from exec.
5144 static int vfork_called;
5146 /*{{{int my_vfork()*/
5157 vms_execfree(struct dsc$descriptor_s *vmscmd)
5160 if (vmscmd->dsc$a_pointer) {
5161 Safefree(vmscmd->dsc$a_pointer);
5168 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5170 char *junk, *tmps = Nullch;
5171 register size_t cmdlen = 0;
5178 tmps = SvPV(really,rlen);
5185 for (idx++; idx <= sp; idx++) {
5187 junk = SvPVx(*idx,rlen);
5188 cmdlen += rlen ? rlen + 1 : 0;
5191 Newx(PL_Cmd,cmdlen+1,char);
5193 if (tmps && *tmps) {
5194 strcpy(PL_Cmd,tmps);
5197 else *PL_Cmd = '\0';
5198 while (++mark <= sp) {
5200 char *s = SvPVx(*mark,n_a);
5202 if (*PL_Cmd) strcat(PL_Cmd," ");
5208 } /* end of setup_argstr() */
5211 static unsigned long int
5212 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5213 struct dsc$descriptor_s **pvmscmd)
5215 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5216 $DESCRIPTOR(defdsc,".EXE");
5217 $DESCRIPTOR(defdsc2,".");
5218 $DESCRIPTOR(resdsc,resspec);
5219 struct dsc$descriptor_s *vmscmd;
5220 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5221 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5222 register char *s, *rest, *cp, *wordbreak;
5225 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5226 vmscmd->dsc$a_pointer = NULL;
5227 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5228 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5229 vmscmd->dsc$w_length = 0;
5230 if (pvmscmd) *pvmscmd = vmscmd;
5232 if (suggest_quote) *suggest_quote = 0;
5234 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5235 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5237 while (*s && isspace(*s)) s++;
5239 if (*s == '@' || *s == '$') {
5240 vmsspec[0] = *s; rest = s + 1;
5241 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5243 else { cp = vmsspec; rest = s; }
5244 if (*rest == '.' || *rest == '/') {
5247 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5248 rest++, cp2++) *cp2 = *rest;
5250 if (do_tovmsspec(resspec,cp,0)) {
5253 for (cp2 = vmsspec + strlen(vmsspec);
5254 *rest && cp2 - vmsspec < sizeof vmsspec;
5255 rest++, cp2++) *cp2 = *rest;
5260 /* Intuit whether verb (first word of cmd) is a DCL command:
5261 * - if first nonspace char is '@', it's a DCL indirection
5263 * - if verb contains a filespec separator, it's not a DCL command
5264 * - if it doesn't, caller tells us whether to default to a DCL
5265 * command, or to a local image unless told it's DCL (by leading '$')
5269 if (suggest_quote) *suggest_quote = 1;
5271 register char *filespec = strpbrk(s,":<[.;");
5272 rest = wordbreak = strpbrk(s," \"\t/");
5273 if (!wordbreak) wordbreak = s + strlen(s);
5274 if (*s == '$') check_img = 0;
5275 if (filespec && (filespec < wordbreak)) isdcl = 0;
5276 else isdcl = !check_img;
5280 imgdsc.dsc$a_pointer = s;
5281 imgdsc.dsc$w_length = wordbreak - s;
5282 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5284 _ckvmssts(lib$find_file_end(&cxt));
5285 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5286 if (!(retsts & 1) && *s == '$') {
5287 _ckvmssts(lib$find_file_end(&cxt));
5288 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5289 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5291 _ckvmssts(lib$find_file_end(&cxt));
5292 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5296 _ckvmssts(lib$find_file_end(&cxt));
5301 while (*s && !isspace(*s)) s++;
5304 /* check that it's really not DCL with no file extension */
5305 fp = fopen(resspec,"r","ctx=bin","shr=get");
5307 char b[4] = {0,0,0,0};
5308 read(fileno(fp),b,4);
5309 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5312 if (check_img && isdcl) return RMS$_FNF;
5314 if (cando_by_name(S_IXUSR,0,resspec)) {
5315 Newx(vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5317 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5318 if (suggest_quote) *suggest_quote = 1;
5320 strcpy(vmscmd->dsc$a_pointer,"@");
5321 if (suggest_quote) *suggest_quote = 1;
5323 strcat(vmscmd->dsc$a_pointer,resspec);
5324 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5325 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5326 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5328 else retsts = RMS$_PRV;
5331 /* It's either a DCL command or we couldn't find a suitable image */
5332 vmscmd->dsc$w_length = strlen(cmd);
5333 /* if (cmd == PL_Cmd) {
5334 vmscmd->dsc$a_pointer = PL_Cmd;
5335 if (suggest_quote) *suggest_quote = 1;
5338 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5340 /* check if it's a symbol (for quoting purposes) */
5341 if (suggest_quote && !*suggest_quote) {
5343 char equiv[LNM$C_NAMLENGTH];
5344 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5345 eqvdsc.dsc$a_pointer = equiv;
5347 iss = lib$get_symbol(vmscmd,&eqvdsc);
5348 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5350 if (!(retsts & 1)) {
5351 /* just hand off status values likely to be due to user error */
5352 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5353 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5354 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5355 else { _ckvmssts(retsts); }
5358 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5360 } /* end of setup_cmddsc() */
5363 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5365 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5368 if (vfork_called) { /* this follows a vfork - act Unixish */
5370 if (vfork_called < 0) {
5371 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5374 else return do_aexec(really,mark,sp);
5376 /* no vfork - act VMSish */
5377 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5382 } /* end of vms_do_aexec() */
5385 /* {{{bool vms_do_exec(char *cmd) */
5387 Perl_vms_do_exec(pTHX_ char *cmd)
5389 struct dsc$descriptor_s *vmscmd;
5391 if (vfork_called) { /* this follows a vfork - act Unixish */
5393 if (vfork_called < 0) {
5394 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5397 else return do_exec(cmd);
5400 { /* no vfork - act VMSish */
5401 unsigned long int retsts;
5404 TAINT_PROPER("exec");
5405 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5406 retsts = lib$do_command(vmscmd);
5409 case RMS$_FNF: case RMS$_DNF:
5410 set_errno(ENOENT); break;
5412 set_errno(ENOTDIR); break;
5414 set_errno(ENODEV); break;
5416 set_errno(EACCES); break;
5418 set_errno(EINVAL); break;
5419 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5420 set_errno(E2BIG); break;
5421 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5422 _ckvmssts(retsts); /* fall through */
5423 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5426 set_vaxc_errno(retsts);
5427 if (ckWARN(WARN_EXEC)) {
5428 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5429 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5431 vms_execfree(vmscmd);
5436 } /* end of vms_do_exec() */
5439 unsigned long int Perl_do_spawn(pTHX_ char *);
5441 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5443 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5445 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5448 } /* end of do_aspawn() */
5451 /* {{{unsigned long int do_spawn(char *cmd) */
5453 Perl_do_spawn(pTHX_ char *cmd)
5455 unsigned long int sts, substs;
5458 TAINT_PROPER("spawn");
5459 if (!cmd || !*cmd) {
5460 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5463 case RMS$_FNF: case RMS$_DNF:
5464 set_errno(ENOENT); break;
5466 set_errno(ENOTDIR); break;
5468 set_errno(ENODEV); break;
5470 set_errno(EACCES); break;
5472 set_errno(EINVAL); break;
5473 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5474 set_errno(E2BIG); break;
5475 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5476 _ckvmssts(sts); /* fall through */
5477 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5480 set_vaxc_errno(sts);
5481 if (ckWARN(WARN_EXEC)) {
5482 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5489 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5492 } /* end of do_spawn() */
5496 static unsigned int *sockflags, sockflagsize;
5499 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5500 * routines found in some versions of the CRTL can't deal with sockets.
5501 * We don't shim the other file open routines since a socket isn't
5502 * likely to be opened by a name.
5504 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5505 FILE *my_fdopen(int fd, const char *mode)
5507 FILE *fp = fdopen(fd, (char *) mode);
5510 unsigned int fdoff = fd / sizeof(unsigned int);
5511 struct stat sbuf; /* native stat; we don't need flex_stat */
5512 if (!sockflagsize || fdoff > sockflagsize) {
5513 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5514 else Newx (sockflags,fdoff+2,unsigned int);
5515 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5516 sockflagsize = fdoff + 2;
5518 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5519 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5528 * Clear the corresponding bit when the (possibly) socket stream is closed.
5529 * There still a small hole: we miss an implicit close which might occur
5530 * via freopen(). >> Todo
5532 /*{{{ int my_fclose(FILE *fp)*/
5533 int my_fclose(FILE *fp) {
5535 unsigned int fd = fileno(fp);
5536 unsigned int fdoff = fd / sizeof(unsigned int);
5538 if (sockflagsize && fdoff <= sockflagsize)
5539 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5547 * A simple fwrite replacement which outputs itmsz*nitm chars without
5548 * introducing record boundaries every itmsz chars.
5549 * We are using fputs, which depends on a terminating null. We may
5550 * well be writing binary data, so we need to accommodate not only
5551 * data with nulls sprinkled in the middle but also data with no null
5554 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5556 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5558 register char *cp, *end, *cpd, *data;
5559 register unsigned int fd = fileno(dest);
5560 register unsigned int fdoff = fd / sizeof(unsigned int);
5562 int bufsize = itmsz * nitm + 1;
5564 if (fdoff < sockflagsize &&
5565 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5566 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5570 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5571 memcpy( data, src, itmsz*nitm );
5572 data[itmsz*nitm] = '\0';
5574 end = data + itmsz * nitm;
5575 retval = (int) nitm; /* on success return # items written */
5578 while (cpd <= end) {
5579 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5580 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5582 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5586 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5589 } /* end of my_fwrite() */
5592 /*{{{ int my_flush(FILE *fp)*/
5594 Perl_my_flush(pTHX_ FILE *fp)
5597 if ((res = fflush(fp)) == 0 && fp) {
5598 #ifdef VMS_DO_SOCKETS
5600 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5602 res = fsync(fileno(fp));
5605 * If the flush succeeded but set end-of-file, we need to clear
5606 * the error because our caller may check ferror(). BTW, this
5607 * probably means we just flushed an empty file.
5609 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5616 * Here are replacements for the following Unix routines in the VMS environment:
5617 * getpwuid Get information for a particular UIC or UID
5618 * getpwnam Get information for a named user
5619 * getpwent Get information for each user in the rights database
5620 * setpwent Reset search to the start of the rights database
5621 * endpwent Finish searching for users in the rights database
5623 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5624 * (defined in pwd.h), which contains the following fields:-
5626 * char *pw_name; Username (in lower case)
5627 * char *pw_passwd; Hashed password
5628 * unsigned int pw_uid; UIC
5629 * unsigned int pw_gid; UIC group number
5630 * char *pw_unixdir; Default device/directory (VMS-style)
5631 * char *pw_gecos; Owner name
5632 * char *pw_dir; Default device/directory (Unix-style)
5633 * char *pw_shell; Default CLI name (eg. DCL)
5635 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5637 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5638 * not the UIC member number (eg. what's returned by getuid()),
5639 * getpwuid() can accept either as input (if uid is specified, the caller's
5640 * UIC group is used), though it won't recognise gid=0.
5642 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5643 * information about other users in your group or in other groups, respectively.
5644 * If the required privilege is not available, then these routines fill only
5645 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5648 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5651 /* sizes of various UAF record fields */
5652 #define UAI$S_USERNAME 12
5653 #define UAI$S_IDENT 31
5654 #define UAI$S_OWNER 31
5655 #define UAI$S_DEFDEV 31
5656 #define UAI$S_DEFDIR 63
5657 #define UAI$S_DEFCLI 31
5660 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5661 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5662 (uic).uic$v_group != UIC$K_WILD_GROUP)
5664 static char __empty[]= "";
5665 static struct passwd __passwd_empty=
5666 {(char *) __empty, (char *) __empty, 0, 0,
5667 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5668 static int contxt= 0;
5669 static struct passwd __pwdcache;
5670 static char __pw_namecache[UAI$S_IDENT+1];
5673 * This routine does most of the work extracting the user information.
5675 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5678 unsigned char length;
5679 char pw_gecos[UAI$S_OWNER+1];
5681 static union uicdef uic;
5683 unsigned char length;
5684 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5687 unsigned char length;
5688 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5691 unsigned char length;
5692 char pw_shell[UAI$S_DEFCLI+1];
5694 static char pw_passwd[UAI$S_PWD+1];
5696 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5697 struct dsc$descriptor_s name_desc;
5698 unsigned long int sts;
5700 static struct itmlst_3 itmlst[]= {
5701 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5702 {sizeof(uic), UAI$_UIC, &uic, &luic},
5703 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5704 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5705 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5706 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5707 {0, 0, NULL, NULL}};
5709 name_desc.dsc$w_length= strlen(name);
5710 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5711 name_desc.dsc$b_class= DSC$K_CLASS_S;
5712 name_desc.dsc$a_pointer= (char *) name;
5714 /* Note that sys$getuai returns many fields as counted strings. */
5715 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5716 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5717 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5719 else { _ckvmssts(sts); }
5720 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5722 if ((int) owner.length < lowner) lowner= (int) owner.length;
5723 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5724 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5725 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5726 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5727 owner.pw_gecos[lowner]= '\0';
5728 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5729 defcli.pw_shell[ldefcli]= '\0';
5730 if (valid_uic(uic)) {
5731 pwd->pw_uid= uic.uic$l_uic;
5732 pwd->pw_gid= uic.uic$v_group;
5735 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5736 pwd->pw_passwd= pw_passwd;
5737 pwd->pw_gecos= owner.pw_gecos;
5738 pwd->pw_dir= defdev.pw_dir;
5739 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5740 pwd->pw_shell= defcli.pw_shell;
5741 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5743 ldir= strlen(pwd->pw_unixdir) - 1;
5744 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5747 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5748 __mystrtolower(pwd->pw_unixdir);
5753 * Get information for a named user.
5755 /*{{{struct passwd *getpwnam(char *name)*/
5756 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5758 struct dsc$descriptor_s name_desc;
5760 unsigned long int status, sts;
5762 __pwdcache = __passwd_empty;
5763 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5764 /* We still may be able to determine pw_uid and pw_gid */
5765 name_desc.dsc$w_length= strlen(name);
5766 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5767 name_desc.dsc$b_class= DSC$K_CLASS_S;
5768 name_desc.dsc$a_pointer= (char *) name;
5769 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5770 __pwdcache.pw_uid= uic.uic$l_uic;
5771 __pwdcache.pw_gid= uic.uic$v_group;
5774 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5775 set_vaxc_errno(sts);
5776 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5779 else { _ckvmssts(sts); }
5782 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5783 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5784 __pwdcache.pw_name= __pw_namecache;
5786 } /* end of my_getpwnam() */
5790 * Get information for a particular UIC or UID.
5791 * Called by my_getpwent with uid=-1 to list all users.
5793 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5794 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5796 const $DESCRIPTOR(name_desc,__pw_namecache);
5797 unsigned short lname;
5799 unsigned long int status;
5801 if (uid == (unsigned int) -1) {
5803 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5804 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5805 set_vaxc_errno(status);
5806 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5810 else { _ckvmssts(status); }
5811 } while (!valid_uic (uic));
5815 if (!uic.uic$v_group)
5816 uic.uic$v_group= PerlProc_getgid();
5818 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5819 else status = SS$_IVIDENT;
5820 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5821 status == RMS$_PRV) {
5822 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5825 else { _ckvmssts(status); }
5827 __pw_namecache[lname]= '\0';
5828 __mystrtolower(__pw_namecache);
5830 __pwdcache = __passwd_empty;
5831 __pwdcache.pw_name = __pw_namecache;
5833 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5834 The identifier's value is usually the UIC, but it doesn't have to be,
5835 so if we can, we let fillpasswd update this. */
5836 __pwdcache.pw_uid = uic.uic$l_uic;
5837 __pwdcache.pw_gid = uic.uic$v_group;
5839 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5842 } /* end of my_getpwuid() */
5846 * Get information for next user.
5848 /*{{{struct passwd *my_getpwent()*/
5849 struct passwd *Perl_my_getpwent(pTHX)
5851 return (my_getpwuid((unsigned int) -1));
5856 * Finish searching rights database for users.
5858 /*{{{void my_endpwent()*/
5859 void Perl_my_endpwent(pTHX)
5862 _ckvmssts(sys$finish_rdb(&contxt));
5868 #ifdef HOMEGROWN_POSIX_SIGNALS
5869 /* Signal handling routines, pulled into the core from POSIX.xs.
5871 * We need these for threads, so they've been rolled into the core,
5872 * rather than left in POSIX.xs.
5874 * (DRS, Oct 23, 1997)
5877 /* sigset_t is atomic under VMS, so these routines are easy */
5878 /*{{{int my_sigemptyset(sigset_t *) */
5879 int my_sigemptyset(sigset_t *set) {
5880 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5886 /*{{{int my_sigfillset(sigset_t *)*/
5887 int my_sigfillset(sigset_t *set) {
5889 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5890 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5896 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5897 int my_sigaddset(sigset_t *set, int sig) {
5898 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5899 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5900 *set |= (1 << (sig - 1));
5906 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5907 int my_sigdelset(sigset_t *set, int sig) {
5908 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5909 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5910 *set &= ~(1 << (sig - 1));
5916 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5917 int my_sigismember(sigset_t *set, int sig) {
5918 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5919 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5920 return *set & (1 << (sig - 1));
5925 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5926 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5929 /* If set and oset are both null, then things are badly wrong. Bail out. */
5930 if ((oset == NULL) && (set == NULL)) {
5931 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5935 /* If set's null, then we're just handling a fetch. */
5937 tempmask = sigblock(0);
5942 tempmask = sigsetmask(*set);
5945 tempmask = sigblock(*set);
5948 tempmask = sigblock(0);
5949 sigsetmask(*oset & ~tempmask);
5952 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5957 /* Did they pass us an oset? If so, stick our holding mask into it */
5964 #endif /* HOMEGROWN_POSIX_SIGNALS */
5967 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5968 * my_utime(), and flex_stat(), all of which operate on UTC unless
5969 * VMSISH_TIMES is true.
5971 /* method used to handle UTC conversions:
5972 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5974 static int gmtime_emulation_type;
5975 /* number of secs to add to UTC POSIX-style time to get local time */
5976 static long int utc_offset_secs;
5978 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5979 * in vmsish.h. #undef them here so we can call the CRTL routines
5988 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5989 * qualifier with the extern prefix pragma. This provisional
5990 * hack circumvents this prefix pragma problem in previous
5993 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5994 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5995 # pragma __extern_prefix save
5996 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5997 # define gmtime decc$__utctz_gmtime
5998 # define localtime decc$__utctz_localtime
5999 # define time decc$__utc_time
6000 # pragma __extern_prefix restore
6002 struct tm *gmtime(), *localtime();
6008 static time_t toutc_dst(time_t loc) {
6011 if ((rsltmp = localtime(&loc)) == NULL) return -1;
6012 loc -= utc_offset_secs;
6013 if (rsltmp->tm_isdst) loc -= 3600;
6016 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6017 ((gmtime_emulation_type || my_time(NULL)), \
6018 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
6019 ((secs) - utc_offset_secs))))
6021 static time_t toloc_dst(time_t utc) {
6024 utc += utc_offset_secs;
6025 if ((rsltmp = localtime(&utc)) == NULL) return -1;
6026 if (rsltmp->tm_isdst) utc += 3600;
6029 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6030 ((gmtime_emulation_type || my_time(NULL)), \
6031 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6032 ((secs) + utc_offset_secs))))
6034 #ifndef RTL_USES_UTC
6037 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6038 DST starts on 1st sun of april at 02:00 std time
6039 ends on last sun of october at 02:00 dst time
6040 see the UCX management command reference, SET CONFIG TIMEZONE
6041 for formatting info.
6043 No, it's not as general as it should be, but then again, NOTHING
6044 will handle UK times in a sensible way.
6049 parse the DST start/end info:
6050 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6054 tz_parse_startend(char *s, struct tm *w, int *past)
6056 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6057 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6062 if (!past) return 0;
6065 if (w->tm_year % 4 == 0) ly = 1;
6066 if (w->tm_year % 100 == 0) ly = 0;
6067 if (w->tm_year+1900 % 400 == 0) ly = 1;
6070 dozjd = isdigit(*s);
6071 if (*s == 'J' || *s == 'j' || dozjd) {
6072 if (!dozjd && !isdigit(*++s)) return 0;
6075 d = d*10 + *s++ - '0';
6077 d = d*10 + *s++ - '0';
6080 if (d == 0) return 0;
6081 if (d > 366) return 0;
6083 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6086 } else if (*s == 'M' || *s == 'm') {
6087 if (!isdigit(*++s)) return 0;
6089 if (isdigit(*s)) m = 10*m + *s++ - '0';
6090 if (*s != '.') return 0;
6091 if (!isdigit(*++s)) return 0;
6093 if (n < 1 || n > 5) return 0;
6094 if (*s != '.') return 0;
6095 if (!isdigit(*++s)) return 0;
6097 if (d > 6) return 0;
6101 if (!isdigit(*++s)) return 0;
6103 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6105 if (!isdigit(*++s)) return 0;
6107 if (isdigit(*s)) min = 10*min + *s++ - '0';
6109 if (!isdigit(*++s)) return 0;
6111 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6121 if (w->tm_yday < d) goto before;
6122 if (w->tm_yday > d) goto after;
6124 if (w->tm_mon+1 < m) goto before;
6125 if (w->tm_mon+1 > m) goto after;
6127 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6128 k = d - j; /* mday of first d */
6130 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6131 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6132 if (w->tm_mday < k) goto before;
6133 if (w->tm_mday > k) goto after;
6136 if (w->tm_hour < hour) goto before;
6137 if (w->tm_hour > hour) goto after;
6138 if (w->tm_min < min) goto before;
6139 if (w->tm_min > min) goto after;
6140 if (w->tm_sec < sec) goto before;
6154 /* parse the offset: (+|-)hh[:mm[:ss]] */
6157 tz_parse_offset(char *s, int *offset)
6159 int hour = 0, min = 0, sec = 0;
6162 if (!offset) return 0;
6164 if (*s == '-') {neg++; s++;}
6166 if (!isdigit(*s)) return 0;
6168 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6169 if (hour > 24) return 0;
6171 if (!isdigit(*++s)) return 0;
6173 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6174 if (min > 59) return 0;
6176 if (!isdigit(*++s)) return 0;
6178 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6179 if (sec > 59) return 0;
6183 *offset = (hour*60+min)*60 + sec;
6184 if (neg) *offset = -*offset;
6189 input time is w, whatever type of time the CRTL localtime() uses.
6190 sets dst, the zone, and the gmtoff (seconds)
6192 caches the value of TZ and UCX$TZ env variables; note that
6193 my_setenv looks for these and sets a flag if they're changed
6196 We have to watch out for the "australian" case (dst starts in
6197 october, ends in april)...flagged by "reverse" and checked by
6198 scanning through the months of the previous year.
6203 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6208 char *dstzone, *tz, *s_start, *s_end;
6209 int std_off, dst_off, isdst;
6210 int y, dststart, dstend;
6211 static char envtz[1025]; /* longer than any logical, symbol, ... */
6212 static char ucxtz[1025];
6213 static char reversed = 0;
6219 reversed = -1; /* flag need to check */
6220 envtz[0] = ucxtz[0] = '\0';
6221 tz = my_getenv("TZ",0);
6222 if (tz) strcpy(envtz, tz);
6223 tz = my_getenv("UCX$TZ",0);
6224 if (tz) strcpy(ucxtz, tz);
6225 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6228 if (!*tz) tz = ucxtz;
6231 while (isalpha(*s)) s++;
6232 s = tz_parse_offset(s, &std_off);
6234 if (!*s) { /* no DST, hurray we're done! */
6240 while (isalpha(*s)) s++;
6241 s2 = tz_parse_offset(s, &dst_off);
6245 dst_off = std_off - 3600;
6248 if (!*s) { /* default dst start/end?? */
6249 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6250 s = strchr(ucxtz,',');
6252 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6254 if (*s != ',') return 0;
6257 when = _toutc(when); /* convert to utc */
6258 when = when - std_off; /* convert to pseudolocal time*/
6260 w2 = localtime(&when);
6263 s = tz_parse_startend(s_start,w2,&dststart);
6265 if (*s != ',') return 0;
6268 when = _toutc(when); /* convert to utc */
6269 when = when - dst_off; /* convert to pseudolocal time*/
6270 w2 = localtime(&when);
6271 if (w2->tm_year != y) { /* spans a year, just check one time */
6272 when += dst_off - std_off;
6273 w2 = localtime(&when);
6276 s = tz_parse_startend(s_end,w2,&dstend);
6279 if (reversed == -1) { /* need to check if start later than end */
6283 if (when < 2*365*86400) {
6284 when += 2*365*86400;
6288 w2 =localtime(&when);
6289 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6291 for (j = 0; j < 12; j++) {
6292 w2 =localtime(&when);
6293 (void) tz_parse_startend(s_start,w2,&ds);
6294 (void) tz_parse_startend(s_end,w2,&de);
6295 if (ds != de) break;
6299 if (de && !ds) reversed = 1;
6302 isdst = dststart && !dstend;
6303 if (reversed) isdst = dststart || !dstend;
6306 if (dst) *dst = isdst;
6307 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6308 if (isdst) tz = dstzone;
6310 while(isalpha(*tz)) *zone++ = *tz++;
6316 #endif /* !RTL_USES_UTC */
6318 /* my_time(), my_localtime(), my_gmtime()
6319 * By default traffic in UTC time values, using CRTL gmtime() or
6320 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6321 * Note: We need to use these functions even when the CRTL has working
6322 * UTC support, since they also handle C<use vmsish qw(times);>
6324 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6325 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6328 /*{{{time_t my_time(time_t *timep)*/
6329 time_t Perl_my_time(pTHX_ time_t *timep)
6334 if (gmtime_emulation_type == 0) {
6336 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6337 /* results of calls to gmtime() and localtime() */
6338 /* for same &base */
6340 gmtime_emulation_type++;
6341 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6342 char off[LNM$C_NAMLENGTH+1];;
6344 gmtime_emulation_type++;
6345 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6346 gmtime_emulation_type++;
6347 utc_offset_secs = 0;
6348 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6350 else { utc_offset_secs = atol(off); }
6352 else { /* We've got a working gmtime() */
6353 struct tm gmt, local;
6356 tm_p = localtime(&base);
6358 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6359 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6360 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6361 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6367 # ifdef RTL_USES_UTC
6368 if (VMSISH_TIME) when = _toloc(when);
6370 if (!VMSISH_TIME) when = _toutc(when);
6373 if (timep != NULL) *timep = when;
6376 } /* end of my_time() */
6380 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6382 Perl_my_gmtime(pTHX_ const time_t *timep)
6388 if (timep == NULL) {
6389 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6392 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6396 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6398 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6399 return gmtime(&when);
6401 /* CRTL localtime() wants local time as input, so does no tz correction */
6402 rsltmp = localtime(&when);
6403 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6406 } /* end of my_gmtime() */
6410 /*{{{struct tm *my_localtime(const time_t *timep)*/
6412 Perl_my_localtime(pTHX_ const time_t *timep)
6414 time_t when, whenutc;
6418 if (timep == NULL) {
6419 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6422 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6423 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6426 # ifdef RTL_USES_UTC
6428 if (VMSISH_TIME) when = _toutc(when);
6430 /* CRTL localtime() wants UTC as input, does tz correction itself */
6431 return localtime(&when);
6433 # else /* !RTL_USES_UTC */
6436 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6437 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6440 #ifndef RTL_USES_UTC
6441 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6442 when = whenutc - offset; /* pseudolocal time*/
6445 /* CRTL localtime() wants local time as input, so does no tz correction */
6446 rsltmp = localtime(&when);
6447 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6451 } /* end of my_localtime() */
6454 /* Reset definitions for later calls */
6455 #define gmtime(t) my_gmtime(t)
6456 #define localtime(t) my_localtime(t)
6457 #define time(t) my_time(t)
6460 /* my_utime - update modification time of a file
6461 * calling sequence is identical to POSIX utime(), but under
6462 * VMS only the modification time is changed; ODS-2 does not
6463 * maintain access times. Restrictions differ from the POSIX
6464 * definition in that the time can be changed as long as the
6465 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6466 * no separate checks are made to insure that the caller is the
6467 * owner of the file or has special privs enabled.
6468 * Code here is based on Joe Meadows' FILE utility.
6471 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6472 * to VMS epoch (01-JAN-1858 00:00:00.00)
6473 * in 100 ns intervals.
6475 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6477 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
6478 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
6481 long int bintime[2], len = 2, lowbit, unixtime,
6482 secscale = 10000000; /* seconds --> 100 ns intervals */
6483 unsigned long int chan, iosb[2], retsts;
6484 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6485 struct FAB myfab = cc$rms_fab;
6486 struct NAM mynam = cc$rms_nam;
6487 #if defined (__DECC) && defined (__VAX)
6488 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6489 * at least through VMS V6.1, which causes a type-conversion warning.
6491 # pragma message save
6492 # pragma message disable cvtdiftypes
6494 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6495 struct fibdef myfib;
6496 #if defined (__DECC) && defined (__VAX)
6497 /* This should be right after the declaration of myatr, but due
6498 * to a bug in VAX DEC C, this takes effect a statement early.
6500 # pragma message restore
6502 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6503 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6504 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6506 if (file == NULL || *file == '\0') {
6508 set_vaxc_errno(LIB$_INVARG);
6511 if (do_tovmsspec((char *)file,vmsspec,0) == NULL) return -1;
6513 if (utimes != NULL) {
6514 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6515 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6516 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6517 * as input, we force the sign bit to be clear by shifting unixtime right
6518 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6520 lowbit = (utimes->modtime & 1) ? secscale : 0;
6521 unixtime = (long int) utimes->modtime;
6523 /* If input was UTC; convert to local for sys svc */
6524 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6526 unixtime >>= 1; secscale <<= 1;
6527 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6528 if (!(retsts & 1)) {
6530 set_vaxc_errno(retsts);
6533 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6534 if (!(retsts & 1)) {
6536 set_vaxc_errno(retsts);
6541 /* Just get the current time in VMS format directly */
6542 retsts = sys$gettim(bintime);
6543 if (!(retsts & 1)) {
6545 set_vaxc_errno(retsts);
6550 myfab.fab$l_fna = vmsspec;
6551 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6552 myfab.fab$l_nam = &mynam;
6553 mynam.nam$l_esa = esa;
6554 mynam.nam$b_ess = (unsigned char) sizeof esa;
6555 mynam.nam$l_rsa = rsa;
6556 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6558 /* Look for the file to be affected, letting RMS parse the file
6559 * specification for us as well. I have set errno using only
6560 * values documented in the utime() man page for VMS POSIX.
6562 retsts = sys$parse(&myfab,0,0);
6563 if (!(retsts & 1)) {
6564 set_vaxc_errno(retsts);
6565 if (retsts == RMS$_PRV) set_errno(EACCES);
6566 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6567 else set_errno(EVMSERR);
6570 retsts = sys$search(&myfab,0,0);
6571 if (!(retsts & 1)) {
6572 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6573 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6574 set_vaxc_errno(retsts);
6575 if (retsts == RMS$_PRV) set_errno(EACCES);
6576 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6577 else set_errno(EVMSERR);
6581 devdsc.dsc$w_length = mynam.nam$b_dev;
6582 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6584 retsts = sys$assign(&devdsc,&chan,0,0);
6585 if (!(retsts & 1)) {
6586 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6587 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6588 set_vaxc_errno(retsts);
6589 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6590 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6591 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6592 else set_errno(EVMSERR);
6596 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6597 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6599 memset((void *) &myfib, 0, sizeof myfib);
6600 #if defined(__DECC) || defined(__DECCXX)
6601 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6602 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6603 /* This prevents the revision time of the file being reset to the current
6604 * time as a result of our IO$_MODIFY $QIO. */
6605 myfib.fib$l_acctl = FIB$M_NORECORD;
6607 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6608 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6609 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6611 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6612 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6613 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6614 _ckvmssts(sys$dassgn(chan));
6615 if (retsts & 1) retsts = iosb[0];
6616 if (!(retsts & 1)) {
6617 set_vaxc_errno(retsts);
6618 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6619 else set_errno(EVMSERR);
6624 } /* end of my_utime() */
6628 * flex_stat, flex_fstat
6629 * basic stat, but gets it right when asked to stat
6630 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6633 /* encode_dev packs a VMS device name string into an integer to allow
6634 * simple comparisons. This can be used, for example, to check whether two
6635 * files are located on the same device, by comparing their encoded device
6636 * names. Even a string comparison would not do, because stat() reuses the
6637 * device name buffer for each call; so without encode_dev, it would be
6638 * necessary to save the buffer and use strcmp (this would mean a number of
6639 * changes to the standard Perl code, to say nothing of what a Perl script
6642 * The device lock id, if it exists, should be unique (unless perhaps compared
6643 * with lock ids transferred from other nodes). We have a lock id if the disk is
6644 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6645 * device names. Thus we use the lock id in preference, and only if that isn't
6646 * available, do we try to pack the device name into an integer (flagged by
6647 * the sign bit (LOCKID_MASK) being set).
6649 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6650 * name and its encoded form, but it seems very unlikely that we will find
6651 * two files on different disks that share the same encoded device names,
6652 * and even more remote that they will share the same file id (if the test
6653 * is to check for the same file).
6655 * A better method might be to use sys$device_scan on the first call, and to
6656 * search for the device, returning an index into the cached array.
6657 * The number returned would be more intelligable.
6658 * This is probably not worth it, and anyway would take quite a bit longer
6659 * on the first call.
6661 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6662 static mydev_t encode_dev (pTHX_ const char *dev)
6665 unsigned long int f;
6670 if (!dev || !dev[0]) return 0;
6674 struct dsc$descriptor_s dev_desc;
6675 unsigned long int status, lockid, item = DVI$_LOCKID;
6677 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6678 can try that first. */
6679 dev_desc.dsc$w_length = strlen (dev);
6680 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6681 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6682 dev_desc.dsc$a_pointer = (char *) dev;
6683 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6684 if (lockid) return (lockid & ~LOCKID_MASK);
6688 /* Otherwise we try to encode the device name */
6692 for (q = dev + strlen(dev); q--; q >= dev) {
6695 else if (isalpha (toupper (*q)))
6696 c= toupper (*q) - 'A' + (char)10;
6698 continue; /* Skip '$'s */
6700 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6702 enc += f * (unsigned long int) c;
6704 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6706 } /* end of encode_dev() */
6708 static char namecache[NAM$C_MAXRSS+1];
6711 is_null_device(name)
6714 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6715 The underscore prefix, controller letter, and unit number are
6716 independently optional; for our purposes, the colon punctuation
6717 is not. The colon can be trailed by optional directory and/or
6718 filename, but two consecutive colons indicates a nodename rather
6719 than a device. [pr] */
6720 if (*name == '_') ++name;
6721 if (tolower(*name++) != 'n') return 0;
6722 if (tolower(*name++) != 'l') return 0;
6723 if (tolower(*name) == 'a') ++name;
6724 if (*name == '0') ++name;
6725 return (*name++ == ':') && (*name != ':');
6728 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6729 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6730 * subset of the applicable information.
6733 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
6735 char fname_phdev[NAM$C_MAXRSS+1];
6736 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6738 char fname[NAM$C_MAXRSS+1];
6739 unsigned long int retsts;
6740 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6741 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6743 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6744 device name on successive calls */
6745 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6746 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6747 namdsc.dsc$a_pointer = fname;
6748 namdsc.dsc$w_length = sizeof fname - 1;
6750 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6751 &namdsc,&namdsc.dsc$w_length,0,0);
6753 fname[namdsc.dsc$w_length] = '\0';
6755 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6756 * but if someone has redefined that logical, Perl gets very lost. Since
6757 * we have the physical device name from the stat buffer, just paste it on.
6759 strcpy( fname_phdev, statbufp->st_devnam );
6760 strcat( fname_phdev, strrchr(fname, ':') );
6762 return cando_by_name(bit,effective,fname_phdev);
6764 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6765 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6769 return FALSE; /* Should never get to here */
6771 } /* end of cando() */
6775 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6777 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6779 static char usrname[L_cuserid];
6780 static struct dsc$descriptor_s usrdsc =
6781 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6782 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6783 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6784 unsigned short int retlen, trnlnm_iter_count;
6785 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6786 union prvdef curprv;
6787 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6788 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6789 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6790 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6792 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6794 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6796 if (!fname || !*fname) return FALSE;
6797 /* Make sure we expand logical names, since sys$check_access doesn't */
6798 if (!strpbrk(fname,"/]>:")) {
6799 strcpy(fileified,fname);
6800 trnlnm_iter_count = 0;
6801 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6802 trnlnm_iter_count++;
6803 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6807 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6808 retlen = namdsc.dsc$w_length = strlen(vmsname);
6809 namdsc.dsc$a_pointer = vmsname;
6810 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6811 vmsname[retlen-1] == ':') {
6812 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6813 namdsc.dsc$w_length = strlen(fileified);
6814 namdsc.dsc$a_pointer = fileified;
6818 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6819 access = ARM$M_EXECUTE; break;
6820 case S_IRUSR: case S_IRGRP: case S_IROTH:
6821 access = ARM$M_READ; break;
6822 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6823 access = ARM$M_WRITE; break;
6824 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6825 access = ARM$M_DELETE; break;
6830 /* Before we call $check_access, create a user profile with the current
6831 * process privs since otherwise it just uses the default privs from the
6832 * UAF and might give false positives or negatives. This only works on
6833 * VMS versions v6.0 and later since that's when sys$create_user_profile
6837 /* get current process privs and username */
6838 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6841 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6843 /* find out the space required for the profile */
6844 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6845 &usrprodsc.dsc$w_length,0));
6847 /* allocate space for the profile and get it filled in */
6848 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6849 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6850 &usrprodsc.dsc$w_length,0));
6852 /* use the profile to check access to the file; free profile & analyze results */
6853 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6854 Safefree(usrprodsc.dsc$a_pointer);
6855 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6859 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6863 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6864 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6865 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6866 set_vaxc_errno(retsts);
6867 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6868 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6869 else set_errno(ENOENT);
6872 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6877 return FALSE; /* Should never get here */
6879 } /* end of cando_by_name() */
6883 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6885 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6887 if (!fstat(fd,(stat_t *) statbufp)) {
6888 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6889 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6890 # ifdef RTL_USES_UTC
6893 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6894 statbufp->st_atime = _toloc(statbufp->st_atime);
6895 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6900 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6904 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6905 statbufp->st_atime = _toutc(statbufp->st_atime);
6906 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6913 } /* end of flex_fstat() */
6916 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6918 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6920 char fileified[NAM$C_MAXRSS+1];
6921 char temp_fspec[NAM$C_MAXRSS+300];
6923 int saved_errno, saved_vaxc_errno;
6925 if (!fspec) return retval;
6926 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6927 strcpy(temp_fspec, fspec);
6928 if (statbufp == (Stat_t *) &PL_statcache)
6929 do_tovmsspec(temp_fspec,namecache,0);
6930 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6931 memset(statbufp,0,sizeof *statbufp);
6932 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6933 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6934 statbufp->st_uid = 0x00010001;
6935 statbufp->st_gid = 0x0001;
6936 time((time_t *)&statbufp->st_mtime);
6937 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6941 /* Try for a directory name first. If fspec contains a filename without
6942 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6943 * and sea:[wine.dark]water. exist, we prefer the directory here.
6944 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6945 * not sea:[wine.dark]., if the latter exists. If the intended target is
6946 * the file with null type, specify this by calling flex_stat() with
6947 * a '.' at the end of fspec.
6949 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6950 retval = stat(fileified,(stat_t *) statbufp);
6951 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6952 strcpy(namecache,fileified);
6954 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6956 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6957 # ifdef RTL_USES_UTC
6960 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6961 statbufp->st_atime = _toloc(statbufp->st_atime);
6962 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6967 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6971 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6972 statbufp->st_atime = _toutc(statbufp->st_atime);
6973 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6977 /* If we were successful, leave errno where we found it */
6978 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6981 } /* end of flex_stat() */
6985 /*{{{char *my_getlogin()*/
6986 /* VMS cuserid == Unix getlogin, except calling sequence */
6990 static char user[L_cuserid];
6991 return cuserid(user);
6996 /* rmscopy - copy a file using VMS RMS routines
6998 * Copies contents and attributes of spec_in to spec_out, except owner
6999 * and protection information. Name and type of spec_in are used as
7000 * defaults for spec_out. The third parameter specifies whether rmscopy()
7001 * should try to propagate timestamps from the input file to the output file.
7002 * If it is less than 0, no timestamps are preserved. If it is 0, then
7003 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
7004 * propagated to the output file at creation iff the output file specification
7005 * did not contain an explicit name or type, and the revision date is always
7006 * updated at the end of the copy operation. If it is greater than 0, then
7007 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
7008 * other than the revision date should be propagated, and bit 1 indicates
7009 * that the revision date should be propagated.
7011 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
7013 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
7014 * Incorporates, with permission, some code from EZCOPY by Tim Adye
7015 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
7016 * as part of the Perl standard distribution under the terms of the
7017 * GNU General Public License or the Perl Artistic License. Copies
7018 * of each may be found in the Perl standard distribution.
7020 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
7022 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
7024 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7025 rsa[NAM$C_MAXRSS], ubf[32256];
7026 unsigned long int i, sts, sts2;
7027 struct FAB fab_in, fab_out;
7028 struct RAB rab_in, rab_out;
7030 struct XABDAT xabdat;
7031 struct XABFHC xabfhc;
7032 struct XABRDT xabrdt;
7033 struct XABSUM xabsum;
7035 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7036 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7037 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7041 fab_in = cc$rms_fab;
7042 fab_in.fab$l_fna = vmsin;
7043 fab_in.fab$b_fns = strlen(vmsin);
7044 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7045 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7046 fab_in.fab$l_fop = FAB$M_SQO;
7047 fab_in.fab$l_nam = &nam;
7048 fab_in.fab$l_xab = (void *) &xabdat;
7051 nam.nam$l_rsa = rsa;
7052 nam.nam$b_rss = sizeof(rsa);
7053 nam.nam$l_esa = esa;
7054 nam.nam$b_ess = sizeof (esa);
7055 nam.nam$b_esl = nam.nam$b_rsl = 0;
7057 xabdat = cc$rms_xabdat; /* To get creation date */
7058 xabdat.xab$l_nxt = (void *) &xabfhc;
7060 xabfhc = cc$rms_xabfhc; /* To get record length */
7061 xabfhc.xab$l_nxt = (void *) &xabsum;
7063 xabsum = cc$rms_xabsum; /* To get key and area information */
7065 if (!((sts = sys$open(&fab_in)) & 1)) {
7066 set_vaxc_errno(sts);
7068 case RMS$_FNF: case RMS$_DNF:
7069 set_errno(ENOENT); break;
7071 set_errno(ENOTDIR); break;
7073 set_errno(ENODEV); break;
7075 set_errno(EINVAL); break;
7077 set_errno(EACCES); break;
7085 fab_out.fab$w_ifi = 0;
7086 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7087 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7088 fab_out.fab$l_fop = FAB$M_SQO;
7089 fab_out.fab$l_fna = vmsout;
7090 fab_out.fab$b_fns = strlen(vmsout);
7091 fab_out.fab$l_dna = nam.nam$l_name;
7092 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7094 if (preserve_dates == 0) { /* Act like DCL COPY */
7095 nam.nam$b_nop = NAM$M_SYNCHK;
7096 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7097 if (!((sts = sys$parse(&fab_out)) & 1)) {
7098 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7099 set_vaxc_errno(sts);
7102 fab_out.fab$l_xab = (void *) &xabdat;
7103 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7105 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7106 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7107 preserve_dates =0; /* bitmask from this point forward */
7109 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7110 if (!((sts = sys$create(&fab_out)) & 1)) {
7111 set_vaxc_errno(sts);
7114 set_errno(ENOENT); break;
7116 set_errno(ENOTDIR); break;
7118 set_errno(ENODEV); break;
7120 set_errno(EINVAL); break;
7122 set_errno(EACCES); break;
7128 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7129 if (preserve_dates & 2) {
7130 /* sys$close() will process xabrdt, not xabdat */
7131 xabrdt = cc$rms_xabrdt;
7133 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7135 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7136 * is unsigned long[2], while DECC & VAXC use a struct */
7137 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7139 fab_out.fab$l_xab = (void *) &xabrdt;
7142 rab_in = cc$rms_rab;
7143 rab_in.rab$l_fab = &fab_in;
7144 rab_in.rab$l_rop = RAB$M_BIO;
7145 rab_in.rab$l_ubf = ubf;
7146 rab_in.rab$w_usz = sizeof ubf;
7147 if (!((sts = sys$connect(&rab_in)) & 1)) {
7148 sys$close(&fab_in); sys$close(&fab_out);
7149 set_errno(EVMSERR); set_vaxc_errno(sts);
7153 rab_out = cc$rms_rab;
7154 rab_out.rab$l_fab = &fab_out;
7155 rab_out.rab$l_rbf = ubf;
7156 if (!((sts = sys$connect(&rab_out)) & 1)) {
7157 sys$close(&fab_in); sys$close(&fab_out);
7158 set_errno(EVMSERR); set_vaxc_errno(sts);
7162 while ((sts = sys$read(&rab_in))) { /* always true */
7163 if (sts == RMS$_EOF) break;
7164 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7165 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7166 sys$close(&fab_in); sys$close(&fab_out);
7167 set_errno(EVMSERR); set_vaxc_errno(sts);
7172 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7173 sys$close(&fab_in); sys$close(&fab_out);
7174 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7176 set_errno(EVMSERR); set_vaxc_errno(sts);
7182 } /* end of rmscopy() */
7186 /*** The following glue provides 'hooks' to make some of the routines
7187 * from this file available from Perl. These routines are sufficiently
7188 * basic, and are required sufficiently early in the build process,
7189 * that's it's nice to have them available to miniperl as well as the
7190 * full Perl, so they're set up here instead of in an extension. The
7191 * Perl code which handles importation of these names into a given
7192 * package lives in [.VMS]Filespec.pm in @INC.
7196 rmsexpand_fromperl(pTHX_ CV *cv)
7199 char *fspec, *defspec = NULL, *rslt;
7202 if (!items || items > 2)
7203 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7204 fspec = SvPV(ST(0),n_a);
7205 if (!fspec || !*fspec) XSRETURN_UNDEF;
7206 if (items == 2) defspec = SvPV(ST(1),n_a);
7208 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7209 ST(0) = sv_newmortal();
7210 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7215 vmsify_fromperl(pTHX_ CV *cv)
7221 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7222 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7223 ST(0) = sv_newmortal();
7224 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7229 unixify_fromperl(pTHX_ CV *cv)
7235 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7236 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7237 ST(0) = sv_newmortal();
7238 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7243 fileify_fromperl(pTHX_ CV *cv)
7249 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7250 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7251 ST(0) = sv_newmortal();
7252 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7257 pathify_fromperl(pTHX_ CV *cv)
7263 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7264 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7265 ST(0) = sv_newmortal();
7266 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7271 vmspath_fromperl(pTHX_ CV *cv)
7277 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7278 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7279 ST(0) = sv_newmortal();
7280 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7285 unixpath_fromperl(pTHX_ CV *cv)
7291 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7292 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7293 ST(0) = sv_newmortal();
7294 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7299 candelete_fromperl(pTHX_ CV *cv)
7302 char fspec[NAM$C_MAXRSS+1], *fsp;
7307 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7309 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7310 if (SvTYPE(mysv) == SVt_PVGV) {
7311 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7312 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7319 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7320 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7326 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7331 rmscopy_fromperl(pTHX_ CV *cv)
7334 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7336 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7337 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7338 unsigned long int sts;
7343 if (items < 2 || items > 3)
7344 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7346 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7347 if (SvTYPE(mysv) == SVt_PVGV) {
7348 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7349 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7356 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7357 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7362 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7363 if (SvTYPE(mysv) == SVt_PVGV) {
7364 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7365 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7372 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7373 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7378 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7380 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7386 mod2fname(pTHX_ CV *cv)
7389 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7390 workbuff[NAM$C_MAXRSS*1 + 1];
7391 int total_namelen = 3, counter, num_entries;
7392 /* ODS-5 ups this, but we want to be consistent, so... */
7393 int max_name_len = 39;
7394 AV *in_array = (AV *)SvRV(ST(0));
7396 num_entries = av_len(in_array);
7398 /* All the names start with PL_. */
7399 strcpy(ultimate_name, "PL_");
7401 /* Clean up our working buffer */
7402 Zero(work_name, sizeof(work_name), char);
7404 /* Run through the entries and build up a working name */
7405 for(counter = 0; counter <= num_entries; counter++) {
7406 /* If it's not the first name then tack on a __ */
7408 strcat(work_name, "__");
7410 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7414 /* Check to see if we actually have to bother...*/
7415 if (strlen(work_name) + 3 <= max_name_len) {
7416 strcat(ultimate_name, work_name);
7418 /* It's too darned big, so we need to go strip. We use the same */
7419 /* algorithm as xsubpp does. First, strip out doubled __ */
7420 char *source, *dest, last;
7423 for (source = work_name; *source; source++) {
7424 if (last == *source && last == '_') {
7430 /* Go put it back */
7431 strcpy(work_name, workbuff);
7432 /* Is it still too big? */
7433 if (strlen(work_name) + 3 > max_name_len) {
7434 /* Strip duplicate letters */
7437 for (source = work_name; *source; source++) {
7438 if (last == toupper(*source)) {
7442 last = toupper(*source);
7444 strcpy(work_name, workbuff);
7447 /* Is it *still* too big? */
7448 if (strlen(work_name) + 3 > max_name_len) {
7449 /* Too bad, we truncate */
7450 work_name[max_name_len - 2] = 0;
7452 strcat(ultimate_name, work_name);
7455 /* Okay, return it */
7456 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7461 hushexit_fromperl(pTHX_ CV *cv)
7466 VMSISH_HUSHED = SvTRUE(ST(0));
7468 ST(0) = boolSV(VMSISH_HUSHED);
7473 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7474 struct interp_intern *dst)
7476 memcpy(dst,src,sizeof(struct interp_intern));
7480 Perl_sys_intern_clear(pTHX)
7485 Perl_sys_intern_init(pTHX)
7487 unsigned int ix = RAND_MAX;
7493 MY_INV_RAND_MAX = 1./x;
7500 char* file = __FILE__;
7501 char temp_buff[512];
7502 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7503 no_translate_barewords = TRUE;
7505 no_translate_barewords = FALSE;
7508 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7509 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7510 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7511 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7512 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7513 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7514 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7515 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7516 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7517 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7518 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7520 store_pipelocs(aTHX); /* will redo any earlier attempts */