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 New(1380,__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 New(1381,__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) New(1322,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);
668 sv = newSVpvn(cp2,cp1 - cp2 + 1);
670 hv_store(envhv,key,keylen,sv,hash);
671 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
673 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
674 /* get the PPFs for this process, not the subprocess */
675 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
676 char eqv[LNM$C_NAMLENGTH+1];
678 for (i = 0; ppfs[i]; i++) {
679 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
680 sv = newSVpv(eqv,trnlen);
682 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
687 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
688 if (buf) Safefree(buf);
689 if (seenhv) SvREFCNT_dec(seenhv);
690 MUTEX_UNLOCK(&primenv_mutex);
693 } /* end of prime_env_iter */
697 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
698 /* Define or delete an element in the same "environment" as
699 * vmstrnenv(). If an element is to be deleted, it's removed from
700 * the first place it's found. If it's to be set, it's set in the
701 * place designated by the first element of the table vector.
702 * Like setenv() returns 0 for success, non-zero on error.
705 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
707 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
708 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
710 unsigned long int retsts, usermode = PSL$C_USER;
711 struct itmlst_3 *ile, *ilist;
712 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
713 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
714 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
715 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
716 $DESCRIPTOR(local,"_LOCAL");
719 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
723 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
724 *cp2 = _toupper(*cp1);
725 if (cp1 - lnm > LNM$C_NAMLENGTH) {
726 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
730 lnmdsc.dsc$w_length = cp1 - lnm;
731 if (!tabvec || !*tabvec) tabvec = env_tables;
733 if (!eqv) { /* we're deleting n element */
734 for (curtab = 0; tabvec[curtab]; curtab++) {
735 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
737 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
738 if ((cp1 = strchr(environ[i],'=')) &&
739 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
740 !strncmp(environ[i],lnm,cp1 - environ[i])) {
742 return setenv(lnm,"",1) ? vaxc$errno : 0;
745 ivenv = 1; retsts = SS$_NOLOGNAM;
747 if (ckWARN(WARN_INTERNAL))
748 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
749 ivenv = 1; retsts = SS$_NOSUCHPGM;
755 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
756 !str$case_blind_compare(&tmpdsc,&clisym)) {
757 unsigned int symtype;
758 if (tabvec[curtab]->dsc$w_length == 12 &&
759 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
760 !str$case_blind_compare(&tmpdsc,&local))
761 symtype = LIB$K_CLI_LOCAL_SYM;
762 else symtype = LIB$K_CLI_GLOBAL_SYM;
763 retsts = lib$delete_symbol(&lnmdsc,&symtype);
764 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
765 if (retsts == LIB$_NOSUCHSYM) continue;
769 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
770 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
771 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
772 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
773 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
777 else { /* we're defining a value */
778 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
780 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
782 if (ckWARN(WARN_INTERNAL))
783 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
784 retsts = SS$_NOSUCHPGM;
788 eqvdsc.dsc$a_pointer = eqv;
789 eqvdsc.dsc$w_length = strlen(eqv);
790 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
791 !str$case_blind_compare(&tmpdsc,&clisym)) {
792 unsigned int symtype;
793 if (tabvec[0]->dsc$w_length == 12 &&
794 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
795 !str$case_blind_compare(&tmpdsc,&local))
796 symtype = LIB$K_CLI_LOCAL_SYM;
797 else symtype = LIB$K_CLI_GLOBAL_SYM;
798 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
801 if (!*eqv) eqvdsc.dsc$w_length = 1;
802 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
804 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
805 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
806 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
807 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
808 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
809 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
812 New(1382,ilist,nseg+1,struct itmlst_3);
815 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
818 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
820 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
821 ile->itmcode = LNM$_STRING;
824 ile->buflen = strlen(c);
825 /* in case we are truncating one that's too long */
826 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
829 ile->buflen = LNM$C_NAMLENGTH;
833 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
837 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
844 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
845 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
846 set_errno(EVMSERR); break;
847 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
848 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
849 set_errno(EINVAL); break;
856 set_vaxc_errno(retsts);
857 return (int) retsts || 44; /* retsts should never be 0, but just in case */
860 /* We reset error values on success because Perl does an hv_fetch()
861 * before each hv_store(), and if the thing we're setting didn't
862 * previously exist, we've got a leftover error message. (Of course,
863 * this fails in the face of
864 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
865 * in that the error reported in $! isn't spurious,
866 * but it's right more often than not.)
868 set_errno(0); set_vaxc_errno(retsts);
872 } /* end of vmssetenv() */
875 /*{{{ void my_setenv(char *lnm, char *eqv)*/
876 /* This has to be a function since there's a prototype for it in proto.h */
878 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
881 int len = strlen(lnm);
885 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
886 if (!strcmp(uplnm,"DEFAULT")) {
887 if (eqv && *eqv) chdir(eqv);
892 if (len == 6 || len == 2) {
895 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
897 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
898 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
902 (void) vmssetenv(lnm,eqv,NULL);
906 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
908 * sets a user-mode logical in the process logical name table
909 * used for redirection of sys$error
912 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
914 $DESCRIPTOR(d_tab, "LNM$PROCESS");
915 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
916 unsigned long int iss, attr = LNM$M_CONFINE;
917 unsigned char acmode = PSL$C_USER;
918 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
920 d_name.dsc$a_pointer = name;
921 d_name.dsc$w_length = strlen(name);
923 lnmlst[0].buflen = strlen(eqv);
924 lnmlst[0].bufadr = eqv;
926 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
927 if (!(iss&1)) lib$signal(iss);
932 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
933 /* my_crypt - VMS password hashing
934 * my_crypt() provides an interface compatible with the Unix crypt()
935 * C library function, and uses sys$hash_password() to perform VMS
936 * password hashing. The quadword hashed password value is returned
937 * as a NUL-terminated 8 character string. my_crypt() does not change
938 * the case of its string arguments; in order to match the behavior
939 * of LOGINOUT et al., alphabetic characters in both arguments must
940 * be upcased by the caller.
943 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
945 # ifndef UAI$C_PREFERRED_ALGORITHM
946 # define UAI$C_PREFERRED_ALGORITHM 127
948 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
949 unsigned short int salt = 0;
950 unsigned long int sts;
952 unsigned short int dsc$w_length;
953 unsigned char dsc$b_type;
954 unsigned char dsc$b_class;
955 const char * dsc$a_pointer;
956 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
957 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
958 struct itmlst_3 uailst[3] = {
959 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
960 { sizeof salt, UAI$_SALT, &salt, 0},
961 { 0, 0, NULL, NULL}};
964 usrdsc.dsc$w_length = strlen(usrname);
965 usrdsc.dsc$a_pointer = usrname;
966 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
968 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
972 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
978 if (sts != RMS$_RNF) return NULL;
981 txtdsc.dsc$w_length = strlen(textpasswd);
982 txtdsc.dsc$a_pointer = textpasswd;
983 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
984 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
987 return (char *) hash;
989 } /* end of my_crypt() */
993 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
994 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
995 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
997 /*{{{int do_rmdir(char *name)*/
999 Perl_do_rmdir(pTHX_ char *name)
1001 char dirfile[NAM$C_MAXRSS+1];
1005 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1006 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1007 else retval = kill_file(dirfile);
1010 } /* end of do_rmdir */
1014 * Delete any file to which user has control access, regardless of whether
1015 * delete access is explicitly allowed.
1016 * Limitations: User must have write access to parent directory.
1017 * Does not block signals or ASTs; if interrupted in midstream
1018 * may leave file with an altered ACL.
1021 /*{{{int kill_file(char *name)*/
1023 Perl_kill_file(pTHX_ char *name)
1025 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1026 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1027 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1028 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1030 unsigned char myace$b_length;
1031 unsigned char myace$b_type;
1032 unsigned short int myace$w_flags;
1033 unsigned long int myace$l_access;
1034 unsigned long int myace$l_ident;
1035 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1036 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1037 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1039 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1040 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1041 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1042 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1043 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1044 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1046 /* Expand the input spec using RMS, since the CRTL remove() and
1047 * system services won't do this by themselves, so we may miss
1048 * a file "hiding" behind a logical name or search list. */
1049 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1050 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1051 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1052 /* If not, can changing protections help? */
1053 if (vaxc$errno != RMS$_PRV) return -1;
1055 /* No, so we get our own UIC to use as a rights identifier,
1056 * and the insert an ACE at the head of the ACL which allows us
1057 * to delete the file.
1059 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1060 fildsc.dsc$w_length = strlen(rspec);
1061 fildsc.dsc$a_pointer = rspec;
1063 newace.myace$l_ident = oldace.myace$l_ident;
1064 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1066 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1067 set_errno(ENOENT); break;
1069 set_errno(ENOTDIR); break;
1071 set_errno(ENODEV); break;
1072 case RMS$_SYN: case SS$_INVFILFOROP:
1073 set_errno(EINVAL); break;
1075 set_errno(EACCES); break;
1079 set_vaxc_errno(aclsts);
1082 /* Grab any existing ACEs with this identifier in case we fail */
1083 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1084 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1085 || fndsts == SS$_NOMOREACE ) {
1086 /* Add the new ACE . . . */
1087 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1089 if ((rmsts = remove(name))) {
1090 /* We blew it - dir with files in it, no write priv for
1091 * parent directory, etc. Put things back the way they were. */
1092 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1095 addlst[0].bufadr = &oldace;
1096 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1103 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1104 /* We just deleted it, so of course it's not there. Some versions of
1105 * VMS seem to return success on the unlock operation anyhow (after all
1106 * the unlock is successful), but others don't.
1108 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1109 if (aclsts & 1) aclsts = fndsts;
1110 if (!(aclsts & 1)) {
1112 set_vaxc_errno(aclsts);
1118 } /* end of kill_file() */
1122 /*{{{int my_mkdir(char *,Mode_t)*/
1124 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1126 STRLEN dirlen = strlen(dir);
1128 /* zero length string sometimes gives ACCVIO */
1129 if (dirlen == 0) return -1;
1131 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1132 * null file name/type. However, it's commonplace under Unix,
1133 * so we'll allow it for a gain in portability.
1135 if (dir[dirlen-1] == '/') {
1136 char *newdir = savepvn(dir,dirlen-1);
1137 int ret = mkdir(newdir,mode);
1141 else return mkdir(dir,mode);
1142 } /* end of my_mkdir */
1145 /*{{{int my_chdir(char *)*/
1147 Perl_my_chdir(pTHX_ char *dir)
1149 STRLEN dirlen = strlen(dir);
1151 /* zero length string sometimes gives ACCVIO */
1152 if (dirlen == 0) return -1;
1154 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1156 * null file name/type. However, it's commonplace under Unix,
1157 * so we'll allow it for a gain in portability.
1159 if (dir[dirlen-1] == '/') {
1160 char *newdir = savepvn(dir,dirlen-1);
1161 int ret = chdir(newdir);
1165 else return chdir(dir);
1166 } /* end of my_chdir */
1170 /*{{{FILE *my_tmpfile()*/
1177 if ((fp = tmpfile())) return fp;
1179 New(1323,cp,L_tmpnam+24,char);
1180 strcpy(cp,"Sys$Scratch:");
1181 tmpnam(cp+strlen(cp));
1182 strcat(cp,".Perltmp");
1183 fp = fopen(cp,"w+","fop=dlt");
1190 #ifndef HOMEGROWN_POSIX_SIGNALS
1192 * The C RTL's sigaction fails to check for invalid signal numbers so we
1193 * help it out a bit. The docs are correct, but the actual routine doesn't
1194 * do what the docs say it will.
1196 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1198 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1199 struct sigaction* oact)
1201 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1202 SETERRNO(EINVAL, SS$_INVARG);
1205 return sigaction(sig, act, oact);
1210 #ifdef KILL_BY_SIGPRC
1211 #include <errnodef.h>
1213 /* We implement our own kill() using the undocumented system service
1214 sys$sigprc for one of two reasons:
1216 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1217 target process to do a sys$exit, which usually can't be handled
1218 gracefully...certainly not by Perl and the %SIG{} mechanism.
1220 2.) If the kill() in the CRTL can't be called from a signal
1221 handler without disappearing into the ether, i.e., the signal
1222 it purportedly sends is never trapped. Still true as of VMS 7.3.
1224 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1225 in the target process rather than calling sys$exit.
1227 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1228 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1229 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1230 with condition codes C$_SIG0+nsig*8, catching the exception on the
1231 target process and resignaling with appropriate arguments.
1233 But we don't have that VMS 7.0+ exception handler, so if you
1234 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1236 Also note that SIGTERM is listed in the docs as being "unimplemented",
1237 yet always seems to be signaled with a VMS condition code of 4 (and
1238 correctly handled for that code). So we hardwire it in.
1240 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1241 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1242 than signalling with an unrecognized (and unhandled by CRTL) code.
1245 #define _MY_SIG_MAX 17
1248 Perl_sig_to_vmscondition(int sig)
1250 static unsigned int sig_code[_MY_SIG_MAX+1] =
1253 SS$_HANGUP, /* 1 SIGHUP */
1254 SS$_CONTROLC, /* 2 SIGINT */
1255 SS$_CONTROLY, /* 3 SIGQUIT */
1256 SS$_RADRMOD, /* 4 SIGILL */
1257 SS$_BREAK, /* 5 SIGTRAP */
1258 SS$_OPCCUS, /* 6 SIGABRT */
1259 SS$_COMPAT, /* 7 SIGEMT */
1261 SS$_FLTOVF, /* 8 SIGFPE VAX */
1263 SS$_HPARITH, /* 8 SIGFPE AXP */
1265 SS$_ABORT, /* 9 SIGKILL */
1266 SS$_ACCVIO, /* 10 SIGBUS */
1267 SS$_ACCVIO, /* 11 SIGSEGV */
1268 SS$_BADPARAM, /* 12 SIGSYS */
1269 SS$_NOMBX, /* 13 SIGPIPE */
1270 SS$_ASTFLT, /* 14 SIGALRM */
1276 #if __VMS_VER >= 60200000
1277 static int initted = 0;
1280 sig_code[16] = C$_SIGUSR1;
1281 sig_code[17] = C$_SIGUSR2;
1285 if (sig < _SIG_MIN) return 0;
1286 if (sig > _MY_SIG_MAX) return 0;
1287 return sig_code[sig];
1292 Perl_my_kill(int pid, int sig)
1297 int sys$sigprc(unsigned int *pidadr,
1298 struct dsc$descriptor_s *prcname,
1301 code = Perl_sig_to_vmscondition(sig);
1303 if (!pid || !code) {
1307 iss = sys$sigprc((unsigned int *)&pid,0,code);
1308 if (iss&1) return 0;
1312 set_errno(EPERM); break;
1314 case SS$_NOSUCHNODE:
1315 case SS$_UNREACHABLE:
1316 set_errno(ESRCH); break;
1318 set_errno(ENOMEM); break;
1323 set_vaxc_errno(iss);
1329 /* default piping mailbox size */
1330 #define PERL_BUFSIZ 512
1334 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1336 unsigned long int mbxbufsiz;
1337 static unsigned long int syssize = 0;
1338 unsigned long int dviitm = DVI$_DEVNAM;
1339 char csize[LNM$C_NAMLENGTH+1];
1342 unsigned long syiitm = SYI$_MAXBUF;
1344 * Get the SYSGEN parameter MAXBUF
1346 * If the logical 'PERL_MBX_SIZE' is defined
1347 * use the value of the logical instead of PERL_BUFSIZ, but
1348 * keep the size between 128 and MAXBUF.
1351 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1354 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1355 mbxbufsiz = atoi(csize);
1357 mbxbufsiz = PERL_BUFSIZ;
1359 if (mbxbufsiz < 128) mbxbufsiz = 128;
1360 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1362 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1364 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1365 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1367 } /* end of create_mbx() */
1370 /*{{{ my_popen and my_pclose*/
1372 typedef struct _iosb IOSB;
1373 typedef struct _iosb* pIOSB;
1374 typedef struct _pipe Pipe;
1375 typedef struct _pipe* pPipe;
1376 typedef struct pipe_details Info;
1377 typedef struct pipe_details* pInfo;
1378 typedef struct _srqp RQE;
1379 typedef struct _srqp* pRQE;
1380 typedef struct _tochildbuf CBuf;
1381 typedef struct _tochildbuf* pCBuf;
1384 unsigned short status;
1385 unsigned short count;
1386 unsigned long dvispec;
1389 #pragma member_alignment save
1390 #pragma nomember_alignment quadword
1391 struct _srqp { /* VMS self-relative queue entry */
1392 unsigned long qptr[2];
1394 #pragma member_alignment restore
1395 static RQE RQE_ZERO = {0,0};
1397 struct _tochildbuf {
1400 unsigned short size;
1408 unsigned short chan_in;
1409 unsigned short chan_out;
1411 unsigned int bufsize;
1423 #if defined(PERL_IMPLICIT_CONTEXT)
1424 void *thx; /* Either a thread or an interpreter */
1425 /* pointer, depending on how we're built */
1433 PerlIO *fp; /* file pointer to pipe mailbox */
1434 int useFILE; /* using stdio, not perlio */
1435 int pid; /* PID of subprocess */
1436 int mode; /* == 'r' if pipe open for reading */
1437 int done; /* subprocess has completed */
1438 int waiting; /* waiting for completion/closure */
1439 int closing; /* my_pclose is closing this pipe */
1440 unsigned long completion; /* termination status of subprocess */
1441 pPipe in; /* pipe in to sub */
1442 pPipe out; /* pipe out of sub */
1443 pPipe err; /* pipe of sub's sys$error */
1444 int in_done; /* true when in pipe finished */
1449 struct exit_control_block
1451 struct exit_control_block *flink;
1452 unsigned long int (*exit_routine)();
1453 unsigned long int arg_count;
1454 unsigned long int *status_address;
1455 unsigned long int exit_status;
1458 typedef struct _closed_pipes Xpipe;
1459 typedef struct _closed_pipes* pXpipe;
1461 struct _closed_pipes {
1462 int pid; /* PID of subprocess */
1463 unsigned long completion; /* termination status of subprocess */
1465 #define NKEEPCLOSED 50
1466 static Xpipe closed_list[NKEEPCLOSED];
1467 static int closed_index = 0;
1468 static int closed_num = 0;
1470 #define RETRY_DELAY "0 ::0.20"
1471 #define MAX_RETRY 50
1473 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1474 static unsigned long mypid;
1475 static unsigned long delaytime[2];
1477 static pInfo open_pipes = NULL;
1478 static $DESCRIPTOR(nl_desc, "NL:");
1480 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1484 static unsigned long int
1485 pipe_exit_routine(pTHX)
1488 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1489 int sts, did_stuff, need_eof, j;
1492 flush any pending i/o
1498 PerlIO_flush(info->fp); /* first, flush data */
1500 fflush((FILE *)info->fp);
1506 next we try sending an EOF...ignore if doesn't work, make sure we
1514 _ckvmssts(sys$setast(0));
1515 if (info->in && !info->in->shut_on_empty) {
1516 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1521 _ckvmssts(sys$setast(1));
1525 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1527 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1532 _ckvmssts(sys$setast(0));
1533 if (info->waiting && info->done)
1535 nwait += info->waiting;
1536 _ckvmssts(sys$setast(1));
1546 _ckvmssts(sys$setast(0));
1547 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1548 sts = sys$forcex(&info->pid,0,&abort);
1549 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1552 _ckvmssts(sys$setast(1));
1556 /* again, wait for effect */
1558 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1563 _ckvmssts(sys$setast(0));
1564 if (info->waiting && info->done)
1566 nwait += info->waiting;
1567 _ckvmssts(sys$setast(1));
1576 _ckvmssts(sys$setast(0));
1577 if (!info->done) { /* We tried to be nice . . . */
1578 sts = sys$delprc(&info->pid,0);
1579 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1581 _ckvmssts(sys$setast(1));
1586 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1587 else if (!(sts & 1)) retsts = sts;
1592 static struct exit_control_block pipe_exitblock =
1593 {(struct exit_control_block *) 0,
1594 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1596 static void pipe_mbxtofd_ast(pPipe p);
1597 static void pipe_tochild1_ast(pPipe p);
1598 static void pipe_tochild2_ast(pPipe p);
1601 popen_completion_ast(pInfo info)
1603 pInfo i = open_pipes;
1607 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1608 closed_list[closed_index].pid = info->pid;
1609 closed_list[closed_index].completion = info->completion;
1611 if (closed_index == NKEEPCLOSED)
1616 if (i == info) break;
1619 if (!i) return; /* unlinked, probably freed too */
1624 Writing to subprocess ...
1625 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1627 chan_out may be waiting for "done" flag, or hung waiting
1628 for i/o completion to child...cancel the i/o. This will
1629 put it into "snarf mode" (done but no EOF yet) that discards
1632 Output from subprocess (stdout, stderr) needs to be flushed and
1633 shut down. We try sending an EOF, but if the mbx is full the pipe
1634 routine should still catch the "shut_on_empty" flag, telling it to
1635 use immediate-style reads so that "mbx empty" -> EOF.
1639 if (info->in && !info->in_done) { /* only for mode=w */
1640 if (info->in->shut_on_empty && info->in->need_wake) {
1641 info->in->need_wake = FALSE;
1642 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1644 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1648 if (info->out && !info->out_done) { /* were we also piping output? */
1649 info->out->shut_on_empty = TRUE;
1650 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1651 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1652 _ckvmssts_noperl(iss);
1655 if (info->err && !info->err_done) { /* we were piping stderr */
1656 info->err->shut_on_empty = TRUE;
1657 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1658 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1659 _ckvmssts_noperl(iss);
1661 _ckvmssts_noperl(sys$setef(pipe_ef));
1665 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1666 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1669 we actually differ from vmstrnenv since we use this to
1670 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1671 are pointing to the same thing
1674 static unsigned short
1675 popen_translate(pTHX_ char *logical, char *result)
1678 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1679 $DESCRIPTOR(d_log,"");
1681 unsigned short length;
1682 unsigned short code;
1684 unsigned short *retlenaddr;
1686 unsigned short l, ifi;
1688 d_log.dsc$a_pointer = logical;
1689 d_log.dsc$w_length = strlen(logical);
1691 itmlst[0].code = LNM$_STRING;
1692 itmlst[0].length = 255;
1693 itmlst[0].buffer_addr = result;
1694 itmlst[0].retlenaddr = &l;
1697 itmlst[1].length = 0;
1698 itmlst[1].buffer_addr = 0;
1699 itmlst[1].retlenaddr = 0;
1701 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1702 if (iss == SS$_NOLOGNAM) {
1706 if (!(iss&1)) lib$signal(iss);
1709 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1710 strip it off and return the ifi, if any
1713 if (result[0] == 0x1b && result[1] == 0x00) {
1714 memcpy(&ifi,result+2,2);
1715 strcpy(result,result+4);
1717 return ifi; /* this is the RMS internal file id */
1720 static void pipe_infromchild_ast(pPipe p);
1723 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1724 inside an AST routine without worrying about reentrancy and which Perl
1725 memory allocator is being used.
1727 We read data and queue up the buffers, then spit them out one at a
1728 time to the output mailbox when the output mailbox is ready for one.
1731 #define INITIAL_TOCHILDQUEUE 2
1734 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1738 char mbx1[64], mbx2[64];
1739 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1740 DSC$K_CLASS_S, mbx1},
1741 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1742 DSC$K_CLASS_S, mbx2};
1743 unsigned int dviitm = DVI$_DEVBUFSIZ;
1746 New(1368, p, 1, Pipe);
1748 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1749 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1750 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1753 p->shut_on_empty = FALSE;
1754 p->need_wake = FALSE;
1757 p->iosb.status = SS$_NORMAL;
1758 p->iosb2.status = SS$_NORMAL;
1764 #ifdef PERL_IMPLICIT_CONTEXT
1768 n = sizeof(CBuf) + p->bufsize;
1770 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1771 _ckvmssts(lib$get_vm(&n, &b));
1772 b->buf = (char *) b + sizeof(CBuf);
1773 _ckvmssts(lib$insqhi(b, &p->free));
1776 pipe_tochild2_ast(p);
1777 pipe_tochild1_ast(p);
1783 /* reads the MBX Perl is writing, and queues */
1786 pipe_tochild1_ast(pPipe p)
1789 int iss = p->iosb.status;
1790 int eof = (iss == SS$_ENDOFFILE);
1791 #ifdef PERL_IMPLICIT_CONTEXT
1797 p->shut_on_empty = TRUE;
1799 _ckvmssts(sys$dassgn(p->chan_in));
1805 b->size = p->iosb.count;
1806 _ckvmssts(lib$insqhi(b, &p->wait));
1808 p->need_wake = FALSE;
1809 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1812 p->retry = 1; /* initial call */
1815 if (eof) { /* flush the free queue, return when done */
1816 int n = sizeof(CBuf) + p->bufsize;
1818 iss = lib$remqti(&p->free, &b);
1819 if (iss == LIB$_QUEWASEMP) return;
1821 _ckvmssts(lib$free_vm(&n, &b));
1825 iss = lib$remqti(&p->free, &b);
1826 if (iss == LIB$_QUEWASEMP) {
1827 int n = sizeof(CBuf) + p->bufsize;
1828 _ckvmssts(lib$get_vm(&n, &b));
1829 b->buf = (char *) b + sizeof(CBuf);
1835 iss = sys$qio(0,p->chan_in,
1836 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1838 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1839 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1844 /* writes queued buffers to output, waits for each to complete before
1848 pipe_tochild2_ast(pPipe p)
1851 int iss = p->iosb2.status;
1852 int n = sizeof(CBuf) + p->bufsize;
1853 int done = (p->info && p->info->done) ||
1854 iss == SS$_CANCEL || iss == SS$_ABORT;
1855 #if defined(PERL_IMPLICIT_CONTEXT)
1860 if (p->type) { /* type=1 has old buffer, dispose */
1861 if (p->shut_on_empty) {
1862 _ckvmssts(lib$free_vm(&n, &b));
1864 _ckvmssts(lib$insqhi(b, &p->free));
1869 iss = lib$remqti(&p->wait, &b);
1870 if (iss == LIB$_QUEWASEMP) {
1871 if (p->shut_on_empty) {
1873 _ckvmssts(sys$dassgn(p->chan_out));
1874 *p->pipe_done = TRUE;
1875 _ckvmssts(sys$setef(pipe_ef));
1877 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1878 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1882 p->need_wake = TRUE;
1892 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1893 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1895 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1896 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1905 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1908 char mbx1[64], mbx2[64];
1909 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1910 DSC$K_CLASS_S, mbx1},
1911 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1912 DSC$K_CLASS_S, mbx2};
1913 unsigned int dviitm = DVI$_DEVBUFSIZ;
1915 New(1367, p, 1, Pipe);
1916 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1917 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1919 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1920 New(1367, p->buf, p->bufsize, char);
1921 p->shut_on_empty = FALSE;
1924 p->iosb.status = SS$_NORMAL;
1925 #if defined(PERL_IMPLICIT_CONTEXT)
1928 pipe_infromchild_ast(p);
1936 pipe_infromchild_ast(pPipe p)
1938 int iss = p->iosb.status;
1939 int eof = (iss == SS$_ENDOFFILE);
1940 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1941 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1942 #if defined(PERL_IMPLICIT_CONTEXT)
1946 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1947 _ckvmssts(sys$dassgn(p->chan_out));
1952 input shutdown if EOF from self (done or shut_on_empty)
1953 output shutdown if closing flag set (my_pclose)
1954 send data/eof from child or eof from self
1955 otherwise, re-read (snarf of data from child)
1960 if (myeof && p->chan_in) { /* input shutdown */
1961 _ckvmssts(sys$dassgn(p->chan_in));
1966 if (myeof || kideof) { /* pass EOF to parent */
1967 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1968 pipe_infromchild_ast, p,
1971 } else if (eof) { /* eat EOF --- fall through to read*/
1973 } else { /* transmit data */
1974 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1975 pipe_infromchild_ast,p,
1976 p->buf, p->iosb.count, 0, 0, 0, 0));
1982 /* everything shut? flag as done */
1984 if (!p->chan_in && !p->chan_out) {
1985 *p->pipe_done = TRUE;
1986 _ckvmssts(sys$setef(pipe_ef));
1990 /* write completed (or read, if snarfing from child)
1991 if still have input active,
1992 queue read...immediate mode if shut_on_empty so we get EOF if empty
1994 check if Perl reading, generate EOFs as needed
2000 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2001 pipe_infromchild_ast,p,
2002 p->buf, p->bufsize, 0, 0, 0, 0);
2003 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2005 } else { /* send EOFs for extra reads */
2006 p->iosb.status = SS$_ENDOFFILE;
2007 p->iosb.dvispec = 0;
2008 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2010 pipe_infromchild_ast, p, 0, 0, 0, 0));
2016 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2020 unsigned long dviitm = DVI$_DEVBUFSIZ;
2022 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2023 DSC$K_CLASS_S, mbx};
2025 /* things like terminals and mbx's don't need this filter */
2026 if (fd && fstat(fd,&s) == 0) {
2027 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2028 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2029 DSC$K_CLASS_S, s.st_dev};
2031 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2032 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2033 strcpy(out, s.st_dev);
2038 New(1366, p, 1, Pipe);
2039 p->fd_out = dup(fd);
2040 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2041 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2042 New(1366, p->buf, p->bufsize+1, char);
2043 p->shut_on_empty = FALSE;
2048 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2049 pipe_mbxtofd_ast, p,
2050 p->buf, p->bufsize, 0, 0, 0, 0));
2056 pipe_mbxtofd_ast(pPipe p)
2058 int iss = p->iosb.status;
2059 int done = p->info->done;
2061 int eof = (iss == SS$_ENDOFFILE);
2062 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2063 int err = !(iss&1) && !eof;
2064 #if defined(PERL_IMPLICIT_CONTEXT)
2068 if (done && myeof) { /* end piping */
2070 sys$dassgn(p->chan_in);
2071 *p->pipe_done = TRUE;
2072 _ckvmssts(sys$setef(pipe_ef));
2076 if (!err && !eof) { /* good data to send to file */
2077 p->buf[p->iosb.count] = '\n';
2078 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2081 if (p->retry < MAX_RETRY) {
2082 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2092 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2093 pipe_mbxtofd_ast, p,
2094 p->buf, p->bufsize, 0, 0, 0, 0);
2095 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2100 typedef struct _pipeloc PLOC;
2101 typedef struct _pipeloc* pPLOC;
2105 char dir[NAM$C_MAXRSS+1];
2107 static pPLOC head_PLOC = 0;
2110 free_pipelocs(pTHX_ void *head)
2113 pPLOC *pHead = (pPLOC *)head;
2125 store_pipelocs(pTHX)
2134 char temp[NAM$C_MAXRSS+1];
2138 free_pipelocs(aTHX_ &head_PLOC);
2140 /* the . directory from @INC comes last */
2143 p->next = head_PLOC;
2145 strcpy(p->dir,"./");
2147 /* get the directory from $^X */
2149 #ifdef PERL_IMPLICIT_CONTEXT
2150 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2152 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2154 strcpy(temp, PL_origargv[0]);
2155 x = strrchr(temp,']');
2158 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2160 p->next = head_PLOC;
2162 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2163 p->dir[NAM$C_MAXRSS] = '\0';
2167 /* reverse order of @INC entries, skip "." since entered above */
2169 #ifdef PERL_IMPLICIT_CONTEXT
2172 if (PL_incgv) av = GvAVn(PL_incgv);
2174 for (i = 0; av && i <= AvFILL(av); i++) {
2175 dirsv = *av_fetch(av,i,TRUE);
2177 if (SvROK(dirsv)) continue;
2178 dir = SvPVx(dirsv,n_a);
2179 if (strcmp(dir,".") == 0) continue;
2180 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2184 p->next = head_PLOC;
2186 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2187 p->dir[NAM$C_MAXRSS] = '\0';
2190 /* most likely spot (ARCHLIB) put first in the list */
2193 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2195 p->next = head_PLOC;
2197 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2198 p->dir[NAM$C_MAXRSS] = '\0';
2207 static int vmspipe_file_status = 0;
2208 static char vmspipe_file[NAM$C_MAXRSS+1];
2210 /* already found? Check and use ... need read+execute permission */
2212 if (vmspipe_file_status == 1) {
2213 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2214 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2215 return vmspipe_file;
2217 vmspipe_file_status = 0;
2220 /* scan through stored @INC, $^X */
2222 if (vmspipe_file_status == 0) {
2223 char file[NAM$C_MAXRSS+1];
2224 pPLOC p = head_PLOC;
2227 strcpy(file, p->dir);
2228 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2229 file[NAM$C_MAXRSS] = '\0';
2232 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2234 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2235 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2236 vmspipe_file_status = 1;
2237 return vmspipe_file;
2240 vmspipe_file_status = -1; /* failed, use tempfiles */
2247 vmspipe_tempfile(pTHX)
2249 char file[NAM$C_MAXRSS+1];
2251 static int index = 0;
2254 /* create a tempfile */
2256 /* we can't go from W, shr=get to R, shr=get without
2257 an intermediate vulnerable state, so don't bother trying...
2259 and lib$spawn doesn't shr=put, so have to close the write
2261 So... match up the creation date/time and the FID to
2262 make sure we're dealing with the same file
2267 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2268 fp = fopen(file,"w");
2270 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2271 fp = fopen(file,"w");
2273 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2274 fp = fopen(file,"w");
2277 if (!fp) return 0; /* we're hosed */
2279 fprintf(fp,"$! 'f$verify(0)'\n");
2280 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2281 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2282 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2283 fprintf(fp,"$ perl_on = \"set noon\"\n");
2284 fprintf(fp,"$ perl_exit = \"exit\"\n");
2285 fprintf(fp,"$ perl_del = \"delete\"\n");
2286 fprintf(fp,"$ pif = \"if\"\n");
2287 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2288 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2289 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2290 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2291 fprintf(fp,"$! --- build command line to get max possible length\n");
2292 fprintf(fp,"$c=perl_popen_cmd0\n");
2293 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2294 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2295 fprintf(fp,"$x=perl_popen_cmd3\n");
2296 fprintf(fp,"$c=c+x\n");
2297 fprintf(fp,"$ perl_on\n");
2298 fprintf(fp,"$ 'c'\n");
2299 fprintf(fp,"$ perl_status = $STATUS\n");
2300 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2301 fprintf(fp,"$ perl_exit 'perl_status'\n");
2304 fgetname(fp, file, 1);
2305 fstat(fileno(fp), &s0);
2308 fp = fopen(file,"r","shr=get");
2310 fstat(fileno(fp), &s1);
2312 if (s0.st_ino[0] != s1.st_ino[0] ||
2313 s0.st_ino[1] != s1.st_ino[1] ||
2314 s0.st_ino[2] != s1.st_ino[2] ||
2315 s0.st_ctime != s1.st_ctime ) {
2326 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2328 static int handler_set_up = FALSE;
2329 unsigned long int sts, flags = CLI$M_NOWAIT;
2330 /* The use of a GLOBAL table (as was done previously) rendered
2331 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2332 * environment. Hence we've switched to LOCAL symbol table.
2334 unsigned int table = LIB$K_CLI_LOCAL_SYM;
2336 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2337 char in[512], out[512], err[512], mbx[512];
2339 char tfilebuf[NAM$C_MAXRSS+1];
2341 char cmd_sym_name[20];
2342 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2343 DSC$K_CLASS_S, symbol};
2344 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2346 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2347 DSC$K_CLASS_S, cmd_sym_name};
2348 struct dsc$descriptor_s *vmscmd;
2349 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2350 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2351 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2353 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2355 /* once-per-program initialization...
2356 note that the SETAST calls and the dual test of pipe_ef
2357 makes sure that only the FIRST thread through here does
2358 the initialization...all other threads wait until it's
2361 Yeah, uglier than a pthread call, it's got all the stuff inline
2362 rather than in a separate routine.
2366 _ckvmssts(sys$setast(0));
2368 unsigned long int pidcode = JPI$_PID;
2369 $DESCRIPTOR(d_delay, RETRY_DELAY);
2370 _ckvmssts(lib$get_ef(&pipe_ef));
2371 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2372 _ckvmssts(sys$bintim(&d_delay, delaytime));
2374 if (!handler_set_up) {
2375 _ckvmssts(sys$dclexh(&pipe_exitblock));
2376 handler_set_up = TRUE;
2378 _ckvmssts(sys$setast(1));
2381 /* see if we can find a VMSPIPE.COM */
2384 vmspipe = find_vmspipe(aTHX);
2386 strcpy(tfilebuf+1,vmspipe);
2387 } else { /* uh, oh...we're in tempfile hell */
2388 tpipe = vmspipe_tempfile(aTHX);
2389 if (!tpipe) { /* a fish popular in Boston */
2390 if (ckWARN(WARN_PIPE)) {
2391 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2395 fgetname(tpipe,tfilebuf+1,1);
2397 vmspipedsc.dsc$a_pointer = tfilebuf;
2398 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2400 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2403 case RMS$_FNF: case RMS$_DNF:
2404 set_errno(ENOENT); break;
2406 set_errno(ENOTDIR); break;
2408 set_errno(ENODEV); break;
2410 set_errno(EACCES); break;
2412 set_errno(EINVAL); break;
2413 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2414 set_errno(E2BIG); break;
2415 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2416 _ckvmssts(sts); /* fall through */
2417 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2420 set_vaxc_errno(sts);
2421 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2422 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2427 New(1301,info,1,Info);
2429 strcpy(mode,in_mode);
2432 info->completion = 0;
2433 info->closing = FALSE;
2440 info->in_done = TRUE;
2441 info->out_done = TRUE;
2442 info->err_done = TRUE;
2443 in[0] = out[0] = err[0] = '\0';
2445 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2449 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2454 if (*mode == 'r') { /* piping from subroutine */
2456 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2458 info->out->pipe_done = &info->out_done;
2459 info->out_done = FALSE;
2460 info->out->info = info;
2462 if (!info->useFILE) {
2463 info->fp = PerlIO_open(mbx, mode);
2465 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2466 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2469 if (!info->fp && info->out) {
2470 sys$cancel(info->out->chan_out);
2472 while (!info->out_done) {
2474 _ckvmssts(sys$setast(0));
2475 done = info->out_done;
2476 if (!done) _ckvmssts(sys$clref(pipe_ef));
2477 _ckvmssts(sys$setast(1));
2478 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2481 if (info->out->buf) Safefree(info->out->buf);
2482 Safefree(info->out);
2488 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2490 info->err->pipe_done = &info->err_done;
2491 info->err_done = FALSE;
2492 info->err->info = info;
2495 } else if (*mode == 'w') { /* piping to subroutine */
2497 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2499 info->out->pipe_done = &info->out_done;
2500 info->out_done = FALSE;
2501 info->out->info = info;
2504 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2506 info->err->pipe_done = &info->err_done;
2507 info->err_done = FALSE;
2508 info->err->info = info;
2511 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2512 if (!info->useFILE) {
2513 info->fp = PerlIO_open(mbx, mode);
2515 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2516 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2520 info->in->pipe_done = &info->in_done;
2521 info->in_done = FALSE;
2522 info->in->info = info;
2526 if (!info->fp && info->in) {
2528 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2529 0, 0, 0, 0, 0, 0, 0, 0));
2531 while (!info->in_done) {
2533 _ckvmssts(sys$setast(0));
2534 done = info->in_done;
2535 if (!done) _ckvmssts(sys$clref(pipe_ef));
2536 _ckvmssts(sys$setast(1));
2537 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2540 if (info->in->buf) Safefree(info->in->buf);
2548 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2549 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2551 info->out->pipe_done = &info->out_done;
2552 info->out_done = FALSE;
2553 info->out->info = info;
2556 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2558 info->err->pipe_done = &info->err_done;
2559 info->err_done = FALSE;
2560 info->err->info = info;
2564 symbol[MAX_DCL_SYMBOL] = '\0';
2566 strncpy(symbol, in, MAX_DCL_SYMBOL);
2567 d_symbol.dsc$w_length = strlen(symbol);
2568 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2570 strncpy(symbol, err, MAX_DCL_SYMBOL);
2571 d_symbol.dsc$w_length = strlen(symbol);
2572 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2574 strncpy(symbol, out, MAX_DCL_SYMBOL);
2575 d_symbol.dsc$w_length = strlen(symbol);
2576 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2578 p = vmscmd->dsc$a_pointer;
2579 while (*p && *p != '\n') p++;
2580 *p = '\0'; /* truncate on \n */
2581 p = vmscmd->dsc$a_pointer;
2582 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2583 if (*p == '$') p++; /* remove leading $ */
2584 while (*p == ' ' || *p == '\t') p++;
2586 for (j = 0; j < 4; j++) {
2587 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2588 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2590 strncpy(symbol, p, MAX_DCL_SYMBOL);
2591 d_symbol.dsc$w_length = strlen(symbol);
2592 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2594 if (strlen(p) > MAX_DCL_SYMBOL) {
2595 p += MAX_DCL_SYMBOL;
2600 _ckvmssts(sys$setast(0));
2601 info->next=open_pipes; /* prepend to list */
2603 _ckvmssts(sys$setast(1));
2604 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2605 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2606 * have SYS$COMMAND if we need it.
2608 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2609 0, &info->pid, &info->completion,
2610 0, popen_completion_ast,info,0,0,0));
2612 /* if we were using a tempfile, close it now */
2614 if (tpipe) fclose(tpipe);
2616 /* once the subprocess is spawned, it has copied the symbols and
2617 we can get rid of ours */
2619 for (j = 0; j < 4; j++) {
2620 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2621 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2622 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2624 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2625 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2626 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2627 vms_execfree(vmscmd);
2629 #ifdef PERL_IMPLICIT_CONTEXT
2632 PL_forkprocess = info->pid;
2637 _ckvmssts(sys$setast(0));
2639 if (!done) _ckvmssts(sys$clref(pipe_ef));
2640 _ckvmssts(sys$setast(1));
2641 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2643 *psts = info->completion;
2644 my_pclose(info->fp);
2649 } /* end of safe_popen */
2652 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2654 Perl_my_popen(pTHX_ char *cmd, char *mode)
2658 TAINT_PROPER("popen");
2659 PERL_FLUSHALL_FOR_CHILD;
2660 return safe_popen(aTHX_ cmd,mode,&sts);
2665 /*{{{ I32 my_pclose(PerlIO *fp)*/
2666 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2668 pInfo info, last = NULL;
2669 unsigned long int retsts;
2672 for (info = open_pipes; info != NULL; last = info, info = info->next)
2673 if (info->fp == fp) break;
2675 if (info == NULL) { /* no such pipe open */
2676 set_errno(ECHILD); /* quoth POSIX */
2677 set_vaxc_errno(SS$_NONEXPR);
2681 /* If we were writing to a subprocess, insure that someone reading from
2682 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2683 * produce an EOF record in the mailbox.
2685 * well, at least sometimes it *does*, so we have to watch out for
2686 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2690 PerlIO_flush(info->fp); /* first, flush data */
2692 fflush((FILE *)info->fp);
2695 _ckvmssts(sys$setast(0));
2696 info->closing = TRUE;
2697 done = info->done && info->in_done && info->out_done && info->err_done;
2698 /* hanging on write to Perl's input? cancel it */
2699 if (info->mode == 'r' && info->out && !info->out_done) {
2700 if (info->out->chan_out) {
2701 _ckvmssts(sys$cancel(info->out->chan_out));
2702 if (!info->out->chan_in) { /* EOF generation, need AST */
2703 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2707 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2708 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2710 _ckvmssts(sys$setast(1));
2713 PerlIO_close(info->fp);
2715 fclose((FILE *)info->fp);
2718 we have to wait until subprocess completes, but ALSO wait until all
2719 the i/o completes...otherwise we'll be freeing the "info" structure
2720 that the i/o ASTs could still be using...
2724 _ckvmssts(sys$setast(0));
2725 done = info->done && info->in_done && info->out_done && info->err_done;
2726 if (!done) _ckvmssts(sys$clref(pipe_ef));
2727 _ckvmssts(sys$setast(1));
2728 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2730 retsts = info->completion;
2732 /* remove from list of open pipes */
2733 _ckvmssts(sys$setast(0));
2734 if (last) last->next = info->next;
2735 else open_pipes = info->next;
2736 _ckvmssts(sys$setast(1));
2738 /* free buffers and structures */
2741 if (info->in->buf) Safefree(info->in->buf);
2745 if (info->out->buf) Safefree(info->out->buf);
2746 Safefree(info->out);
2749 if (info->err->buf) Safefree(info->err->buf);
2750 Safefree(info->err);
2756 } /* end of my_pclose() */
2758 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2759 /* Roll our own prototype because we want this regardless of whether
2760 * _VMS_WAIT is defined.
2762 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2764 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2765 created with popen(); otherwise partially emulate waitpid() unless
2766 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2767 Also check processes not considered by the CRTL waitpid().
2769 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2771 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2778 if (statusp) *statusp = 0;
2780 for (info = open_pipes; info != NULL; info = info->next)
2781 if (info->pid == pid) break;
2783 if (info != NULL) { /* we know about this child */
2784 while (!info->done) {
2785 _ckvmssts(sys$setast(0));
2787 if (!done) _ckvmssts(sys$clref(pipe_ef));
2788 _ckvmssts(sys$setast(1));
2789 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2792 if (statusp) *statusp = info->completion;
2796 /* child that already terminated? */
2798 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2799 if (closed_list[j].pid == pid) {
2800 if (statusp) *statusp = closed_list[j].completion;
2805 /* fall through if this child is not one of our own pipe children */
2807 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2809 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2810 * in 7.2 did we get a version that fills in the VMS completion
2811 * status as Perl has always tried to do.
2814 sts = __vms_waitpid( pid, statusp, flags );
2816 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2819 /* If the real waitpid tells us the child does not exist, we
2820 * fall through here to implement waiting for a child that
2821 * was created by some means other than exec() (say, spawned
2822 * from DCL) or to wait for a process that is not a subprocess
2823 * of the current process.
2826 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
2829 $DESCRIPTOR(intdsc,"0 00:00:01");
2830 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2831 unsigned long int pidcode = JPI$_PID, mypid;
2832 unsigned long int interval[2];
2833 unsigned int jpi_iosb[2];
2834 struct itmlst_3 jpilist[2] = {
2835 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2840 /* Sorry folks, we don't presently implement rooting around for
2841 the first child we can find, and we definitely don't want to
2842 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2848 /* Get the owner of the child so I can warn if it's not mine. If the
2849 * process doesn't exist or I don't have the privs to look at it,
2850 * I can go home early.
2852 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2853 if (sts & 1) sts = jpi_iosb[0];
2865 set_vaxc_errno(sts);
2869 if (ckWARN(WARN_EXEC)) {
2870 /* remind folks they are asking for non-standard waitpid behavior */
2871 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2872 if (ownerpid != mypid)
2873 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2874 "waitpid: process %x is not a child of process %x",
2878 /* simply check on it once a second until it's not there anymore. */
2880 _ckvmssts(sys$bintim(&intdsc,interval));
2881 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2882 _ckvmssts(sys$schdwk(0,0,interval,0));
2883 _ckvmssts(sys$hiber());
2885 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2890 } /* end of waitpid() */
2895 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2897 my_gconvert(double val, int ndig, int trail, char *buf)
2899 static char __gcvtbuf[DBL_DIG+1];
2902 loc = buf ? buf : __gcvtbuf;
2904 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2906 sprintf(loc,"%.*g",ndig,val);
2912 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2913 return gcvt(val,ndig,loc);
2916 loc[0] = '0'; loc[1] = '\0';
2924 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2925 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2926 * to expand file specification. Allows for a single default file
2927 * specification and a simple mask of options. If outbuf is non-NULL,
2928 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2929 * the resultant file specification is placed. If outbuf is NULL, the
2930 * resultant file specification is placed into a static buffer.
2931 * The third argument, if non-NULL, is taken to be a default file
2932 * specification string. The fourth argument is unused at present.
2933 * rmesexpand() returns the address of the resultant string if
2934 * successful, and NULL on error.
2936 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2939 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2941 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2942 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2943 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2944 struct FAB myfab = cc$rms_fab;
2945 struct NAM mynam = cc$rms_nam;
2947 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2949 if (!filespec || !*filespec) {
2950 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2954 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2955 else outbuf = __rmsexpand_retbuf;
2957 if ((isunix = (strchr(filespec,'/') != NULL))) {
2958 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2959 filespec = vmsfspec;
2962 myfab.fab$l_fna = filespec;
2963 myfab.fab$b_fns = strlen(filespec);
2964 myfab.fab$l_nam = &mynam;
2966 if (defspec && *defspec) {
2967 if (strchr(defspec,'/') != NULL) {
2968 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2971 myfab.fab$l_dna = defspec;
2972 myfab.fab$b_dns = strlen(defspec);
2975 mynam.nam$l_esa = esa;
2976 mynam.nam$b_ess = sizeof esa;
2977 mynam.nam$l_rsa = outbuf;
2978 mynam.nam$b_rss = NAM$C_MAXRSS;
2980 retsts = sys$parse(&myfab,0,0);
2981 if (!(retsts & 1)) {
2982 mynam.nam$b_nop |= NAM$M_SYNCHK;
2983 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2984 retsts = sys$parse(&myfab,0,0);
2985 if (retsts & 1) goto expanded;
2987 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2988 (void) sys$parse(&myfab,0,0); /* Free search context */
2989 if (out) Safefree(out);
2990 set_vaxc_errno(retsts);
2991 if (retsts == RMS$_PRV) set_errno(EACCES);
2992 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2993 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2994 else set_errno(EVMSERR);
2997 retsts = sys$search(&myfab,0,0);
2998 if (!(retsts & 1) && retsts != RMS$_FNF) {
2999 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3000 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
3001 if (out) Safefree(out);
3002 set_vaxc_errno(retsts);
3003 if (retsts == RMS$_PRV) set_errno(EACCES);
3004 else set_errno(EVMSERR);
3008 /* If the input filespec contained any lowercase characters,
3009 * downcase the result for compatibility with Unix-minded code. */
3011 for (out = myfab.fab$l_fna; *out; out++)
3012 if (islower(*out)) { haslower = 1; break; }
3013 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3014 else { out = esa; speclen = mynam.nam$b_esl; }
3015 /* Trim off null fields added by $PARSE
3016 * If type > 1 char, must have been specified in original or default spec
3017 * (not true for version; $SEARCH may have added version of existing file).
3019 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3020 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3021 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3022 if (trimver || trimtype) {
3023 if (defspec && *defspec) {
3024 char defesa[NAM$C_MAXRSS];
3025 struct FAB deffab = cc$rms_fab;
3026 struct NAM defnam = cc$rms_nam;
3028 deffab.fab$l_nam = &defnam;
3029 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3030 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3031 defnam.nam$b_nop = NAM$M_SYNCHK;
3032 if (sys$parse(&deffab,0,0) & 1) {
3033 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3034 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3037 if (trimver) speclen = mynam.nam$l_ver - out;
3039 /* If we didn't already trim version, copy down */
3040 if (speclen > mynam.nam$l_ver - out)
3041 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3042 speclen - (mynam.nam$l_ver - out));
3043 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3046 /* If we just had a directory spec on input, $PARSE "helpfully"
3047 * adds an empty name and type for us */
3048 if (mynam.nam$l_name == mynam.nam$l_type &&
3049 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3050 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3051 speclen = mynam.nam$l_name - out;
3052 out[speclen] = '\0';
3053 if (haslower) __mystrtolower(out);
3055 /* Have we been working with an expanded, but not resultant, spec? */
3056 /* Also, convert back to Unix syntax if necessary. */
3057 if (!mynam.nam$b_rsl) {
3059 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3061 else strcpy(outbuf,esa);
3064 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3065 strcpy(outbuf,tmpfspec);
3067 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3068 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
3069 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
3073 /* External entry points */
3074 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3075 { return do_rmsexpand(spec,buf,0,def,opt); }
3076 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
3077 { return do_rmsexpand(spec,buf,1,def,opt); }
3081 ** The following routines are provided to make life easier when
3082 ** converting among VMS-style and Unix-style directory specifications.
3083 ** All will take input specifications in either VMS or Unix syntax. On
3084 ** failure, all return NULL. If successful, the routines listed below
3085 ** return a pointer to a buffer containing the appropriately
3086 ** reformatted spec (and, therefore, subsequent calls to that routine
3087 ** will clobber the result), while the routines of the same names with
3088 ** a _ts suffix appended will return a pointer to a mallocd string
3089 ** containing the appropriately reformatted spec.
3090 ** In all cases, only explicit syntax is altered; no check is made that
3091 ** the resulting string is valid or that the directory in question
3094 ** fileify_dirspec() - convert a directory spec into the name of the
3095 ** directory file (i.e. what you can stat() to see if it's a dir).
3096 ** The style (VMS or Unix) of the result is the same as the style
3097 ** of the parameter passed in.
3098 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3099 ** what you prepend to a filename to indicate what directory it's in).
3100 ** The style (VMS or Unix) of the result is the same as the style
3101 ** of the parameter passed in.
3102 ** tounixpath() - convert a directory spec into a Unix-style path.
3103 ** tovmspath() - convert a directory spec into a VMS-style path.
3104 ** tounixspec() - convert any file spec into a Unix-style file spec.
3105 ** tovmsspec() - convert any file spec into a VMS-style spec.
3107 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3108 ** Permission is given to distribute this code as part of the Perl
3109 ** standard distribution under the terms of the GNU General Public
3110 ** License or the Perl Artistic License. Copies of each may be
3111 ** found in the Perl standard distribution.
3114 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3115 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3117 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3118 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3119 char *retspec, *cp1, *cp2, *lastdir;
3120 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3121 unsigned short int trnlnm_iter_count;
3123 if (!dir || !*dir) {
3124 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3126 dirlen = strlen(dir);
3127 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3128 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3129 strcpy(trndir,"/sys$disk/000000");
3133 if (dirlen > NAM$C_MAXRSS) {
3134 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3136 if (!strpbrk(dir+1,"/]>:")) {
3137 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3138 trnlnm_iter_count = 0;
3139 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3140 trnlnm_iter_count++;
3141 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3144 dirlen = strlen(dir);
3147 strncpy(trndir,dir,dirlen);
3148 trndir[dirlen] = '\0';
3151 /* If we were handed a rooted logical name or spec, treat it like a
3152 * simple directory, so that
3153 * $ Define myroot dev:[dir.]
3154 * ... do_fileify_dirspec("myroot",buf,1) ...
3155 * does something useful.
3157 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3158 dir[--dirlen] = '\0';
3159 dir[dirlen-1] = ']';
3161 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3162 dir[--dirlen] = '\0';
3163 dir[dirlen-1] = '>';
3166 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3167 /* If we've got an explicit filename, we can just shuffle the string. */
3168 if (*(cp1+1)) hasfilename = 1;
3169 /* Similarly, we can just back up a level if we've got multiple levels
3170 of explicit directories in a VMS spec which ends with directories. */
3172 for (cp2 = cp1; cp2 > dir; cp2--) {
3174 *cp2 = *cp1; *cp1 = '\0';
3178 if (*cp2 == '[' || *cp2 == '<') break;
3183 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3184 if (dir[0] == '.') {
3185 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3186 return do_fileify_dirspec("[]",buf,ts);
3187 else if (dir[1] == '.' &&
3188 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3189 return do_fileify_dirspec("[-]",buf,ts);
3191 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3192 dirlen -= 1; /* to last element */
3193 lastdir = strrchr(dir,'/');
3195 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3196 /* If we have "/." or "/..", VMSify it and let the VMS code
3197 * below expand it, rather than repeating the code to handle
3198 * relative components of a filespec here */
3200 if (*(cp1+2) == '.') cp1++;
3201 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3202 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3203 if (strchr(vmsdir,'/') != NULL) {
3204 /* If do_tovmsspec() returned it, it must have VMS syntax
3205 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3206 * the time to check this here only so we avoid a recursion
3207 * loop; otherwise, gigo.
3209 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3211 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3212 return do_tounixspec(trndir,buf,ts);
3215 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3216 lastdir = strrchr(dir,'/');
3218 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3219 /* Ditto for specs that end in an MFD -- let the VMS code
3220 * figure out whether it's a real device or a rooted logical. */
3221 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3222 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3223 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3224 return do_tounixspec(trndir,buf,ts);
3227 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3228 !(lastdir = cp1 = strrchr(dir,']')) &&
3229 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3230 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3232 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3233 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3234 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3235 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3236 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3237 (ver || *cp3)))))) {
3239 set_vaxc_errno(RMS$_DIR);
3245 /* If we lead off with a device or rooted logical, add the MFD
3246 if we're specifying a top-level directory. */
3247 if (lastdir && *dir == '/') {
3249 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3256 retlen = dirlen + (addmfd ? 13 : 6);
3257 if (buf) retspec = buf;
3258 else if (ts) New(1309,retspec,retlen+1,char);
3259 else retspec = __fileify_retbuf;
3261 dirlen = lastdir - dir;
3262 memcpy(retspec,dir,dirlen);
3263 strcpy(&retspec[dirlen],"/000000");
3264 strcpy(&retspec[dirlen+7],lastdir);
3267 memcpy(retspec,dir,dirlen);
3268 retspec[dirlen] = '\0';
3270 /* We've picked up everything up to the directory file name.
3271 Now just add the type and version, and we're set. */
3272 strcat(retspec,".dir;1");
3275 else { /* VMS-style directory spec */
3276 char esa[NAM$C_MAXRSS+1], term, *cp;
3277 unsigned long int sts, cmplen, haslower = 0;
3278 struct FAB dirfab = cc$rms_fab;
3279 struct NAM savnam, dirnam = cc$rms_nam;
3281 dirfab.fab$b_fns = strlen(dir);
3282 dirfab.fab$l_fna = dir;
3283 dirfab.fab$l_nam = &dirnam;
3284 dirfab.fab$l_dna = ".DIR;1";
3285 dirfab.fab$b_dns = 6;
3286 dirnam.nam$b_ess = NAM$C_MAXRSS;
3287 dirnam.nam$l_esa = esa;
3289 for (cp = dir; *cp; cp++)
3290 if (islower(*cp)) { haslower = 1; break; }
3291 if (!((sts = sys$parse(&dirfab))&1)) {
3292 if (dirfab.fab$l_sts == RMS$_DIR) {
3293 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3294 sts = sys$parse(&dirfab) & 1;
3298 set_vaxc_errno(dirfab.fab$l_sts);
3304 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3305 /* Yes; fake the fnb bits so we'll check type below */
3306 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3308 else { /* No; just work with potential name */
3309 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3311 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3312 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3313 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3318 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3319 cp1 = strchr(esa,']');
3320 if (!cp1) cp1 = strchr(esa,'>');
3321 if (cp1) { /* Should always be true */
3322 dirnam.nam$b_esl -= cp1 - esa - 1;
3323 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3326 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3327 /* Yep; check version while we're at it, if it's there. */
3328 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3329 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3330 /* Something other than .DIR[;1]. Bzzt. */
3331 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3332 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3334 set_vaxc_errno(RMS$_DIR);
3338 esa[dirnam.nam$b_esl] = '\0';
3339 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3340 /* They provided at least the name; we added the type, if necessary, */
3341 if (buf) retspec = buf; /* in sys$parse() */
3342 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3343 else retspec = __fileify_retbuf;
3344 strcpy(retspec,esa);
3345 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3346 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3349 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3350 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3352 dirnam.nam$b_esl -= 9;
3354 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3355 if (cp1 == NULL) { /* should never happen */
3356 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3357 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3362 retlen = strlen(esa);
3363 if ((cp1 = strrchr(esa,'.')) != NULL) {
3364 /* There's more than one directory in the path. Just roll back. */
3366 if (buf) retspec = buf;
3367 else if (ts) New(1311,retspec,retlen+7,char);
3368 else retspec = __fileify_retbuf;
3369 strcpy(retspec,esa);
3372 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3373 /* Go back and expand rooted logical name */
3374 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3375 if (!(sys$parse(&dirfab) & 1)) {
3376 dirnam.nam$l_rlf = NULL;
3377 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3379 set_vaxc_errno(dirfab.fab$l_sts);
3382 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3383 if (buf) retspec = buf;
3384 else if (ts) New(1312,retspec,retlen+16,char);
3385 else retspec = __fileify_retbuf;
3386 cp1 = strstr(esa,"][");
3387 if (!cp1) cp1 = strstr(esa,"]<");
3389 memcpy(retspec,esa,dirlen);
3390 if (!strncmp(cp1+2,"000000]",7)) {
3391 retspec[dirlen-1] = '\0';
3392 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3393 if (*cp1 == '.') *cp1 = ']';
3395 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3396 memcpy(cp1+1,"000000]",7);
3400 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3401 retspec[retlen] = '\0';
3402 /* Convert last '.' to ']' */
3403 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3404 if (*cp1 == '.') *cp1 = ']';
3406 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3407 memcpy(cp1+1,"000000]",7);
3411 else { /* This is a top-level dir. Add the MFD to the path. */
3412 if (buf) retspec = buf;
3413 else if (ts) New(1312,retspec,retlen+16,char);
3414 else retspec = __fileify_retbuf;
3417 while (*cp1 != ':') *(cp2++) = *(cp1++);
3418 strcpy(cp2,":[000000]");
3423 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3424 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3425 /* We've set up the string up through the filename. Add the
3426 type and version, and we're done. */
3427 strcat(retspec,".DIR;1");
3429 /* $PARSE may have upcased filespec, so convert output to lower
3430 * case if input contained any lowercase characters. */
3431 if (haslower) __mystrtolower(retspec);
3434 } /* end of do_fileify_dirspec() */
3436 /* External entry points */
3437 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3438 { return do_fileify_dirspec(dir,buf,0); }
3439 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3440 { return do_fileify_dirspec(dir,buf,1); }
3442 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3443 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3445 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3446 unsigned long int retlen;
3447 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3448 unsigned short int trnlnm_iter_count;
3451 if (!dir || !*dir) {
3452 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3455 if (*dir) strcpy(trndir,dir);
3456 else getcwd(trndir,sizeof trndir - 1);
3458 trnlnm_iter_count = 0;
3459 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3460 && my_trnlnm(trndir,trndir,0)) {
3461 trnlnm_iter_count++;
3462 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3463 trnlen = strlen(trndir);
3465 /* Trap simple rooted lnms, and return lnm:[000000] */
3466 if (!strcmp(trndir+trnlen-2,".]")) {
3467 if (buf) retpath = buf;
3468 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3469 else retpath = __pathify_retbuf;
3470 strcpy(retpath,dir);
3471 strcat(retpath,":[000000]");
3477 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3478 if (*dir == '.' && (*(dir+1) == '\0' ||
3479 (*(dir+1) == '.' && *(dir+2) == '\0')))
3480 retlen = 2 + (*(dir+1) != '\0');
3482 if ( !(cp1 = strrchr(dir,'/')) &&
3483 !(cp1 = strrchr(dir,']')) &&
3484 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3485 if ((cp2 = strchr(cp1,'.')) != NULL &&
3486 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3487 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3488 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3489 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3491 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3492 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3493 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3494 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3495 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3496 (ver || *cp3)))))) {
3498 set_vaxc_errno(RMS$_DIR);
3501 retlen = cp2 - dir + 1;
3503 else { /* No file type present. Treat the filename as a directory. */
3504 retlen = strlen(dir) + 1;
3507 if (buf) retpath = buf;
3508 else if (ts) New(1313,retpath,retlen+1,char);
3509 else retpath = __pathify_retbuf;
3510 strncpy(retpath,dir,retlen-1);
3511 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3512 retpath[retlen-1] = '/'; /* with '/', add it. */
3513 retpath[retlen] = '\0';
3515 else retpath[retlen-1] = '\0';
3517 else { /* VMS-style directory spec */
3518 char esa[NAM$C_MAXRSS+1], *cp;
3519 unsigned long int sts, cmplen, haslower;
3520 struct FAB dirfab = cc$rms_fab;
3521 struct NAM savnam, dirnam = cc$rms_nam;
3523 /* If we've got an explicit filename, we can just shuffle the string. */
3524 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3525 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3526 if ((cp2 = strchr(cp1,'.')) != NULL) {
3528 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3529 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3530 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3531 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3532 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3533 (ver || *cp3)))))) {
3535 set_vaxc_errno(RMS$_DIR);
3539 else { /* No file type, so just draw name into directory part */
3540 for (cp2 = cp1; *cp2; cp2++) ;
3543 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3545 /* We've now got a VMS 'path'; fall through */
3547 dirfab.fab$b_fns = strlen(dir);
3548 dirfab.fab$l_fna = dir;
3549 if (dir[dirfab.fab$b_fns-1] == ']' ||
3550 dir[dirfab.fab$b_fns-1] == '>' ||
3551 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3552 if (buf) retpath = buf;
3553 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3554 else retpath = __pathify_retbuf;
3555 strcpy(retpath,dir);
3558 dirfab.fab$l_dna = ".DIR;1";
3559 dirfab.fab$b_dns = 6;
3560 dirfab.fab$l_nam = &dirnam;
3561 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3562 dirnam.nam$l_esa = esa;
3564 for (cp = dir; *cp; cp++)
3565 if (islower(*cp)) { haslower = 1; break; }
3567 if (!(sts = (sys$parse(&dirfab)&1))) {
3568 if (dirfab.fab$l_sts == RMS$_DIR) {
3569 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3570 sts = sys$parse(&dirfab) & 1;
3574 set_vaxc_errno(dirfab.fab$l_sts);
3580 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3581 if (dirfab.fab$l_sts != RMS$_FNF) {
3582 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3583 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3585 set_vaxc_errno(dirfab.fab$l_sts);
3588 dirnam = savnam; /* No; just work with potential name */
3591 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3592 /* Yep; check version while we're at it, if it's there. */
3593 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3594 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3595 /* Something other than .DIR[;1]. Bzzt. */
3596 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3597 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3599 set_vaxc_errno(RMS$_DIR);
3603 /* OK, the type was fine. Now pull any file name into the
3605 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3607 cp1 = strrchr(esa,'>');
3608 *dirnam.nam$l_type = '>';
3611 *(dirnam.nam$l_type + 1) = '\0';
3612 retlen = dirnam.nam$l_type - esa + 2;
3613 if (buf) retpath = buf;
3614 else if (ts) New(1314,retpath,retlen,char);
3615 else retpath = __pathify_retbuf;
3616 strcpy(retpath,esa);
3617 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3618 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3619 /* $PARSE may have upcased filespec, so convert output to lower
3620 * case if input contained any lowercase characters. */
3621 if (haslower) __mystrtolower(retpath);
3625 } /* end of do_pathify_dirspec() */
3627 /* External entry points */
3628 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3629 { return do_pathify_dirspec(dir,buf,0); }
3630 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3631 { return do_pathify_dirspec(dir,buf,1); }
3633 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3634 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3636 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3637 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3638 int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
3639 int expand = 1; /* guarantee room for leading and trailing slashes */
3640 unsigned short int trnlnm_iter_count;
3642 if (spec == NULL) return NULL;
3643 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3644 if (buf) rslt = buf;
3646 retlen = strlen(spec);
3647 cp1 = strchr(spec,'[');
3648 if (!cp1) cp1 = strchr(spec,'<');
3650 for (cp1++; *cp1; cp1++) {
3651 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3652 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3653 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3656 New(1315,rslt,retlen+2+2*expand,char);
3658 else rslt = __tounixspec_retbuf;
3659 if (strchr(spec,'/') != NULL) {
3666 dirend = strrchr(spec,']');
3667 if (dirend == NULL) dirend = strrchr(spec,'>');
3668 if (dirend == NULL) dirend = strchr(spec,':');
3669 if (dirend == NULL) {
3673 if (*cp2 != '[' && *cp2 != '<') {
3676 else { /* the VMS spec begins with directories */
3678 if (*cp2 == ']' || *cp2 == '>') {
3679 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3682 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3683 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3684 if (ts) Safefree(rslt);
3687 trnlnm_iter_count = 0;
3690 while (*cp3 != ':' && *cp3) cp3++;
3692 if (strchr(cp3,']') != NULL) break;
3693 trnlnm_iter_count++;
3694 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3695 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3697 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3698 retlen = devlen + dirlen;
3699 Renew(rslt,retlen+1+2*expand,char);
3705 *(cp1++) = *(cp3++);
3706 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3710 else if ( *cp2 == '.') {
3711 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3712 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3718 for (; cp2 <= dirend; cp2++) {
3721 if (*(cp2+1) == '[') cp2++;
3723 else if (*cp2 == ']' || *cp2 == '>') {
3724 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3726 else if (*cp2 == '.') {
3728 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3729 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3730 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3731 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3732 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3734 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3735 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3739 else if (*cp2 == '-') {
3740 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3741 while (*cp2 == '-') {
3743 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3745 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3746 if (ts) Safefree(rslt); /* filespecs like */
3747 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3751 else *(cp1++) = *cp2;
3753 else *(cp1++) = *cp2;
3755 while (*cp2) *(cp1++) = *(cp2++);
3760 } /* end of do_tounixspec() */
3762 /* External entry points */
3763 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3764 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3766 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3767 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3768 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3769 char *rslt, *dirend;
3770 register char *cp1, *cp2;
3771 unsigned long int infront = 0, hasdir = 1;
3773 if (path == NULL) return NULL;
3774 if (buf) rslt = buf;
3775 else if (ts) New(1316,rslt,strlen(path)+9,char);
3776 else rslt = __tovmsspec_retbuf;
3777 if (strpbrk(path,"]:>") ||
3778 (dirend = strrchr(path,'/')) == NULL) {
3779 if (path[0] == '.') {
3780 if (path[1] == '\0') strcpy(rslt,"[]");
3781 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3782 else strcpy(rslt,path); /* probably garbage */
3784 else strcpy(rslt,path);
3787 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3788 if (!*(dirend+2)) dirend +=2;
3789 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3790 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3795 char trndev[NAM$C_MAXRSS+1];
3799 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3801 if (!buf & ts) Renew(rslt,18,char);
3802 strcpy(rslt,"sys$disk:[000000]");
3805 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3807 islnm = my_trnlnm(rslt,trndev,0);
3808 trnend = islnm ? strlen(trndev) - 1 : 0;
3809 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3810 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3811 /* If the first element of the path is a logical name, determine
3812 * whether it has to be translated so we can add more directories. */
3813 if (!islnm || rooted) {
3816 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3820 if (cp2 != dirend) {
3821 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3822 strcpy(rslt,trndev);
3823 cp1 = rslt + trnend;
3836 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3837 cp2 += 2; /* skip over "./" - it's redundant */
3838 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3840 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3841 *(cp1++) = '-'; /* "../" --> "-" */
3844 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3845 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3846 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3847 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3850 if (cp2 > dirend) cp2 = dirend;
3852 else *(cp1++) = '.';
3854 for (; cp2 < dirend; cp2++) {
3856 if (*(cp2-1) == '/') continue;
3857 if (*(cp1-1) != '.') *(cp1++) = '.';
3860 else if (!infront && *cp2 == '.') {
3861 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3862 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3863 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3864 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3865 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3866 else { /* back up over previous directory name */
3868 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3869 if (*(cp1-1) == '[') {
3870 memcpy(cp1,"000000.",7);
3875 if (cp2 == dirend) break;
3877 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3878 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3879 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3880 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3882 *(cp1++) = '.'; /* Simulate trailing '/' */
3883 cp2 += 2; /* for loop will incr this to == dirend */
3885 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3887 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3890 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3891 if (*cp2 == '.') *(cp1++) = '_';
3892 else *(cp1++) = *cp2;
3896 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3897 if (hasdir) *(cp1++) = ']';
3898 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3899 while (*cp2) *(cp1++) = *(cp2++);
3904 } /* end of do_tovmsspec() */
3906 /* External entry points */
3907 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3908 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3910 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3911 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3912 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3914 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3916 if (path == NULL) return NULL;
3917 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3918 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3919 if (buf) return buf;
3921 vmslen = strlen(vmsified);
3922 New(1317,cp,vmslen+1,char);
3923 memcpy(cp,vmsified,vmslen);
3928 strcpy(__tovmspath_retbuf,vmsified);
3929 return __tovmspath_retbuf;
3932 } /* end of do_tovmspath() */
3934 /* External entry points */
3935 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3936 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3939 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3940 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3941 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3943 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3945 if (path == NULL) return NULL;
3946 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3947 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3948 if (buf) return buf;
3950 unixlen = strlen(unixified);
3951 New(1317,cp,unixlen+1,char);
3952 memcpy(cp,unixified,unixlen);
3957 strcpy(__tounixpath_retbuf,unixified);
3958 return __tounixpath_retbuf;
3961 } /* end of do_tounixpath() */
3963 /* External entry points */
3964 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3965 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3968 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3970 *****************************************************************************
3972 * Copyright (C) 1989-1994 by *
3973 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3975 * Permission is hereby granted for the reproduction of this software, *
3976 * on condition that this copyright notice is included in the reproduction, *
3977 * and that such reproduction is not for purposes of profit or material *
3980 * 27-Aug-1994 Modified for inclusion in perl5 *
3981 * by Charles Bailey bailey@newman.upenn.edu *
3982 *****************************************************************************
3986 * getredirection() is intended to aid in porting C programs
3987 * to VMS (Vax-11 C). The native VMS environment does not support
3988 * '>' and '<' I/O redirection, or command line wild card expansion,
3989 * or a command line pipe mechanism using the '|' AND background
3990 * command execution '&'. All of these capabilities are provided to any
3991 * C program which calls this procedure as the first thing in the
3993 * The piping mechanism will probably work with almost any 'filter' type
3994 * of program. With suitable modification, it may useful for other
3995 * portability problems as well.
3997 * Author: Mark Pizzolato mark@infocomm.com
4001 struct list_item *next;
4005 static void add_item(struct list_item **head,
4006 struct list_item **tail,
4010 static void mp_expand_wild_cards(pTHX_ char *item,
4011 struct list_item **head,
4012 struct list_item **tail,
4015 static int background_process(pTHX_ int argc, char **argv);
4017 static void pipe_and_fork(pTHX_ char **cmargv);
4019 /*{{{ void getredirection(int *ac, char ***av)*/
4021 mp_getredirection(pTHX_ int *ac, char ***av)
4023 * Process vms redirection arg's. Exit if any error is seen.
4024 * If getredirection() processes an argument, it is erased
4025 * from the vector. getredirection() returns a new argc and argv value.
4026 * In the event that a background command is requested (by a trailing "&"),
4027 * this routine creates a background subprocess, and simply exits the program.
4029 * Warning: do not try to simplify the code for vms. The code
4030 * presupposes that getredirection() is called before any data is
4031 * read from stdin or written to stdout.
4033 * Normal usage is as follows:
4039 * getredirection(&argc, &argv);
4043 int argc = *ac; /* Argument Count */
4044 char **argv = *av; /* Argument Vector */
4045 char *ap; /* Argument pointer */
4046 int j; /* argv[] index */
4047 int item_count = 0; /* Count of Items in List */
4048 struct list_item *list_head = 0; /* First Item in List */
4049 struct list_item *list_tail; /* Last Item in List */
4050 char *in = NULL; /* Input File Name */
4051 char *out = NULL; /* Output File Name */
4052 char *outmode = "w"; /* Mode to Open Output File */
4053 char *err = NULL; /* Error File Name */
4054 char *errmode = "w"; /* Mode to Open Error File */
4055 int cmargc = 0; /* Piped Command Arg Count */
4056 char **cmargv = NULL;/* Piped Command Arg Vector */
4059 * First handle the case where the last thing on the line ends with
4060 * a '&'. This indicates the desire for the command to be run in a
4061 * subprocess, so we satisfy that desire.
4064 if (0 == strcmp("&", ap))
4065 exit(background_process(aTHX_ --argc, argv));
4066 if (*ap && '&' == ap[strlen(ap)-1])
4068 ap[strlen(ap)-1] = '\0';
4069 exit(background_process(aTHX_ argc, argv));
4072 * Now we handle the general redirection cases that involve '>', '>>',
4073 * '<', and pipes '|'.
4075 for (j = 0; j < argc; ++j)
4077 if (0 == strcmp("<", argv[j]))
4081 fprintf(stderr,"No input file after < on command line");
4082 exit(LIB$_WRONUMARG);
4087 if ('<' == *(ap = argv[j]))
4092 if (0 == strcmp(">", ap))
4096 fprintf(stderr,"No output file after > on command line");
4097 exit(LIB$_WRONUMARG);
4116 fprintf(stderr,"No output file after > or >> on command line");
4117 exit(LIB$_WRONUMARG);
4121 if (('2' == *ap) && ('>' == ap[1]))
4138 fprintf(stderr,"No output file after 2> or 2>> on command line");
4139 exit(LIB$_WRONUMARG);
4143 if (0 == strcmp("|", argv[j]))
4147 fprintf(stderr,"No command into which to pipe on command line");
4148 exit(LIB$_WRONUMARG);
4150 cmargc = argc-(j+1);
4151 cmargv = &argv[j+1];
4155 if ('|' == *(ap = argv[j]))
4163 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4166 * Allocate and fill in the new argument vector, Some Unix's terminate
4167 * the list with an extra null pointer.
4169 New(1302, argv, item_count+1, char *);
4171 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4172 argv[j] = list_head->value;
4178 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4179 exit(LIB$_INVARGORD);
4181 pipe_and_fork(aTHX_ cmargv);
4184 /* Check for input from a pipe (mailbox) */
4186 if (in == NULL && 1 == isapipe(0))
4188 char mbxname[L_tmpnam];
4190 long int dvi_item = DVI$_DEVBUFSIZ;
4191 $DESCRIPTOR(mbxnam, "");
4192 $DESCRIPTOR(mbxdevnam, "");
4194 /* Input from a pipe, reopen it in binary mode to disable */
4195 /* carriage control processing. */
4197 fgetname(stdin, mbxname);
4198 mbxnam.dsc$a_pointer = mbxname;
4199 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4200 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4201 mbxdevnam.dsc$a_pointer = mbxname;
4202 mbxdevnam.dsc$w_length = sizeof(mbxname);
4203 dvi_item = DVI$_DEVNAM;
4204 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4205 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4208 freopen(mbxname, "rb", stdin);
4211 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4215 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4217 fprintf(stderr,"Can't open input file %s as stdin",in);
4220 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4222 fprintf(stderr,"Can't open output file %s as stdout",out);
4225 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4228 if (strcmp(err,"&1") == 0) {
4229 dup2(fileno(stdout), fileno(stderr));
4230 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4233 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4235 fprintf(stderr,"Can't open error file %s as stderr",err);
4239 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4243 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4246 #ifdef ARGPROC_DEBUG
4247 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4248 for (j = 0; j < *ac; ++j)
4249 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4251 /* Clear errors we may have hit expanding wildcards, so they don't
4252 show up in Perl's $! later */
4253 set_errno(0); set_vaxc_errno(1);
4254 } /* end of getredirection() */
4257 static void add_item(struct list_item **head,
4258 struct list_item **tail,
4264 New(1303,*head,1,struct list_item);
4268 New(1304,(*tail)->next,1,struct list_item);
4269 *tail = (*tail)->next;
4271 (*tail)->value = value;
4275 static void mp_expand_wild_cards(pTHX_ char *item,
4276 struct list_item **head,
4277 struct list_item **tail,
4281 unsigned long int context = 0;
4288 char vmsspec[NAM$C_MAXRSS+1];
4289 $DESCRIPTOR(filespec, "");
4290 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4291 $DESCRIPTOR(resultspec, "");
4292 unsigned long int zero = 0, sts;
4294 for (cp = item; *cp; cp++) {
4295 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4296 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4298 if (!*cp || isspace(*cp))
4300 add_item(head, tail, item, count);
4305 /* "double quoted" wild card expressions pass as is */
4306 /* From DCL that means using e.g.: */
4307 /* perl program """perl.*""" */
4308 item_len = strlen(item);
4309 if ( '"' == *item && '"' == item[item_len-1] )
4312 item[item_len-2] = '\0';
4313 add_item(head, tail, item, count);
4317 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4318 resultspec.dsc$b_class = DSC$K_CLASS_D;
4319 resultspec.dsc$a_pointer = NULL;
4320 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4321 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4322 if (!isunix || !filespec.dsc$a_pointer)
4323 filespec.dsc$a_pointer = item;
4324 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4326 * Only return version specs, if the caller specified a version
4328 had_version = strchr(item, ';');
4330 * Only return device and directory specs, if the caller specifed either.
4332 had_device = strchr(item, ':');
4333 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4335 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4336 &defaultspec, 0, 0, &zero))))
4341 New(1305,string,resultspec.dsc$w_length+1,char);
4342 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4343 string[resultspec.dsc$w_length] = '\0';
4344 if (NULL == had_version)
4345 *((char *)strrchr(string, ';')) = '\0';
4346 if ((!had_directory) && (had_device == NULL))
4348 if (NULL == (devdir = strrchr(string, ']')))
4349 devdir = strrchr(string, '>');
4350 strcpy(string, devdir + 1);
4353 * Be consistent with what the C RTL has already done to the rest of
4354 * the argv items and lowercase all of these names.
4356 for (c = string; *c; ++c)
4359 if (isunix) trim_unixpath(string,item,1);
4360 add_item(head, tail, string, count);
4363 if (sts != RMS$_NMF)
4365 set_vaxc_errno(sts);
4368 case RMS$_FNF: case RMS$_DNF:
4369 set_errno(ENOENT); break;
4371 set_errno(ENOTDIR); break;
4373 set_errno(ENODEV); break;
4374 case RMS$_FNM: case RMS$_SYN:
4375 set_errno(EINVAL); break;
4377 set_errno(EACCES); break;
4379 _ckvmssts_noperl(sts);
4383 add_item(head, tail, item, count);
4384 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4385 _ckvmssts_noperl(lib$find_file_end(&context));
4388 static int child_st[2];/* Event Flag set when child process completes */
4390 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4392 static unsigned long int exit_handler(int *status)
4396 if (0 == child_st[0])
4398 #ifdef ARGPROC_DEBUG
4399 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4401 fflush(stdout); /* Have to flush pipe for binary data to */
4402 /* terminate properly -- <tp@mccall.com> */
4403 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4404 sys$dassgn(child_chan);
4406 sys$synch(0, child_st);
4411 static void sig_child(int chan)
4413 #ifdef ARGPROC_DEBUG
4414 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4416 if (child_st[0] == 0)
4420 static struct exit_control_block exit_block =
4425 &exit_block.exit_status,
4430 pipe_and_fork(pTHX_ char **cmargv)
4433 struct dsc$descriptor_s *vmscmd;
4434 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4435 int sts, j, l, ismcr, quote, tquote = 0;
4437 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4438 vms_execfree(vmscmd);
4443 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4444 && toupper(*(q+2)) == 'R' && !*(q+3);
4446 while (q && l < MAX_DCL_LINE_LENGTH) {
4448 if (j > 0 && quote) {
4454 if (ismcr && j > 1) quote = 1;
4455 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4458 if (quote || tquote) {
4464 if ((quote||tquote) && *q == '"') {
4474 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4476 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4480 static int background_process(pTHX_ int argc, char **argv)
4482 char command[2048] = "$";
4483 $DESCRIPTOR(value, "");
4484 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4485 static $DESCRIPTOR(null, "NLA0:");
4486 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4488 $DESCRIPTOR(pidstr, "");
4490 unsigned long int flags = 17, one = 1, retsts;
4492 strcat(command, argv[0]);
4495 strcat(command, " \"");
4496 strcat(command, *(++argv));
4497 strcat(command, "\"");
4499 value.dsc$a_pointer = command;
4500 value.dsc$w_length = strlen(value.dsc$a_pointer);
4501 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4502 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4503 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4504 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4507 _ckvmssts_noperl(retsts);
4509 #ifdef ARGPROC_DEBUG
4510 PerlIO_printf(Perl_debug_log, "%s\n", command);
4512 sprintf(pidstring, "%08X", pid);
4513 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4514 pidstr.dsc$a_pointer = pidstring;
4515 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4516 lib$set_symbol(&pidsymbol, &pidstr);
4520 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4523 /* OS-specific initialization at image activation (not thread startup) */
4524 /* Older VAXC header files lack these constants */
4525 #ifndef JPI$_RIGHTS_SIZE
4526 # define JPI$_RIGHTS_SIZE 817
4528 #ifndef KGB$M_SUBSYSTEM
4529 # define KGB$M_SUBSYSTEM 0x8
4532 /*{{{void vms_image_init(int *, char ***)*/
4534 vms_image_init(int *argcp, char ***argvp)
4536 char eqv[LNM$C_NAMLENGTH+1] = "";
4537 unsigned int len, tabct = 8, tabidx = 0;
4538 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4539 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4540 unsigned short int dummy, rlen;
4541 struct dsc$descriptor_s **tabvec;
4542 #if defined(PERL_IMPLICIT_CONTEXT)
4545 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4546 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4547 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4550 #ifdef KILL_BY_SIGPRC
4551 (void) Perl_csighandler_init();
4554 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4555 _ckvmssts_noperl(iosb[0]);
4556 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4557 if (iprv[i]) { /* Running image installed with privs? */
4558 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4563 /* Rights identifiers might trigger tainting as well. */
4564 if (!will_taint && (rlen || rsz)) {
4565 while (rlen < rsz) {
4566 /* We didn't get all the identifiers on the first pass. Allocate a
4567 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4568 * were needed to hold all identifiers at time of last call; we'll
4569 * allocate that many unsigned long ints), and go back and get 'em.
4570 * If it gave us less than it wanted to despite ample buffer space,
4571 * something's broken. Is your system missing a system identifier?
4573 if (rsz <= jpilist[1].buflen) {
4574 /* Perl_croak accvios when used this early in startup. */
4575 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4576 rsz, (unsigned long) jpilist[1].buflen,
4577 "Check your rights database for corruption.\n");
4580 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4581 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4582 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4583 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4584 _ckvmssts_noperl(iosb[0]);
4586 mask = jpilist[1].bufadr;
4587 /* Check attribute flags for each identifier (2nd longword); protected
4588 * subsystem identifiers trigger tainting.
4590 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4591 if (mask[i] & KGB$M_SUBSYSTEM) {
4596 if (mask != rlst) Safefree(mask);
4598 /* We need to use this hack to tell Perl it should run with tainting,
4599 * since its tainting flag may be part of the PL_curinterp struct, which
4600 * hasn't been allocated when vms_image_init() is called.
4603 char **newargv, **oldargv;
4605 New(1320,newargv,(*argcp)+2,char *);
4606 newargv[0] = oldargv[0];
4607 New(1320,newargv[1],3,char);
4608 strcpy(newargv[1], "-T");
4609 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4611 newargv[*argcp] = NULL;
4612 /* We orphan the old argv, since we don't know where it's come from,
4613 * so we don't know how to free it.
4617 else { /* Did user explicitly request tainting? */
4619 char *cp, **av = *argvp;
4620 for (i = 1; i < *argcp; i++) {
4621 if (*av[i] != '-') break;
4622 for (cp = av[i]+1; *cp; cp++) {
4623 if (*cp == 'T') { will_taint = 1; break; }
4624 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4625 strchr("DFIiMmx",*cp)) break;
4627 if (will_taint) break;
4632 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4634 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4635 else if (tabidx >= tabct) {
4637 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4639 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4640 tabvec[tabidx]->dsc$w_length = 0;
4641 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4642 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4643 tabvec[tabidx]->dsc$a_pointer = NULL;
4644 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4646 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4648 getredirection(argcp,argvp);
4649 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4651 # include <reentrancy.h>
4652 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4661 * Trim Unix-style prefix off filespec, so it looks like what a shell
4662 * glob expansion would return (i.e. from specified prefix on, not
4663 * full path). Note that returned filespec is Unix-style, regardless
4664 * of whether input filespec was VMS-style or Unix-style.
4666 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4667 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4668 * vector of options; at present, only bit 0 is used, and if set tells
4669 * trim unixpath to try the current default directory as a prefix when
4670 * presented with a possibly ambiguous ... wildcard.
4672 * Returns !=0 on success, with trimmed filespec replacing contents of
4673 * fspec, and 0 on failure, with contents of fpsec unchanged.
4675 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4677 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4679 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4680 *template, *base, *end, *cp1, *cp2;
4681 register int tmplen, reslen = 0, dirs = 0;
4683 if (!wildspec || !fspec) return 0;
4684 if (strpbrk(wildspec,"]>:") != NULL) {
4685 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4686 else template = unixwild;
4688 else template = wildspec;
4689 if (strpbrk(fspec,"]>:") != NULL) {
4690 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4691 else base = unixified;
4692 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4693 * check to see that final result fits into (isn't longer than) fspec */
4694 reslen = strlen(fspec);
4698 /* No prefix or absolute path on wildcard, so nothing to remove */
4699 if (!*template || *template == '/') {
4700 if (base == fspec) return 1;
4701 tmplen = strlen(unixified);
4702 if (tmplen > reslen) return 0; /* not enough space */
4703 /* Copy unixified resultant, including trailing NUL */
4704 memmove(fspec,unixified,tmplen+1);
4708 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4709 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4710 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4711 for (cp1 = end ;cp1 >= base; cp1--)
4712 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4714 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4718 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4719 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4720 int ells = 1, totells, segdirs, match;
4721 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4722 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4724 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4726 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4727 if (ellipsis == template && opts & 1) {
4728 /* Template begins with an ellipsis. Since we can't tell how many
4729 * directory names at the front of the resultant to keep for an
4730 * arbitrary starting point, we arbitrarily choose the current
4731 * default directory as a starting point. If it's there as a prefix,
4732 * clip it off. If not, fall through and act as if the leading
4733 * ellipsis weren't there (i.e. return shortest possible path that
4734 * could match template).
4736 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4737 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4738 if (_tolower(*cp1) != _tolower(*cp2)) break;
4739 segdirs = dirs - totells; /* Min # of dirs we must have left */
4740 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4741 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4742 memcpy(fspec,cp2+1,end - cp2);
4746 /* First off, back up over constant elements at end of path */
4748 for (front = end ; front >= base; front--)
4749 if (*front == '/' && !dirs--) { front++; break; }
4751 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4752 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4753 if (cp1 != '\0') return 0; /* Path too long. */
4755 *cp2 = '\0'; /* Pick up with memcpy later */
4756 lcfront = lcres + (front - base);
4757 /* Now skip over each ellipsis and try to match the path in front of it. */
4759 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4760 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4761 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4762 if (cp1 < template) break; /* template started with an ellipsis */
4763 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4764 ellipsis = cp1; continue;
4766 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4768 for (segdirs = 0, cp2 = tpl;
4769 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4771 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4772 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4773 if (*cp2 == '/') segdirs++;
4775 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4776 /* Back up at least as many dirs as in template before matching */
4777 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4778 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4779 for (match = 0; cp1 > lcres;) {
4780 resdsc.dsc$a_pointer = cp1;
4781 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4783 if (match == 1) lcfront = cp1;
4785 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4787 if (!match) return 0; /* Can't find prefix ??? */
4788 if (match > 1 && opts & 1) {
4789 /* This ... wildcard could cover more than one set of dirs (i.e.
4790 * a set of similar dir names is repeated). If the template
4791 * contains more than 1 ..., upstream elements could resolve the
4792 * ambiguity, but it's not worth a full backtracking setup here.
4793 * As a quick heuristic, clip off the current default directory
4794 * if it's present to find the trimmed spec, else use the
4795 * shortest string that this ... could cover.
4797 char def[NAM$C_MAXRSS+1], *st;
4799 if (getcwd(def, sizeof def,0) == NULL) return 0;
4800 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4801 if (_tolower(*cp1) != _tolower(*cp2)) break;
4802 segdirs = dirs - totells; /* Min # of dirs we must have left */
4803 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4804 if (*cp1 == '\0' && *cp2 == '/') {
4805 memcpy(fspec,cp2+1,end - cp2);
4808 /* Nope -- stick with lcfront from above and keep going. */
4811 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4816 } /* end of trim_unixpath() */
4821 * VMS readdir() routines.
4822 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4824 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4825 * Minor modifications to original routines.
4828 /* readdir may have been redefined by reentr.h, so make sure we get
4829 * the local version for what we do here.
4834 #if !defined(PERL_IMPLICIT_CONTEXT)
4835 # define readdir Perl_readdir
4837 # define readdir(a) Perl_readdir(aTHX_ a)
4840 /* Number of elements in vms_versions array */
4841 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4844 * Open a directory, return a handle for later use.
4846 /*{{{ DIR *opendir(char*name) */
4848 Perl_opendir(pTHX_ char *name)
4851 char dir[NAM$C_MAXRSS+1];
4854 if (do_tovmspath(name,dir,0) == NULL) {
4857 /* Check access before stat; otherwise stat does not
4858 * accurately report whether it's a directory.
4860 if (!cando_by_name(S_IRUSR,0,dir)) {
4861 /* cando_by_name has already set errno */
4864 if (flex_stat(dir,&sb) == -1) return NULL;
4865 if (!S_ISDIR(sb.st_mode)) {
4866 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4869 /* Get memory for the handle, and the pattern. */
4871 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4873 /* Fill in the fields; mainly playing with the descriptor. */
4874 (void)sprintf(dd->pattern, "%s*.*",dir);
4877 dd->vms_wantversions = 0;
4878 dd->pat.dsc$a_pointer = dd->pattern;
4879 dd->pat.dsc$w_length = strlen(dd->pattern);
4880 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4881 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4882 #if defined(USE_ITHREADS)
4883 New(1308,dd->mutex,1,perl_mutex);
4884 MUTEX_INIT( (perl_mutex *) dd->mutex );
4890 } /* end of opendir() */
4894 * Set the flag to indicate we want versions or not.
4896 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4898 vmsreaddirversions(DIR *dd, int flag)
4900 dd->vms_wantversions = flag;
4905 * Free up an opened directory.
4907 /*{{{ void closedir(DIR *dd)*/
4911 (void)lib$find_file_end(&dd->context);
4912 Safefree(dd->pattern);
4913 #if defined(USE_ITHREADS)
4914 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4915 Safefree(dd->mutex);
4917 Safefree((char *)dd);
4922 * Collect all the version numbers for the current file.
4925 collectversions(pTHX_ DIR *dd)
4927 struct dsc$descriptor_s pat;
4928 struct dsc$descriptor_s res;
4930 char *p, *text, buff[sizeof dd->entry.d_name];
4932 unsigned long context, tmpsts;
4934 /* Convenient shorthand. */
4937 /* Add the version wildcard, ignoring the "*.*" put on before */
4938 i = strlen(dd->pattern);
4939 New(1308,text,i + e->d_namlen + 3,char);
4940 (void)strcpy(text, dd->pattern);
4941 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4943 /* Set up the pattern descriptor. */
4944 pat.dsc$a_pointer = text;
4945 pat.dsc$w_length = i + e->d_namlen - 1;
4946 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4947 pat.dsc$b_class = DSC$K_CLASS_S;
4949 /* Set up result descriptor. */
4950 res.dsc$a_pointer = buff;
4951 res.dsc$w_length = sizeof buff - 2;
4952 res.dsc$b_dtype = DSC$K_DTYPE_T;
4953 res.dsc$b_class = DSC$K_CLASS_S;
4955 /* Read files, collecting versions. */
4956 for (context = 0, e->vms_verscount = 0;
4957 e->vms_verscount < VERSIZE(e);
4958 e->vms_verscount++) {
4959 tmpsts = lib$find_file(&pat, &res, &context);
4960 if (tmpsts == RMS$_NMF || context == 0) break;
4962 buff[sizeof buff - 1] = '\0';
4963 if ((p = strchr(buff, ';')))
4964 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4966 e->vms_versions[e->vms_verscount] = -1;
4969 _ckvmssts(lib$find_file_end(&context));
4972 } /* end of collectversions() */
4975 * Read the next entry from the directory.
4977 /*{{{ struct dirent *readdir(DIR *dd)*/
4979 Perl_readdir(pTHX_ DIR *dd)
4981 struct dsc$descriptor_s res;
4982 char *p, buff[sizeof dd->entry.d_name];
4983 unsigned long int tmpsts;
4985 /* Set up result descriptor, and get next file. */
4986 res.dsc$a_pointer = buff;
4987 res.dsc$w_length = sizeof buff - 2;
4988 res.dsc$b_dtype = DSC$K_DTYPE_T;
4989 res.dsc$b_class = DSC$K_CLASS_S;
4990 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4991 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4992 if (!(tmpsts & 1)) {
4993 set_vaxc_errno(tmpsts);
4996 set_errno(EACCES); break;
4998 set_errno(ENODEV); break;
5000 set_errno(ENOTDIR); break;
5001 case RMS$_FNF: case RMS$_DNF:
5002 set_errno(ENOENT); break;
5009 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5010 buff[sizeof buff - 1] = '\0';
5011 for (p = buff; *p; p++) *p = _tolower(*p);
5012 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5015 /* Skip any directory component and just copy the name. */
5016 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5017 else (void)strcpy(dd->entry.d_name, buff);
5019 /* Clobber the version. */
5020 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5022 dd->entry.d_namlen = strlen(dd->entry.d_name);
5023 dd->entry.vms_verscount = 0;
5024 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5027 } /* end of readdir() */
5031 * Read the next entry from the directory -- thread-safe version.
5033 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5035 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5039 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5041 entry = readdir(dd);
5043 retval = ( *result == NULL ? errno : 0 );
5045 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5049 } /* end of readdir_r() */
5053 * Return something that can be used in a seekdir later.
5055 /*{{{ long telldir(DIR *dd)*/
5064 * Return to a spot where we used to be. Brute force.
5066 /*{{{ void seekdir(DIR *dd,long count)*/
5068 Perl_seekdir(pTHX_ DIR *dd, long count)
5070 int vms_wantversions;
5072 /* If we haven't done anything yet... */
5076 /* Remember some state, and clear it. */
5077 vms_wantversions = dd->vms_wantversions;
5078 dd->vms_wantversions = 0;
5079 _ckvmssts(lib$find_file_end(&dd->context));
5082 /* The increment is in readdir(). */
5083 for (dd->count = 0; dd->count < count; )
5086 dd->vms_wantversions = vms_wantversions;
5088 } /* end of seekdir() */
5091 /* VMS subprocess management
5093 * my_vfork() - just a vfork(), after setting a flag to record that
5094 * the current script is trying a Unix-style fork/exec.
5096 * vms_do_aexec() and vms_do_exec() are called in response to the
5097 * perl 'exec' function. If this follows a vfork call, then they
5098 * call out the regular perl routines in doio.c which do an
5099 * execvp (for those who really want to try this under VMS).
5100 * Otherwise, they do exactly what the perl docs say exec should
5101 * do - terminate the current script and invoke a new command
5102 * (See below for notes on command syntax.)
5104 * do_aspawn() and do_spawn() implement the VMS side of the perl
5105 * 'system' function.
5107 * Note on command arguments to perl 'exec' and 'system': When handled
5108 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5109 * are concatenated to form a DCL command string. If the first arg
5110 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5111 * the command string is handed off to DCL directly. Otherwise,
5112 * the first token of the command is taken as the filespec of an image
5113 * to run. The filespec is expanded using a default type of '.EXE' and
5114 * the process defaults for device, directory, etc., and if found, the resultant
5115 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5116 * the command string as parameters. This is perhaps a bit complicated,
5117 * but I hope it will form a happy medium between what VMS folks expect
5118 * from lib$spawn and what Unix folks expect from exec.
5121 static int vfork_called;
5123 /*{{{int my_vfork()*/
5134 vms_execfree(struct dsc$descriptor_s *vmscmd)
5137 if (vmscmd->dsc$a_pointer) {
5138 Safefree(vmscmd->dsc$a_pointer);
5145 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5147 char *junk, *tmps = Nullch;
5148 register size_t cmdlen = 0;
5155 tmps = SvPV(really,rlen);
5162 for (idx++; idx <= sp; idx++) {
5164 junk = SvPVx(*idx,rlen);
5165 cmdlen += rlen ? rlen + 1 : 0;
5168 New(401,PL_Cmd,cmdlen+1,char);
5170 if (tmps && *tmps) {
5171 strcpy(PL_Cmd,tmps);
5174 else *PL_Cmd = '\0';
5175 while (++mark <= sp) {
5177 char *s = SvPVx(*mark,n_a);
5179 if (*PL_Cmd) strcat(PL_Cmd," ");
5185 } /* end of setup_argstr() */
5188 static unsigned long int
5189 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5190 struct dsc$descriptor_s **pvmscmd)
5192 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5193 $DESCRIPTOR(defdsc,".EXE");
5194 $DESCRIPTOR(defdsc2,".");
5195 $DESCRIPTOR(resdsc,resspec);
5196 struct dsc$descriptor_s *vmscmd;
5197 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5198 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5199 register char *s, *rest, *cp, *wordbreak;
5202 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5203 vmscmd->dsc$a_pointer = NULL;
5204 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5205 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5206 vmscmd->dsc$w_length = 0;
5207 if (pvmscmd) *pvmscmd = vmscmd;
5209 if (suggest_quote) *suggest_quote = 0;
5211 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5212 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5214 while (*s && isspace(*s)) s++;
5216 if (*s == '@' || *s == '$') {
5217 vmsspec[0] = *s; rest = s + 1;
5218 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5220 else { cp = vmsspec; rest = s; }
5221 if (*rest == '.' || *rest == '/') {
5224 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5225 rest++, cp2++) *cp2 = *rest;
5227 if (do_tovmsspec(resspec,cp,0)) {
5230 for (cp2 = vmsspec + strlen(vmsspec);
5231 *rest && cp2 - vmsspec < sizeof vmsspec;
5232 rest++, cp2++) *cp2 = *rest;
5237 /* Intuit whether verb (first word of cmd) is a DCL command:
5238 * - if first nonspace char is '@', it's a DCL indirection
5240 * - if verb contains a filespec separator, it's not a DCL command
5241 * - if it doesn't, caller tells us whether to default to a DCL
5242 * command, or to a local image unless told it's DCL (by leading '$')
5246 if (suggest_quote) *suggest_quote = 1;
5248 register char *filespec = strpbrk(s,":<[.;");
5249 rest = wordbreak = strpbrk(s," \"\t/");
5250 if (!wordbreak) wordbreak = s + strlen(s);
5251 if (*s == '$') check_img = 0;
5252 if (filespec && (filespec < wordbreak)) isdcl = 0;
5253 else isdcl = !check_img;
5257 imgdsc.dsc$a_pointer = s;
5258 imgdsc.dsc$w_length = wordbreak - s;
5259 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5261 _ckvmssts(lib$find_file_end(&cxt));
5262 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5263 if (!(retsts & 1) && *s == '$') {
5264 _ckvmssts(lib$find_file_end(&cxt));
5265 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5266 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5268 _ckvmssts(lib$find_file_end(&cxt));
5269 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5273 _ckvmssts(lib$find_file_end(&cxt));
5278 while (*s && !isspace(*s)) s++;
5281 /* check that it's really not DCL with no file extension */
5282 fp = fopen(resspec,"r","ctx=bin,shr=get");
5284 char b[4] = {0,0,0,0};
5285 read(fileno(fp),b,4);
5286 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5289 if (check_img && isdcl) return RMS$_FNF;
5291 if (cando_by_name(S_IXUSR,0,resspec)) {
5292 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5294 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5295 if (suggest_quote) *suggest_quote = 1;
5297 strcpy(vmscmd->dsc$a_pointer,"@");
5298 if (suggest_quote) *suggest_quote = 1;
5300 strcat(vmscmd->dsc$a_pointer,resspec);
5301 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5302 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5303 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5305 else retsts = RMS$_PRV;
5308 /* It's either a DCL command or we couldn't find a suitable image */
5309 vmscmd->dsc$w_length = strlen(cmd);
5310 /* if (cmd == PL_Cmd) {
5311 vmscmd->dsc$a_pointer = PL_Cmd;
5312 if (suggest_quote) *suggest_quote = 1;
5315 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5317 /* check if it's a symbol (for quoting purposes) */
5318 if (suggest_quote && !*suggest_quote) {
5320 char equiv[LNM$C_NAMLENGTH];
5321 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5322 eqvdsc.dsc$a_pointer = equiv;
5324 iss = lib$get_symbol(vmscmd,&eqvdsc);
5325 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5327 if (!(retsts & 1)) {
5328 /* just hand off status values likely to be due to user error */
5329 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5330 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5331 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5332 else { _ckvmssts(retsts); }
5335 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5337 } /* end of setup_cmddsc() */
5340 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5342 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5345 if (vfork_called) { /* this follows a vfork - act Unixish */
5347 if (vfork_called < 0) {
5348 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5351 else return do_aexec(really,mark,sp);
5353 /* no vfork - act VMSish */
5354 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5359 } /* end of vms_do_aexec() */
5362 /* {{{bool vms_do_exec(char *cmd) */
5364 Perl_vms_do_exec(pTHX_ char *cmd)
5366 struct dsc$descriptor_s *vmscmd;
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_exec(cmd);
5377 { /* no vfork - act VMSish */
5378 unsigned long int retsts;
5381 TAINT_PROPER("exec");
5382 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5383 retsts = lib$do_command(vmscmd);
5386 case RMS$_FNF: case RMS$_DNF:
5387 set_errno(ENOENT); break;
5389 set_errno(ENOTDIR); break;
5391 set_errno(ENODEV); break;
5393 set_errno(EACCES); break;
5395 set_errno(EINVAL); break;
5396 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5397 set_errno(E2BIG); break;
5398 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5399 _ckvmssts(retsts); /* fall through */
5400 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5403 set_vaxc_errno(retsts);
5404 if (ckWARN(WARN_EXEC)) {
5405 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5406 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5408 vms_execfree(vmscmd);
5413 } /* end of vms_do_exec() */
5416 unsigned long int Perl_do_spawn(pTHX_ char *);
5418 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5420 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5422 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5425 } /* end of do_aspawn() */
5428 /* {{{unsigned long int do_spawn(char *cmd) */
5430 Perl_do_spawn(pTHX_ char *cmd)
5432 unsigned long int sts, substs;
5435 TAINT_PROPER("spawn");
5436 if (!cmd || !*cmd) {
5437 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5440 case RMS$_FNF: case RMS$_DNF:
5441 set_errno(ENOENT); break;
5443 set_errno(ENOTDIR); break;
5445 set_errno(ENODEV); break;
5447 set_errno(EACCES); break;
5449 set_errno(EINVAL); break;
5450 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5451 set_errno(E2BIG); break;
5452 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5453 _ckvmssts(sts); /* fall through */
5454 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5457 set_vaxc_errno(sts);
5458 if (ckWARN(WARN_EXEC)) {
5459 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5466 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5469 } /* end of do_spawn() */
5473 static unsigned int *sockflags, sockflagsize;
5476 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5477 * routines found in some versions of the CRTL can't deal with sockets.
5478 * We don't shim the other file open routines since a socket isn't
5479 * likely to be opened by a name.
5481 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5482 FILE *my_fdopen(int fd, const char *mode)
5484 FILE *fp = fdopen(fd, (char *) mode);
5487 unsigned int fdoff = fd / sizeof(unsigned int);
5488 struct stat sbuf; /* native stat; we don't need flex_stat */
5489 if (!sockflagsize || fdoff > sockflagsize) {
5490 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5491 else New (1324,sockflags,fdoff+2,unsigned int);
5492 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5493 sockflagsize = fdoff + 2;
5495 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5496 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5505 * Clear the corresponding bit when the (possibly) socket stream is closed.
5506 * There still a small hole: we miss an implicit close which might occur
5507 * via freopen(). >> Todo
5509 /*{{{ int my_fclose(FILE *fp)*/
5510 int my_fclose(FILE *fp) {
5512 unsigned int fd = fileno(fp);
5513 unsigned int fdoff = fd / sizeof(unsigned int);
5515 if (sockflagsize && fdoff <= sockflagsize)
5516 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5524 * A simple fwrite replacement which outputs itmsz*nitm chars without
5525 * introducing record boundaries every itmsz chars.
5526 * We are using fputs, which depends on a terminating null. We may
5527 * well be writing binary data, so we need to accommodate not only
5528 * data with nulls sprinkled in the middle but also data with no null
5531 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5533 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5535 register char *cp, *end, *cpd, *data;
5536 register unsigned int fd = fileno(dest);
5537 register unsigned int fdoff = fd / sizeof(unsigned int);
5539 int bufsize = itmsz * nitm + 1;
5541 if (fdoff < sockflagsize &&
5542 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5543 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5547 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5548 memcpy( data, src, itmsz*nitm );
5549 data[itmsz*nitm] = '\0';
5551 end = data + itmsz * nitm;
5552 retval = (int) nitm; /* on success return # items written */
5555 while (cpd <= end) {
5556 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5557 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5559 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5563 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5566 } /* end of my_fwrite() */
5569 /*{{{ int my_flush(FILE *fp)*/
5571 Perl_my_flush(pTHX_ FILE *fp)
5574 if ((res = fflush(fp)) == 0 && fp) {
5575 #ifdef VMS_DO_SOCKETS
5577 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5579 res = fsync(fileno(fp));
5582 * If the flush succeeded but set end-of-file, we need to clear
5583 * the error because our caller may check ferror(). BTW, this
5584 * probably means we just flushed an empty file.
5586 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5593 * Here are replacements for the following Unix routines in the VMS environment:
5594 * getpwuid Get information for a particular UIC or UID
5595 * getpwnam Get information for a named user
5596 * getpwent Get information for each user in the rights database
5597 * setpwent Reset search to the start of the rights database
5598 * endpwent Finish searching for users in the rights database
5600 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5601 * (defined in pwd.h), which contains the following fields:-
5603 * char *pw_name; Username (in lower case)
5604 * char *pw_passwd; Hashed password
5605 * unsigned int pw_uid; UIC
5606 * unsigned int pw_gid; UIC group number
5607 * char *pw_unixdir; Default device/directory (VMS-style)
5608 * char *pw_gecos; Owner name
5609 * char *pw_dir; Default device/directory (Unix-style)
5610 * char *pw_shell; Default CLI name (eg. DCL)
5612 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5614 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5615 * not the UIC member number (eg. what's returned by getuid()),
5616 * getpwuid() can accept either as input (if uid is specified, the caller's
5617 * UIC group is used), though it won't recognise gid=0.
5619 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5620 * information about other users in your group or in other groups, respectively.
5621 * If the required privilege is not available, then these routines fill only
5622 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5625 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5628 /* sizes of various UAF record fields */
5629 #define UAI$S_USERNAME 12
5630 #define UAI$S_IDENT 31
5631 #define UAI$S_OWNER 31
5632 #define UAI$S_DEFDEV 31
5633 #define UAI$S_DEFDIR 63
5634 #define UAI$S_DEFCLI 31
5637 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5638 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5639 (uic).uic$v_group != UIC$K_WILD_GROUP)
5641 static char __empty[]= "";
5642 static struct passwd __passwd_empty=
5643 {(char *) __empty, (char *) __empty, 0, 0,
5644 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5645 static int contxt= 0;
5646 static struct passwd __pwdcache;
5647 static char __pw_namecache[UAI$S_IDENT+1];
5650 * This routine does most of the work extracting the user information.
5652 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5655 unsigned char length;
5656 char pw_gecos[UAI$S_OWNER+1];
5658 static union uicdef uic;
5660 unsigned char length;
5661 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5664 unsigned char length;
5665 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5668 unsigned char length;
5669 char pw_shell[UAI$S_DEFCLI+1];
5671 static char pw_passwd[UAI$S_PWD+1];
5673 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5674 struct dsc$descriptor_s name_desc;
5675 unsigned long int sts;
5677 static struct itmlst_3 itmlst[]= {
5678 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5679 {sizeof(uic), UAI$_UIC, &uic, &luic},
5680 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5681 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5682 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5683 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5684 {0, 0, NULL, NULL}};
5686 name_desc.dsc$w_length= strlen(name);
5687 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5688 name_desc.dsc$b_class= DSC$K_CLASS_S;
5689 name_desc.dsc$a_pointer= (char *) name;
5691 /* Note that sys$getuai returns many fields as counted strings. */
5692 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5693 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5694 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5696 else { _ckvmssts(sts); }
5697 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5699 if ((int) owner.length < lowner) lowner= (int) owner.length;
5700 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5701 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5702 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5703 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5704 owner.pw_gecos[lowner]= '\0';
5705 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5706 defcli.pw_shell[ldefcli]= '\0';
5707 if (valid_uic(uic)) {
5708 pwd->pw_uid= uic.uic$l_uic;
5709 pwd->pw_gid= uic.uic$v_group;
5712 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5713 pwd->pw_passwd= pw_passwd;
5714 pwd->pw_gecos= owner.pw_gecos;
5715 pwd->pw_dir= defdev.pw_dir;
5716 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5717 pwd->pw_shell= defcli.pw_shell;
5718 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5720 ldir= strlen(pwd->pw_unixdir) - 1;
5721 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5724 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5725 __mystrtolower(pwd->pw_unixdir);
5730 * Get information for a named user.
5732 /*{{{struct passwd *getpwnam(char *name)*/
5733 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5735 struct dsc$descriptor_s name_desc;
5737 unsigned long int status, sts;
5739 __pwdcache = __passwd_empty;
5740 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5741 /* We still may be able to determine pw_uid and pw_gid */
5742 name_desc.dsc$w_length= strlen(name);
5743 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5744 name_desc.dsc$b_class= DSC$K_CLASS_S;
5745 name_desc.dsc$a_pointer= (char *) name;
5746 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5747 __pwdcache.pw_uid= uic.uic$l_uic;
5748 __pwdcache.pw_gid= uic.uic$v_group;
5751 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5752 set_vaxc_errno(sts);
5753 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5756 else { _ckvmssts(sts); }
5759 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5760 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5761 __pwdcache.pw_name= __pw_namecache;
5763 } /* end of my_getpwnam() */
5767 * Get information for a particular UIC or UID.
5768 * Called by my_getpwent with uid=-1 to list all users.
5770 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5771 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5773 const $DESCRIPTOR(name_desc,__pw_namecache);
5774 unsigned short lname;
5776 unsigned long int status;
5778 if (uid == (unsigned int) -1) {
5780 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5781 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5782 set_vaxc_errno(status);
5783 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5787 else { _ckvmssts(status); }
5788 } while (!valid_uic (uic));
5792 if (!uic.uic$v_group)
5793 uic.uic$v_group= PerlProc_getgid();
5795 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5796 else status = SS$_IVIDENT;
5797 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5798 status == RMS$_PRV) {
5799 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5802 else { _ckvmssts(status); }
5804 __pw_namecache[lname]= '\0';
5805 __mystrtolower(__pw_namecache);
5807 __pwdcache = __passwd_empty;
5808 __pwdcache.pw_name = __pw_namecache;
5810 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5811 The identifier's value is usually the UIC, but it doesn't have to be,
5812 so if we can, we let fillpasswd update this. */
5813 __pwdcache.pw_uid = uic.uic$l_uic;
5814 __pwdcache.pw_gid = uic.uic$v_group;
5816 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5819 } /* end of my_getpwuid() */
5823 * Get information for next user.
5825 /*{{{struct passwd *my_getpwent()*/
5826 struct passwd *Perl_my_getpwent(pTHX)
5828 return (my_getpwuid((unsigned int) -1));
5833 * Finish searching rights database for users.
5835 /*{{{void my_endpwent()*/
5836 void Perl_my_endpwent(pTHX)
5839 _ckvmssts(sys$finish_rdb(&contxt));
5845 #ifdef HOMEGROWN_POSIX_SIGNALS
5846 /* Signal handling routines, pulled into the core from POSIX.xs.
5848 * We need these for threads, so they've been rolled into the core,
5849 * rather than left in POSIX.xs.
5851 * (DRS, Oct 23, 1997)
5854 /* sigset_t is atomic under VMS, so these routines are easy */
5855 /*{{{int my_sigemptyset(sigset_t *) */
5856 int my_sigemptyset(sigset_t *set) {
5857 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5863 /*{{{int my_sigfillset(sigset_t *)*/
5864 int my_sigfillset(sigset_t *set) {
5866 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5867 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5873 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5874 int my_sigaddset(sigset_t *set, int sig) {
5875 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5876 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5877 *set |= (1 << (sig - 1));
5883 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5884 int my_sigdelset(sigset_t *set, int sig) {
5885 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5886 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5887 *set &= ~(1 << (sig - 1));
5893 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5894 int my_sigismember(sigset_t *set, int sig) {
5895 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5896 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5897 return *set & (1 << (sig - 1));
5902 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5903 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5906 /* If set and oset are both null, then things are badly wrong. Bail out. */
5907 if ((oset == NULL) && (set == NULL)) {
5908 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5912 /* If set's null, then we're just handling a fetch. */
5914 tempmask = sigblock(0);
5919 tempmask = sigsetmask(*set);
5922 tempmask = sigblock(*set);
5925 tempmask = sigblock(0);
5926 sigsetmask(*oset & ~tempmask);
5929 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5934 /* Did they pass us an oset? If so, stick our holding mask into it */
5941 #endif /* HOMEGROWN_POSIX_SIGNALS */
5944 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5945 * my_utime(), and flex_stat(), all of which operate on UTC unless
5946 * VMSISH_TIMES is true.
5948 /* method used to handle UTC conversions:
5949 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5951 static int gmtime_emulation_type;
5952 /* number of secs to add to UTC POSIX-style time to get local time */
5953 static long int utc_offset_secs;
5955 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5956 * in vmsish.h. #undef them here so we can call the CRTL routines
5965 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5966 * qualifier with the extern prefix pragma. This provisional
5967 * hack circumvents this prefix pragma problem in previous
5970 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5971 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5972 # pragma __extern_prefix save
5973 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5974 # define gmtime decc$__utctz_gmtime
5975 # define localtime decc$__utctz_localtime
5976 # define time decc$__utc_time
5977 # pragma __extern_prefix restore
5979 struct tm *gmtime(), *localtime();
5985 static time_t toutc_dst(time_t loc) {
5988 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5989 loc -= utc_offset_secs;
5990 if (rsltmp->tm_isdst) loc -= 3600;
5993 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5994 ((gmtime_emulation_type || my_time(NULL)), \
5995 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5996 ((secs) - utc_offset_secs))))
5998 static time_t toloc_dst(time_t utc) {
6001 utc += utc_offset_secs;
6002 if ((rsltmp = localtime(&utc)) == NULL) return -1;
6003 if (rsltmp->tm_isdst) utc += 3600;
6006 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6007 ((gmtime_emulation_type || my_time(NULL)), \
6008 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6009 ((secs) + utc_offset_secs))))
6011 #ifndef RTL_USES_UTC
6014 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6015 DST starts on 1st sun of april at 02:00 std time
6016 ends on last sun of october at 02:00 dst time
6017 see the UCX management command reference, SET CONFIG TIMEZONE
6018 for formatting info.
6020 No, it's not as general as it should be, but then again, NOTHING
6021 will handle UK times in a sensible way.
6026 parse the DST start/end info:
6027 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6031 tz_parse_startend(char *s, struct tm *w, int *past)
6033 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6034 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6039 if (!past) return 0;
6042 if (w->tm_year % 4 == 0) ly = 1;
6043 if (w->tm_year % 100 == 0) ly = 0;
6044 if (w->tm_year+1900 % 400 == 0) ly = 1;
6047 dozjd = isdigit(*s);
6048 if (*s == 'J' || *s == 'j' || dozjd) {
6049 if (!dozjd && !isdigit(*++s)) return 0;
6052 d = d*10 + *s++ - '0';
6054 d = d*10 + *s++ - '0';
6057 if (d == 0) return 0;
6058 if (d > 366) return 0;
6060 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6063 } else if (*s == 'M' || *s == 'm') {
6064 if (!isdigit(*++s)) return 0;
6066 if (isdigit(*s)) m = 10*m + *s++ - '0';
6067 if (*s != '.') return 0;
6068 if (!isdigit(*++s)) return 0;
6070 if (n < 1 || n > 5) return 0;
6071 if (*s != '.') return 0;
6072 if (!isdigit(*++s)) return 0;
6074 if (d > 6) return 0;
6078 if (!isdigit(*++s)) return 0;
6080 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6082 if (!isdigit(*++s)) return 0;
6084 if (isdigit(*s)) min = 10*min + *s++ - '0';
6086 if (!isdigit(*++s)) return 0;
6088 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6098 if (w->tm_yday < d) goto before;
6099 if (w->tm_yday > d) goto after;
6101 if (w->tm_mon+1 < m) goto before;
6102 if (w->tm_mon+1 > m) goto after;
6104 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6105 k = d - j; /* mday of first d */
6107 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6108 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6109 if (w->tm_mday < k) goto before;
6110 if (w->tm_mday > k) goto after;
6113 if (w->tm_hour < hour) goto before;
6114 if (w->tm_hour > hour) goto after;
6115 if (w->tm_min < min) goto before;
6116 if (w->tm_min > min) goto after;
6117 if (w->tm_sec < sec) goto before;
6131 /* parse the offset: (+|-)hh[:mm[:ss]] */
6134 tz_parse_offset(char *s, int *offset)
6136 int hour = 0, min = 0, sec = 0;
6139 if (!offset) return 0;
6141 if (*s == '-') {neg++; s++;}
6143 if (!isdigit(*s)) return 0;
6145 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6146 if (hour > 24) return 0;
6148 if (!isdigit(*++s)) return 0;
6150 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6151 if (min > 59) return 0;
6153 if (!isdigit(*++s)) return 0;
6155 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6156 if (sec > 59) return 0;
6160 *offset = (hour*60+min)*60 + sec;
6161 if (neg) *offset = -*offset;
6166 input time is w, whatever type of time the CRTL localtime() uses.
6167 sets dst, the zone, and the gmtoff (seconds)
6169 caches the value of TZ and UCX$TZ env variables; note that
6170 my_setenv looks for these and sets a flag if they're changed
6173 We have to watch out for the "australian" case (dst starts in
6174 october, ends in april)...flagged by "reverse" and checked by
6175 scanning through the months of the previous year.
6180 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6185 char *dstzone, *tz, *s_start, *s_end;
6186 int std_off, dst_off, isdst;
6187 int y, dststart, dstend;
6188 static char envtz[1025]; /* longer than any logical, symbol, ... */
6189 static char ucxtz[1025];
6190 static char reversed = 0;
6196 reversed = -1; /* flag need to check */
6197 envtz[0] = ucxtz[0] = '\0';
6198 tz = my_getenv("TZ",0);
6199 if (tz) strcpy(envtz, tz);
6200 tz = my_getenv("UCX$TZ",0);
6201 if (tz) strcpy(ucxtz, tz);
6202 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6205 if (!*tz) tz = ucxtz;
6208 while (isalpha(*s)) s++;
6209 s = tz_parse_offset(s, &std_off);
6211 if (!*s) { /* no DST, hurray we're done! */
6217 while (isalpha(*s)) s++;
6218 s2 = tz_parse_offset(s, &dst_off);
6222 dst_off = std_off - 3600;
6225 if (!*s) { /* default dst start/end?? */
6226 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6227 s = strchr(ucxtz,',');
6229 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6231 if (*s != ',') return 0;
6234 when = _toutc(when); /* convert to utc */
6235 when = when - std_off; /* convert to pseudolocal time*/
6237 w2 = localtime(&when);
6240 s = tz_parse_startend(s_start,w2,&dststart);
6242 if (*s != ',') return 0;
6245 when = _toutc(when); /* convert to utc */
6246 when = when - dst_off; /* convert to pseudolocal time*/
6247 w2 = localtime(&when);
6248 if (w2->tm_year != y) { /* spans a year, just check one time */
6249 when += dst_off - std_off;
6250 w2 = localtime(&when);
6253 s = tz_parse_startend(s_end,w2,&dstend);
6256 if (reversed == -1) { /* need to check if start later than end */
6260 if (when < 2*365*86400) {
6261 when += 2*365*86400;
6265 w2 =localtime(&when);
6266 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6268 for (j = 0; j < 12; j++) {
6269 w2 =localtime(&when);
6270 (void) tz_parse_startend(s_start,w2,&ds);
6271 (void) tz_parse_startend(s_end,w2,&de);
6272 if (ds != de) break;
6276 if (de && !ds) reversed = 1;
6279 isdst = dststart && !dstend;
6280 if (reversed) isdst = dststart || !dstend;
6283 if (dst) *dst = isdst;
6284 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6285 if (isdst) tz = dstzone;
6287 while(isalpha(*tz)) *zone++ = *tz++;
6293 #endif /* !RTL_USES_UTC */
6295 /* my_time(), my_localtime(), my_gmtime()
6296 * By default traffic in UTC time values, using CRTL gmtime() or
6297 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6298 * Note: We need to use these functions even when the CRTL has working
6299 * UTC support, since they also handle C<use vmsish qw(times);>
6301 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6302 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6305 /*{{{time_t my_time(time_t *timep)*/
6306 time_t Perl_my_time(pTHX_ time_t *timep)
6311 if (gmtime_emulation_type == 0) {
6313 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6314 /* results of calls to gmtime() and localtime() */
6315 /* for same &base */
6317 gmtime_emulation_type++;
6318 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6319 char off[LNM$C_NAMLENGTH+1];;
6321 gmtime_emulation_type++;
6322 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6323 gmtime_emulation_type++;
6324 utc_offset_secs = 0;
6325 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6327 else { utc_offset_secs = atol(off); }
6329 else { /* We've got a working gmtime() */
6330 struct tm gmt, local;
6333 tm_p = localtime(&base);
6335 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6336 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6337 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6338 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6344 # ifdef RTL_USES_UTC
6345 if (VMSISH_TIME) when = _toloc(when);
6347 if (!VMSISH_TIME) when = _toutc(when);
6350 if (timep != NULL) *timep = when;
6353 } /* end of my_time() */
6357 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6359 Perl_my_gmtime(pTHX_ const time_t *timep)
6365 if (timep == NULL) {
6366 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6369 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6373 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6375 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6376 return gmtime(&when);
6378 /* CRTL localtime() wants local time as input, so does no tz correction */
6379 rsltmp = localtime(&when);
6380 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6383 } /* end of my_gmtime() */
6387 /*{{{struct tm *my_localtime(const time_t *timep)*/
6389 Perl_my_localtime(pTHX_ const time_t *timep)
6391 time_t when, whenutc;
6395 if (timep == NULL) {
6396 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6399 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6400 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6403 # ifdef RTL_USES_UTC
6405 if (VMSISH_TIME) when = _toutc(when);
6407 /* CRTL localtime() wants UTC as input, does tz correction itself */
6408 return localtime(&when);
6410 # else /* !RTL_USES_UTC */
6413 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6414 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6417 #ifndef RTL_USES_UTC
6418 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6419 when = whenutc - offset; /* pseudolocal time*/
6422 /* CRTL localtime() wants local time as input, so does no tz correction */
6423 rsltmp = localtime(&when);
6424 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6428 } /* end of my_localtime() */
6431 /* Reset definitions for later calls */
6432 #define gmtime(t) my_gmtime(t)
6433 #define localtime(t) my_localtime(t)
6434 #define time(t) my_time(t)
6437 /* my_utime - update modification time of a file
6438 * calling sequence is identical to POSIX utime(), but under
6439 * VMS only the modification time is changed; ODS-2 does not
6440 * maintain access times. Restrictions differ from the POSIX
6441 * definition in that the time can be changed as long as the
6442 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6443 * no separate checks are made to insure that the caller is the
6444 * owner of the file or has special privs enabled.
6445 * Code here is based on Joe Meadows' FILE utility.
6448 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6449 * to VMS epoch (01-JAN-1858 00:00:00.00)
6450 * in 100 ns intervals.
6452 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6454 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6455 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6458 long int bintime[2], len = 2, lowbit, unixtime,
6459 secscale = 10000000; /* seconds --> 100 ns intervals */
6460 unsigned long int chan, iosb[2], retsts;
6461 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6462 struct FAB myfab = cc$rms_fab;
6463 struct NAM mynam = cc$rms_nam;
6464 #if defined (__DECC) && defined (__VAX)
6465 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6466 * at least through VMS V6.1, which causes a type-conversion warning.
6468 # pragma message save
6469 # pragma message disable cvtdiftypes
6471 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6472 struct fibdef myfib;
6473 #if defined (__DECC) && defined (__VAX)
6474 /* This should be right after the declaration of myatr, but due
6475 * to a bug in VAX DEC C, this takes effect a statement early.
6477 # pragma message restore
6479 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6480 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6481 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6483 if (file == NULL || *file == '\0') {
6485 set_vaxc_errno(LIB$_INVARG);
6488 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6490 if (utimes != NULL) {
6491 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6492 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6493 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6494 * as input, we force the sign bit to be clear by shifting unixtime right
6495 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6497 lowbit = (utimes->modtime & 1) ? secscale : 0;
6498 unixtime = (long int) utimes->modtime;
6500 /* If input was UTC; convert to local for sys svc */
6501 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6503 unixtime >>= 1; secscale <<= 1;
6504 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6505 if (!(retsts & 1)) {
6507 set_vaxc_errno(retsts);
6510 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6511 if (!(retsts & 1)) {
6513 set_vaxc_errno(retsts);
6518 /* Just get the current time in VMS format directly */
6519 retsts = sys$gettim(bintime);
6520 if (!(retsts & 1)) {
6522 set_vaxc_errno(retsts);
6527 myfab.fab$l_fna = vmsspec;
6528 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6529 myfab.fab$l_nam = &mynam;
6530 mynam.nam$l_esa = esa;
6531 mynam.nam$b_ess = (unsigned char) sizeof esa;
6532 mynam.nam$l_rsa = rsa;
6533 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6535 /* Look for the file to be affected, letting RMS parse the file
6536 * specification for us as well. I have set errno using only
6537 * values documented in the utime() man page for VMS POSIX.
6539 retsts = sys$parse(&myfab,0,0);
6540 if (!(retsts & 1)) {
6541 set_vaxc_errno(retsts);
6542 if (retsts == RMS$_PRV) set_errno(EACCES);
6543 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6544 else set_errno(EVMSERR);
6547 retsts = sys$search(&myfab,0,0);
6548 if (!(retsts & 1)) {
6549 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6550 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6551 set_vaxc_errno(retsts);
6552 if (retsts == RMS$_PRV) set_errno(EACCES);
6553 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6554 else set_errno(EVMSERR);
6558 devdsc.dsc$w_length = mynam.nam$b_dev;
6559 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6561 retsts = sys$assign(&devdsc,&chan,0,0);
6562 if (!(retsts & 1)) {
6563 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6564 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6565 set_vaxc_errno(retsts);
6566 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6567 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6568 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6569 else set_errno(EVMSERR);
6573 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6574 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6576 memset((void *) &myfib, 0, sizeof myfib);
6577 #if defined(__DECC) || defined(__DECCXX)
6578 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6579 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6580 /* This prevents the revision time of the file being reset to the current
6581 * time as a result of our IO$_MODIFY $QIO. */
6582 myfib.fib$l_acctl = FIB$M_NORECORD;
6584 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6585 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6586 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6588 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6589 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6590 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6591 _ckvmssts(sys$dassgn(chan));
6592 if (retsts & 1) retsts = iosb[0];
6593 if (!(retsts & 1)) {
6594 set_vaxc_errno(retsts);
6595 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6596 else set_errno(EVMSERR);
6601 } /* end of my_utime() */
6605 * flex_stat, flex_fstat
6606 * basic stat, but gets it right when asked to stat
6607 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6610 /* encode_dev packs a VMS device name string into an integer to allow
6611 * simple comparisons. This can be used, for example, to check whether two
6612 * files are located on the same device, by comparing their encoded device
6613 * names. Even a string comparison would not do, because stat() reuses the
6614 * device name buffer for each call; so without encode_dev, it would be
6615 * necessary to save the buffer and use strcmp (this would mean a number of
6616 * changes to the standard Perl code, to say nothing of what a Perl script
6619 * The device lock id, if it exists, should be unique (unless perhaps compared
6620 * with lock ids transferred from other nodes). We have a lock id if the disk is
6621 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6622 * device names. Thus we use the lock id in preference, and only if that isn't
6623 * available, do we try to pack the device name into an integer (flagged by
6624 * the sign bit (LOCKID_MASK) being set).
6626 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6627 * name and its encoded form, but it seems very unlikely that we will find
6628 * two files on different disks that share the same encoded device names,
6629 * and even more remote that they will share the same file id (if the test
6630 * is to check for the same file).
6632 * A better method might be to use sys$device_scan on the first call, and to
6633 * search for the device, returning an index into the cached array.
6634 * The number returned would be more intelligable.
6635 * This is probably not worth it, and anyway would take quite a bit longer
6636 * on the first call.
6638 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6639 static mydev_t encode_dev (pTHX_ const char *dev)
6642 unsigned long int f;
6647 if (!dev || !dev[0]) return 0;
6651 struct dsc$descriptor_s dev_desc;
6652 unsigned long int status, lockid, item = DVI$_LOCKID;
6654 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6655 can try that first. */
6656 dev_desc.dsc$w_length = strlen (dev);
6657 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6658 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6659 dev_desc.dsc$a_pointer = (char *) dev;
6660 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6661 if (lockid) return (lockid & ~LOCKID_MASK);
6665 /* Otherwise we try to encode the device name */
6669 for (q = dev + strlen(dev); q--; q >= dev) {
6672 else if (isalpha (toupper (*q)))
6673 c= toupper (*q) - 'A' + (char)10;
6675 continue; /* Skip '$'s */
6677 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6679 enc += f * (unsigned long int) c;
6681 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6683 } /* end of encode_dev() */
6685 static char namecache[NAM$C_MAXRSS+1];
6688 is_null_device(name)
6691 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6692 The underscore prefix, controller letter, and unit number are
6693 independently optional; for our purposes, the colon punctuation
6694 is not. The colon can be trailed by optional directory and/or
6695 filename, but two consecutive colons indicates a nodename rather
6696 than a device. [pr] */
6697 if (*name == '_') ++name;
6698 if (tolower(*name++) != 'n') return 0;
6699 if (tolower(*name++) != 'l') return 0;
6700 if (tolower(*name) == 'a') ++name;
6701 if (*name == '0') ++name;
6702 return (*name++ == ':') && (*name != ':');
6705 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6706 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6707 * subset of the applicable information.
6710 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6712 char fname_phdev[NAM$C_MAXRSS+1];
6713 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6715 char fname[NAM$C_MAXRSS+1];
6716 unsigned long int retsts;
6717 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6718 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6720 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6721 device name on successive calls */
6722 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6723 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6724 namdsc.dsc$a_pointer = fname;
6725 namdsc.dsc$w_length = sizeof fname - 1;
6727 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6728 &namdsc,&namdsc.dsc$w_length,0,0);
6730 fname[namdsc.dsc$w_length] = '\0';
6732 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6733 * but if someone has redefined that logical, Perl gets very lost. Since
6734 * we have the physical device name from the stat buffer, just paste it on.
6736 strcpy( fname_phdev, statbufp->st_devnam );
6737 strcat( fname_phdev, strrchr(fname, ':') );
6739 return cando_by_name(bit,effective,fname_phdev);
6741 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6742 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6746 return FALSE; /* Should never get to here */
6748 } /* end of cando() */
6752 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6754 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6756 static char usrname[L_cuserid];
6757 static struct dsc$descriptor_s usrdsc =
6758 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6759 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6760 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6761 unsigned short int retlen, trnlnm_iter_count;
6762 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6763 union prvdef curprv;
6764 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6765 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6766 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6767 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6769 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6771 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6773 if (!fname || !*fname) return FALSE;
6774 /* Make sure we expand logical names, since sys$check_access doesn't */
6775 if (!strpbrk(fname,"/]>:")) {
6776 strcpy(fileified,fname);
6777 trnlnm_iter_count = 0;
6778 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6779 trnlnm_iter_count++;
6780 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6784 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6785 retlen = namdsc.dsc$w_length = strlen(vmsname);
6786 namdsc.dsc$a_pointer = vmsname;
6787 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6788 vmsname[retlen-1] == ':') {
6789 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6790 namdsc.dsc$w_length = strlen(fileified);
6791 namdsc.dsc$a_pointer = fileified;
6795 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6796 access = ARM$M_EXECUTE; break;
6797 case S_IRUSR: case S_IRGRP: case S_IROTH:
6798 access = ARM$M_READ; break;
6799 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6800 access = ARM$M_WRITE; break;
6801 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6802 access = ARM$M_DELETE; break;
6807 /* Before we call $check_access, create a user profile with the current
6808 * process privs since otherwise it just uses the default privs from the
6809 * UAF and might give false positives or negatives. This only works on
6810 * VMS versions v6.0 and later since that's when sys$create_user_profile
6814 /* get current process privs and username */
6815 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6818 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6820 /* find out the space required for the profile */
6821 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6822 &usrprodsc.dsc$w_length,0));
6824 /* allocate space for the profile and get it filled in */
6825 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6826 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6827 &usrprodsc.dsc$w_length,0));
6829 /* use the profile to check access to the file; free profile & analyze results */
6830 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6831 Safefree(usrprodsc.dsc$a_pointer);
6832 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6836 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6840 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6841 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6842 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6843 set_vaxc_errno(retsts);
6844 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6845 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6846 else set_errno(ENOENT);
6849 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6854 return FALSE; /* Should never get here */
6856 } /* end of cando_by_name() */
6860 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6862 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6864 if (!fstat(fd,(stat_t *) statbufp)) {
6865 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6866 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6867 # ifdef RTL_USES_UTC
6870 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6871 statbufp->st_atime = _toloc(statbufp->st_atime);
6872 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6877 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6881 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6882 statbufp->st_atime = _toutc(statbufp->st_atime);
6883 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6890 } /* end of flex_fstat() */
6893 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6895 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6897 char fileified[NAM$C_MAXRSS+1];
6898 char temp_fspec[NAM$C_MAXRSS+300];
6900 int saved_errno, saved_vaxc_errno;
6902 if (!fspec) return retval;
6903 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6904 strcpy(temp_fspec, fspec);
6905 if (statbufp == (Stat_t *) &PL_statcache)
6906 do_tovmsspec(temp_fspec,namecache,0);
6907 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6908 memset(statbufp,0,sizeof *statbufp);
6909 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6910 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6911 statbufp->st_uid = 0x00010001;
6912 statbufp->st_gid = 0x0001;
6913 time((time_t *)&statbufp->st_mtime);
6914 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6918 /* Try for a directory name first. If fspec contains a filename without
6919 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6920 * and sea:[wine.dark]water. exist, we prefer the directory here.
6921 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6922 * not sea:[wine.dark]., if the latter exists. If the intended target is
6923 * the file with null type, specify this by calling flex_stat() with
6924 * a '.' at the end of fspec.
6926 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6927 retval = stat(fileified,(stat_t *) statbufp);
6928 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6929 strcpy(namecache,fileified);
6931 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6933 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6934 # ifdef RTL_USES_UTC
6937 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6938 statbufp->st_atime = _toloc(statbufp->st_atime);
6939 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6944 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6948 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6949 statbufp->st_atime = _toutc(statbufp->st_atime);
6950 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6954 /* If we were successful, leave errno where we found it */
6955 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6958 } /* end of flex_stat() */
6962 /*{{{char *my_getlogin()*/
6963 /* VMS cuserid == Unix getlogin, except calling sequence */
6967 static char user[L_cuserid];
6968 return cuserid(user);
6973 /* rmscopy - copy a file using VMS RMS routines
6975 * Copies contents and attributes of spec_in to spec_out, except owner
6976 * and protection information. Name and type of spec_in are used as
6977 * defaults for spec_out. The third parameter specifies whether rmscopy()
6978 * should try to propagate timestamps from the input file to the output file.
6979 * If it is less than 0, no timestamps are preserved. If it is 0, then
6980 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6981 * propagated to the output file at creation iff the output file specification
6982 * did not contain an explicit name or type, and the revision date is always
6983 * updated at the end of the copy operation. If it is greater than 0, then
6984 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6985 * other than the revision date should be propagated, and bit 1 indicates
6986 * that the revision date should be propagated.
6988 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6990 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6991 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6992 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6993 * as part of the Perl standard distribution under the terms of the
6994 * GNU General Public License or the Perl Artistic License. Copies
6995 * of each may be found in the Perl standard distribution.
6997 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6999 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
7001 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7002 rsa[NAM$C_MAXRSS], ubf[32256];
7003 unsigned long int i, sts, sts2;
7004 struct FAB fab_in, fab_out;
7005 struct RAB rab_in, rab_out;
7007 struct XABDAT xabdat;
7008 struct XABFHC xabfhc;
7009 struct XABRDT xabrdt;
7010 struct XABSUM xabsum;
7012 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7013 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7014 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7018 fab_in = cc$rms_fab;
7019 fab_in.fab$l_fna = vmsin;
7020 fab_in.fab$b_fns = strlen(vmsin);
7021 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7022 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7023 fab_in.fab$l_fop = FAB$M_SQO;
7024 fab_in.fab$l_nam = &nam;
7025 fab_in.fab$l_xab = (void *) &xabdat;
7028 nam.nam$l_rsa = rsa;
7029 nam.nam$b_rss = sizeof(rsa);
7030 nam.nam$l_esa = esa;
7031 nam.nam$b_ess = sizeof (esa);
7032 nam.nam$b_esl = nam.nam$b_rsl = 0;
7034 xabdat = cc$rms_xabdat; /* To get creation date */
7035 xabdat.xab$l_nxt = (void *) &xabfhc;
7037 xabfhc = cc$rms_xabfhc; /* To get record length */
7038 xabfhc.xab$l_nxt = (void *) &xabsum;
7040 xabsum = cc$rms_xabsum; /* To get key and area information */
7042 if (!((sts = sys$open(&fab_in)) & 1)) {
7043 set_vaxc_errno(sts);
7045 case RMS$_FNF: case RMS$_DNF:
7046 set_errno(ENOENT); break;
7048 set_errno(ENOTDIR); break;
7050 set_errno(ENODEV); break;
7052 set_errno(EINVAL); break;
7054 set_errno(EACCES); break;
7062 fab_out.fab$w_ifi = 0;
7063 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7064 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7065 fab_out.fab$l_fop = FAB$M_SQO;
7066 fab_out.fab$l_fna = vmsout;
7067 fab_out.fab$b_fns = strlen(vmsout);
7068 fab_out.fab$l_dna = nam.nam$l_name;
7069 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7071 if (preserve_dates == 0) { /* Act like DCL COPY */
7072 nam.nam$b_nop = NAM$M_SYNCHK;
7073 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7074 if (!((sts = sys$parse(&fab_out)) & 1)) {
7075 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7076 set_vaxc_errno(sts);
7079 fab_out.fab$l_xab = (void *) &xabdat;
7080 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7082 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7083 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7084 preserve_dates =0; /* bitmask from this point forward */
7086 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7087 if (!((sts = sys$create(&fab_out)) & 1)) {
7088 set_vaxc_errno(sts);
7091 set_errno(ENOENT); break;
7093 set_errno(ENOTDIR); break;
7095 set_errno(ENODEV); break;
7097 set_errno(EINVAL); break;
7099 set_errno(EACCES); break;
7105 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7106 if (preserve_dates & 2) {
7107 /* sys$close() will process xabrdt, not xabdat */
7108 xabrdt = cc$rms_xabrdt;
7110 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7112 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7113 * is unsigned long[2], while DECC & VAXC use a struct */
7114 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7116 fab_out.fab$l_xab = (void *) &xabrdt;
7119 rab_in = cc$rms_rab;
7120 rab_in.rab$l_fab = &fab_in;
7121 rab_in.rab$l_rop = RAB$M_BIO;
7122 rab_in.rab$l_ubf = ubf;
7123 rab_in.rab$w_usz = sizeof ubf;
7124 if (!((sts = sys$connect(&rab_in)) & 1)) {
7125 sys$close(&fab_in); sys$close(&fab_out);
7126 set_errno(EVMSERR); set_vaxc_errno(sts);
7130 rab_out = cc$rms_rab;
7131 rab_out.rab$l_fab = &fab_out;
7132 rab_out.rab$l_rbf = ubf;
7133 if (!((sts = sys$connect(&rab_out)) & 1)) {
7134 sys$close(&fab_in); sys$close(&fab_out);
7135 set_errno(EVMSERR); set_vaxc_errno(sts);
7139 while ((sts = sys$read(&rab_in))) { /* always true */
7140 if (sts == RMS$_EOF) break;
7141 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7142 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7143 sys$close(&fab_in); sys$close(&fab_out);
7144 set_errno(EVMSERR); set_vaxc_errno(sts);
7149 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7150 sys$close(&fab_in); sys$close(&fab_out);
7151 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7153 set_errno(EVMSERR); set_vaxc_errno(sts);
7159 } /* end of rmscopy() */
7163 /*** The following glue provides 'hooks' to make some of the routines
7164 * from this file available from Perl. These routines are sufficiently
7165 * basic, and are required sufficiently early in the build process,
7166 * that's it's nice to have them available to miniperl as well as the
7167 * full Perl, so they're set up here instead of in an extension. The
7168 * Perl code which handles importation of these names into a given
7169 * package lives in [.VMS]Filespec.pm in @INC.
7173 rmsexpand_fromperl(pTHX_ CV *cv)
7176 char *fspec, *defspec = NULL, *rslt;
7179 if (!items || items > 2)
7180 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7181 fspec = SvPV(ST(0),n_a);
7182 if (!fspec || !*fspec) XSRETURN_UNDEF;
7183 if (items == 2) defspec = SvPV(ST(1),n_a);
7185 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7186 ST(0) = sv_newmortal();
7187 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7192 vmsify_fromperl(pTHX_ CV *cv)
7198 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7199 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7200 ST(0) = sv_newmortal();
7201 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7206 unixify_fromperl(pTHX_ CV *cv)
7212 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7213 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7214 ST(0) = sv_newmortal();
7215 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7220 fileify_fromperl(pTHX_ CV *cv)
7226 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7227 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7228 ST(0) = sv_newmortal();
7229 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7234 pathify_fromperl(pTHX_ CV *cv)
7240 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7241 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7242 ST(0) = sv_newmortal();
7243 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7248 vmspath_fromperl(pTHX_ CV *cv)
7254 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7255 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7256 ST(0) = sv_newmortal();
7257 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7262 unixpath_fromperl(pTHX_ CV *cv)
7268 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7269 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7270 ST(0) = sv_newmortal();
7271 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7276 candelete_fromperl(pTHX_ CV *cv)
7279 char fspec[NAM$C_MAXRSS+1], *fsp;
7284 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7286 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7287 if (SvTYPE(mysv) == SVt_PVGV) {
7288 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7289 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7296 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7297 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7303 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7308 rmscopy_fromperl(pTHX_ CV *cv)
7311 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7313 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7314 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7315 unsigned long int sts;
7320 if (items < 2 || items > 3)
7321 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7323 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7324 if (SvTYPE(mysv) == SVt_PVGV) {
7325 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7326 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7333 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7334 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7339 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7340 if (SvTYPE(mysv) == SVt_PVGV) {
7341 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7342 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7349 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7350 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7355 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7357 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7363 mod2fname(pTHX_ CV *cv)
7366 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7367 workbuff[NAM$C_MAXRSS*1 + 1];
7368 int total_namelen = 3, counter, num_entries;
7369 /* ODS-5 ups this, but we want to be consistent, so... */
7370 int max_name_len = 39;
7371 AV *in_array = (AV *)SvRV(ST(0));
7373 num_entries = av_len(in_array);
7375 /* All the names start with PL_. */
7376 strcpy(ultimate_name, "PL_");
7378 /* Clean up our working buffer */
7379 Zero(work_name, sizeof(work_name), char);
7381 /* Run through the entries and build up a working name */
7382 for(counter = 0; counter <= num_entries; counter++) {
7383 /* If it's not the first name then tack on a __ */
7385 strcat(work_name, "__");
7387 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7391 /* Check to see if we actually have to bother...*/
7392 if (strlen(work_name) + 3 <= max_name_len) {
7393 strcat(ultimate_name, work_name);
7395 /* It's too darned big, so we need to go strip. We use the same */
7396 /* algorithm as xsubpp does. First, strip out doubled __ */
7397 char *source, *dest, last;
7400 for (source = work_name; *source; source++) {
7401 if (last == *source && last == '_') {
7407 /* Go put it back */
7408 strcpy(work_name, workbuff);
7409 /* Is it still too big? */
7410 if (strlen(work_name) + 3 > max_name_len) {
7411 /* Strip duplicate letters */
7414 for (source = work_name; *source; source++) {
7415 if (last == toupper(*source)) {
7419 last = toupper(*source);
7421 strcpy(work_name, workbuff);
7424 /* Is it *still* too big? */
7425 if (strlen(work_name) + 3 > max_name_len) {
7426 /* Too bad, we truncate */
7427 work_name[max_name_len - 2] = 0;
7429 strcat(ultimate_name, work_name);
7432 /* Okay, return it */
7433 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7438 hushexit_fromperl(pTHX_ CV *cv)
7443 VMSISH_HUSHED = SvTRUE(ST(0));
7445 ST(0) = boolSV(VMSISH_HUSHED);
7450 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7451 struct interp_intern *dst)
7453 memcpy(dst,src,sizeof(struct interp_intern));
7457 Perl_sys_intern_clear(pTHX)
7462 Perl_sys_intern_init(pTHX)
7464 unsigned int ix = RAND_MAX;
7470 MY_INV_RAND_MAX = 1./x;
7477 char* file = __FILE__;
7478 char temp_buff[512];
7479 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7480 no_translate_barewords = TRUE;
7482 no_translate_barewords = FALSE;
7485 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7486 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7487 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7488 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7489 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7490 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7491 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7492 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7493 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7494 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7495 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7497 store_pipelocs(aTHX); /* will redo any earlier attempts */