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, expand = 0;
3639 unsigned short int trnlnm_iter_count;
3641 if (spec == NULL) return NULL;
3642 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3643 if (buf) rslt = buf;
3645 retlen = strlen(spec);
3646 cp1 = strchr(spec,'[');
3647 if (!cp1) cp1 = strchr(spec,'<');
3649 for (cp1++; *cp1; cp1++) {
3650 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3651 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3652 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3655 New(1315,rslt,retlen+2+2*expand,char);
3657 else rslt = __tounixspec_retbuf;
3658 if (strchr(spec,'/') != NULL) {
3665 dirend = strrchr(spec,']');
3666 if (dirend == NULL) dirend = strrchr(spec,'>');
3667 if (dirend == NULL) dirend = strchr(spec,':');
3668 if (dirend == NULL) {
3672 if (*cp2 != '[' && *cp2 != '<') {
3675 else { /* the VMS spec begins with directories */
3677 if (*cp2 == ']' || *cp2 == '>') {
3678 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3681 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3682 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3683 if (ts) Safefree(rslt);
3686 trnlnm_iter_count = 0;
3689 while (*cp3 != ':' && *cp3) cp3++;
3691 if (strchr(cp3,']') != NULL) break;
3692 trnlnm_iter_count++;
3693 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3694 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3696 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3697 retlen = devlen + dirlen;
3698 Renew(rslt,retlen+1+2*expand,char);
3704 *(cp1++) = *(cp3++);
3705 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3709 else if ( *cp2 == '.') {
3710 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3711 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3717 for (; cp2 <= dirend; cp2++) {
3720 if (*(cp2+1) == '[') cp2++;
3722 else if (*cp2 == ']' || *cp2 == '>') {
3723 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3725 else if (*cp2 == '.') {
3727 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3728 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3729 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3730 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3731 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3733 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3734 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3738 else if (*cp2 == '-') {
3739 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3740 while (*cp2 == '-') {
3742 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3744 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3745 if (ts) Safefree(rslt); /* filespecs like */
3746 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3750 else *(cp1++) = *cp2;
3752 else *(cp1++) = *cp2;
3754 while (*cp2) *(cp1++) = *(cp2++);
3759 } /* end of do_tounixspec() */
3761 /* External entry points */
3762 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3763 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3765 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3766 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3767 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3768 char *rslt, *dirend;
3769 register char *cp1, *cp2;
3770 unsigned long int infront = 0, hasdir = 1;
3772 if (path == NULL) return NULL;
3773 if (buf) rslt = buf;
3774 else if (ts) New(1316,rslt,strlen(path)+9,char);
3775 else rslt = __tovmsspec_retbuf;
3776 if (strpbrk(path,"]:>") ||
3777 (dirend = strrchr(path,'/')) == NULL) {
3778 if (path[0] == '.') {
3779 if (path[1] == '\0') strcpy(rslt,"[]");
3780 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3781 else strcpy(rslt,path); /* probably garbage */
3783 else strcpy(rslt,path);
3786 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3787 if (!*(dirend+2)) dirend +=2;
3788 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3789 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3794 char trndev[NAM$C_MAXRSS+1];
3798 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3800 if (!buf & ts) Renew(rslt,18,char);
3801 strcpy(rslt,"sys$disk:[000000]");
3804 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3806 islnm = my_trnlnm(rslt,trndev,0);
3807 trnend = islnm ? strlen(trndev) - 1 : 0;
3808 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3809 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3810 /* If the first element of the path is a logical name, determine
3811 * whether it has to be translated so we can add more directories. */
3812 if (!islnm || rooted) {
3815 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3819 if (cp2 != dirend) {
3820 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3821 strcpy(rslt,trndev);
3822 cp1 = rslt + trnend;
3835 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3836 cp2 += 2; /* skip over "./" - it's redundant */
3837 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3839 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3840 *(cp1++) = '-'; /* "../" --> "-" */
3843 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3844 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3845 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3846 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3849 if (cp2 > dirend) cp2 = dirend;
3851 else *(cp1++) = '.';
3853 for (; cp2 < dirend; cp2++) {
3855 if (*(cp2-1) == '/') continue;
3856 if (*(cp1-1) != '.') *(cp1++) = '.';
3859 else if (!infront && *cp2 == '.') {
3860 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3861 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3862 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3863 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3864 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3865 else { /* back up over previous directory name */
3867 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3868 if (*(cp1-1) == '[') {
3869 memcpy(cp1,"000000.",7);
3874 if (cp2 == dirend) break;
3876 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3877 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3878 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3879 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3881 *(cp1++) = '.'; /* Simulate trailing '/' */
3882 cp2 += 2; /* for loop will incr this to == dirend */
3884 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3886 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3889 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3890 if (*cp2 == '.') *(cp1++) = '_';
3891 else *(cp1++) = *cp2;
3895 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3896 if (hasdir) *(cp1++) = ']';
3897 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3898 while (*cp2) *(cp1++) = *(cp2++);
3903 } /* end of do_tovmsspec() */
3905 /* External entry points */
3906 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3907 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3909 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3910 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3911 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3913 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3915 if (path == NULL) return NULL;
3916 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3917 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3918 if (buf) return buf;
3920 vmslen = strlen(vmsified);
3921 New(1317,cp,vmslen+1,char);
3922 memcpy(cp,vmsified,vmslen);
3927 strcpy(__tovmspath_retbuf,vmsified);
3928 return __tovmspath_retbuf;
3931 } /* end of do_tovmspath() */
3933 /* External entry points */
3934 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3935 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3938 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3939 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3940 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3942 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3944 if (path == NULL) return NULL;
3945 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3946 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3947 if (buf) return buf;
3949 unixlen = strlen(unixified);
3950 New(1317,cp,unixlen+1,char);
3951 memcpy(cp,unixified,unixlen);
3956 strcpy(__tounixpath_retbuf,unixified);
3957 return __tounixpath_retbuf;
3960 } /* end of do_tounixpath() */
3962 /* External entry points */
3963 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3964 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3967 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3969 *****************************************************************************
3971 * Copyright (C) 1989-1994 by *
3972 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3974 * Permission is hereby granted for the reproduction of this software, *
3975 * on condition that this copyright notice is included in the reproduction, *
3976 * and that such reproduction is not for purposes of profit or material *
3979 * 27-Aug-1994 Modified for inclusion in perl5 *
3980 * by Charles Bailey bailey@newman.upenn.edu *
3981 *****************************************************************************
3985 * getredirection() is intended to aid in porting C programs
3986 * to VMS (Vax-11 C). The native VMS environment does not support
3987 * '>' and '<' I/O redirection, or command line wild card expansion,
3988 * or a command line pipe mechanism using the '|' AND background
3989 * command execution '&'. All of these capabilities are provided to any
3990 * C program which calls this procedure as the first thing in the
3992 * The piping mechanism will probably work with almost any 'filter' type
3993 * of program. With suitable modification, it may useful for other
3994 * portability problems as well.
3996 * Author: Mark Pizzolato mark@infocomm.com
4000 struct list_item *next;
4004 static void add_item(struct list_item **head,
4005 struct list_item **tail,
4009 static void mp_expand_wild_cards(pTHX_ char *item,
4010 struct list_item **head,
4011 struct list_item **tail,
4014 static int background_process(pTHX_ int argc, char **argv);
4016 static void pipe_and_fork(pTHX_ char **cmargv);
4018 /*{{{ void getredirection(int *ac, char ***av)*/
4020 mp_getredirection(pTHX_ int *ac, char ***av)
4022 * Process vms redirection arg's. Exit if any error is seen.
4023 * If getredirection() processes an argument, it is erased
4024 * from the vector. getredirection() returns a new argc and argv value.
4025 * In the event that a background command is requested (by a trailing "&"),
4026 * this routine creates a background subprocess, and simply exits the program.
4028 * Warning: do not try to simplify the code for vms. The code
4029 * presupposes that getredirection() is called before any data is
4030 * read from stdin or written to stdout.
4032 * Normal usage is as follows:
4038 * getredirection(&argc, &argv);
4042 int argc = *ac; /* Argument Count */
4043 char **argv = *av; /* Argument Vector */
4044 char *ap; /* Argument pointer */
4045 int j; /* argv[] index */
4046 int item_count = 0; /* Count of Items in List */
4047 struct list_item *list_head = 0; /* First Item in List */
4048 struct list_item *list_tail; /* Last Item in List */
4049 char *in = NULL; /* Input File Name */
4050 char *out = NULL; /* Output File Name */
4051 char *outmode = "w"; /* Mode to Open Output File */
4052 char *err = NULL; /* Error File Name */
4053 char *errmode = "w"; /* Mode to Open Error File */
4054 int cmargc = 0; /* Piped Command Arg Count */
4055 char **cmargv = NULL;/* Piped Command Arg Vector */
4058 * First handle the case where the last thing on the line ends with
4059 * a '&'. This indicates the desire for the command to be run in a
4060 * subprocess, so we satisfy that desire.
4063 if (0 == strcmp("&", ap))
4064 exit(background_process(aTHX_ --argc, argv));
4065 if (*ap && '&' == ap[strlen(ap)-1])
4067 ap[strlen(ap)-1] = '\0';
4068 exit(background_process(aTHX_ argc, argv));
4071 * Now we handle the general redirection cases that involve '>', '>>',
4072 * '<', and pipes '|'.
4074 for (j = 0; j < argc; ++j)
4076 if (0 == strcmp("<", argv[j]))
4080 fprintf(stderr,"No input file after < on command line");
4081 exit(LIB$_WRONUMARG);
4086 if ('<' == *(ap = argv[j]))
4091 if (0 == strcmp(">", ap))
4095 fprintf(stderr,"No output file after > on command line");
4096 exit(LIB$_WRONUMARG);
4115 fprintf(stderr,"No output file after > or >> on command line");
4116 exit(LIB$_WRONUMARG);
4120 if (('2' == *ap) && ('>' == ap[1]))
4137 fprintf(stderr,"No output file after 2> or 2>> on command line");
4138 exit(LIB$_WRONUMARG);
4142 if (0 == strcmp("|", argv[j]))
4146 fprintf(stderr,"No command into which to pipe on command line");
4147 exit(LIB$_WRONUMARG);
4149 cmargc = argc-(j+1);
4150 cmargv = &argv[j+1];
4154 if ('|' == *(ap = argv[j]))
4162 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4165 * Allocate and fill in the new argument vector, Some Unix's terminate
4166 * the list with an extra null pointer.
4168 New(1302, argv, item_count+1, char *);
4170 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4171 argv[j] = list_head->value;
4177 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4178 exit(LIB$_INVARGORD);
4180 pipe_and_fork(aTHX_ cmargv);
4183 /* Check for input from a pipe (mailbox) */
4185 if (in == NULL && 1 == isapipe(0))
4187 char mbxname[L_tmpnam];
4189 long int dvi_item = DVI$_DEVBUFSIZ;
4190 $DESCRIPTOR(mbxnam, "");
4191 $DESCRIPTOR(mbxdevnam, "");
4193 /* Input from a pipe, reopen it in binary mode to disable */
4194 /* carriage control processing. */
4196 fgetname(stdin, mbxname);
4197 mbxnam.dsc$a_pointer = mbxname;
4198 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4199 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4200 mbxdevnam.dsc$a_pointer = mbxname;
4201 mbxdevnam.dsc$w_length = sizeof(mbxname);
4202 dvi_item = DVI$_DEVNAM;
4203 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4204 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4207 freopen(mbxname, "rb", stdin);
4210 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4214 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4216 fprintf(stderr,"Can't open input file %s as stdin",in);
4219 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4221 fprintf(stderr,"Can't open output file %s as stdout",out);
4224 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4227 if (strcmp(err,"&1") == 0) {
4228 dup2(fileno(stdout), fileno(stderr));
4229 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4232 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4234 fprintf(stderr,"Can't open error file %s as stderr",err);
4238 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4242 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4245 #ifdef ARGPROC_DEBUG
4246 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4247 for (j = 0; j < *ac; ++j)
4248 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4250 /* Clear errors we may have hit expanding wildcards, so they don't
4251 show up in Perl's $! later */
4252 set_errno(0); set_vaxc_errno(1);
4253 } /* end of getredirection() */
4256 static void add_item(struct list_item **head,
4257 struct list_item **tail,
4263 New(1303,*head,1,struct list_item);
4267 New(1304,(*tail)->next,1,struct list_item);
4268 *tail = (*tail)->next;
4270 (*tail)->value = value;
4274 static void mp_expand_wild_cards(pTHX_ char *item,
4275 struct list_item **head,
4276 struct list_item **tail,
4280 unsigned long int context = 0;
4287 char vmsspec[NAM$C_MAXRSS+1];
4288 $DESCRIPTOR(filespec, "");
4289 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4290 $DESCRIPTOR(resultspec, "");
4291 unsigned long int zero = 0, sts;
4293 for (cp = item; *cp; cp++) {
4294 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4295 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4297 if (!*cp || isspace(*cp))
4299 add_item(head, tail, item, count);
4304 /* "double quoted" wild card expressions pass as is */
4305 /* From DCL that means using e.g.: */
4306 /* perl program """perl.*""" */
4307 item_len = strlen(item);
4308 if ( '"' == *item && '"' == item[item_len-1] )
4311 item[item_len-2] = '\0';
4312 add_item(head, tail, item, count);
4316 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4317 resultspec.dsc$b_class = DSC$K_CLASS_D;
4318 resultspec.dsc$a_pointer = NULL;
4319 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4320 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4321 if (!isunix || !filespec.dsc$a_pointer)
4322 filespec.dsc$a_pointer = item;
4323 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4325 * Only return version specs, if the caller specified a version
4327 had_version = strchr(item, ';');
4329 * Only return device and directory specs, if the caller specifed either.
4331 had_device = strchr(item, ':');
4332 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4334 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4335 &defaultspec, 0, 0, &zero))))
4340 New(1305,string,resultspec.dsc$w_length+1,char);
4341 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4342 string[resultspec.dsc$w_length] = '\0';
4343 if (NULL == had_version)
4344 *((char *)strrchr(string, ';')) = '\0';
4345 if ((!had_directory) && (had_device == NULL))
4347 if (NULL == (devdir = strrchr(string, ']')))
4348 devdir = strrchr(string, '>');
4349 strcpy(string, devdir + 1);
4352 * Be consistent with what the C RTL has already done to the rest of
4353 * the argv items and lowercase all of these names.
4355 for (c = string; *c; ++c)
4358 if (isunix) trim_unixpath(string,item,1);
4359 add_item(head, tail, string, count);
4362 if (sts != RMS$_NMF)
4364 set_vaxc_errno(sts);
4367 case RMS$_FNF: case RMS$_DNF:
4368 set_errno(ENOENT); break;
4370 set_errno(ENOTDIR); break;
4372 set_errno(ENODEV); break;
4373 case RMS$_FNM: case RMS$_SYN:
4374 set_errno(EINVAL); break;
4376 set_errno(EACCES); break;
4378 _ckvmssts_noperl(sts);
4382 add_item(head, tail, item, count);
4383 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4384 _ckvmssts_noperl(lib$find_file_end(&context));
4387 static int child_st[2];/* Event Flag set when child process completes */
4389 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4391 static unsigned long int exit_handler(int *status)
4395 if (0 == child_st[0])
4397 #ifdef ARGPROC_DEBUG
4398 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4400 fflush(stdout); /* Have to flush pipe for binary data to */
4401 /* terminate properly -- <tp@mccall.com> */
4402 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4403 sys$dassgn(child_chan);
4405 sys$synch(0, child_st);
4410 static void sig_child(int chan)
4412 #ifdef ARGPROC_DEBUG
4413 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4415 if (child_st[0] == 0)
4419 static struct exit_control_block exit_block =
4424 &exit_block.exit_status,
4429 pipe_and_fork(pTHX_ char **cmargv)
4432 struct dsc$descriptor_s *vmscmd;
4433 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4434 int sts, j, l, ismcr, quote, tquote = 0;
4436 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4437 vms_execfree(vmscmd);
4442 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4443 && toupper(*(q+2)) == 'R' && !*(q+3);
4445 while (q && l < MAX_DCL_LINE_LENGTH) {
4447 if (j > 0 && quote) {
4453 if (ismcr && j > 1) quote = 1;
4454 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4457 if (quote || tquote) {
4463 if ((quote||tquote) && *q == '"') {
4473 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4475 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4479 static int background_process(pTHX_ int argc, char **argv)
4481 char command[2048] = "$";
4482 $DESCRIPTOR(value, "");
4483 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4484 static $DESCRIPTOR(null, "NLA0:");
4485 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4487 $DESCRIPTOR(pidstr, "");
4489 unsigned long int flags = 17, one = 1, retsts;
4491 strcat(command, argv[0]);
4494 strcat(command, " \"");
4495 strcat(command, *(++argv));
4496 strcat(command, "\"");
4498 value.dsc$a_pointer = command;
4499 value.dsc$w_length = strlen(value.dsc$a_pointer);
4500 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4501 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4502 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4503 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4506 _ckvmssts_noperl(retsts);
4508 #ifdef ARGPROC_DEBUG
4509 PerlIO_printf(Perl_debug_log, "%s\n", command);
4511 sprintf(pidstring, "%08X", pid);
4512 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4513 pidstr.dsc$a_pointer = pidstring;
4514 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4515 lib$set_symbol(&pidsymbol, &pidstr);
4519 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4522 /* OS-specific initialization at image activation (not thread startup) */
4523 /* Older VAXC header files lack these constants */
4524 #ifndef JPI$_RIGHTS_SIZE
4525 # define JPI$_RIGHTS_SIZE 817
4527 #ifndef KGB$M_SUBSYSTEM
4528 # define KGB$M_SUBSYSTEM 0x8
4531 /*{{{void vms_image_init(int *, char ***)*/
4533 vms_image_init(int *argcp, char ***argvp)
4535 char eqv[LNM$C_NAMLENGTH+1] = "";
4536 unsigned int len, tabct = 8, tabidx = 0;
4537 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4538 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4539 unsigned short int dummy, rlen;
4540 struct dsc$descriptor_s **tabvec;
4541 #if defined(PERL_IMPLICIT_CONTEXT)
4544 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4545 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4546 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4549 #ifdef KILL_BY_SIGPRC
4550 (void) Perl_csighandler_init();
4553 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4554 _ckvmssts_noperl(iosb[0]);
4555 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4556 if (iprv[i]) { /* Running image installed with privs? */
4557 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4562 /* Rights identifiers might trigger tainting as well. */
4563 if (!will_taint && (rlen || rsz)) {
4564 while (rlen < rsz) {
4565 /* We didn't get all the identifiers on the first pass. Allocate a
4566 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4567 * were needed to hold all identifiers at time of last call; we'll
4568 * allocate that many unsigned long ints), and go back and get 'em.
4569 * If it gave us less than it wanted to despite ample buffer space,
4570 * something's broken. Is your system missing a system identifier?
4572 if (rsz <= jpilist[1].buflen) {
4573 /* Perl_croak accvios when used this early in startup. */
4574 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4575 rsz, (unsigned long) jpilist[1].buflen,
4576 "Check your rights database for corruption.\n");
4579 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4580 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4581 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4582 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4583 _ckvmssts_noperl(iosb[0]);
4585 mask = jpilist[1].bufadr;
4586 /* Check attribute flags for each identifier (2nd longword); protected
4587 * subsystem identifiers trigger tainting.
4589 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4590 if (mask[i] & KGB$M_SUBSYSTEM) {
4595 if (mask != rlst) Safefree(mask);
4597 /* We need to use this hack to tell Perl it should run with tainting,
4598 * since its tainting flag may be part of the PL_curinterp struct, which
4599 * hasn't been allocated when vms_image_init() is called.
4602 char **newargv, **oldargv;
4604 New(1320,newargv,(*argcp)+2,char *);
4605 newargv[0] = oldargv[0];
4606 New(1320,newargv[1],3,char);
4607 strcpy(newargv[1], "-T");
4608 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4610 newargv[*argcp] = NULL;
4611 /* We orphan the old argv, since we don't know where it's come from,
4612 * so we don't know how to free it.
4616 else { /* Did user explicitly request tainting? */
4618 char *cp, **av = *argvp;
4619 for (i = 1; i < *argcp; i++) {
4620 if (*av[i] != '-') break;
4621 for (cp = av[i]+1; *cp; cp++) {
4622 if (*cp == 'T') { will_taint = 1; break; }
4623 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4624 strchr("DFIiMmx",*cp)) break;
4626 if (will_taint) break;
4631 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4633 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4634 else if (tabidx >= tabct) {
4636 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4638 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4639 tabvec[tabidx]->dsc$w_length = 0;
4640 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4641 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4642 tabvec[tabidx]->dsc$a_pointer = NULL;
4643 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4645 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4647 getredirection(argcp,argvp);
4648 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
4650 # include <reentrancy.h>
4651 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4660 * Trim Unix-style prefix off filespec, so it looks like what a shell
4661 * glob expansion would return (i.e. from specified prefix on, not
4662 * full path). Note that returned filespec is Unix-style, regardless
4663 * of whether input filespec was VMS-style or Unix-style.
4665 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4666 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4667 * vector of options; at present, only bit 0 is used, and if set tells
4668 * trim unixpath to try the current default directory as a prefix when
4669 * presented with a possibly ambiguous ... wildcard.
4671 * Returns !=0 on success, with trimmed filespec replacing contents of
4672 * fspec, and 0 on failure, with contents of fpsec unchanged.
4674 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4676 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4678 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4679 *template, *base, *end, *cp1, *cp2;
4680 register int tmplen, reslen = 0, dirs = 0;
4682 if (!wildspec || !fspec) return 0;
4683 if (strpbrk(wildspec,"]>:") != NULL) {
4684 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4685 else template = unixwild;
4687 else template = wildspec;
4688 if (strpbrk(fspec,"]>:") != NULL) {
4689 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4690 else base = unixified;
4691 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4692 * check to see that final result fits into (isn't longer than) fspec */
4693 reslen = strlen(fspec);
4697 /* No prefix or absolute path on wildcard, so nothing to remove */
4698 if (!*template || *template == '/') {
4699 if (base == fspec) return 1;
4700 tmplen = strlen(unixified);
4701 if (tmplen > reslen) return 0; /* not enough space */
4702 /* Copy unixified resultant, including trailing NUL */
4703 memmove(fspec,unixified,tmplen+1);
4707 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4708 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4709 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4710 for (cp1 = end ;cp1 >= base; cp1--)
4711 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4713 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4717 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4718 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4719 int ells = 1, totells, segdirs, match;
4720 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4721 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4723 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4725 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4726 if (ellipsis == template && opts & 1) {
4727 /* Template begins with an ellipsis. Since we can't tell how many
4728 * directory names at the front of the resultant to keep for an
4729 * arbitrary starting point, we arbitrarily choose the current
4730 * default directory as a starting point. If it's there as a prefix,
4731 * clip it off. If not, fall through and act as if the leading
4732 * ellipsis weren't there (i.e. return shortest possible path that
4733 * could match template).
4735 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4736 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4737 if (_tolower(*cp1) != _tolower(*cp2)) break;
4738 segdirs = dirs - totells; /* Min # of dirs we must have left */
4739 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4740 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4741 memcpy(fspec,cp2+1,end - cp2);
4745 /* First off, back up over constant elements at end of path */
4747 for (front = end ; front >= base; front--)
4748 if (*front == '/' && !dirs--) { front++; break; }
4750 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4751 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4752 if (cp1 != '\0') return 0; /* Path too long. */
4754 *cp2 = '\0'; /* Pick up with memcpy later */
4755 lcfront = lcres + (front - base);
4756 /* Now skip over each ellipsis and try to match the path in front of it. */
4758 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4759 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4760 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4761 if (cp1 < template) break; /* template started with an ellipsis */
4762 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4763 ellipsis = cp1; continue;
4765 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4767 for (segdirs = 0, cp2 = tpl;
4768 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4770 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4771 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4772 if (*cp2 == '/') segdirs++;
4774 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4775 /* Back up at least as many dirs as in template before matching */
4776 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4777 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4778 for (match = 0; cp1 > lcres;) {
4779 resdsc.dsc$a_pointer = cp1;
4780 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4782 if (match == 1) lcfront = cp1;
4784 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4786 if (!match) return 0; /* Can't find prefix ??? */
4787 if (match > 1 && opts & 1) {
4788 /* This ... wildcard could cover more than one set of dirs (i.e.
4789 * a set of similar dir names is repeated). If the template
4790 * contains more than 1 ..., upstream elements could resolve the
4791 * ambiguity, but it's not worth a full backtracking setup here.
4792 * As a quick heuristic, clip off the current default directory
4793 * if it's present to find the trimmed spec, else use the
4794 * shortest string that this ... could cover.
4796 char def[NAM$C_MAXRSS+1], *st;
4798 if (getcwd(def, sizeof def,0) == NULL) return 0;
4799 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4800 if (_tolower(*cp1) != _tolower(*cp2)) break;
4801 segdirs = dirs - totells; /* Min # of dirs we must have left */
4802 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4803 if (*cp1 == '\0' && *cp2 == '/') {
4804 memcpy(fspec,cp2+1,end - cp2);
4807 /* Nope -- stick with lcfront from above and keep going. */
4810 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4815 } /* end of trim_unixpath() */
4820 * VMS readdir() routines.
4821 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4823 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4824 * Minor modifications to original routines.
4827 /* readdir may have been redefined by reentr.h, so make sure we get
4828 * the local version for what we do here.
4833 #if !defined(PERL_IMPLICIT_CONTEXT)
4834 # define readdir Perl_readdir
4836 # define readdir(a) Perl_readdir(aTHX_ a)
4839 /* Number of elements in vms_versions array */
4840 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4843 * Open a directory, return a handle for later use.
4845 /*{{{ DIR *opendir(char*name) */
4847 Perl_opendir(pTHX_ char *name)
4850 char dir[NAM$C_MAXRSS+1];
4853 if (do_tovmspath(name,dir,0) == NULL) {
4856 /* Check access before stat; otherwise stat does not
4857 * accurately report whether it's a directory.
4859 if (!cando_by_name(S_IRUSR,0,dir)) {
4860 /* cando_by_name has already set errno */
4863 if (flex_stat(dir,&sb) == -1) return NULL;
4864 if (!S_ISDIR(sb.st_mode)) {
4865 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4868 /* Get memory for the handle, and the pattern. */
4870 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4872 /* Fill in the fields; mainly playing with the descriptor. */
4873 (void)sprintf(dd->pattern, "%s*.*",dir);
4876 dd->vms_wantversions = 0;
4877 dd->pat.dsc$a_pointer = dd->pattern;
4878 dd->pat.dsc$w_length = strlen(dd->pattern);
4879 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4880 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4881 #if defined(USE_ITHREADS)
4882 New(1308,dd->mutex,1,perl_mutex);
4883 MUTEX_INIT( (perl_mutex *) dd->mutex );
4889 } /* end of opendir() */
4893 * Set the flag to indicate we want versions or not.
4895 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4897 vmsreaddirversions(DIR *dd, int flag)
4899 dd->vms_wantversions = flag;
4904 * Free up an opened directory.
4906 /*{{{ void closedir(DIR *dd)*/
4910 (void)lib$find_file_end(&dd->context);
4911 Safefree(dd->pattern);
4912 #if defined(USE_ITHREADS)
4913 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
4914 Safefree(dd->mutex);
4916 Safefree((char *)dd);
4921 * Collect all the version numbers for the current file.
4924 collectversions(pTHX_ DIR *dd)
4926 struct dsc$descriptor_s pat;
4927 struct dsc$descriptor_s res;
4929 char *p, *text, buff[sizeof dd->entry.d_name];
4931 unsigned long context, tmpsts;
4933 /* Convenient shorthand. */
4936 /* Add the version wildcard, ignoring the "*.*" put on before */
4937 i = strlen(dd->pattern);
4938 New(1308,text,i + e->d_namlen + 3,char);
4939 (void)strcpy(text, dd->pattern);
4940 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4942 /* Set up the pattern descriptor. */
4943 pat.dsc$a_pointer = text;
4944 pat.dsc$w_length = i + e->d_namlen - 1;
4945 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4946 pat.dsc$b_class = DSC$K_CLASS_S;
4948 /* Set up result descriptor. */
4949 res.dsc$a_pointer = buff;
4950 res.dsc$w_length = sizeof buff - 2;
4951 res.dsc$b_dtype = DSC$K_DTYPE_T;
4952 res.dsc$b_class = DSC$K_CLASS_S;
4954 /* Read files, collecting versions. */
4955 for (context = 0, e->vms_verscount = 0;
4956 e->vms_verscount < VERSIZE(e);
4957 e->vms_verscount++) {
4958 tmpsts = lib$find_file(&pat, &res, &context);
4959 if (tmpsts == RMS$_NMF || context == 0) break;
4961 buff[sizeof buff - 1] = '\0';
4962 if ((p = strchr(buff, ';')))
4963 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4965 e->vms_versions[e->vms_verscount] = -1;
4968 _ckvmssts(lib$find_file_end(&context));
4971 } /* end of collectversions() */
4974 * Read the next entry from the directory.
4976 /*{{{ struct dirent *readdir(DIR *dd)*/
4978 Perl_readdir(pTHX_ DIR *dd)
4980 struct dsc$descriptor_s res;
4981 char *p, buff[sizeof dd->entry.d_name];
4982 unsigned long int tmpsts;
4984 /* Set up result descriptor, and get next file. */
4985 res.dsc$a_pointer = buff;
4986 res.dsc$w_length = sizeof buff - 2;
4987 res.dsc$b_dtype = DSC$K_DTYPE_T;
4988 res.dsc$b_class = DSC$K_CLASS_S;
4989 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4990 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4991 if (!(tmpsts & 1)) {
4992 set_vaxc_errno(tmpsts);
4995 set_errno(EACCES); break;
4997 set_errno(ENODEV); break;
4999 set_errno(ENOTDIR); break;
5000 case RMS$_FNF: case RMS$_DNF:
5001 set_errno(ENOENT); break;
5008 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
5009 buff[sizeof buff - 1] = '\0';
5010 for (p = buff; *p; p++) *p = _tolower(*p);
5011 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
5014 /* Skip any directory component and just copy the name. */
5015 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
5016 else (void)strcpy(dd->entry.d_name, buff);
5018 /* Clobber the version. */
5019 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
5021 dd->entry.d_namlen = strlen(dd->entry.d_name);
5022 dd->entry.vms_verscount = 0;
5023 if (dd->vms_wantversions) collectversions(aTHX_ dd);
5026 } /* end of readdir() */
5030 * Read the next entry from the directory -- thread-safe version.
5032 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
5034 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
5038 MUTEX_LOCK( (perl_mutex *) dd->mutex );
5040 entry = readdir(dd);
5042 retval = ( *result == NULL ? errno : 0 );
5044 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
5048 } /* end of readdir_r() */
5052 * Return something that can be used in a seekdir later.
5054 /*{{{ long telldir(DIR *dd)*/
5063 * Return to a spot where we used to be. Brute force.
5065 /*{{{ void seekdir(DIR *dd,long count)*/
5067 Perl_seekdir(pTHX_ DIR *dd, long count)
5069 int vms_wantversions;
5071 /* If we haven't done anything yet... */
5075 /* Remember some state, and clear it. */
5076 vms_wantversions = dd->vms_wantversions;
5077 dd->vms_wantversions = 0;
5078 _ckvmssts(lib$find_file_end(&dd->context));
5081 /* The increment is in readdir(). */
5082 for (dd->count = 0; dd->count < count; )
5085 dd->vms_wantversions = vms_wantversions;
5087 } /* end of seekdir() */
5090 /* VMS subprocess management
5092 * my_vfork() - just a vfork(), after setting a flag to record that
5093 * the current script is trying a Unix-style fork/exec.
5095 * vms_do_aexec() and vms_do_exec() are called in response to the
5096 * perl 'exec' function. If this follows a vfork call, then they
5097 * call out the regular perl routines in doio.c which do an
5098 * execvp (for those who really want to try this under VMS).
5099 * Otherwise, they do exactly what the perl docs say exec should
5100 * do - terminate the current script and invoke a new command
5101 * (See below for notes on command syntax.)
5103 * do_aspawn() and do_spawn() implement the VMS side of the perl
5104 * 'system' function.
5106 * Note on command arguments to perl 'exec' and 'system': When handled
5107 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
5108 * are concatenated to form a DCL command string. If the first arg
5109 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
5110 * the command string is handed off to DCL directly. Otherwise,
5111 * the first token of the command is taken as the filespec of an image
5112 * to run. The filespec is expanded using a default type of '.EXE' and
5113 * the process defaults for device, directory, etc., and if found, the resultant
5114 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
5115 * the command string as parameters. This is perhaps a bit complicated,
5116 * but I hope it will form a happy medium between what VMS folks expect
5117 * from lib$spawn and what Unix folks expect from exec.
5120 static int vfork_called;
5122 /*{{{int my_vfork()*/
5133 vms_execfree(struct dsc$descriptor_s *vmscmd)
5136 if (vmscmd->dsc$a_pointer) {
5137 Safefree(vmscmd->dsc$a_pointer);
5144 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
5146 char *junk, *tmps = Nullch;
5147 register size_t cmdlen = 0;
5154 tmps = SvPV(really,rlen);
5161 for (idx++; idx <= sp; idx++) {
5163 junk = SvPVx(*idx,rlen);
5164 cmdlen += rlen ? rlen + 1 : 0;
5167 New(401,PL_Cmd,cmdlen+1,char);
5169 if (tmps && *tmps) {
5170 strcpy(PL_Cmd,tmps);
5173 else *PL_Cmd = '\0';
5174 while (++mark <= sp) {
5176 char *s = SvPVx(*mark,n_a);
5178 if (*PL_Cmd) strcat(PL_Cmd," ");
5184 } /* end of setup_argstr() */
5187 static unsigned long int
5188 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5189 struct dsc$descriptor_s **pvmscmd)
5191 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5192 $DESCRIPTOR(defdsc,".EXE");
5193 $DESCRIPTOR(defdsc2,".");
5194 $DESCRIPTOR(resdsc,resspec);
5195 struct dsc$descriptor_s *vmscmd;
5196 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5197 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5198 register char *s, *rest, *cp, *wordbreak;
5201 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5202 vmscmd->dsc$a_pointer = NULL;
5203 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5204 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5205 vmscmd->dsc$w_length = 0;
5206 if (pvmscmd) *pvmscmd = vmscmd;
5208 if (suggest_quote) *suggest_quote = 0;
5210 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5211 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5213 while (*s && isspace(*s)) s++;
5215 if (*s == '@' || *s == '$') {
5216 vmsspec[0] = *s; rest = s + 1;
5217 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5219 else { cp = vmsspec; rest = s; }
5220 if (*rest == '.' || *rest == '/') {
5223 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5224 rest++, cp2++) *cp2 = *rest;
5226 if (do_tovmsspec(resspec,cp,0)) {
5229 for (cp2 = vmsspec + strlen(vmsspec);
5230 *rest && cp2 - vmsspec < sizeof vmsspec;
5231 rest++, cp2++) *cp2 = *rest;
5236 /* Intuit whether verb (first word of cmd) is a DCL command:
5237 * - if first nonspace char is '@', it's a DCL indirection
5239 * - if verb contains a filespec separator, it's not a DCL command
5240 * - if it doesn't, caller tells us whether to default to a DCL
5241 * command, or to a local image unless told it's DCL (by leading '$')
5245 if (suggest_quote) *suggest_quote = 1;
5247 register char *filespec = strpbrk(s,":<[.;");
5248 rest = wordbreak = strpbrk(s," \"\t/");
5249 if (!wordbreak) wordbreak = s + strlen(s);
5250 if (*s == '$') check_img = 0;
5251 if (filespec && (filespec < wordbreak)) isdcl = 0;
5252 else isdcl = !check_img;
5256 imgdsc.dsc$a_pointer = s;
5257 imgdsc.dsc$w_length = wordbreak - s;
5258 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5260 _ckvmssts(lib$find_file_end(&cxt));
5261 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5262 if (!(retsts & 1) && *s == '$') {
5263 _ckvmssts(lib$find_file_end(&cxt));
5264 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5267 _ckvmssts(lib$find_file_end(&cxt));
5268 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5272 _ckvmssts(lib$find_file_end(&cxt));
5277 while (*s && !isspace(*s)) s++;
5280 /* check that it's really not DCL with no file extension */
5281 fp = fopen(resspec,"r","ctx=bin,shr=get");
5283 char b[4] = {0,0,0,0};
5284 read(fileno(fp),b,4);
5285 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5288 if (check_img && isdcl) return RMS$_FNF;
5290 if (cando_by_name(S_IXUSR,0,resspec)) {
5291 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5293 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5294 if (suggest_quote) *suggest_quote = 1;
5296 strcpy(vmscmd->dsc$a_pointer,"@");
5297 if (suggest_quote) *suggest_quote = 1;
5299 strcat(vmscmd->dsc$a_pointer,resspec);
5300 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5301 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5302 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5304 else retsts = RMS$_PRV;
5307 /* It's either a DCL command or we couldn't find a suitable image */
5308 vmscmd->dsc$w_length = strlen(cmd);
5309 /* if (cmd == PL_Cmd) {
5310 vmscmd->dsc$a_pointer = PL_Cmd;
5311 if (suggest_quote) *suggest_quote = 1;
5314 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5316 /* check if it's a symbol (for quoting purposes) */
5317 if (suggest_quote && !*suggest_quote) {
5319 char equiv[LNM$C_NAMLENGTH];
5320 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5321 eqvdsc.dsc$a_pointer = equiv;
5323 iss = lib$get_symbol(vmscmd,&eqvdsc);
5324 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5326 if (!(retsts & 1)) {
5327 /* just hand off status values likely to be due to user error */
5328 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5329 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5330 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5331 else { _ckvmssts(retsts); }
5334 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5336 } /* end of setup_cmddsc() */
5339 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5341 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5344 if (vfork_called) { /* this follows a vfork - act Unixish */
5346 if (vfork_called < 0) {
5347 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5350 else return do_aexec(really,mark,sp);
5352 /* no vfork - act VMSish */
5353 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5358 } /* end of vms_do_aexec() */
5361 /* {{{bool vms_do_exec(char *cmd) */
5363 Perl_vms_do_exec(pTHX_ char *cmd)
5365 struct dsc$descriptor_s *vmscmd;
5367 if (vfork_called) { /* this follows a vfork - act Unixish */
5369 if (vfork_called < 0) {
5370 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5373 else return do_exec(cmd);
5376 { /* no vfork - act VMSish */
5377 unsigned long int retsts;
5380 TAINT_PROPER("exec");
5381 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5382 retsts = lib$do_command(vmscmd);
5385 case RMS$_FNF: case RMS$_DNF:
5386 set_errno(ENOENT); break;
5388 set_errno(ENOTDIR); break;
5390 set_errno(ENODEV); break;
5392 set_errno(EACCES); break;
5394 set_errno(EINVAL); break;
5395 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5396 set_errno(E2BIG); break;
5397 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5398 _ckvmssts(retsts); /* fall through */
5399 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5402 set_vaxc_errno(retsts);
5403 if (ckWARN(WARN_EXEC)) {
5404 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5405 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5407 vms_execfree(vmscmd);
5412 } /* end of vms_do_exec() */
5415 unsigned long int Perl_do_spawn(pTHX_ char *);
5417 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5419 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5421 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5424 } /* end of do_aspawn() */
5427 /* {{{unsigned long int do_spawn(char *cmd) */
5429 Perl_do_spawn(pTHX_ char *cmd)
5431 unsigned long int sts, substs;
5434 TAINT_PROPER("spawn");
5435 if (!cmd || !*cmd) {
5436 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5439 case RMS$_FNF: case RMS$_DNF:
5440 set_errno(ENOENT); break;
5442 set_errno(ENOTDIR); break;
5444 set_errno(ENODEV); break;
5446 set_errno(EACCES); break;
5448 set_errno(EINVAL); break;
5449 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5450 set_errno(E2BIG); break;
5451 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5452 _ckvmssts(sts); /* fall through */
5453 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5456 set_vaxc_errno(sts);
5457 if (ckWARN(WARN_EXEC)) {
5458 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5465 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5468 } /* end of do_spawn() */
5472 static unsigned int *sockflags, sockflagsize;
5475 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5476 * routines found in some versions of the CRTL can't deal with sockets.
5477 * We don't shim the other file open routines since a socket isn't
5478 * likely to be opened by a name.
5480 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5481 FILE *my_fdopen(int fd, const char *mode)
5483 FILE *fp = fdopen(fd, (char *) mode);
5486 unsigned int fdoff = fd / sizeof(unsigned int);
5487 struct stat sbuf; /* native stat; we don't need flex_stat */
5488 if (!sockflagsize || fdoff > sockflagsize) {
5489 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5490 else New (1324,sockflags,fdoff+2,unsigned int);
5491 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5492 sockflagsize = fdoff + 2;
5494 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5495 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5504 * Clear the corresponding bit when the (possibly) socket stream is closed.
5505 * There still a small hole: we miss an implicit close which might occur
5506 * via freopen(). >> Todo
5508 /*{{{ int my_fclose(FILE *fp)*/
5509 int my_fclose(FILE *fp) {
5511 unsigned int fd = fileno(fp);
5512 unsigned int fdoff = fd / sizeof(unsigned int);
5514 if (sockflagsize && fdoff <= sockflagsize)
5515 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5523 * A simple fwrite replacement which outputs itmsz*nitm chars without
5524 * introducing record boundaries every itmsz chars.
5525 * We are using fputs, which depends on a terminating null. We may
5526 * well be writing binary data, so we need to accommodate not only
5527 * data with nulls sprinkled in the middle but also data with no null
5530 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5532 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5534 register char *cp, *end, *cpd, *data;
5535 register unsigned int fd = fileno(dest);
5536 register unsigned int fdoff = fd / sizeof(unsigned int);
5538 int bufsize = itmsz * nitm + 1;
5540 if (fdoff < sockflagsize &&
5541 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5542 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5546 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5547 memcpy( data, src, itmsz*nitm );
5548 data[itmsz*nitm] = '\0';
5550 end = data + itmsz * nitm;
5551 retval = (int) nitm; /* on success return # items written */
5554 while (cpd <= end) {
5555 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5556 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5558 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5562 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5565 } /* end of my_fwrite() */
5568 /*{{{ int my_flush(FILE *fp)*/
5570 Perl_my_flush(pTHX_ FILE *fp)
5573 if ((res = fflush(fp)) == 0 && fp) {
5574 #ifdef VMS_DO_SOCKETS
5576 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5578 res = fsync(fileno(fp));
5581 * If the flush succeeded but set end-of-file, we need to clear
5582 * the error because our caller may check ferror(). BTW, this
5583 * probably means we just flushed an empty file.
5585 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5592 * Here are replacements for the following Unix routines in the VMS environment:
5593 * getpwuid Get information for a particular UIC or UID
5594 * getpwnam Get information for a named user
5595 * getpwent Get information for each user in the rights database
5596 * setpwent Reset search to the start of the rights database
5597 * endpwent Finish searching for users in the rights database
5599 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5600 * (defined in pwd.h), which contains the following fields:-
5602 * char *pw_name; Username (in lower case)
5603 * char *pw_passwd; Hashed password
5604 * unsigned int pw_uid; UIC
5605 * unsigned int pw_gid; UIC group number
5606 * char *pw_unixdir; Default device/directory (VMS-style)
5607 * char *pw_gecos; Owner name
5608 * char *pw_dir; Default device/directory (Unix-style)
5609 * char *pw_shell; Default CLI name (eg. DCL)
5611 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5613 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5614 * not the UIC member number (eg. what's returned by getuid()),
5615 * getpwuid() can accept either as input (if uid is specified, the caller's
5616 * UIC group is used), though it won't recognise gid=0.
5618 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5619 * information about other users in your group or in other groups, respectively.
5620 * If the required privilege is not available, then these routines fill only
5621 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5624 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5627 /* sizes of various UAF record fields */
5628 #define UAI$S_USERNAME 12
5629 #define UAI$S_IDENT 31
5630 #define UAI$S_OWNER 31
5631 #define UAI$S_DEFDEV 31
5632 #define UAI$S_DEFDIR 63
5633 #define UAI$S_DEFCLI 31
5636 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5637 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5638 (uic).uic$v_group != UIC$K_WILD_GROUP)
5640 static char __empty[]= "";
5641 static struct passwd __passwd_empty=
5642 {(char *) __empty, (char *) __empty, 0, 0,
5643 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5644 static int contxt= 0;
5645 static struct passwd __pwdcache;
5646 static char __pw_namecache[UAI$S_IDENT+1];
5649 * This routine does most of the work extracting the user information.
5651 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5654 unsigned char length;
5655 char pw_gecos[UAI$S_OWNER+1];
5657 static union uicdef uic;
5659 unsigned char length;
5660 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5663 unsigned char length;
5664 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5667 unsigned char length;
5668 char pw_shell[UAI$S_DEFCLI+1];
5670 static char pw_passwd[UAI$S_PWD+1];
5672 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5673 struct dsc$descriptor_s name_desc;
5674 unsigned long int sts;
5676 static struct itmlst_3 itmlst[]= {
5677 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5678 {sizeof(uic), UAI$_UIC, &uic, &luic},
5679 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5680 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5681 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5682 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5683 {0, 0, NULL, NULL}};
5685 name_desc.dsc$w_length= strlen(name);
5686 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5687 name_desc.dsc$b_class= DSC$K_CLASS_S;
5688 name_desc.dsc$a_pointer= (char *) name;
5690 /* Note that sys$getuai returns many fields as counted strings. */
5691 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5692 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5693 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5695 else { _ckvmssts(sts); }
5696 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5698 if ((int) owner.length < lowner) lowner= (int) owner.length;
5699 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5700 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5701 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5702 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5703 owner.pw_gecos[lowner]= '\0';
5704 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5705 defcli.pw_shell[ldefcli]= '\0';
5706 if (valid_uic(uic)) {
5707 pwd->pw_uid= uic.uic$l_uic;
5708 pwd->pw_gid= uic.uic$v_group;
5711 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5712 pwd->pw_passwd= pw_passwd;
5713 pwd->pw_gecos= owner.pw_gecos;
5714 pwd->pw_dir= defdev.pw_dir;
5715 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5716 pwd->pw_shell= defcli.pw_shell;
5717 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5719 ldir= strlen(pwd->pw_unixdir) - 1;
5720 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5723 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5724 __mystrtolower(pwd->pw_unixdir);
5729 * Get information for a named user.
5731 /*{{{struct passwd *getpwnam(char *name)*/
5732 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5734 struct dsc$descriptor_s name_desc;
5736 unsigned long int status, sts;
5738 __pwdcache = __passwd_empty;
5739 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5740 /* We still may be able to determine pw_uid and pw_gid */
5741 name_desc.dsc$w_length= strlen(name);
5742 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5743 name_desc.dsc$b_class= DSC$K_CLASS_S;
5744 name_desc.dsc$a_pointer= (char *) name;
5745 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5746 __pwdcache.pw_uid= uic.uic$l_uic;
5747 __pwdcache.pw_gid= uic.uic$v_group;
5750 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5751 set_vaxc_errno(sts);
5752 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5755 else { _ckvmssts(sts); }
5758 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5759 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5760 __pwdcache.pw_name= __pw_namecache;
5762 } /* end of my_getpwnam() */
5766 * Get information for a particular UIC or UID.
5767 * Called by my_getpwent with uid=-1 to list all users.
5769 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5770 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5772 const $DESCRIPTOR(name_desc,__pw_namecache);
5773 unsigned short lname;
5775 unsigned long int status;
5777 if (uid == (unsigned int) -1) {
5779 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5780 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5781 set_vaxc_errno(status);
5782 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5786 else { _ckvmssts(status); }
5787 } while (!valid_uic (uic));
5791 if (!uic.uic$v_group)
5792 uic.uic$v_group= PerlProc_getgid();
5794 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5795 else status = SS$_IVIDENT;
5796 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5797 status == RMS$_PRV) {
5798 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5801 else { _ckvmssts(status); }
5803 __pw_namecache[lname]= '\0';
5804 __mystrtolower(__pw_namecache);
5806 __pwdcache = __passwd_empty;
5807 __pwdcache.pw_name = __pw_namecache;
5809 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5810 The identifier's value is usually the UIC, but it doesn't have to be,
5811 so if we can, we let fillpasswd update this. */
5812 __pwdcache.pw_uid = uic.uic$l_uic;
5813 __pwdcache.pw_gid = uic.uic$v_group;
5815 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5818 } /* end of my_getpwuid() */
5822 * Get information for next user.
5824 /*{{{struct passwd *my_getpwent()*/
5825 struct passwd *Perl_my_getpwent(pTHX)
5827 return (my_getpwuid((unsigned int) -1));
5832 * Finish searching rights database for users.
5834 /*{{{void my_endpwent()*/
5835 void Perl_my_endpwent(pTHX)
5838 _ckvmssts(sys$finish_rdb(&contxt));
5844 #ifdef HOMEGROWN_POSIX_SIGNALS
5845 /* Signal handling routines, pulled into the core from POSIX.xs.
5847 * We need these for threads, so they've been rolled into the core,
5848 * rather than left in POSIX.xs.
5850 * (DRS, Oct 23, 1997)
5853 /* sigset_t is atomic under VMS, so these routines are easy */
5854 /*{{{int my_sigemptyset(sigset_t *) */
5855 int my_sigemptyset(sigset_t *set) {
5856 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5862 /*{{{int my_sigfillset(sigset_t *)*/
5863 int my_sigfillset(sigset_t *set) {
5865 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5866 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5872 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5873 int my_sigaddset(sigset_t *set, int sig) {
5874 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5875 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5876 *set |= (1 << (sig - 1));
5882 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5883 int my_sigdelset(sigset_t *set, int sig) {
5884 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5885 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5886 *set &= ~(1 << (sig - 1));
5892 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5893 int my_sigismember(sigset_t *set, int sig) {
5894 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5895 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5896 return *set & (1 << (sig - 1));
5901 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5902 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5905 /* If set and oset are both null, then things are badly wrong. Bail out. */
5906 if ((oset == NULL) && (set == NULL)) {
5907 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5911 /* If set's null, then we're just handling a fetch. */
5913 tempmask = sigblock(0);
5918 tempmask = sigsetmask(*set);
5921 tempmask = sigblock(*set);
5924 tempmask = sigblock(0);
5925 sigsetmask(*oset & ~tempmask);
5928 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5933 /* Did they pass us an oset? If so, stick our holding mask into it */
5940 #endif /* HOMEGROWN_POSIX_SIGNALS */
5943 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5944 * my_utime(), and flex_stat(), all of which operate on UTC unless
5945 * VMSISH_TIMES is true.
5947 /* method used to handle UTC conversions:
5948 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5950 static int gmtime_emulation_type;
5951 /* number of secs to add to UTC POSIX-style time to get local time */
5952 static long int utc_offset_secs;
5954 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5955 * in vmsish.h. #undef them here so we can call the CRTL routines
5964 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5965 * qualifier with the extern prefix pragma. This provisional
5966 * hack circumvents this prefix pragma problem in previous
5969 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5970 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5971 # pragma __extern_prefix save
5972 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5973 # define gmtime decc$__utctz_gmtime
5974 # define localtime decc$__utctz_localtime
5975 # define time decc$__utc_time
5976 # pragma __extern_prefix restore
5978 struct tm *gmtime(), *localtime();
5984 static time_t toutc_dst(time_t loc) {
5987 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5988 loc -= utc_offset_secs;
5989 if (rsltmp->tm_isdst) loc -= 3600;
5992 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5993 ((gmtime_emulation_type || my_time(NULL)), \
5994 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5995 ((secs) - utc_offset_secs))))
5997 static time_t toloc_dst(time_t utc) {
6000 utc += utc_offset_secs;
6001 if ((rsltmp = localtime(&utc)) == NULL) return -1;
6002 if (rsltmp->tm_isdst) utc += 3600;
6005 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
6006 ((gmtime_emulation_type || my_time(NULL)), \
6007 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
6008 ((secs) + utc_offset_secs))))
6010 #ifndef RTL_USES_UTC
6013 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
6014 DST starts on 1st sun of april at 02:00 std time
6015 ends on last sun of october at 02:00 dst time
6016 see the UCX management command reference, SET CONFIG TIMEZONE
6017 for formatting info.
6019 No, it's not as general as it should be, but then again, NOTHING
6020 will handle UK times in a sensible way.
6025 parse the DST start/end info:
6026 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
6030 tz_parse_startend(char *s, struct tm *w, int *past)
6032 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
6033 int ly, dozjd, d, m, n, hour, min, sec, j, k;
6038 if (!past) return 0;
6041 if (w->tm_year % 4 == 0) ly = 1;
6042 if (w->tm_year % 100 == 0) ly = 0;
6043 if (w->tm_year+1900 % 400 == 0) ly = 1;
6046 dozjd = isdigit(*s);
6047 if (*s == 'J' || *s == 'j' || dozjd) {
6048 if (!dozjd && !isdigit(*++s)) return 0;
6051 d = d*10 + *s++ - '0';
6053 d = d*10 + *s++ - '0';
6056 if (d == 0) return 0;
6057 if (d > 366) return 0;
6059 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
6062 } else if (*s == 'M' || *s == 'm') {
6063 if (!isdigit(*++s)) return 0;
6065 if (isdigit(*s)) m = 10*m + *s++ - '0';
6066 if (*s != '.') return 0;
6067 if (!isdigit(*++s)) return 0;
6069 if (n < 1 || n > 5) return 0;
6070 if (*s != '.') return 0;
6071 if (!isdigit(*++s)) return 0;
6073 if (d > 6) return 0;
6077 if (!isdigit(*++s)) return 0;
6079 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
6081 if (!isdigit(*++s)) return 0;
6083 if (isdigit(*s)) min = 10*min + *s++ - '0';
6085 if (!isdigit(*++s)) return 0;
6087 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
6097 if (w->tm_yday < d) goto before;
6098 if (w->tm_yday > d) goto after;
6100 if (w->tm_mon+1 < m) goto before;
6101 if (w->tm_mon+1 > m) goto after;
6103 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
6104 k = d - j; /* mday of first d */
6106 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
6107 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
6108 if (w->tm_mday < k) goto before;
6109 if (w->tm_mday > k) goto after;
6112 if (w->tm_hour < hour) goto before;
6113 if (w->tm_hour > hour) goto after;
6114 if (w->tm_min < min) goto before;
6115 if (w->tm_min > min) goto after;
6116 if (w->tm_sec < sec) goto before;
6130 /* parse the offset: (+|-)hh[:mm[:ss]] */
6133 tz_parse_offset(char *s, int *offset)
6135 int hour = 0, min = 0, sec = 0;
6138 if (!offset) return 0;
6140 if (*s == '-') {neg++; s++;}
6142 if (!isdigit(*s)) return 0;
6144 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
6145 if (hour > 24) return 0;
6147 if (!isdigit(*++s)) return 0;
6149 if (isdigit(*s)) min = min*10 + (*s++ - '0');
6150 if (min > 59) return 0;
6152 if (!isdigit(*++s)) return 0;
6154 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
6155 if (sec > 59) return 0;
6159 *offset = (hour*60+min)*60 + sec;
6160 if (neg) *offset = -*offset;
6165 input time is w, whatever type of time the CRTL localtime() uses.
6166 sets dst, the zone, and the gmtoff (seconds)
6168 caches the value of TZ and UCX$TZ env variables; note that
6169 my_setenv looks for these and sets a flag if they're changed
6172 We have to watch out for the "australian" case (dst starts in
6173 october, ends in april)...flagged by "reverse" and checked by
6174 scanning through the months of the previous year.
6179 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6184 char *dstzone, *tz, *s_start, *s_end;
6185 int std_off, dst_off, isdst;
6186 int y, dststart, dstend;
6187 static char envtz[1025]; /* longer than any logical, symbol, ... */
6188 static char ucxtz[1025];
6189 static char reversed = 0;
6195 reversed = -1; /* flag need to check */
6196 envtz[0] = ucxtz[0] = '\0';
6197 tz = my_getenv("TZ",0);
6198 if (tz) strcpy(envtz, tz);
6199 tz = my_getenv("UCX$TZ",0);
6200 if (tz) strcpy(ucxtz, tz);
6201 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6204 if (!*tz) tz = ucxtz;
6207 while (isalpha(*s)) s++;
6208 s = tz_parse_offset(s, &std_off);
6210 if (!*s) { /* no DST, hurray we're done! */
6216 while (isalpha(*s)) s++;
6217 s2 = tz_parse_offset(s, &dst_off);
6221 dst_off = std_off - 3600;
6224 if (!*s) { /* default dst start/end?? */
6225 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6226 s = strchr(ucxtz,',');
6228 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6230 if (*s != ',') return 0;
6233 when = _toutc(when); /* convert to utc */
6234 when = when - std_off; /* convert to pseudolocal time*/
6236 w2 = localtime(&when);
6239 s = tz_parse_startend(s_start,w2,&dststart);
6241 if (*s != ',') return 0;
6244 when = _toutc(when); /* convert to utc */
6245 when = when - dst_off; /* convert to pseudolocal time*/
6246 w2 = localtime(&when);
6247 if (w2->tm_year != y) { /* spans a year, just check one time */
6248 when += dst_off - std_off;
6249 w2 = localtime(&when);
6252 s = tz_parse_startend(s_end,w2,&dstend);
6255 if (reversed == -1) { /* need to check if start later than end */
6259 if (when < 2*365*86400) {
6260 when += 2*365*86400;
6264 w2 =localtime(&when);
6265 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6267 for (j = 0; j < 12; j++) {
6268 w2 =localtime(&when);
6269 (void) tz_parse_startend(s_start,w2,&ds);
6270 (void) tz_parse_startend(s_end,w2,&de);
6271 if (ds != de) break;
6275 if (de && !ds) reversed = 1;
6278 isdst = dststart && !dstend;
6279 if (reversed) isdst = dststart || !dstend;
6282 if (dst) *dst = isdst;
6283 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6284 if (isdst) tz = dstzone;
6286 while(isalpha(*tz)) *zone++ = *tz++;
6292 #endif /* !RTL_USES_UTC */
6294 /* my_time(), my_localtime(), my_gmtime()
6295 * By default traffic in UTC time values, using CRTL gmtime() or
6296 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6297 * Note: We need to use these functions even when the CRTL has working
6298 * UTC support, since they also handle C<use vmsish qw(times);>
6300 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6301 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6304 /*{{{time_t my_time(time_t *timep)*/
6305 time_t Perl_my_time(pTHX_ time_t *timep)
6310 if (gmtime_emulation_type == 0) {
6312 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6313 /* results of calls to gmtime() and localtime() */
6314 /* for same &base */
6316 gmtime_emulation_type++;
6317 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6318 char off[LNM$C_NAMLENGTH+1];;
6320 gmtime_emulation_type++;
6321 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6322 gmtime_emulation_type++;
6323 utc_offset_secs = 0;
6324 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6326 else { utc_offset_secs = atol(off); }
6328 else { /* We've got a working gmtime() */
6329 struct tm gmt, local;
6332 tm_p = localtime(&base);
6334 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6335 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6336 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6337 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6343 # ifdef RTL_USES_UTC
6344 if (VMSISH_TIME) when = _toloc(when);
6346 if (!VMSISH_TIME) when = _toutc(when);
6349 if (timep != NULL) *timep = when;
6352 } /* end of my_time() */
6356 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6358 Perl_my_gmtime(pTHX_ const time_t *timep)
6364 if (timep == NULL) {
6365 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6368 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6372 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6374 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6375 return gmtime(&when);
6377 /* CRTL localtime() wants local time as input, so does no tz correction */
6378 rsltmp = localtime(&when);
6379 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6382 } /* end of my_gmtime() */
6386 /*{{{struct tm *my_localtime(const time_t *timep)*/
6388 Perl_my_localtime(pTHX_ const time_t *timep)
6390 time_t when, whenutc;
6394 if (timep == NULL) {
6395 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6398 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6399 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6402 # ifdef RTL_USES_UTC
6404 if (VMSISH_TIME) when = _toutc(when);
6406 /* CRTL localtime() wants UTC as input, does tz correction itself */
6407 return localtime(&when);
6409 # else /* !RTL_USES_UTC */
6412 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6413 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6416 #ifndef RTL_USES_UTC
6417 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6418 when = whenutc - offset; /* pseudolocal time*/
6421 /* CRTL localtime() wants local time as input, so does no tz correction */
6422 rsltmp = localtime(&when);
6423 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6427 } /* end of my_localtime() */
6430 /* Reset definitions for later calls */
6431 #define gmtime(t) my_gmtime(t)
6432 #define localtime(t) my_localtime(t)
6433 #define time(t) my_time(t)
6436 /* my_utime - update modification time of a file
6437 * calling sequence is identical to POSIX utime(), but under
6438 * VMS only the modification time is changed; ODS-2 does not
6439 * maintain access times. Restrictions differ from the POSIX
6440 * definition in that the time can be changed as long as the
6441 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6442 * no separate checks are made to insure that the caller is the
6443 * owner of the file or has special privs enabled.
6444 * Code here is based on Joe Meadows' FILE utility.
6447 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6448 * to VMS epoch (01-JAN-1858 00:00:00.00)
6449 * in 100 ns intervals.
6451 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6453 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6454 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6457 long int bintime[2], len = 2, lowbit, unixtime,
6458 secscale = 10000000; /* seconds --> 100 ns intervals */
6459 unsigned long int chan, iosb[2], retsts;
6460 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6461 struct FAB myfab = cc$rms_fab;
6462 struct NAM mynam = cc$rms_nam;
6463 #if defined (__DECC) && defined (__VAX)
6464 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6465 * at least through VMS V6.1, which causes a type-conversion warning.
6467 # pragma message save
6468 # pragma message disable cvtdiftypes
6470 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6471 struct fibdef myfib;
6472 #if defined (__DECC) && defined (__VAX)
6473 /* This should be right after the declaration of myatr, but due
6474 * to a bug in VAX DEC C, this takes effect a statement early.
6476 # pragma message restore
6478 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6479 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6480 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6482 if (file == NULL || *file == '\0') {
6484 set_vaxc_errno(LIB$_INVARG);
6487 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6489 if (utimes != NULL) {
6490 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6491 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6492 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6493 * as input, we force the sign bit to be clear by shifting unixtime right
6494 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6496 lowbit = (utimes->modtime & 1) ? secscale : 0;
6497 unixtime = (long int) utimes->modtime;
6499 /* If input was UTC; convert to local for sys svc */
6500 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6502 unixtime >>= 1; secscale <<= 1;
6503 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6504 if (!(retsts & 1)) {
6506 set_vaxc_errno(retsts);
6509 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6510 if (!(retsts & 1)) {
6512 set_vaxc_errno(retsts);
6517 /* Just get the current time in VMS format directly */
6518 retsts = sys$gettim(bintime);
6519 if (!(retsts & 1)) {
6521 set_vaxc_errno(retsts);
6526 myfab.fab$l_fna = vmsspec;
6527 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6528 myfab.fab$l_nam = &mynam;
6529 mynam.nam$l_esa = esa;
6530 mynam.nam$b_ess = (unsigned char) sizeof esa;
6531 mynam.nam$l_rsa = rsa;
6532 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6534 /* Look for the file to be affected, letting RMS parse the file
6535 * specification for us as well. I have set errno using only
6536 * values documented in the utime() man page for VMS POSIX.
6538 retsts = sys$parse(&myfab,0,0);
6539 if (!(retsts & 1)) {
6540 set_vaxc_errno(retsts);
6541 if (retsts == RMS$_PRV) set_errno(EACCES);
6542 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6543 else set_errno(EVMSERR);
6546 retsts = sys$search(&myfab,0,0);
6547 if (!(retsts & 1)) {
6548 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6549 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6550 set_vaxc_errno(retsts);
6551 if (retsts == RMS$_PRV) set_errno(EACCES);
6552 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6553 else set_errno(EVMSERR);
6557 devdsc.dsc$w_length = mynam.nam$b_dev;
6558 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6560 retsts = sys$assign(&devdsc,&chan,0,0);
6561 if (!(retsts & 1)) {
6562 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6563 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6564 set_vaxc_errno(retsts);
6565 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6566 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6567 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6568 else set_errno(EVMSERR);
6572 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6573 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6575 memset((void *) &myfib, 0, sizeof myfib);
6576 #if defined(__DECC) || defined(__DECCXX)
6577 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6578 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6579 /* This prevents the revision time of the file being reset to the current
6580 * time as a result of our IO$_MODIFY $QIO. */
6581 myfib.fib$l_acctl = FIB$M_NORECORD;
6583 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6584 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6585 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6587 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6588 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6589 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6590 _ckvmssts(sys$dassgn(chan));
6591 if (retsts & 1) retsts = iosb[0];
6592 if (!(retsts & 1)) {
6593 set_vaxc_errno(retsts);
6594 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6595 else set_errno(EVMSERR);
6600 } /* end of my_utime() */
6604 * flex_stat, flex_fstat
6605 * basic stat, but gets it right when asked to stat
6606 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6609 /* encode_dev packs a VMS device name string into an integer to allow
6610 * simple comparisons. This can be used, for example, to check whether two
6611 * files are located on the same device, by comparing their encoded device
6612 * names. Even a string comparison would not do, because stat() reuses the
6613 * device name buffer for each call; so without encode_dev, it would be
6614 * necessary to save the buffer and use strcmp (this would mean a number of
6615 * changes to the standard Perl code, to say nothing of what a Perl script
6618 * The device lock id, if it exists, should be unique (unless perhaps compared
6619 * with lock ids transferred from other nodes). We have a lock id if the disk is
6620 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6621 * device names. Thus we use the lock id in preference, and only if that isn't
6622 * available, do we try to pack the device name into an integer (flagged by
6623 * the sign bit (LOCKID_MASK) being set).
6625 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6626 * name and its encoded form, but it seems very unlikely that we will find
6627 * two files on different disks that share the same encoded device names,
6628 * and even more remote that they will share the same file id (if the test
6629 * is to check for the same file).
6631 * A better method might be to use sys$device_scan on the first call, and to
6632 * search for the device, returning an index into the cached array.
6633 * The number returned would be more intelligable.
6634 * This is probably not worth it, and anyway would take quite a bit longer
6635 * on the first call.
6637 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6638 static mydev_t encode_dev (pTHX_ const char *dev)
6641 unsigned long int f;
6646 if (!dev || !dev[0]) return 0;
6650 struct dsc$descriptor_s dev_desc;
6651 unsigned long int status, lockid, item = DVI$_LOCKID;
6653 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6654 can try that first. */
6655 dev_desc.dsc$w_length = strlen (dev);
6656 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6657 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6658 dev_desc.dsc$a_pointer = (char *) dev;
6659 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6660 if (lockid) return (lockid & ~LOCKID_MASK);
6664 /* Otherwise we try to encode the device name */
6668 for (q = dev + strlen(dev); q--; q >= dev) {
6671 else if (isalpha (toupper (*q)))
6672 c= toupper (*q) - 'A' + (char)10;
6674 continue; /* Skip '$'s */
6676 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6678 enc += f * (unsigned long int) c;
6680 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6682 } /* end of encode_dev() */
6684 static char namecache[NAM$C_MAXRSS+1];
6687 is_null_device(name)
6690 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6691 The underscore prefix, controller letter, and unit number are
6692 independently optional; for our purposes, the colon punctuation
6693 is not. The colon can be trailed by optional directory and/or
6694 filename, but two consecutive colons indicates a nodename rather
6695 than a device. [pr] */
6696 if (*name == '_') ++name;
6697 if (tolower(*name++) != 'n') return 0;
6698 if (tolower(*name++) != 'l') return 0;
6699 if (tolower(*name) == 'a') ++name;
6700 if (*name == '0') ++name;
6701 return (*name++ == ':') && (*name != ':');
6704 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6705 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6706 * subset of the applicable information.
6709 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6711 char fname_phdev[NAM$C_MAXRSS+1];
6712 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6714 char fname[NAM$C_MAXRSS+1];
6715 unsigned long int retsts;
6716 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6717 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6719 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6720 device name on successive calls */
6721 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6722 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6723 namdsc.dsc$a_pointer = fname;
6724 namdsc.dsc$w_length = sizeof fname - 1;
6726 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6727 &namdsc,&namdsc.dsc$w_length,0,0);
6729 fname[namdsc.dsc$w_length] = '\0';
6731 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6732 * but if someone has redefined that logical, Perl gets very lost. Since
6733 * we have the physical device name from the stat buffer, just paste it on.
6735 strcpy( fname_phdev, statbufp->st_devnam );
6736 strcat( fname_phdev, strrchr(fname, ':') );
6738 return cando_by_name(bit,effective,fname_phdev);
6740 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6741 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6745 return FALSE; /* Should never get to here */
6747 } /* end of cando() */
6751 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6753 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6755 static char usrname[L_cuserid];
6756 static struct dsc$descriptor_s usrdsc =
6757 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6758 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6759 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6760 unsigned short int retlen, trnlnm_iter_count;
6761 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6762 union prvdef curprv;
6763 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6764 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6765 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6766 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6768 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6770 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6772 if (!fname || !*fname) return FALSE;
6773 /* Make sure we expand logical names, since sys$check_access doesn't */
6774 if (!strpbrk(fname,"/]>:")) {
6775 strcpy(fileified,fname);
6776 trnlnm_iter_count = 0;
6777 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6778 trnlnm_iter_count++;
6779 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6783 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6784 retlen = namdsc.dsc$w_length = strlen(vmsname);
6785 namdsc.dsc$a_pointer = vmsname;
6786 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6787 vmsname[retlen-1] == ':') {
6788 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6789 namdsc.dsc$w_length = strlen(fileified);
6790 namdsc.dsc$a_pointer = fileified;
6794 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6795 access = ARM$M_EXECUTE; break;
6796 case S_IRUSR: case S_IRGRP: case S_IROTH:
6797 access = ARM$M_READ; break;
6798 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6799 access = ARM$M_WRITE; break;
6800 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6801 access = ARM$M_DELETE; break;
6806 /* Before we call $check_access, create a user profile with the current
6807 * process privs since otherwise it just uses the default privs from the
6808 * UAF and might give false positives or negatives. This only works on
6809 * VMS versions v6.0 and later since that's when sys$create_user_profile
6813 /* get current process privs and username */
6814 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6817 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6819 /* find out the space required for the profile */
6820 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6821 &usrprodsc.dsc$w_length,0));
6823 /* allocate space for the profile and get it filled in */
6824 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6825 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6826 &usrprodsc.dsc$w_length,0));
6828 /* use the profile to check access to the file; free profile & analyze results */
6829 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6830 Safefree(usrprodsc.dsc$a_pointer);
6831 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6835 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6839 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6840 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6841 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6842 set_vaxc_errno(retsts);
6843 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6844 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6845 else set_errno(ENOENT);
6848 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6853 return FALSE; /* Should never get here */
6855 } /* end of cando_by_name() */
6859 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6861 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6863 if (!fstat(fd,(stat_t *) statbufp)) {
6864 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6865 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6866 # ifdef RTL_USES_UTC
6869 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6870 statbufp->st_atime = _toloc(statbufp->st_atime);
6871 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6876 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6880 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6881 statbufp->st_atime = _toutc(statbufp->st_atime);
6882 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6889 } /* end of flex_fstat() */
6892 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6894 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6896 char fileified[NAM$C_MAXRSS+1];
6897 char temp_fspec[NAM$C_MAXRSS+300];
6899 int saved_errno, saved_vaxc_errno;
6901 if (!fspec) return retval;
6902 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6903 strcpy(temp_fspec, fspec);
6904 if (statbufp == (Stat_t *) &PL_statcache)
6905 do_tovmsspec(temp_fspec,namecache,0);
6906 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6907 memset(statbufp,0,sizeof *statbufp);
6908 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6909 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6910 statbufp->st_uid = 0x00010001;
6911 statbufp->st_gid = 0x0001;
6912 time((time_t *)&statbufp->st_mtime);
6913 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6917 /* Try for a directory name first. If fspec contains a filename without
6918 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6919 * and sea:[wine.dark]water. exist, we prefer the directory here.
6920 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6921 * not sea:[wine.dark]., if the latter exists. If the intended target is
6922 * the file with null type, specify this by calling flex_stat() with
6923 * a '.' at the end of fspec.
6925 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6926 retval = stat(fileified,(stat_t *) statbufp);
6927 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6928 strcpy(namecache,fileified);
6930 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6932 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6933 # ifdef RTL_USES_UTC
6936 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6937 statbufp->st_atime = _toloc(statbufp->st_atime);
6938 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6943 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6947 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6948 statbufp->st_atime = _toutc(statbufp->st_atime);
6949 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6953 /* If we were successful, leave errno where we found it */
6954 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6957 } /* end of flex_stat() */
6961 /*{{{char *my_getlogin()*/
6962 /* VMS cuserid == Unix getlogin, except calling sequence */
6966 static char user[L_cuserid];
6967 return cuserid(user);
6972 /* rmscopy - copy a file using VMS RMS routines
6974 * Copies contents and attributes of spec_in to spec_out, except owner
6975 * and protection information. Name and type of spec_in are used as
6976 * defaults for spec_out. The third parameter specifies whether rmscopy()
6977 * should try to propagate timestamps from the input file to the output file.
6978 * If it is less than 0, no timestamps are preserved. If it is 0, then
6979 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6980 * propagated to the output file at creation iff the output file specification
6981 * did not contain an explicit name or type, and the revision date is always
6982 * updated at the end of the copy operation. If it is greater than 0, then
6983 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6984 * other than the revision date should be propagated, and bit 1 indicates
6985 * that the revision date should be propagated.
6987 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6989 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6990 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6991 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6992 * as part of the Perl standard distribution under the terms of the
6993 * GNU General Public License or the Perl Artistic License. Copies
6994 * of each may be found in the Perl standard distribution.
6996 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6998 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
7000 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
7001 rsa[NAM$C_MAXRSS], ubf[32256];
7002 unsigned long int i, sts, sts2;
7003 struct FAB fab_in, fab_out;
7004 struct RAB rab_in, rab_out;
7006 struct XABDAT xabdat;
7007 struct XABFHC xabfhc;
7008 struct XABRDT xabrdt;
7009 struct XABSUM xabsum;
7011 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
7012 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
7013 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7017 fab_in = cc$rms_fab;
7018 fab_in.fab$l_fna = vmsin;
7019 fab_in.fab$b_fns = strlen(vmsin);
7020 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
7021 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
7022 fab_in.fab$l_fop = FAB$M_SQO;
7023 fab_in.fab$l_nam = &nam;
7024 fab_in.fab$l_xab = (void *) &xabdat;
7027 nam.nam$l_rsa = rsa;
7028 nam.nam$b_rss = sizeof(rsa);
7029 nam.nam$l_esa = esa;
7030 nam.nam$b_ess = sizeof (esa);
7031 nam.nam$b_esl = nam.nam$b_rsl = 0;
7033 xabdat = cc$rms_xabdat; /* To get creation date */
7034 xabdat.xab$l_nxt = (void *) &xabfhc;
7036 xabfhc = cc$rms_xabfhc; /* To get record length */
7037 xabfhc.xab$l_nxt = (void *) &xabsum;
7039 xabsum = cc$rms_xabsum; /* To get key and area information */
7041 if (!((sts = sys$open(&fab_in)) & 1)) {
7042 set_vaxc_errno(sts);
7044 case RMS$_FNF: case RMS$_DNF:
7045 set_errno(ENOENT); break;
7047 set_errno(ENOTDIR); break;
7049 set_errno(ENODEV); break;
7051 set_errno(EINVAL); break;
7053 set_errno(EACCES); break;
7061 fab_out.fab$w_ifi = 0;
7062 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
7063 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
7064 fab_out.fab$l_fop = FAB$M_SQO;
7065 fab_out.fab$l_fna = vmsout;
7066 fab_out.fab$b_fns = strlen(vmsout);
7067 fab_out.fab$l_dna = nam.nam$l_name;
7068 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
7070 if (preserve_dates == 0) { /* Act like DCL COPY */
7071 nam.nam$b_nop = NAM$M_SYNCHK;
7072 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
7073 if (!((sts = sys$parse(&fab_out)) & 1)) {
7074 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
7075 set_vaxc_errno(sts);
7078 fab_out.fab$l_xab = (void *) &xabdat;
7079 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
7081 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
7082 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
7083 preserve_dates =0; /* bitmask from this point forward */
7085 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
7086 if (!((sts = sys$create(&fab_out)) & 1)) {
7087 set_vaxc_errno(sts);
7090 set_errno(ENOENT); break;
7092 set_errno(ENOTDIR); break;
7094 set_errno(ENODEV); break;
7096 set_errno(EINVAL); break;
7098 set_errno(EACCES); break;
7104 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
7105 if (preserve_dates & 2) {
7106 /* sys$close() will process xabrdt, not xabdat */
7107 xabrdt = cc$rms_xabrdt;
7109 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
7111 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
7112 * is unsigned long[2], while DECC & VAXC use a struct */
7113 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
7115 fab_out.fab$l_xab = (void *) &xabrdt;
7118 rab_in = cc$rms_rab;
7119 rab_in.rab$l_fab = &fab_in;
7120 rab_in.rab$l_rop = RAB$M_BIO;
7121 rab_in.rab$l_ubf = ubf;
7122 rab_in.rab$w_usz = sizeof ubf;
7123 if (!((sts = sys$connect(&rab_in)) & 1)) {
7124 sys$close(&fab_in); sys$close(&fab_out);
7125 set_errno(EVMSERR); set_vaxc_errno(sts);
7129 rab_out = cc$rms_rab;
7130 rab_out.rab$l_fab = &fab_out;
7131 rab_out.rab$l_rbf = ubf;
7132 if (!((sts = sys$connect(&rab_out)) & 1)) {
7133 sys$close(&fab_in); sys$close(&fab_out);
7134 set_errno(EVMSERR); set_vaxc_errno(sts);
7138 while ((sts = sys$read(&rab_in))) { /* always true */
7139 if (sts == RMS$_EOF) break;
7140 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
7141 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
7142 sys$close(&fab_in); sys$close(&fab_out);
7143 set_errno(EVMSERR); set_vaxc_errno(sts);
7148 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
7149 sys$close(&fab_in); sys$close(&fab_out);
7150 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
7152 set_errno(EVMSERR); set_vaxc_errno(sts);
7158 } /* end of rmscopy() */
7162 /*** The following glue provides 'hooks' to make some of the routines
7163 * from this file available from Perl. These routines are sufficiently
7164 * basic, and are required sufficiently early in the build process,
7165 * that's it's nice to have them available to miniperl as well as the
7166 * full Perl, so they're set up here instead of in an extension. The
7167 * Perl code which handles importation of these names into a given
7168 * package lives in [.VMS]Filespec.pm in @INC.
7172 rmsexpand_fromperl(pTHX_ CV *cv)
7175 char *fspec, *defspec = NULL, *rslt;
7178 if (!items || items > 2)
7179 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7180 fspec = SvPV(ST(0),n_a);
7181 if (!fspec || !*fspec) XSRETURN_UNDEF;
7182 if (items == 2) defspec = SvPV(ST(1),n_a);
7184 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7185 ST(0) = sv_newmortal();
7186 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7191 vmsify_fromperl(pTHX_ CV *cv)
7197 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7198 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7199 ST(0) = sv_newmortal();
7200 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7205 unixify_fromperl(pTHX_ CV *cv)
7211 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7212 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7213 ST(0) = sv_newmortal();
7214 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7219 fileify_fromperl(pTHX_ CV *cv)
7225 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7226 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7227 ST(0) = sv_newmortal();
7228 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7233 pathify_fromperl(pTHX_ CV *cv)
7239 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7240 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7241 ST(0) = sv_newmortal();
7242 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7247 vmspath_fromperl(pTHX_ CV *cv)
7253 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7254 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7255 ST(0) = sv_newmortal();
7256 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7261 unixpath_fromperl(pTHX_ CV *cv)
7267 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7268 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7269 ST(0) = sv_newmortal();
7270 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7275 candelete_fromperl(pTHX_ CV *cv)
7278 char fspec[NAM$C_MAXRSS+1], *fsp;
7283 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7285 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7286 if (SvTYPE(mysv) == SVt_PVGV) {
7287 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7288 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7295 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7296 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7302 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7307 rmscopy_fromperl(pTHX_ CV *cv)
7310 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7312 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7313 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7314 unsigned long int sts;
7319 if (items < 2 || items > 3)
7320 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7322 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7323 if (SvTYPE(mysv) == SVt_PVGV) {
7324 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7325 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7332 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7333 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7338 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7339 if (SvTYPE(mysv) == SVt_PVGV) {
7340 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7341 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7348 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7349 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7354 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7356 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7362 mod2fname(pTHX_ CV *cv)
7365 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7366 workbuff[NAM$C_MAXRSS*1 + 1];
7367 int total_namelen = 3, counter, num_entries;
7368 /* ODS-5 ups this, but we want to be consistent, so... */
7369 int max_name_len = 39;
7370 AV *in_array = (AV *)SvRV(ST(0));
7372 num_entries = av_len(in_array);
7374 /* All the names start with PL_. */
7375 strcpy(ultimate_name, "PL_");
7377 /* Clean up our working buffer */
7378 Zero(work_name, sizeof(work_name), char);
7380 /* Run through the entries and build up a working name */
7381 for(counter = 0; counter <= num_entries; counter++) {
7382 /* If it's not the first name then tack on a __ */
7384 strcat(work_name, "__");
7386 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7390 /* Check to see if we actually have to bother...*/
7391 if (strlen(work_name) + 3 <= max_name_len) {
7392 strcat(ultimate_name, work_name);
7394 /* It's too darned big, so we need to go strip. We use the same */
7395 /* algorithm as xsubpp does. First, strip out doubled __ */
7396 char *source, *dest, last;
7399 for (source = work_name; *source; source++) {
7400 if (last == *source && last == '_') {
7406 /* Go put it back */
7407 strcpy(work_name, workbuff);
7408 /* Is it still too big? */
7409 if (strlen(work_name) + 3 > max_name_len) {
7410 /* Strip duplicate letters */
7413 for (source = work_name; *source; source++) {
7414 if (last == toupper(*source)) {
7418 last = toupper(*source);
7420 strcpy(work_name, workbuff);
7423 /* Is it *still* too big? */
7424 if (strlen(work_name) + 3 > max_name_len) {
7425 /* Too bad, we truncate */
7426 work_name[max_name_len - 2] = 0;
7428 strcat(ultimate_name, work_name);
7431 /* Okay, return it */
7432 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7437 hushexit_fromperl(pTHX_ CV *cv)
7442 VMSISH_HUSHED = SvTRUE(ST(0));
7444 ST(0) = boolSV(VMSISH_HUSHED);
7449 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7450 struct interp_intern *dst)
7452 memcpy(dst,src,sizeof(struct interp_intern));
7456 Perl_sys_intern_clear(pTHX)
7461 Perl_sys_intern_init(pTHX)
7463 unsigned int ix = RAND_MAX;
7469 MY_INV_RAND_MAX = 1./x;
7476 char* file = __FILE__;
7477 char temp_buff[512];
7478 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7479 no_translate_barewords = TRUE;
7481 no_translate_barewords = FALSE;
7484 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7485 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7486 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7487 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7488 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7489 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7490 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7491 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7492 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7493 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7494 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7496 store_pipelocs(aTHX); /* will redo any earlier attempts */