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;
140 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
142 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
143 struct dsc$descriptor_s **tabvec, unsigned long int flags)
145 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
146 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
147 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
148 unsigned char acmode;
149 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
150 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
151 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
152 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
154 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
155 #if defined(PERL_IMPLICIT_CONTEXT)
157 # if defined(USE_5005THREADS)
158 /* We jump through these hoops because we can be called at */
159 /* platform-specific initialization time, which is before anything is */
160 /* set up--we can't even do a plain dTHX since that relies on the */
161 /* interpreter structure to be initialized */
163 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
169 aTHX = PERL_GET_INTERP;
177 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
178 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
180 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
181 *cp2 = _toupper(*cp1);
182 if (cp1 - lnm > LNM$C_NAMLENGTH) {
183 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
187 lnmdsc.dsc$w_length = cp1 - lnm;
188 lnmdsc.dsc$a_pointer = uplnm;
189 uplnm[lnmdsc.dsc$w_length] = '\0';
190 secure = flags & PERL__TRNENV_SECURE;
191 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
192 if (!tabvec || !*tabvec) tabvec = env_tables;
194 for (curtab = 0; tabvec[curtab]; curtab++) {
195 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
196 if (!ivenv && !secure) {
201 Perl_warn(aTHX_ "Can't read CRTL environ\n");
204 retsts = SS$_NOLOGNAM;
205 for (i = 0; environ[i]; i++) {
206 if ((eq = strchr(environ[i],'=')) &&
207 !strncmp(environ[i],uplnm,eq - environ[i])) {
209 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
210 if (!eqvlen) continue;
215 if (retsts != SS$_NOLOGNAM) break;
218 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
219 !str$case_blind_compare(&tmpdsc,&clisym)) {
220 if (!ivsym && !secure) {
221 unsigned short int deflen = LNM$C_NAMLENGTH;
222 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
223 /* dynamic dsc to accomodate possible long value */
224 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
225 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
228 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
230 /* Special hack--we might be called before the interpreter's */
231 /* fully initialized, in which case either thr or PL_curcop */
232 /* might be bogus. We have to check, since ckWARN needs them */
233 /* both to be valid if running threaded */
234 #if defined(USE_5005THREADS)
235 if (thr && PL_curcop) {
237 if (ckWARN(WARN_MISC)) {
238 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
240 #if defined(USE_5005THREADS)
242 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
247 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
249 _ckvmssts(lib$sfree1_dd(&eqvdsc));
250 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
251 if (retsts == LIB$_NOSUCHSYM) continue;
256 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
257 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
258 if (retsts == SS$_NOLOGNAM) continue;
259 /* PPFs have a prefix */
262 *((int *)uplnm) == *((int *)"SYS$") &&
264 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
265 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
266 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
267 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
268 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
269 memcpy(eqv,eqv+4,eqvlen-4);
275 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
276 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
277 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
278 retsts == SS$_NOLOGNAM) {
279 set_errno(EINVAL); set_vaxc_errno(retsts);
281 else _ckvmssts(retsts);
283 } /* end of vmstrnenv */
286 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
287 /* Define as a function so we can access statics. */
288 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
290 return vmstrnenv(lnm,eqv,idx,fildev,
291 #ifdef SECURE_INTERNAL_GETENV
292 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
301 * Note: Uses Perl temp to store result so char * can be returned to
302 * caller; this pointer will be invalidated at next Perl statement
304 * We define this as a function rather than a macro in terms of my_getenv_len()
305 * so that it'll work when PL_curinterp is undefined (and we therefore can't
308 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
310 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
312 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
313 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
314 unsigned long int idx = 0;
315 int trnsuccess, success, secure, saverr, savvmserr;
318 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
319 /* Set up a temporary buffer for the return value; Perl will
320 * clean it up at the next statement transition */
321 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
322 if (!tmpsv) return NULL;
325 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
326 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
327 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
328 getcwd(eqv,LNM$C_NAMLENGTH);
332 if ((cp2 = strchr(lnm,';')) != NULL) {
334 uplnm[cp2-lnm] = '\0';
335 idx = strtoul(cp2+1,NULL,0);
338 /* Impose security constraints only if tainting */
340 /* Impose security constraints only if tainting */
341 secure = PL_curinterp ? PL_tainting : will_taint;
342 saverr = errno; savvmserr = vaxc$errno;
345 success = vmstrnenv(lnm,eqv,idx,
346 secure ? fildev : NULL,
347 #ifdef SECURE_INTERNAL_GETENV
348 secure ? PERL__TRNENV_SECURE : 0
353 /* Discard NOLOGNAM on internal calls since we're often looking
354 * for an optional name, and this "error" often shows up as the
355 * (bogus) exit status for a die() call later on. */
356 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
357 return success ? eqv : Nullch;
360 } /* end of my_getenv() */
364 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
366 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
368 char *buf, *cp1, *cp2;
369 unsigned long idx = 0;
370 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
371 int secure, saverr, savvmserr;
374 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
375 /* Set up a temporary buffer for the return value; Perl will
376 * clean it up at the next statement transition */
377 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
378 if (!tmpsv) return NULL;
381 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
382 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
383 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
384 getcwd(buf,LNM$C_NAMLENGTH);
389 if ((cp2 = strchr(lnm,';')) != NULL) {
392 idx = strtoul(cp2+1,NULL,0);
396 /* Impose security constraints only if tainting */
397 secure = PL_curinterp ? PL_tainting : will_taint;
398 saverr = errno; savvmserr = vaxc$errno;
401 *len = vmstrnenv(lnm,buf,idx,
402 secure ? fildev : NULL,
403 #ifdef SECURE_INTERNAL_GETENV
404 secure ? PERL__TRNENV_SECURE : 0
409 /* Discard NOLOGNAM on internal calls since we're often looking
410 * for an optional name, and this "error" often shows up as the
411 * (bogus) exit status for a die() call later on. */
412 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
413 return *len ? buf : Nullch;
416 } /* end of my_getenv_len() */
419 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
421 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
423 /*{{{ void prime_env_iter() */
426 /* Fill the %ENV associative array with all logical names we can
427 * find, in preparation for iterating over it.
430 static int primed = 0;
431 HV *seenhv = NULL, *envhv;
433 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
434 unsigned short int chan;
435 #ifndef CLI$M_TRUSTED
436 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
438 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
439 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
441 bool have_sym = FALSE, have_lnm = FALSE;
442 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
443 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
444 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
445 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
446 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
447 #if defined(PERL_IMPLICIT_CONTEXT)
450 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
451 static perl_mutex primenv_mutex;
452 MUTEX_INIT(&primenv_mutex);
455 #if defined(PERL_IMPLICIT_CONTEXT)
456 /* We jump through these hoops because we can be called at */
457 /* platform-specific initialization time, which is before anything is */
458 /* set up--we can't even do a plain dTHX since that relies on the */
459 /* interpreter structure to be initialized */
460 #if defined(USE_5005THREADS)
462 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
468 aTHX = PERL_GET_INTERP;
475 if (primed || !PL_envgv) return;
476 MUTEX_LOCK(&primenv_mutex);
477 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
478 envhv = GvHVn(PL_envgv);
479 /* Perform a dummy fetch as an lval to insure that the hash table is
480 * set up. Otherwise, the hv_store() will turn into a nullop. */
481 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
483 for (i = 0; env_tables[i]; i++) {
484 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
485 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
486 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
488 if (have_sym || have_lnm) {
489 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
490 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
491 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
492 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
495 for (i--; i >= 0; i--) {
496 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
499 for (j = 0; environ[j]; j++) {
500 if (!(start = strchr(environ[j],'='))) {
501 if (ckWARN(WARN_INTERNAL))
502 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
506 sv = newSVpv(start,0);
508 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
513 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
514 !str$case_blind_compare(&tmpdsc,&clisym)) {
515 strcpy(cmd,"Show Symbol/Global *");
516 cmddsc.dsc$w_length = 20;
517 if (env_tables[i]->dsc$w_length == 12 &&
518 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
519 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
520 flags = defflags | CLI$M_NOLOGNAM;
523 strcpy(cmd,"Show Logical *");
524 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
525 strcat(cmd," /Table=");
526 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
527 cmddsc.dsc$w_length = strlen(cmd);
529 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
530 flags = defflags | CLI$M_NOCLISYM;
533 /* Create a new subprocess to execute each command, to exclude the
534 * remote possibility that someone could subvert a mbx or file used
535 * to write multiple commands to a single subprocess.
538 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
539 0,&riseandshine,0,0,&clidsc,&clitabdsc);
540 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
541 defflags &= ~CLI$M_TRUSTED;
542 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
544 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
545 if (seenhv) SvREFCNT_dec(seenhv);
548 char *cp1, *cp2, *key;
549 unsigned long int sts, iosb[2], retlen, keylen;
552 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
553 if (sts & 1) sts = iosb[0] & 0xffff;
554 if (sts == SS$_ENDOFFILE) {
556 while (substs == 0) { sys$hiber(); wakect++;}
557 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
562 retlen = iosb[0] >> 16;
563 if (!retlen) continue; /* blank line */
565 if (iosb[1] != subpid) {
567 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
571 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
572 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
574 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
575 if (*cp1 == '(' || /* Logical name table name */
576 *cp1 == '=' /* Next eqv of searchlist */) continue;
577 if (*cp1 == '"') cp1++;
578 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
579 key = cp1; keylen = cp2 - cp1;
580 if (keylen && hv_exists(seenhv,key,keylen)) continue;
581 while (*cp2 && *cp2 != '=') cp2++;
582 while (*cp2 && *cp2 == '=') cp2++;
583 while (*cp2 && *cp2 == ' ') cp2++;
584 if (*cp2 == '"') { /* String translation; may embed "" */
585 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
586 cp2++; cp1--; /* Skip "" surrounding translation */
588 else { /* Numeric translation */
589 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
590 cp1--; /* stop on last non-space char */
592 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
593 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
596 PERL_HASH(hash,key,keylen);
597 sv = newSVpvn(cp2,cp1 - cp2 + 1);
599 hv_store(envhv,key,keylen,sv,hash);
600 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
602 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
603 /* get the PPFs for this process, not the subprocess */
604 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
605 char eqv[LNM$C_NAMLENGTH+1];
607 for (i = 0; ppfs[i]; i++) {
608 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
609 sv = newSVpv(eqv,trnlen);
611 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
616 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
617 if (buf) Safefree(buf);
618 if (seenhv) SvREFCNT_dec(seenhv);
619 MUTEX_UNLOCK(&primenv_mutex);
622 } /* end of prime_env_iter */
626 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
627 /* Define or delete an element in the same "environment" as
628 * vmstrnenv(). If an element is to be deleted, it's removed from
629 * the first place it's found. If it's to be set, it's set in the
630 * place designated by the first element of the table vector.
631 * Like setenv() returns 0 for success, non-zero on error.
634 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
636 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
637 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
638 unsigned long int retsts, usermode = PSL$C_USER;
639 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
640 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
641 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
642 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
643 $DESCRIPTOR(local,"_LOCAL");
645 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
646 *cp2 = _toupper(*cp1);
647 if (cp1 - lnm > LNM$C_NAMLENGTH) {
648 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
652 lnmdsc.dsc$w_length = cp1 - lnm;
653 if (!tabvec || !*tabvec) tabvec = env_tables;
655 if (!eqv) { /* we're deleting n element */
656 for (curtab = 0; tabvec[curtab]; curtab++) {
657 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
659 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
660 if ((cp1 = strchr(environ[i],'=')) &&
661 !strncmp(environ[i],lnm,cp1 - environ[i])) {
663 return setenv(lnm,"",1) ? vaxc$errno : 0;
666 ivenv = 1; retsts = SS$_NOLOGNAM;
668 if (ckWARN(WARN_INTERNAL))
669 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
670 ivenv = 1; retsts = SS$_NOSUCHPGM;
676 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
677 !str$case_blind_compare(&tmpdsc,&clisym)) {
678 unsigned int symtype;
679 if (tabvec[curtab]->dsc$w_length == 12 &&
680 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
681 !str$case_blind_compare(&tmpdsc,&local))
682 symtype = LIB$K_CLI_LOCAL_SYM;
683 else symtype = LIB$K_CLI_GLOBAL_SYM;
684 retsts = lib$delete_symbol(&lnmdsc,&symtype);
685 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
686 if (retsts == LIB$_NOSUCHSYM) continue;
690 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
691 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
692 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
693 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
694 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
698 else { /* we're defining a value */
699 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
701 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
703 if (ckWARN(WARN_INTERNAL))
704 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
705 retsts = SS$_NOSUCHPGM;
709 eqvdsc.dsc$a_pointer = eqv;
710 eqvdsc.dsc$w_length = strlen(eqv);
711 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
712 !str$case_blind_compare(&tmpdsc,&clisym)) {
713 unsigned int symtype;
714 if (tabvec[0]->dsc$w_length == 12 &&
715 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
716 !str$case_blind_compare(&tmpdsc,&local))
717 symtype = LIB$K_CLI_LOCAL_SYM;
718 else symtype = LIB$K_CLI_GLOBAL_SYM;
719 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
722 if (!*eqv) eqvdsc.dsc$w_length = 1;
723 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
724 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
725 if (ckWARN(WARN_MISC)) {
726 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
729 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
735 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
736 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
737 set_errno(EVMSERR); break;
738 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
739 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
740 set_errno(EINVAL); break;
747 set_vaxc_errno(retsts);
748 return (int) retsts || 44; /* retsts should never be 0, but just in case */
751 /* We reset error values on success because Perl does an hv_fetch()
752 * before each hv_store(), and if the thing we're setting didn't
753 * previously exist, we've got a leftover error message. (Of course,
754 * this fails in the face of
755 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
756 * in that the error reported in $! isn't spurious,
757 * but it's right more often than not.)
759 set_errno(0); set_vaxc_errno(retsts);
763 } /* end of vmssetenv() */
766 /*{{{ void my_setenv(char *lnm, char *eqv)*/
767 /* This has to be a function since there's a prototype for it in proto.h */
769 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
772 int len = strlen(lnm);
776 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
777 if (!strcmp(uplnm,"DEFAULT")) {
778 if (eqv && *eqv) chdir(eqv);
783 if (len == 6 || len == 2) {
786 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
788 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
789 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
793 (void) vmssetenv(lnm,eqv,NULL);
797 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
799 * sets a user-mode logical in the process logical name table
800 * used for redirection of sys$error
803 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
805 $DESCRIPTOR(d_tab, "LNM$PROCESS");
806 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
807 unsigned long int iss, attr = LNM$M_CONFINE;
808 unsigned char acmode = PSL$C_USER;
809 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
811 d_name.dsc$a_pointer = name;
812 d_name.dsc$w_length = strlen(name);
814 lnmlst[0].buflen = strlen(eqv);
815 lnmlst[0].bufadr = eqv;
817 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
818 if (!(iss&1)) lib$signal(iss);
823 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
824 /* my_crypt - VMS password hashing
825 * my_crypt() provides an interface compatible with the Unix crypt()
826 * C library function, and uses sys$hash_password() to perform VMS
827 * password hashing. The quadword hashed password value is returned
828 * as a NUL-terminated 8 character string. my_crypt() does not change
829 * the case of its string arguments; in order to match the behavior
830 * of LOGINOUT et al., alphabetic characters in both arguments must
831 * be upcased by the caller.
834 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
836 # ifndef UAI$C_PREFERRED_ALGORITHM
837 # define UAI$C_PREFERRED_ALGORITHM 127
839 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
840 unsigned short int salt = 0;
841 unsigned long int sts;
843 unsigned short int dsc$w_length;
844 unsigned char dsc$b_type;
845 unsigned char dsc$b_class;
846 const char * dsc$a_pointer;
847 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
848 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
849 struct itmlst_3 uailst[3] = {
850 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
851 { sizeof salt, UAI$_SALT, &salt, 0},
852 { 0, 0, NULL, NULL}};
855 usrdsc.dsc$w_length = strlen(usrname);
856 usrdsc.dsc$a_pointer = usrname;
857 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
859 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
863 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
869 if (sts != RMS$_RNF) return NULL;
872 txtdsc.dsc$w_length = strlen(textpasswd);
873 txtdsc.dsc$a_pointer = textpasswd;
874 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
875 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
878 return (char *) hash;
880 } /* end of my_crypt() */
884 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
885 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
886 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
888 /*{{{int do_rmdir(char *name)*/
890 Perl_do_rmdir(pTHX_ char *name)
892 char dirfile[NAM$C_MAXRSS+1];
896 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
897 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
898 else retval = kill_file(dirfile);
901 } /* end of do_rmdir */
905 * Delete any file to which user has control access, regardless of whether
906 * delete access is explicitly allowed.
907 * Limitations: User must have write access to parent directory.
908 * Does not block signals or ASTs; if interrupted in midstream
909 * may leave file with an altered ACL.
912 /*{{{int kill_file(char *name)*/
914 Perl_kill_file(pTHX_ char *name)
916 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
917 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
918 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
919 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
921 unsigned char myace$b_length;
922 unsigned char myace$b_type;
923 unsigned short int myace$w_flags;
924 unsigned long int myace$l_access;
925 unsigned long int myace$l_ident;
926 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
927 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
928 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
930 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
931 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
932 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
933 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
934 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
935 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
937 /* Expand the input spec using RMS, since the CRTL remove() and
938 * system services won't do this by themselves, so we may miss
939 * a file "hiding" behind a logical name or search list. */
940 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
941 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
942 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
943 /* If not, can changing protections help? */
944 if (vaxc$errno != RMS$_PRV) return -1;
946 /* No, so we get our own UIC to use as a rights identifier,
947 * and the insert an ACE at the head of the ACL which allows us
948 * to delete the file.
950 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
951 fildsc.dsc$w_length = strlen(rspec);
952 fildsc.dsc$a_pointer = rspec;
954 newace.myace$l_ident = oldace.myace$l_ident;
955 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
957 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
958 set_errno(ENOENT); break;
960 set_errno(ENOTDIR); break;
962 set_errno(ENODEV); break;
963 case RMS$_SYN: case SS$_INVFILFOROP:
964 set_errno(EINVAL); break;
966 set_errno(EACCES); break;
970 set_vaxc_errno(aclsts);
973 /* Grab any existing ACEs with this identifier in case we fail */
974 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
975 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
976 || fndsts == SS$_NOMOREACE ) {
977 /* Add the new ACE . . . */
978 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
980 if ((rmsts = remove(name))) {
981 /* We blew it - dir with files in it, no write priv for
982 * parent directory, etc. Put things back the way they were. */
983 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
986 addlst[0].bufadr = &oldace;
987 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
994 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
995 /* We just deleted it, so of course it's not there. Some versions of
996 * VMS seem to return success on the unlock operation anyhow (after all
997 * the unlock is successful), but others don't.
999 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1000 if (aclsts & 1) aclsts = fndsts;
1001 if (!(aclsts & 1)) {
1003 set_vaxc_errno(aclsts);
1009 } /* end of kill_file() */
1013 /*{{{int my_mkdir(char *,Mode_t)*/
1015 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1017 STRLEN dirlen = strlen(dir);
1019 /* zero length string sometimes gives ACCVIO */
1020 if (dirlen == 0) return -1;
1022 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1023 * null file name/type. However, it's commonplace under Unix,
1024 * so we'll allow it for a gain in portability.
1026 if (dir[dirlen-1] == '/') {
1027 char *newdir = savepvn(dir,dirlen-1);
1028 int ret = mkdir(newdir,mode);
1032 else return mkdir(dir,mode);
1033 } /* end of my_mkdir */
1036 /*{{{int my_chdir(char *)*/
1038 Perl_my_chdir(pTHX_ char *dir)
1040 STRLEN dirlen = strlen(dir);
1042 /* zero length string sometimes gives ACCVIO */
1043 if (dirlen == 0) return -1;
1045 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1047 * null file name/type. However, it's commonplace under Unix,
1048 * so we'll allow it for a gain in portability.
1050 if (dir[dirlen-1] == '/') {
1051 char *newdir = savepvn(dir,dirlen-1);
1052 int ret = chdir(newdir);
1056 else return chdir(dir);
1057 } /* end of my_chdir */
1061 /*{{{FILE *my_tmpfile()*/
1068 if ((fp = tmpfile())) return fp;
1070 New(1323,cp,L_tmpnam+24,char);
1071 strcpy(cp,"Sys$Scratch:");
1072 tmpnam(cp+strlen(cp));
1073 strcat(cp,".Perltmp");
1074 fp = fopen(cp,"w+","fop=dlt");
1081 #ifndef HOMEGROWN_POSIX_SIGNALS
1083 * The C RTL's sigaction fails to check for invalid signal numbers so we
1084 * help it out a bit. The docs are correct, but the actual routine doesn't
1085 * do what the docs say it will.
1087 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1089 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1090 struct sigaction* oact)
1092 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1093 SETERRNO(EINVAL, SS$_INVARG);
1096 return sigaction(sig, act, oact);
1101 #ifdef KILL_BY_SIGPRC
1102 #include <errnodef.h>
1104 /* We implement our own kill() using the undocumented system service
1105 sys$sigprc for one of two reasons:
1107 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1108 target process to do a sys$exit, which usually can't be handled
1109 gracefully...certainly not by Perl and the %SIG{} mechanism.
1111 2.) If the kill() in the CRTL can't be called from a signal
1112 handler without disappearing into the ether, i.e., the signal
1113 it purportedly sends is never trapped. Still true as of VMS 7.3.
1115 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1116 in the target process rather than calling sys$exit.
1118 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1119 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1120 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1121 with condition codes C$_SIG0+nsig*8, catching the exception on the
1122 target process and resignaling with appropriate arguments.
1124 But we don't have that VMS 7.0+ exception handler, so if you
1125 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1127 Also note that SIGTERM is listed in the docs as being "unimplemented",
1128 yet always seems to be signaled with a VMS condition code of 4 (and
1129 correctly handled for that code). So we hardwire it in.
1131 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1132 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1133 than signalling with an unrecognized (and unhandled by CRTL) code.
1136 #define _MY_SIG_MAX 17
1139 Perl_sig_to_vmscondition(int sig)
1141 static unsigned int sig_code[_MY_SIG_MAX+1] =
1144 SS$_HANGUP, /* 1 SIGHUP */
1145 SS$_CONTROLC, /* 2 SIGINT */
1146 SS$_CONTROLY, /* 3 SIGQUIT */
1147 SS$_RADRMOD, /* 4 SIGILL */
1148 SS$_BREAK, /* 5 SIGTRAP */
1149 SS$_OPCCUS, /* 6 SIGABRT */
1150 SS$_COMPAT, /* 7 SIGEMT */
1152 SS$_FLTOVF, /* 8 SIGFPE VAX */
1154 SS$_HPARITH, /* 8 SIGFPE AXP */
1156 SS$_ABORT, /* 9 SIGKILL */
1157 SS$_ACCVIO, /* 10 SIGBUS */
1158 SS$_ACCVIO, /* 11 SIGSEGV */
1159 SS$_BADPARAM, /* 12 SIGSYS */
1160 SS$_NOMBX, /* 13 SIGPIPE */
1161 SS$_ASTFLT, /* 14 SIGALRM */
1167 #if __VMS_VER >= 60200000
1168 static int initted = 0;
1171 sig_code[16] = C$_SIGUSR1;
1172 sig_code[17] = C$_SIGUSR2;
1176 if (sig < _SIG_MIN) return 0;
1177 if (sig > _MY_SIG_MAX) return 0;
1178 return sig_code[sig];
1183 Perl_my_kill(int pid, int sig)
1188 int sys$sigprc(unsigned int *pidadr,
1189 struct dsc$descriptor_s *prcname,
1192 code = Perl_sig_to_vmscondition(sig);
1194 if (!pid || !code) {
1198 iss = sys$sigprc((unsigned int *)&pid,0,code);
1199 if (iss&1) return 0;
1203 set_errno(EPERM); break;
1205 case SS$_NOSUCHNODE:
1206 case SS$_UNREACHABLE:
1207 set_errno(ESRCH); break;
1209 set_errno(ENOMEM); break;
1214 set_vaxc_errno(iss);
1220 /* default piping mailbox size */
1221 #define PERL_BUFSIZ 512
1225 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1227 unsigned long int mbxbufsiz;
1228 static unsigned long int syssize = 0;
1229 unsigned long int dviitm = DVI$_DEVNAM;
1230 char csize[LNM$C_NAMLENGTH+1];
1233 unsigned long syiitm = SYI$_MAXBUF;
1235 * Get the SYSGEN parameter MAXBUF
1237 * If the logical 'PERL_MBX_SIZE' is defined
1238 * use the value of the logical instead of PERL_BUFSIZ, but
1239 * keep the size between 128 and MAXBUF.
1242 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1245 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1246 mbxbufsiz = atoi(csize);
1248 mbxbufsiz = PERL_BUFSIZ;
1250 if (mbxbufsiz < 128) mbxbufsiz = 128;
1251 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1253 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1255 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1256 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1258 } /* end of create_mbx() */
1261 /*{{{ my_popen and my_pclose*/
1263 typedef struct _iosb IOSB;
1264 typedef struct _iosb* pIOSB;
1265 typedef struct _pipe Pipe;
1266 typedef struct _pipe* pPipe;
1267 typedef struct pipe_details Info;
1268 typedef struct pipe_details* pInfo;
1269 typedef struct _srqp RQE;
1270 typedef struct _srqp* pRQE;
1271 typedef struct _tochildbuf CBuf;
1272 typedef struct _tochildbuf* pCBuf;
1275 unsigned short status;
1276 unsigned short count;
1277 unsigned long dvispec;
1280 #pragma member_alignment save
1281 #pragma nomember_alignment quadword
1282 struct _srqp { /* VMS self-relative queue entry */
1283 unsigned long qptr[2];
1285 #pragma member_alignment restore
1286 static RQE RQE_ZERO = {0,0};
1288 struct _tochildbuf {
1291 unsigned short size;
1299 unsigned short chan_in;
1300 unsigned short chan_out;
1302 unsigned int bufsize;
1314 #if defined(PERL_IMPLICIT_CONTEXT)
1315 void *thx; /* Either a thread or an interpreter */
1316 /* pointer, depending on how we're built */
1324 PerlIO *fp; /* file pointer to pipe mailbox */
1325 int useFILE; /* using stdio, not perlio */
1326 int pid; /* PID of subprocess */
1327 int mode; /* == 'r' if pipe open for reading */
1328 int done; /* subprocess has completed */
1329 int waiting; /* waiting for completion/closure */
1330 int closing; /* my_pclose is closing this pipe */
1331 unsigned long completion; /* termination status of subprocess */
1332 pPipe in; /* pipe in to sub */
1333 pPipe out; /* pipe out of sub */
1334 pPipe err; /* pipe of sub's sys$error */
1335 int in_done; /* true when in pipe finished */
1340 struct exit_control_block
1342 struct exit_control_block *flink;
1343 unsigned long int (*exit_routine)();
1344 unsigned long int arg_count;
1345 unsigned long int *status_address;
1346 unsigned long int exit_status;
1349 typedef struct _closed_pipes Xpipe;
1350 typedef struct _closed_pipes* pXpipe;
1352 struct _closed_pipes {
1353 int pid; /* PID of subprocess */
1354 unsigned long completion; /* termination status of subprocess */
1356 #define NKEEPCLOSED 50
1357 static Xpipe closed_list[NKEEPCLOSED];
1358 static int closed_index = 0;
1359 static int closed_num = 0;
1361 #define RETRY_DELAY "0 ::0.20"
1362 #define MAX_RETRY 50
1364 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1365 static unsigned long mypid;
1366 static unsigned long delaytime[2];
1368 static pInfo open_pipes = NULL;
1369 static $DESCRIPTOR(nl_desc, "NL:");
1371 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1375 static unsigned long int
1376 pipe_exit_routine(pTHX)
1379 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1380 int sts, did_stuff, need_eof, j;
1383 flush any pending i/o
1389 PerlIO_flush(info->fp); /* first, flush data */
1391 fflush((FILE *)info->fp);
1397 next we try sending an EOF...ignore if doesn't work, make sure we
1405 _ckvmssts(sys$setast(0));
1406 if (info->in && !info->in->shut_on_empty) {
1407 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1412 _ckvmssts(sys$setast(1));
1416 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1418 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1423 _ckvmssts(sys$setast(0));
1424 if (info->waiting && info->done)
1426 nwait += info->waiting;
1427 _ckvmssts(sys$setast(1));
1437 _ckvmssts(sys$setast(0));
1438 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1439 sts = sys$forcex(&info->pid,0,&abort);
1440 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1443 _ckvmssts(sys$setast(1));
1447 /* again, wait for effect */
1449 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1454 _ckvmssts(sys$setast(0));
1455 if (info->waiting && info->done)
1457 nwait += info->waiting;
1458 _ckvmssts(sys$setast(1));
1467 _ckvmssts(sys$setast(0));
1468 if (!info->done) { /* We tried to be nice . . . */
1469 sts = sys$delprc(&info->pid,0);
1470 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1472 _ckvmssts(sys$setast(1));
1477 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1478 else if (!(sts & 1)) retsts = sts;
1483 static struct exit_control_block pipe_exitblock =
1484 {(struct exit_control_block *) 0,
1485 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1487 static void pipe_mbxtofd_ast(pPipe p);
1488 static void pipe_tochild1_ast(pPipe p);
1489 static void pipe_tochild2_ast(pPipe p);
1492 popen_completion_ast(pInfo info)
1494 pInfo i = open_pipes;
1498 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1499 closed_list[closed_index].pid = info->pid;
1500 closed_list[closed_index].completion = info->completion;
1502 if (closed_index == NKEEPCLOSED)
1507 if (i == info) break;
1510 if (!i) return; /* unlinked, probably freed too */
1515 Writing to subprocess ...
1516 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1518 chan_out may be waiting for "done" flag, or hung waiting
1519 for i/o completion to child...cancel the i/o. This will
1520 put it into "snarf mode" (done but no EOF yet) that discards
1523 Output from subprocess (stdout, stderr) needs to be flushed and
1524 shut down. We try sending an EOF, but if the mbx is full the pipe
1525 routine should still catch the "shut_on_empty" flag, telling it to
1526 use immediate-style reads so that "mbx empty" -> EOF.
1530 if (info->in && !info->in_done) { /* only for mode=w */
1531 if (info->in->shut_on_empty && info->in->need_wake) {
1532 info->in->need_wake = FALSE;
1533 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1535 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1539 if (info->out && !info->out_done) { /* were we also piping output? */
1540 info->out->shut_on_empty = TRUE;
1541 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1542 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1543 _ckvmssts_noperl(iss);
1546 if (info->err && !info->err_done) { /* we were piping stderr */
1547 info->err->shut_on_empty = TRUE;
1548 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1549 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1550 _ckvmssts_noperl(iss);
1552 _ckvmssts_noperl(sys$setef(pipe_ef));
1556 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1557 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1560 we actually differ from vmstrnenv since we use this to
1561 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1562 are pointing to the same thing
1565 static unsigned short
1566 popen_translate(pTHX_ char *logical, char *result)
1569 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1570 $DESCRIPTOR(d_log,"");
1572 unsigned short length;
1573 unsigned short code;
1575 unsigned short *retlenaddr;
1577 unsigned short l, ifi;
1579 d_log.dsc$a_pointer = logical;
1580 d_log.dsc$w_length = strlen(logical);
1582 itmlst[0].code = LNM$_STRING;
1583 itmlst[0].length = 255;
1584 itmlst[0].buffer_addr = result;
1585 itmlst[0].retlenaddr = &l;
1588 itmlst[1].length = 0;
1589 itmlst[1].buffer_addr = 0;
1590 itmlst[1].retlenaddr = 0;
1592 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1593 if (iss == SS$_NOLOGNAM) {
1597 if (!(iss&1)) lib$signal(iss);
1600 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1601 strip it off and return the ifi, if any
1604 if (result[0] == 0x1b && result[1] == 0x00) {
1605 memcpy(&ifi,result+2,2);
1606 strcpy(result,result+4);
1608 return ifi; /* this is the RMS internal file id */
1611 static void pipe_infromchild_ast(pPipe p);
1614 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1615 inside an AST routine without worrying about reentrancy and which Perl
1616 memory allocator is being used.
1618 We read data and queue up the buffers, then spit them out one at a
1619 time to the output mailbox when the output mailbox is ready for one.
1622 #define INITIAL_TOCHILDQUEUE 2
1625 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1629 char mbx1[64], mbx2[64];
1630 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1631 DSC$K_CLASS_S, mbx1},
1632 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1633 DSC$K_CLASS_S, mbx2};
1634 unsigned int dviitm = DVI$_DEVBUFSIZ;
1637 New(1368, p, 1, Pipe);
1639 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1640 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1641 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1644 p->shut_on_empty = FALSE;
1645 p->need_wake = FALSE;
1648 p->iosb.status = SS$_NORMAL;
1649 p->iosb2.status = SS$_NORMAL;
1655 #ifdef PERL_IMPLICIT_CONTEXT
1659 n = sizeof(CBuf) + p->bufsize;
1661 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1662 _ckvmssts(lib$get_vm(&n, &b));
1663 b->buf = (char *) b + sizeof(CBuf);
1664 _ckvmssts(lib$insqhi(b, &p->free));
1667 pipe_tochild2_ast(p);
1668 pipe_tochild1_ast(p);
1674 /* reads the MBX Perl is writing, and queues */
1677 pipe_tochild1_ast(pPipe p)
1680 int iss = p->iosb.status;
1681 int eof = (iss == SS$_ENDOFFILE);
1682 #ifdef PERL_IMPLICIT_CONTEXT
1688 p->shut_on_empty = TRUE;
1690 _ckvmssts(sys$dassgn(p->chan_in));
1696 b->size = p->iosb.count;
1697 _ckvmssts(lib$insqhi(b, &p->wait));
1699 p->need_wake = FALSE;
1700 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1703 p->retry = 1; /* initial call */
1706 if (eof) { /* flush the free queue, return when done */
1707 int n = sizeof(CBuf) + p->bufsize;
1709 iss = lib$remqti(&p->free, &b);
1710 if (iss == LIB$_QUEWASEMP) return;
1712 _ckvmssts(lib$free_vm(&n, &b));
1716 iss = lib$remqti(&p->free, &b);
1717 if (iss == LIB$_QUEWASEMP) {
1718 int n = sizeof(CBuf) + p->bufsize;
1719 _ckvmssts(lib$get_vm(&n, &b));
1720 b->buf = (char *) b + sizeof(CBuf);
1726 iss = sys$qio(0,p->chan_in,
1727 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1729 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1730 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1735 /* writes queued buffers to output, waits for each to complete before
1739 pipe_tochild2_ast(pPipe p)
1742 int iss = p->iosb2.status;
1743 int n = sizeof(CBuf) + p->bufsize;
1744 int done = (p->info && p->info->done) ||
1745 iss == SS$_CANCEL || iss == SS$_ABORT;
1746 #if defined(PERL_IMPLICIT_CONTEXT)
1751 if (p->type) { /* type=1 has old buffer, dispose */
1752 if (p->shut_on_empty) {
1753 _ckvmssts(lib$free_vm(&n, &b));
1755 _ckvmssts(lib$insqhi(b, &p->free));
1760 iss = lib$remqti(&p->wait, &b);
1761 if (iss == LIB$_QUEWASEMP) {
1762 if (p->shut_on_empty) {
1764 _ckvmssts(sys$dassgn(p->chan_out));
1765 *p->pipe_done = TRUE;
1766 _ckvmssts(sys$setef(pipe_ef));
1768 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1769 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1773 p->need_wake = TRUE;
1783 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1784 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1786 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1787 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1796 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1799 char mbx1[64], mbx2[64];
1800 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1801 DSC$K_CLASS_S, mbx1},
1802 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1803 DSC$K_CLASS_S, mbx2};
1804 unsigned int dviitm = DVI$_DEVBUFSIZ;
1806 New(1367, p, 1, Pipe);
1807 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1808 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1810 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1811 New(1367, p->buf, p->bufsize, char);
1812 p->shut_on_empty = FALSE;
1815 p->iosb.status = SS$_NORMAL;
1816 #if defined(PERL_IMPLICIT_CONTEXT)
1819 pipe_infromchild_ast(p);
1827 pipe_infromchild_ast(pPipe p)
1829 int iss = p->iosb.status;
1830 int eof = (iss == SS$_ENDOFFILE);
1831 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1832 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1833 #if defined(PERL_IMPLICIT_CONTEXT)
1837 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1838 _ckvmssts(sys$dassgn(p->chan_out));
1843 input shutdown if EOF from self (done or shut_on_empty)
1844 output shutdown if closing flag set (my_pclose)
1845 send data/eof from child or eof from self
1846 otherwise, re-read (snarf of data from child)
1851 if (myeof && p->chan_in) { /* input shutdown */
1852 _ckvmssts(sys$dassgn(p->chan_in));
1857 if (myeof || kideof) { /* pass EOF to parent */
1858 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1859 pipe_infromchild_ast, p,
1862 } else if (eof) { /* eat EOF --- fall through to read*/
1864 } else { /* transmit data */
1865 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1866 pipe_infromchild_ast,p,
1867 p->buf, p->iosb.count, 0, 0, 0, 0));
1873 /* everything shut? flag as done */
1875 if (!p->chan_in && !p->chan_out) {
1876 *p->pipe_done = TRUE;
1877 _ckvmssts(sys$setef(pipe_ef));
1881 /* write completed (or read, if snarfing from child)
1882 if still have input active,
1883 queue read...immediate mode if shut_on_empty so we get EOF if empty
1885 check if Perl reading, generate EOFs as needed
1891 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1892 pipe_infromchild_ast,p,
1893 p->buf, p->bufsize, 0, 0, 0, 0);
1894 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1896 } else { /* send EOFs for extra reads */
1897 p->iosb.status = SS$_ENDOFFILE;
1898 p->iosb.dvispec = 0;
1899 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1901 pipe_infromchild_ast, p, 0, 0, 0, 0));
1907 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1911 unsigned long dviitm = DVI$_DEVBUFSIZ;
1913 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1914 DSC$K_CLASS_S, mbx};
1916 /* things like terminals and mbx's don't need this filter */
1917 if (fd && fstat(fd,&s) == 0) {
1918 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1919 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1920 DSC$K_CLASS_S, s.st_dev};
1922 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1923 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1924 strcpy(out, s.st_dev);
1929 New(1366, p, 1, Pipe);
1930 p->fd_out = dup(fd);
1931 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1932 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1933 New(1366, p->buf, p->bufsize+1, char);
1934 p->shut_on_empty = FALSE;
1939 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1940 pipe_mbxtofd_ast, p,
1941 p->buf, p->bufsize, 0, 0, 0, 0));
1947 pipe_mbxtofd_ast(pPipe p)
1949 int iss = p->iosb.status;
1950 int done = p->info->done;
1952 int eof = (iss == SS$_ENDOFFILE);
1953 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1954 int err = !(iss&1) && !eof;
1955 #if defined(PERL_IMPLICIT_CONTEXT)
1959 if (done && myeof) { /* end piping */
1961 sys$dassgn(p->chan_in);
1962 *p->pipe_done = TRUE;
1963 _ckvmssts(sys$setef(pipe_ef));
1967 if (!err && !eof) { /* good data to send to file */
1968 p->buf[p->iosb.count] = '\n';
1969 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1972 if (p->retry < MAX_RETRY) {
1973 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1983 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1984 pipe_mbxtofd_ast, p,
1985 p->buf, p->bufsize, 0, 0, 0, 0);
1986 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1991 typedef struct _pipeloc PLOC;
1992 typedef struct _pipeloc* pPLOC;
1996 char dir[NAM$C_MAXRSS+1];
1998 static pPLOC head_PLOC = 0;
2001 free_pipelocs(pTHX_ void *head)
2004 pPLOC *pHead = (pPLOC *)head;
2016 store_pipelocs(pTHX)
2025 char temp[NAM$C_MAXRSS+1];
2029 free_pipelocs(aTHX_ &head_PLOC);
2031 /* the . directory from @INC comes last */
2034 p->next = head_PLOC;
2036 strcpy(p->dir,"./");
2038 /* get the directory from $^X */
2040 #ifdef PERL_IMPLICIT_CONTEXT
2041 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2043 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2045 strcpy(temp, PL_origargv[0]);
2046 x = strrchr(temp,']');
2049 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2051 p->next = head_PLOC;
2053 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2054 p->dir[NAM$C_MAXRSS] = '\0';
2058 /* reverse order of @INC entries, skip "." since entered above */
2060 #ifdef PERL_IMPLICIT_CONTEXT
2063 if (PL_incgv) av = GvAVn(PL_incgv);
2065 for (i = 0; av && i <= AvFILL(av); i++) {
2066 dirsv = *av_fetch(av,i,TRUE);
2068 if (SvROK(dirsv)) continue;
2069 dir = SvPVx(dirsv,n_a);
2070 if (strcmp(dir,".") == 0) continue;
2071 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2075 p->next = head_PLOC;
2077 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2078 p->dir[NAM$C_MAXRSS] = '\0';
2081 /* most likely spot (ARCHLIB) put first in the list */
2084 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2086 p->next = head_PLOC;
2088 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2089 p->dir[NAM$C_MAXRSS] = '\0';
2098 static int vmspipe_file_status = 0;
2099 static char vmspipe_file[NAM$C_MAXRSS+1];
2101 /* already found? Check and use ... need read+execute permission */
2103 if (vmspipe_file_status == 1) {
2104 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2105 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2106 return vmspipe_file;
2108 vmspipe_file_status = 0;
2111 /* scan through stored @INC, $^X */
2113 if (vmspipe_file_status == 0) {
2114 char file[NAM$C_MAXRSS+1];
2115 pPLOC p = head_PLOC;
2118 strcpy(file, p->dir);
2119 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2120 file[NAM$C_MAXRSS] = '\0';
2123 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2125 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2126 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2127 vmspipe_file_status = 1;
2128 return vmspipe_file;
2131 vmspipe_file_status = -1; /* failed, use tempfiles */
2138 vmspipe_tempfile(pTHX)
2140 char file[NAM$C_MAXRSS+1];
2142 static int index = 0;
2145 /* create a tempfile */
2147 /* we can't go from W, shr=get to R, shr=get without
2148 an intermediate vulnerable state, so don't bother trying...
2150 and lib$spawn doesn't shr=put, so have to close the write
2152 So... match up the creation date/time and the FID to
2153 make sure we're dealing with the same file
2158 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2159 fp = fopen(file,"w");
2161 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2162 fp = fopen(file,"w");
2164 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2165 fp = fopen(file,"w");
2168 if (!fp) return 0; /* we're hosed */
2170 fprintf(fp,"$! 'f$verify(0)\n");
2171 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2172 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2173 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2174 fprintf(fp,"$ perl_on = \"set noon\"\n");
2175 fprintf(fp,"$ perl_exit = \"exit\"\n");
2176 fprintf(fp,"$ perl_del = \"delete\"\n");
2177 fprintf(fp,"$ pif = \"if\"\n");
2178 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2179 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2180 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2181 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2182 fprintf(fp,"$! --- build command line to get max possible length\n");
2183 fprintf(fp,"$c=perl_popen_cmd0\n");
2184 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2185 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2186 fprintf(fp,"$x=perl_popen_cmd3\n");
2187 fprintf(fp,"$c=c+x\n");
2188 fprintf(fp,"$! --- get rid of global symbols\n");
2189 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2190 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2191 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2192 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2193 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2194 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2195 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2196 fprintf(fp,"$ perl_on\n");
2197 fprintf(fp,"$ 'c\n");
2198 fprintf(fp,"$ perl_status = $STATUS\n");
2199 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2200 fprintf(fp,"$ perl_exit 'perl_status'\n");
2203 fgetname(fp, file, 1);
2204 fstat(fileno(fp), &s0);
2207 fp = fopen(file,"r","shr=get");
2209 fstat(fileno(fp), &s1);
2211 if (s0.st_ino[0] != s1.st_ino[0] ||
2212 s0.st_ino[1] != s1.st_ino[1] ||
2213 s0.st_ino[2] != s1.st_ino[2] ||
2214 s0.st_ctime != s1.st_ctime ) {
2225 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2227 static int handler_set_up = FALSE;
2228 unsigned long int sts, flags = CLI$M_NOWAIT;
2229 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2231 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2232 char in[512], out[512], err[512], mbx[512];
2234 char tfilebuf[NAM$C_MAXRSS+1];
2236 char cmd_sym_name[20];
2237 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2238 DSC$K_CLASS_S, symbol};
2239 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2241 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2242 DSC$K_CLASS_S, cmd_sym_name};
2243 struct dsc$descriptor_s *vmscmd;
2244 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2245 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2246 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2248 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2250 /* once-per-program initialization...
2251 note that the SETAST calls and the dual test of pipe_ef
2252 makes sure that only the FIRST thread through here does
2253 the initialization...all other threads wait until it's
2256 Yeah, uglier than a pthread call, it's got all the stuff inline
2257 rather than in a separate routine.
2261 _ckvmssts(sys$setast(0));
2263 unsigned long int pidcode = JPI$_PID;
2264 $DESCRIPTOR(d_delay, RETRY_DELAY);
2265 _ckvmssts(lib$get_ef(&pipe_ef));
2266 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2267 _ckvmssts(sys$bintim(&d_delay, delaytime));
2269 if (!handler_set_up) {
2270 _ckvmssts(sys$dclexh(&pipe_exitblock));
2271 handler_set_up = TRUE;
2273 _ckvmssts(sys$setast(1));
2276 /* see if we can find a VMSPIPE.COM */
2279 vmspipe = find_vmspipe(aTHX);
2281 strcpy(tfilebuf+1,vmspipe);
2282 } else { /* uh, oh...we're in tempfile hell */
2283 tpipe = vmspipe_tempfile(aTHX);
2284 if (!tpipe) { /* a fish popular in Boston */
2285 if (ckWARN(WARN_PIPE)) {
2286 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2290 fgetname(tpipe,tfilebuf+1,1);
2292 vmspipedsc.dsc$a_pointer = tfilebuf;
2293 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2295 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2298 case RMS$_FNF: case RMS$_DNF:
2299 set_errno(ENOENT); break;
2301 set_errno(ENOTDIR); break;
2303 set_errno(ENODEV); break;
2305 set_errno(EACCES); break;
2307 set_errno(EINVAL); break;
2308 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2309 set_errno(E2BIG); break;
2310 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2311 _ckvmssts(sts); /* fall through */
2312 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2315 set_vaxc_errno(sts);
2316 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2317 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2322 New(1301,info,1,Info);
2324 strcpy(mode,in_mode);
2327 info->completion = 0;
2328 info->closing = FALSE;
2335 info->in_done = TRUE;
2336 info->out_done = TRUE;
2337 info->err_done = TRUE;
2338 in[0] = out[0] = err[0] = '\0';
2340 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2344 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2349 if (*mode == 'r') { /* piping from subroutine */
2351 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2353 info->out->pipe_done = &info->out_done;
2354 info->out_done = FALSE;
2355 info->out->info = info;
2357 if (!info->useFILE) {
2358 info->fp = PerlIO_open(mbx, mode);
2360 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2361 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2364 if (!info->fp && info->out) {
2365 sys$cancel(info->out->chan_out);
2367 while (!info->out_done) {
2369 _ckvmssts(sys$setast(0));
2370 done = info->out_done;
2371 if (!done) _ckvmssts(sys$clref(pipe_ef));
2372 _ckvmssts(sys$setast(1));
2373 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2376 if (info->out->buf) Safefree(info->out->buf);
2377 Safefree(info->out);
2383 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2385 info->err->pipe_done = &info->err_done;
2386 info->err_done = FALSE;
2387 info->err->info = info;
2390 } else if (*mode == 'w') { /* piping to subroutine */
2392 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2394 info->out->pipe_done = &info->out_done;
2395 info->out_done = FALSE;
2396 info->out->info = info;
2399 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2401 info->err->pipe_done = &info->err_done;
2402 info->err_done = FALSE;
2403 info->err->info = info;
2406 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2407 if (!info->useFILE) {
2408 info->fp = PerlIO_open(mbx, mode);
2410 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2411 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2415 info->in->pipe_done = &info->in_done;
2416 info->in_done = FALSE;
2417 info->in->info = info;
2421 if (!info->fp && info->in) {
2423 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2424 0, 0, 0, 0, 0, 0, 0, 0));
2426 while (!info->in_done) {
2428 _ckvmssts(sys$setast(0));
2429 done = info->in_done;
2430 if (!done) _ckvmssts(sys$clref(pipe_ef));
2431 _ckvmssts(sys$setast(1));
2432 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2435 if (info->in->buf) Safefree(info->in->buf);
2443 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2444 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2446 info->out->pipe_done = &info->out_done;
2447 info->out_done = FALSE;
2448 info->out->info = info;
2451 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2453 info->err->pipe_done = &info->err_done;
2454 info->err_done = FALSE;
2455 info->err->info = info;
2459 symbol[MAX_DCL_SYMBOL] = '\0';
2461 strncpy(symbol, in, MAX_DCL_SYMBOL);
2462 d_symbol.dsc$w_length = strlen(symbol);
2463 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2465 strncpy(symbol, err, MAX_DCL_SYMBOL);
2466 d_symbol.dsc$w_length = strlen(symbol);
2467 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2469 strncpy(symbol, out, MAX_DCL_SYMBOL);
2470 d_symbol.dsc$w_length = strlen(symbol);
2471 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2473 p = vmscmd->dsc$a_pointer;
2474 while (*p && *p != '\n') p++;
2475 *p = '\0'; /* truncate on \n */
2476 p = vmscmd->dsc$a_pointer;
2477 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2478 if (*p == '$') p++; /* remove leading $ */
2479 while (*p == ' ' || *p == '\t') p++;
2481 for (j = 0; j < 4; j++) {
2482 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2483 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2485 strncpy(symbol, p, MAX_DCL_SYMBOL);
2486 d_symbol.dsc$w_length = strlen(symbol);
2487 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2489 if (strlen(p) > MAX_DCL_SYMBOL) {
2490 p += MAX_DCL_SYMBOL;
2495 _ckvmssts(sys$setast(0));
2496 info->next=open_pipes; /* prepend to list */
2498 _ckvmssts(sys$setast(1));
2499 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2500 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2501 * have SYS$COMMAND if we need it.
2503 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2504 0, &info->pid, &info->completion,
2505 0, popen_completion_ast,info,0,0,0));
2507 /* if we were using a tempfile, close it now */
2509 if (tpipe) fclose(tpipe);
2511 /* once the subprocess is spawned, it has copied the symbols and
2512 we can get rid of ours */
2514 for (j = 0; j < 4; j++) {
2515 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2516 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2517 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2519 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2520 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2521 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2522 vms_execfree(vmscmd);
2524 #ifdef PERL_IMPLICIT_CONTEXT
2527 PL_forkprocess = info->pid;
2532 _ckvmssts(sys$setast(0));
2534 if (!done) _ckvmssts(sys$clref(pipe_ef));
2535 _ckvmssts(sys$setast(1));
2536 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2538 *psts = info->completion;
2539 my_pclose(info->fp);
2544 } /* end of safe_popen */
2547 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2549 Perl_my_popen(pTHX_ char *cmd, char *mode)
2553 TAINT_PROPER("popen");
2554 PERL_FLUSHALL_FOR_CHILD;
2555 return safe_popen(aTHX_ cmd,mode,&sts);
2560 /*{{{ I32 my_pclose(PerlIO *fp)*/
2561 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2563 pInfo info, last = NULL;
2564 unsigned long int retsts;
2567 for (info = open_pipes; info != NULL; last = info, info = info->next)
2568 if (info->fp == fp) break;
2570 if (info == NULL) { /* no such pipe open */
2571 set_errno(ECHILD); /* quoth POSIX */
2572 set_vaxc_errno(SS$_NONEXPR);
2576 /* If we were writing to a subprocess, insure that someone reading from
2577 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2578 * produce an EOF record in the mailbox.
2580 * well, at least sometimes it *does*, so we have to watch out for
2581 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2585 PerlIO_flush(info->fp); /* first, flush data */
2587 fflush((FILE *)info->fp);
2590 _ckvmssts(sys$setast(0));
2591 info->closing = TRUE;
2592 done = info->done && info->in_done && info->out_done && info->err_done;
2593 /* hanging on write to Perl's input? cancel it */
2594 if (info->mode == 'r' && info->out && !info->out_done) {
2595 if (info->out->chan_out) {
2596 _ckvmssts(sys$cancel(info->out->chan_out));
2597 if (!info->out->chan_in) { /* EOF generation, need AST */
2598 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2602 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2603 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2605 _ckvmssts(sys$setast(1));
2608 PerlIO_close(info->fp);
2610 fclose((FILE *)info->fp);
2613 we have to wait until subprocess completes, but ALSO wait until all
2614 the i/o completes...otherwise we'll be freeing the "info" structure
2615 that the i/o ASTs could still be using...
2619 _ckvmssts(sys$setast(0));
2620 done = info->done && info->in_done && info->out_done && info->err_done;
2621 if (!done) _ckvmssts(sys$clref(pipe_ef));
2622 _ckvmssts(sys$setast(1));
2623 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2625 retsts = info->completion;
2627 /* remove from list of open pipes */
2628 _ckvmssts(sys$setast(0));
2629 if (last) last->next = info->next;
2630 else open_pipes = info->next;
2631 _ckvmssts(sys$setast(1));
2633 /* free buffers and structures */
2636 if (info->in->buf) Safefree(info->in->buf);
2640 if (info->out->buf) Safefree(info->out->buf);
2641 Safefree(info->out);
2644 if (info->err->buf) Safefree(info->err->buf);
2645 Safefree(info->err);
2651 } /* end of my_pclose() */
2653 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2654 /* Roll our own prototype because we want this regardless of whether
2655 * _VMS_WAIT is defined.
2657 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2659 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2660 created with popen(); otherwise partially emulate waitpid() unless
2661 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2662 Also check processes not considered by the CRTL waitpid().
2664 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2666 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2673 if (statusp) *statusp = 0;
2675 for (info = open_pipes; info != NULL; info = info->next)
2676 if (info->pid == pid) break;
2678 if (info != NULL) { /* we know about this child */
2679 while (!info->done) {
2680 _ckvmssts(sys$setast(0));
2682 if (!done) _ckvmssts(sys$clref(pipe_ef));
2683 _ckvmssts(sys$setast(1));
2684 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2687 if (statusp) *statusp = info->completion;
2691 /* child that already terminated? */
2693 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2694 if (closed_list[j].pid == pid) {
2695 if (statusp) *statusp = closed_list[j].completion;
2700 /* fall through if this child is not one of our own pipe children */
2702 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2704 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2705 * in 7.2 did we get a version that fills in the VMS completion
2706 * status as Perl has always tried to do.
2709 sts = __vms_waitpid( pid, statusp, flags );
2711 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2714 /* If the real waitpid tells us the child does not exist, we
2715 * fall through here to implement waiting for a child that
2716 * was created by some means other than exec() (say, spawned
2717 * from DCL) or to wait for a process that is not a subprocess
2718 * of the current process.
2721 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2724 $DESCRIPTOR(intdsc,"0 00:00:01");
2725 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2726 unsigned long int pidcode = JPI$_PID, mypid;
2727 unsigned long int interval[2];
2728 unsigned int jpi_iosb[2];
2729 struct itmlst_3 jpilist[2] = {
2730 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2735 /* Sorry folks, we don't presently implement rooting around for
2736 the first child we can find, and we definitely don't want to
2737 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2743 /* Get the owner of the child so I can warn if it's not mine. If the
2744 * process doesn't exist or I don't have the privs to look at it,
2745 * I can go home early.
2747 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2748 if (sts & 1) sts = jpi_iosb[0];
2760 set_vaxc_errno(sts);
2764 if (ckWARN(WARN_EXEC)) {
2765 /* remind folks they are asking for non-standard waitpid behavior */
2766 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2767 if (ownerpid != mypid)
2768 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2769 "waitpid: process %x is not a child of process %x",
2773 /* simply check on it once a second until it's not there anymore. */
2775 _ckvmssts(sys$bintim(&intdsc,interval));
2776 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2777 _ckvmssts(sys$schdwk(0,0,interval,0));
2778 _ckvmssts(sys$hiber());
2780 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2785 } /* end of waitpid() */
2790 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2792 my_gconvert(double val, int ndig, int trail, char *buf)
2794 static char __gcvtbuf[DBL_DIG+1];
2797 loc = buf ? buf : __gcvtbuf;
2799 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2801 sprintf(loc,"%.*g",ndig,val);
2807 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2808 return gcvt(val,ndig,loc);
2811 loc[0] = '0'; loc[1] = '\0';
2819 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2820 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2821 * to expand file specification. Allows for a single default file
2822 * specification and a simple mask of options. If outbuf is non-NULL,
2823 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2824 * the resultant file specification is placed. If outbuf is NULL, the
2825 * resultant file specification is placed into a static buffer.
2826 * The third argument, if non-NULL, is taken to be a default file
2827 * specification string. The fourth argument is unused at present.
2828 * rmesexpand() returns the address of the resultant string if
2829 * successful, and NULL on error.
2831 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2834 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2836 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2837 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2838 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2839 struct FAB myfab = cc$rms_fab;
2840 struct NAM mynam = cc$rms_nam;
2842 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2844 if (!filespec || !*filespec) {
2845 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2849 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2850 else outbuf = __rmsexpand_retbuf;
2852 if ((isunix = (strchr(filespec,'/') != NULL))) {
2853 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2854 filespec = vmsfspec;
2857 myfab.fab$l_fna = filespec;
2858 myfab.fab$b_fns = strlen(filespec);
2859 myfab.fab$l_nam = &mynam;
2861 if (defspec && *defspec) {
2862 if (strchr(defspec,'/') != NULL) {
2863 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2866 myfab.fab$l_dna = defspec;
2867 myfab.fab$b_dns = strlen(defspec);
2870 mynam.nam$l_esa = esa;
2871 mynam.nam$b_ess = sizeof esa;
2872 mynam.nam$l_rsa = outbuf;
2873 mynam.nam$b_rss = NAM$C_MAXRSS;
2875 retsts = sys$parse(&myfab,0,0);
2876 if (!(retsts & 1)) {
2877 mynam.nam$b_nop |= NAM$M_SYNCHK;
2878 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2879 retsts = sys$parse(&myfab,0,0);
2880 if (retsts & 1) goto expanded;
2882 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2883 (void) sys$parse(&myfab,0,0); /* Free search context */
2884 if (out) Safefree(out);
2885 set_vaxc_errno(retsts);
2886 if (retsts == RMS$_PRV) set_errno(EACCES);
2887 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2888 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2889 else set_errno(EVMSERR);
2892 retsts = sys$search(&myfab,0,0);
2893 if (!(retsts & 1) && retsts != RMS$_FNF) {
2894 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2895 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2896 if (out) Safefree(out);
2897 set_vaxc_errno(retsts);
2898 if (retsts == RMS$_PRV) set_errno(EACCES);
2899 else set_errno(EVMSERR);
2903 /* If the input filespec contained any lowercase characters,
2904 * downcase the result for compatibility with Unix-minded code. */
2906 for (out = myfab.fab$l_fna; *out; out++)
2907 if (islower(*out)) { haslower = 1; break; }
2908 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2909 else { out = esa; speclen = mynam.nam$b_esl; }
2910 /* Trim off null fields added by $PARSE
2911 * If type > 1 char, must have been specified in original or default spec
2912 * (not true for version; $SEARCH may have added version of existing file).
2914 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2915 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2916 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2917 if (trimver || trimtype) {
2918 if (defspec && *defspec) {
2919 char defesa[NAM$C_MAXRSS];
2920 struct FAB deffab = cc$rms_fab;
2921 struct NAM defnam = cc$rms_nam;
2923 deffab.fab$l_nam = &defnam;
2924 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2925 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2926 defnam.nam$b_nop = NAM$M_SYNCHK;
2927 if (sys$parse(&deffab,0,0) & 1) {
2928 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2929 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2932 if (trimver) speclen = mynam.nam$l_ver - out;
2934 /* If we didn't already trim version, copy down */
2935 if (speclen > mynam.nam$l_ver - out)
2936 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2937 speclen - (mynam.nam$l_ver - out));
2938 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2941 /* If we just had a directory spec on input, $PARSE "helpfully"
2942 * adds an empty name and type for us */
2943 if (mynam.nam$l_name == mynam.nam$l_type &&
2944 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2945 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2946 speclen = mynam.nam$l_name - out;
2947 out[speclen] = '\0';
2948 if (haslower) __mystrtolower(out);
2950 /* Have we been working with an expanded, but not resultant, spec? */
2951 /* Also, convert back to Unix syntax if necessary. */
2952 if (!mynam.nam$b_rsl) {
2954 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2956 else strcpy(outbuf,esa);
2959 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2960 strcpy(outbuf,tmpfspec);
2962 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2963 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2964 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2968 /* External entry points */
2969 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2970 { return do_rmsexpand(spec,buf,0,def,opt); }
2971 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2972 { return do_rmsexpand(spec,buf,1,def,opt); }
2976 ** The following routines are provided to make life easier when
2977 ** converting among VMS-style and Unix-style directory specifications.
2978 ** All will take input specifications in either VMS or Unix syntax. On
2979 ** failure, all return NULL. If successful, the routines listed below
2980 ** return a pointer to a buffer containing the appropriately
2981 ** reformatted spec (and, therefore, subsequent calls to that routine
2982 ** will clobber the result), while the routines of the same names with
2983 ** a _ts suffix appended will return a pointer to a mallocd string
2984 ** containing the appropriately reformatted spec.
2985 ** In all cases, only explicit syntax is altered; no check is made that
2986 ** the resulting string is valid or that the directory in question
2989 ** fileify_dirspec() - convert a directory spec into the name of the
2990 ** directory file (i.e. what you can stat() to see if it's a dir).
2991 ** The style (VMS or Unix) of the result is the same as the style
2992 ** of the parameter passed in.
2993 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2994 ** what you prepend to a filename to indicate what directory it's in).
2995 ** The style (VMS or Unix) of the result is the same as the style
2996 ** of the parameter passed in.
2997 ** tounixpath() - convert a directory spec into a Unix-style path.
2998 ** tovmspath() - convert a directory spec into a VMS-style path.
2999 ** tounixspec() - convert any file spec into a Unix-style file spec.
3000 ** tovmsspec() - convert any file spec into a VMS-style spec.
3002 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3003 ** Permission is given to distribute this code as part of the Perl
3004 ** standard distribution under the terms of the GNU General Public
3005 ** License or the Perl Artistic License. Copies of each may be
3006 ** found in the Perl standard distribution.
3009 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3010 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3012 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3013 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3014 char *retspec, *cp1, *cp2, *lastdir;
3015 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3016 unsigned short int trnlnm_iter_count;
3018 if (!dir || !*dir) {
3019 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3021 dirlen = strlen(dir);
3022 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3023 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3024 strcpy(trndir,"/sys$disk/000000");
3028 if (dirlen > NAM$C_MAXRSS) {
3029 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3031 if (!strpbrk(dir+1,"/]>:")) {
3032 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3033 trnlnm_iter_count = 0;
3034 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3035 trnlnm_iter_count++;
3036 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3039 dirlen = strlen(dir);
3042 strncpy(trndir,dir,dirlen);
3043 trndir[dirlen] = '\0';
3046 /* If we were handed a rooted logical name or spec, treat it like a
3047 * simple directory, so that
3048 * $ Define myroot dev:[dir.]
3049 * ... do_fileify_dirspec("myroot",buf,1) ...
3050 * does something useful.
3052 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3053 dir[--dirlen] = '\0';
3054 dir[dirlen-1] = ']';
3056 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3057 dir[--dirlen] = '\0';
3058 dir[dirlen-1] = '>';
3061 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3062 /* If we've got an explicit filename, we can just shuffle the string. */
3063 if (*(cp1+1)) hasfilename = 1;
3064 /* Similarly, we can just back up a level if we've got multiple levels
3065 of explicit directories in a VMS spec which ends with directories. */
3067 for (cp2 = cp1; cp2 > dir; cp2--) {
3069 *cp2 = *cp1; *cp1 = '\0';
3073 if (*cp2 == '[' || *cp2 == '<') break;
3078 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3079 if (dir[0] == '.') {
3080 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3081 return do_fileify_dirspec("[]",buf,ts);
3082 else if (dir[1] == '.' &&
3083 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3084 return do_fileify_dirspec("[-]",buf,ts);
3086 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3087 dirlen -= 1; /* to last element */
3088 lastdir = strrchr(dir,'/');
3090 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3091 /* If we have "/." or "/..", VMSify it and let the VMS code
3092 * below expand it, rather than repeating the code to handle
3093 * relative components of a filespec here */
3095 if (*(cp1+2) == '.') cp1++;
3096 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3097 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3098 if (strchr(vmsdir,'/') != NULL) {
3099 /* If do_tovmsspec() returned it, it must have VMS syntax
3100 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3101 * the time to check this here only so we avoid a recursion
3102 * loop; otherwise, gigo.
3104 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3106 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3107 return do_tounixspec(trndir,buf,ts);
3110 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3111 lastdir = strrchr(dir,'/');
3113 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3114 /* Ditto for specs that end in an MFD -- let the VMS code
3115 * figure out whether it's a real device or a rooted logical. */
3116 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3117 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3118 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3119 return do_tounixspec(trndir,buf,ts);
3122 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3123 !(lastdir = cp1 = strrchr(dir,']')) &&
3124 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3125 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3127 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3128 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3129 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3130 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3131 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3132 (ver || *cp3)))))) {
3134 set_vaxc_errno(RMS$_DIR);
3140 /* If we lead off with a device or rooted logical, add the MFD
3141 if we're specifying a top-level directory. */
3142 if (lastdir && *dir == '/') {
3144 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3151 retlen = dirlen + (addmfd ? 13 : 6);
3152 if (buf) retspec = buf;
3153 else if (ts) New(1309,retspec,retlen+1,char);
3154 else retspec = __fileify_retbuf;
3156 dirlen = lastdir - dir;
3157 memcpy(retspec,dir,dirlen);
3158 strcpy(&retspec[dirlen],"/000000");
3159 strcpy(&retspec[dirlen+7],lastdir);
3162 memcpy(retspec,dir,dirlen);
3163 retspec[dirlen] = '\0';
3165 /* We've picked up everything up to the directory file name.
3166 Now just add the type and version, and we're set. */
3167 strcat(retspec,".dir;1");
3170 else { /* VMS-style directory spec */
3171 char esa[NAM$C_MAXRSS+1], term, *cp;
3172 unsigned long int sts, cmplen, haslower = 0;
3173 struct FAB dirfab = cc$rms_fab;
3174 struct NAM savnam, dirnam = cc$rms_nam;
3176 dirfab.fab$b_fns = strlen(dir);
3177 dirfab.fab$l_fna = dir;
3178 dirfab.fab$l_nam = &dirnam;
3179 dirfab.fab$l_dna = ".DIR;1";
3180 dirfab.fab$b_dns = 6;
3181 dirnam.nam$b_ess = NAM$C_MAXRSS;
3182 dirnam.nam$l_esa = esa;
3184 for (cp = dir; *cp; cp++)
3185 if (islower(*cp)) { haslower = 1; break; }
3186 if (!((sts = sys$parse(&dirfab))&1)) {
3187 if (dirfab.fab$l_sts == RMS$_DIR) {
3188 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3189 sts = sys$parse(&dirfab) & 1;
3193 set_vaxc_errno(dirfab.fab$l_sts);
3199 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3200 /* Yes; fake the fnb bits so we'll check type below */
3201 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3203 else { /* No; just work with potential name */
3204 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3206 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3207 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3208 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3213 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3214 cp1 = strchr(esa,']');
3215 if (!cp1) cp1 = strchr(esa,'>');
3216 if (cp1) { /* Should always be true */
3217 dirnam.nam$b_esl -= cp1 - esa - 1;
3218 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3221 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3222 /* Yep; check version while we're at it, if it's there. */
3223 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3224 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3225 /* Something other than .DIR[;1]. Bzzt. */
3226 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3227 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3229 set_vaxc_errno(RMS$_DIR);
3233 esa[dirnam.nam$b_esl] = '\0';
3234 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3235 /* They provided at least the name; we added the type, if necessary, */
3236 if (buf) retspec = buf; /* in sys$parse() */
3237 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3238 else retspec = __fileify_retbuf;
3239 strcpy(retspec,esa);
3240 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3241 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3244 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3245 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3247 dirnam.nam$b_esl -= 9;
3249 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3250 if (cp1 == NULL) { /* should never happen */
3251 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3252 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3257 retlen = strlen(esa);
3258 if ((cp1 = strrchr(esa,'.')) != NULL) {
3259 /* There's more than one directory in the path. Just roll back. */
3261 if (buf) retspec = buf;
3262 else if (ts) New(1311,retspec,retlen+7,char);
3263 else retspec = __fileify_retbuf;
3264 strcpy(retspec,esa);
3267 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3268 /* Go back and expand rooted logical name */
3269 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3270 if (!(sys$parse(&dirfab) & 1)) {
3271 dirnam.nam$l_rlf = NULL;
3272 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3274 set_vaxc_errno(dirfab.fab$l_sts);
3277 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3278 if (buf) retspec = buf;
3279 else if (ts) New(1312,retspec,retlen+16,char);
3280 else retspec = __fileify_retbuf;
3281 cp1 = strstr(esa,"][");
3282 if (!cp1) cp1 = strstr(esa,"]<");
3284 memcpy(retspec,esa,dirlen);
3285 if (!strncmp(cp1+2,"000000]",7)) {
3286 retspec[dirlen-1] = '\0';
3287 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3288 if (*cp1 == '.') *cp1 = ']';
3290 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3291 memcpy(cp1+1,"000000]",7);
3295 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3296 retspec[retlen] = '\0';
3297 /* Convert last '.' to ']' */
3298 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3299 if (*cp1 == '.') *cp1 = ']';
3301 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3302 memcpy(cp1+1,"000000]",7);
3306 else { /* This is a top-level dir. Add the MFD to the path. */
3307 if (buf) retspec = buf;
3308 else if (ts) New(1312,retspec,retlen+16,char);
3309 else retspec = __fileify_retbuf;
3312 while (*cp1 != ':') *(cp2++) = *(cp1++);
3313 strcpy(cp2,":[000000]");
3318 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3319 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3320 /* We've set up the string up through the filename. Add the
3321 type and version, and we're done. */
3322 strcat(retspec,".DIR;1");
3324 /* $PARSE may have upcased filespec, so convert output to lower
3325 * case if input contained any lowercase characters. */
3326 if (haslower) __mystrtolower(retspec);
3329 } /* end of do_fileify_dirspec() */
3331 /* External entry points */
3332 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3333 { return do_fileify_dirspec(dir,buf,0); }
3334 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3335 { return do_fileify_dirspec(dir,buf,1); }
3337 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3338 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3340 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3341 unsigned long int retlen;
3342 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3343 unsigned short int trnlnm_iter_count;
3345 if (!dir || !*dir) {
3346 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3349 if (*dir) strcpy(trndir,dir);
3350 else getcwd(trndir,sizeof trndir - 1);
3352 trnlnm_iter_count = 0;
3353 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3354 && my_trnlnm(trndir,trndir,0)) {
3355 trnlnm_iter_count++;
3356 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3357 STRLEN trnlen = strlen(trndir);
3359 /* Trap simple rooted lnms, and return lnm:[000000] */
3360 if (!strcmp(trndir+trnlen-2,".]")) {
3361 if (buf) retpath = buf;
3362 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3363 else retpath = __pathify_retbuf;
3364 strcpy(retpath,dir);
3365 strcat(retpath,":[000000]");
3371 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3372 if (*dir == '.' && (*(dir+1) == '\0' ||
3373 (*(dir+1) == '.' && *(dir+2) == '\0')))
3374 retlen = 2 + (*(dir+1) != '\0');
3376 if ( !(cp1 = strrchr(dir,'/')) &&
3377 !(cp1 = strrchr(dir,']')) &&
3378 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3379 if ((cp2 = strchr(cp1,'.')) != NULL &&
3380 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3381 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3382 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3383 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3385 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3386 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3387 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3388 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3389 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3390 (ver || *cp3)))))) {
3392 set_vaxc_errno(RMS$_DIR);
3395 retlen = cp2 - dir + 1;
3397 else { /* No file type present. Treat the filename as a directory. */
3398 retlen = strlen(dir) + 1;
3401 if (buf) retpath = buf;
3402 else if (ts) New(1313,retpath,retlen+1,char);
3403 else retpath = __pathify_retbuf;
3404 strncpy(retpath,dir,retlen-1);
3405 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3406 retpath[retlen-1] = '/'; /* with '/', add it. */
3407 retpath[retlen] = '\0';
3409 else retpath[retlen-1] = '\0';
3411 else { /* VMS-style directory spec */
3412 char esa[NAM$C_MAXRSS+1], *cp;
3413 unsigned long int sts, cmplen, haslower;
3414 struct FAB dirfab = cc$rms_fab;
3415 struct NAM savnam, dirnam = cc$rms_nam;
3417 /* If we've got an explicit filename, we can just shuffle the string. */
3418 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3419 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3420 if ((cp2 = strchr(cp1,'.')) != NULL) {
3422 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3423 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3424 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3425 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3426 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3427 (ver || *cp3)))))) {
3429 set_vaxc_errno(RMS$_DIR);
3433 else { /* No file type, so just draw name into directory part */
3434 for (cp2 = cp1; *cp2; cp2++) ;
3437 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3439 /* We've now got a VMS 'path'; fall through */
3441 dirfab.fab$b_fns = strlen(dir);
3442 dirfab.fab$l_fna = dir;
3443 if (dir[dirfab.fab$b_fns-1] == ']' ||
3444 dir[dirfab.fab$b_fns-1] == '>' ||
3445 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3446 if (buf) retpath = buf;
3447 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3448 else retpath = __pathify_retbuf;
3449 strcpy(retpath,dir);
3452 dirfab.fab$l_dna = ".DIR;1";
3453 dirfab.fab$b_dns = 6;
3454 dirfab.fab$l_nam = &dirnam;
3455 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3456 dirnam.nam$l_esa = esa;
3458 for (cp = dir; *cp; cp++)
3459 if (islower(*cp)) { haslower = 1; break; }
3461 if (!(sts = (sys$parse(&dirfab)&1))) {
3462 if (dirfab.fab$l_sts == RMS$_DIR) {
3463 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3464 sts = sys$parse(&dirfab) & 1;
3468 set_vaxc_errno(dirfab.fab$l_sts);
3474 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3475 if (dirfab.fab$l_sts != RMS$_FNF) {
3476 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3477 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3479 set_vaxc_errno(dirfab.fab$l_sts);
3482 dirnam = savnam; /* No; just work with potential name */
3485 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3486 /* Yep; check version while we're at it, if it's there. */
3487 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3488 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3489 /* Something other than .DIR[;1]. Bzzt. */
3490 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3491 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3493 set_vaxc_errno(RMS$_DIR);
3497 /* OK, the type was fine. Now pull any file name into the
3499 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3501 cp1 = strrchr(esa,'>');
3502 *dirnam.nam$l_type = '>';
3505 *(dirnam.nam$l_type + 1) = '\0';
3506 retlen = dirnam.nam$l_type - esa + 2;
3507 if (buf) retpath = buf;
3508 else if (ts) New(1314,retpath,retlen,char);
3509 else retpath = __pathify_retbuf;
3510 strcpy(retpath,esa);
3511 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3512 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3513 /* $PARSE may have upcased filespec, so convert output to lower
3514 * case if input contained any lowercase characters. */
3515 if (haslower) __mystrtolower(retpath);
3519 } /* end of do_pathify_dirspec() */
3521 /* External entry points */
3522 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3523 { return do_pathify_dirspec(dir,buf,0); }
3524 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3525 { return do_pathify_dirspec(dir,buf,1); }
3527 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3528 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3530 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3531 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3532 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3533 unsigned short int trnlnm_iter_count;
3535 if (spec == NULL) return NULL;
3536 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3537 if (buf) rslt = buf;
3539 retlen = strlen(spec);
3540 cp1 = strchr(spec,'[');
3541 if (!cp1) cp1 = strchr(spec,'<');
3543 for (cp1++; *cp1; cp1++) {
3544 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3545 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3546 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3549 New(1315,rslt,retlen+2+2*expand,char);
3551 else rslt = __tounixspec_retbuf;
3552 if (strchr(spec,'/') != NULL) {
3559 dirend = strrchr(spec,']');
3560 if (dirend == NULL) dirend = strrchr(spec,'>');
3561 if (dirend == NULL) dirend = strchr(spec,':');
3562 if (dirend == NULL) {
3566 if (*cp2 != '[' && *cp2 != '<') {
3569 else { /* the VMS spec begins with directories */
3571 if (*cp2 == ']' || *cp2 == '>') {
3572 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3575 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3576 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3577 if (ts) Safefree(rslt);
3580 trnlnm_iter_count = 0;
3583 while (*cp3 != ':' && *cp3) cp3++;
3585 if (strchr(cp3,']') != NULL) break;
3586 trnlnm_iter_count++;
3587 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3588 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3590 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3591 retlen = devlen + dirlen;
3592 Renew(rslt,retlen+1+2*expand,char);
3598 *(cp1++) = *(cp3++);
3599 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3603 else if ( *cp2 == '.') {
3604 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3605 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3611 for (; cp2 <= dirend; cp2++) {
3614 if (*(cp2+1) == '[') cp2++;
3616 else if (*cp2 == ']' || *cp2 == '>') {
3617 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3619 else if (*cp2 == '.') {
3621 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3622 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3623 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3624 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3625 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3627 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3628 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3632 else if (*cp2 == '-') {
3633 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3634 while (*cp2 == '-') {
3636 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3638 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3639 if (ts) Safefree(rslt); /* filespecs like */
3640 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3644 else *(cp1++) = *cp2;
3646 else *(cp1++) = *cp2;
3648 while (*cp2) *(cp1++) = *(cp2++);
3653 } /* end of do_tounixspec() */
3655 /* External entry points */
3656 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3657 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3659 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3660 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3661 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3662 char *rslt, *dirend;
3663 register char *cp1, *cp2;
3664 unsigned long int infront = 0, hasdir = 1;
3666 if (path == NULL) return NULL;
3667 if (buf) rslt = buf;
3668 else if (ts) New(1316,rslt,strlen(path)+9,char);
3669 else rslt = __tovmsspec_retbuf;
3670 if (strpbrk(path,"]:>") ||
3671 (dirend = strrchr(path,'/')) == NULL) {
3672 if (path[0] == '.') {
3673 if (path[1] == '\0') strcpy(rslt,"[]");
3674 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3675 else strcpy(rslt,path); /* probably garbage */
3677 else strcpy(rslt,path);
3680 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3681 if (!*(dirend+2)) dirend +=2;
3682 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3683 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3688 char trndev[NAM$C_MAXRSS+1];
3692 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3694 if (!buf & ts) Renew(rslt,18,char);
3695 strcpy(rslt,"sys$disk:[000000]");
3698 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3700 islnm = my_trnlnm(rslt,trndev,0);
3701 trnend = islnm ? strlen(trndev) - 1 : 0;
3702 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3703 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3704 /* If the first element of the path is a logical name, determine
3705 * whether it has to be translated so we can add more directories. */
3706 if (!islnm || rooted) {
3709 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3713 if (cp2 != dirend) {
3714 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3715 strcpy(rslt,trndev);
3716 cp1 = rslt + trnend;
3729 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3730 cp2 += 2; /* skip over "./" - it's redundant */
3731 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3733 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3734 *(cp1++) = '-'; /* "../" --> "-" */
3737 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3738 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3739 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3740 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3743 if (cp2 > dirend) cp2 = dirend;
3745 else *(cp1++) = '.';
3747 for (; cp2 < dirend; cp2++) {
3749 if (*(cp2-1) == '/') continue;
3750 if (*(cp1-1) != '.') *(cp1++) = '.';
3753 else if (!infront && *cp2 == '.') {
3754 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3755 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3756 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3757 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3758 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3759 else { /* back up over previous directory name */
3761 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3762 if (*(cp1-1) == '[') {
3763 memcpy(cp1,"000000.",7);
3768 if (cp2 == dirend) break;
3770 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3771 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3772 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3773 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3775 *(cp1++) = '.'; /* Simulate trailing '/' */
3776 cp2 += 2; /* for loop will incr this to == dirend */
3778 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3780 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3783 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3784 if (*cp2 == '.') *(cp1++) = '_';
3785 else *(cp1++) = *cp2;
3789 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3790 if (hasdir) *(cp1++) = ']';
3791 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3792 while (*cp2) *(cp1++) = *(cp2++);
3797 } /* end of do_tovmsspec() */
3799 /* External entry points */
3800 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3801 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3803 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3804 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3805 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3807 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3809 if (path == NULL) return NULL;
3810 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3811 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3812 if (buf) return buf;
3814 vmslen = strlen(vmsified);
3815 New(1317,cp,vmslen+1,char);
3816 memcpy(cp,vmsified,vmslen);
3821 strcpy(__tovmspath_retbuf,vmsified);
3822 return __tovmspath_retbuf;
3825 } /* end of do_tovmspath() */
3827 /* External entry points */
3828 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3829 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3832 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3833 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3834 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3836 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3838 if (path == NULL) return NULL;
3839 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3840 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3841 if (buf) return buf;
3843 unixlen = strlen(unixified);
3844 New(1317,cp,unixlen+1,char);
3845 memcpy(cp,unixified,unixlen);
3850 strcpy(__tounixpath_retbuf,unixified);
3851 return __tounixpath_retbuf;
3854 } /* end of do_tounixpath() */
3856 /* External entry points */
3857 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3858 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3861 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3863 *****************************************************************************
3865 * Copyright (C) 1989-1994 by *
3866 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3868 * Permission is hereby granted for the reproduction of this software, *
3869 * on condition that this copyright notice is included in the reproduction, *
3870 * and that such reproduction is not for purposes of profit or material *
3873 * 27-Aug-1994 Modified for inclusion in perl5 *
3874 * by Charles Bailey bailey@newman.upenn.edu *
3875 *****************************************************************************
3879 * getredirection() is intended to aid in porting C programs
3880 * to VMS (Vax-11 C). The native VMS environment does not support
3881 * '>' and '<' I/O redirection, or command line wild card expansion,
3882 * or a command line pipe mechanism using the '|' AND background
3883 * command execution '&'. All of these capabilities are provided to any
3884 * C program which calls this procedure as the first thing in the
3886 * The piping mechanism will probably work with almost any 'filter' type
3887 * of program. With suitable modification, it may useful for other
3888 * portability problems as well.
3890 * Author: Mark Pizzolato mark@infocomm.com
3894 struct list_item *next;
3898 static void add_item(struct list_item **head,
3899 struct list_item **tail,
3903 static void mp_expand_wild_cards(pTHX_ char *item,
3904 struct list_item **head,
3905 struct list_item **tail,
3908 static int background_process(pTHX_ int argc, char **argv);
3910 static void pipe_and_fork(pTHX_ char **cmargv);
3912 /*{{{ void getredirection(int *ac, char ***av)*/
3914 mp_getredirection(pTHX_ int *ac, char ***av)
3916 * Process vms redirection arg's. Exit if any error is seen.
3917 * If getredirection() processes an argument, it is erased
3918 * from the vector. getredirection() returns a new argc and argv value.
3919 * In the event that a background command is requested (by a trailing "&"),
3920 * this routine creates a background subprocess, and simply exits the program.
3922 * Warning: do not try to simplify the code for vms. The code
3923 * presupposes that getredirection() is called before any data is
3924 * read from stdin or written to stdout.
3926 * Normal usage is as follows:
3932 * getredirection(&argc, &argv);
3936 int argc = *ac; /* Argument Count */
3937 char **argv = *av; /* Argument Vector */
3938 char *ap; /* Argument pointer */
3939 int j; /* argv[] index */
3940 int item_count = 0; /* Count of Items in List */
3941 struct list_item *list_head = 0; /* First Item in List */
3942 struct list_item *list_tail; /* Last Item in List */
3943 char *in = NULL; /* Input File Name */
3944 char *out = NULL; /* Output File Name */
3945 char *outmode = "w"; /* Mode to Open Output File */
3946 char *err = NULL; /* Error File Name */
3947 char *errmode = "w"; /* Mode to Open Error File */
3948 int cmargc = 0; /* Piped Command Arg Count */
3949 char **cmargv = NULL;/* Piped Command Arg Vector */
3952 * First handle the case where the last thing on the line ends with
3953 * a '&'. This indicates the desire for the command to be run in a
3954 * subprocess, so we satisfy that desire.
3957 if (0 == strcmp("&", ap))
3958 exit(background_process(aTHX_ --argc, argv));
3959 if (*ap && '&' == ap[strlen(ap)-1])
3961 ap[strlen(ap)-1] = '\0';
3962 exit(background_process(aTHX_ argc, argv));
3965 * Now we handle the general redirection cases that involve '>', '>>',
3966 * '<', and pipes '|'.
3968 for (j = 0; j < argc; ++j)
3970 if (0 == strcmp("<", argv[j]))
3974 fprintf(stderr,"No input file after < on command line");
3975 exit(LIB$_WRONUMARG);
3980 if ('<' == *(ap = argv[j]))
3985 if (0 == strcmp(">", ap))
3989 fprintf(stderr,"No output file after > on command line");
3990 exit(LIB$_WRONUMARG);
4009 fprintf(stderr,"No output file after > or >> on command line");
4010 exit(LIB$_WRONUMARG);
4014 if (('2' == *ap) && ('>' == ap[1]))
4031 fprintf(stderr,"No output file after 2> or 2>> on command line");
4032 exit(LIB$_WRONUMARG);
4036 if (0 == strcmp("|", argv[j]))
4040 fprintf(stderr,"No command into which to pipe on command line");
4041 exit(LIB$_WRONUMARG);
4043 cmargc = argc-(j+1);
4044 cmargv = &argv[j+1];
4048 if ('|' == *(ap = argv[j]))
4056 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4059 * Allocate and fill in the new argument vector, Some Unix's terminate
4060 * the list with an extra null pointer.
4062 New(1302, argv, item_count+1, char *);
4064 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4065 argv[j] = list_head->value;
4071 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4072 exit(LIB$_INVARGORD);
4074 pipe_and_fork(aTHX_ cmargv);
4077 /* Check for input from a pipe (mailbox) */
4079 if (in == NULL && 1 == isapipe(0))
4081 char mbxname[L_tmpnam];
4083 long int dvi_item = DVI$_DEVBUFSIZ;
4084 $DESCRIPTOR(mbxnam, "");
4085 $DESCRIPTOR(mbxdevnam, "");
4087 /* Input from a pipe, reopen it in binary mode to disable */
4088 /* carriage control processing. */
4090 fgetname(stdin, mbxname);
4091 mbxnam.dsc$a_pointer = mbxname;
4092 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4093 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4094 mbxdevnam.dsc$a_pointer = mbxname;
4095 mbxdevnam.dsc$w_length = sizeof(mbxname);
4096 dvi_item = DVI$_DEVNAM;
4097 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4098 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4101 freopen(mbxname, "rb", stdin);
4104 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4108 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4110 fprintf(stderr,"Can't open input file %s as stdin",in);
4113 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4115 fprintf(stderr,"Can't open output file %s as stdout",out);
4118 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4121 if (strcmp(err,"&1") == 0) {
4122 dup2(fileno(stdout), fileno(stderr));
4123 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4126 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4128 fprintf(stderr,"Can't open error file %s as stderr",err);
4132 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4136 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4139 #ifdef ARGPROC_DEBUG
4140 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4141 for (j = 0; j < *ac; ++j)
4142 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4144 /* Clear errors we may have hit expanding wildcards, so they don't
4145 show up in Perl's $! later */
4146 set_errno(0); set_vaxc_errno(1);
4147 } /* end of getredirection() */
4150 static void add_item(struct list_item **head,
4151 struct list_item **tail,
4157 New(1303,*head,1,struct list_item);
4161 New(1304,(*tail)->next,1,struct list_item);
4162 *tail = (*tail)->next;
4164 (*tail)->value = value;
4168 static void mp_expand_wild_cards(pTHX_ char *item,
4169 struct list_item **head,
4170 struct list_item **tail,
4174 unsigned long int context = 0;
4180 char vmsspec[NAM$C_MAXRSS+1];
4181 $DESCRIPTOR(filespec, "");
4182 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4183 $DESCRIPTOR(resultspec, "");
4184 unsigned long int zero = 0, sts;
4186 for (cp = item; *cp; cp++) {
4187 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4188 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4190 if (!*cp || isspace(*cp))
4192 add_item(head, tail, item, count);
4195 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4196 resultspec.dsc$b_class = DSC$K_CLASS_D;
4197 resultspec.dsc$a_pointer = NULL;
4198 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4199 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4200 if (!isunix || !filespec.dsc$a_pointer)
4201 filespec.dsc$a_pointer = item;
4202 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4204 * Only return version specs, if the caller specified a version
4206 had_version = strchr(item, ';');
4208 * Only return device and directory specs, if the caller specifed either.
4210 had_device = strchr(item, ':');
4211 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4213 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4214 &defaultspec, 0, 0, &zero))))
4219 New(1305,string,resultspec.dsc$w_length+1,char);
4220 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4221 string[resultspec.dsc$w_length] = '\0';
4222 if (NULL == had_version)
4223 *((char *)strrchr(string, ';')) = '\0';
4224 if ((!had_directory) && (had_device == NULL))
4226 if (NULL == (devdir = strrchr(string, ']')))
4227 devdir = strrchr(string, '>');
4228 strcpy(string, devdir + 1);
4231 * Be consistent with what the C RTL has already done to the rest of
4232 * the argv items and lowercase all of these names.
4234 for (c = string; *c; ++c)
4237 if (isunix) trim_unixpath(string,item,1);
4238 add_item(head, tail, string, count);
4241 if (sts != RMS$_NMF)
4243 set_vaxc_errno(sts);
4246 case RMS$_FNF: case RMS$_DNF:
4247 set_errno(ENOENT); break;
4249 set_errno(ENOTDIR); break;
4251 set_errno(ENODEV); break;
4252 case RMS$_FNM: case RMS$_SYN:
4253 set_errno(EINVAL); break;
4255 set_errno(EACCES); break;
4257 _ckvmssts_noperl(sts);
4261 add_item(head, tail, item, count);
4262 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4263 _ckvmssts_noperl(lib$find_file_end(&context));
4266 static int child_st[2];/* Event Flag set when child process completes */
4268 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4270 static unsigned long int exit_handler(int *status)
4274 if (0 == child_st[0])
4276 #ifdef ARGPROC_DEBUG
4277 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4279 fflush(stdout); /* Have to flush pipe for binary data to */
4280 /* terminate properly -- <tp@mccall.com> */
4281 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4282 sys$dassgn(child_chan);
4284 sys$synch(0, child_st);
4289 static void sig_child(int chan)
4291 #ifdef ARGPROC_DEBUG
4292 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4294 if (child_st[0] == 0)
4298 static struct exit_control_block exit_block =
4303 &exit_block.exit_status,
4308 pipe_and_fork(pTHX_ char **cmargv)
4311 struct dsc$descriptor_s *vmscmd;
4312 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4313 int sts, j, l, ismcr, quote, tquote = 0;
4315 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4316 vms_execfree(vmscmd);
4321 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4322 && toupper(*(q+2)) == 'R' && !*(q+3);
4324 while (q && l < MAX_DCL_LINE_LENGTH) {
4326 if (j > 0 && quote) {
4332 if (ismcr && j > 1) quote = 1;
4333 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4336 if (quote || tquote) {
4342 if ((quote||tquote) && *q == '"') {
4352 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4354 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4358 static int background_process(pTHX_ int argc, char **argv)
4360 char command[2048] = "$";
4361 $DESCRIPTOR(value, "");
4362 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4363 static $DESCRIPTOR(null, "NLA0:");
4364 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4366 $DESCRIPTOR(pidstr, "");
4368 unsigned long int flags = 17, one = 1, retsts;
4370 strcat(command, argv[0]);
4373 strcat(command, " \"");
4374 strcat(command, *(++argv));
4375 strcat(command, "\"");
4377 value.dsc$a_pointer = command;
4378 value.dsc$w_length = strlen(value.dsc$a_pointer);
4379 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4380 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4381 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4382 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4385 _ckvmssts_noperl(retsts);
4387 #ifdef ARGPROC_DEBUG
4388 PerlIO_printf(Perl_debug_log, "%s\n", command);
4390 sprintf(pidstring, "%08X", pid);
4391 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4392 pidstr.dsc$a_pointer = pidstring;
4393 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4394 lib$set_symbol(&pidsymbol, &pidstr);
4398 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4401 /* OS-specific initialization at image activation (not thread startup) */
4402 /* Older VAXC header files lack these constants */
4403 #ifndef JPI$_RIGHTS_SIZE
4404 # define JPI$_RIGHTS_SIZE 817
4406 #ifndef KGB$M_SUBSYSTEM
4407 # define KGB$M_SUBSYSTEM 0x8
4410 /*{{{void vms_image_init(int *, char ***)*/
4412 vms_image_init(int *argcp, char ***argvp)
4414 char eqv[LNM$C_NAMLENGTH+1] = "";
4415 unsigned int len, tabct = 8, tabidx = 0;
4416 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4417 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4418 unsigned short int dummy, rlen;
4419 struct dsc$descriptor_s **tabvec;
4420 #if defined(PERL_IMPLICIT_CONTEXT)
4423 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4424 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4425 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4428 #ifdef KILL_BY_SIGPRC
4429 (void) Perl_csighandler_init();
4432 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4433 _ckvmssts_noperl(iosb[0]);
4434 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4435 if (iprv[i]) { /* Running image installed with privs? */
4436 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4441 /* Rights identifiers might trigger tainting as well. */
4442 if (!will_taint && (rlen || rsz)) {
4443 while (rlen < rsz) {
4444 /* We didn't get all the identifiers on the first pass. Allocate a
4445 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4446 * were needed to hold all identifiers at time of last call; we'll
4447 * allocate that many unsigned long ints), and go back and get 'em.
4448 * If it gave us less than it wanted to despite ample buffer space,
4449 * something's broken. Is your system missing a system identifier?
4451 if (rsz <= jpilist[1].buflen) {
4452 /* Perl_croak accvios when used this early in startup. */
4453 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4454 rsz, (unsigned long) jpilist[1].buflen,
4455 "Check your rights database for corruption.\n");
4458 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4459 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4460 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4461 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4462 _ckvmssts_noperl(iosb[0]);
4464 mask = jpilist[1].bufadr;
4465 /* Check attribute flags for each identifier (2nd longword); protected
4466 * subsystem identifiers trigger tainting.
4468 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4469 if (mask[i] & KGB$M_SUBSYSTEM) {
4474 if (mask != rlst) Safefree(mask);
4476 /* We need to use this hack to tell Perl it should run with tainting,
4477 * since its tainting flag may be part of the PL_curinterp struct, which
4478 * hasn't been allocated when vms_image_init() is called.
4482 New(1320,newap,*argcp+2,char **);
4483 newap[0] = argvp[0];
4485 Copy(argvp[1],newap[2],*argcp-1,char **);
4486 /* We orphan the old argv, since we don't know where it's come from,
4487 * so we don't know how to free it.
4489 *argcp++; argvp = newap;
4491 else { /* Did user explicitly request tainting? */
4493 char *cp, **av = *argvp;
4494 for (i = 1; i < *argcp; i++) {
4495 if (*av[i] != '-') break;
4496 for (cp = av[i]+1; *cp; cp++) {
4497 if (*cp == 'T') { will_taint = 1; break; }
4498 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4499 strchr("DFIiMmx",*cp)) break;
4501 if (will_taint) break;
4506 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4508 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4509 else if (tabidx >= tabct) {
4511 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4513 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4514 tabvec[tabidx]->dsc$w_length = 0;
4515 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4516 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4517 tabvec[tabidx]->dsc$a_pointer = NULL;
4518 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4520 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4522 getredirection(argcp,argvp);
4523 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4525 # include <reentrancy.h>
4526 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4535 * Trim Unix-style prefix off filespec, so it looks like what a shell
4536 * glob expansion would return (i.e. from specified prefix on, not
4537 * full path). Note that returned filespec is Unix-style, regardless
4538 * of whether input filespec was VMS-style or Unix-style.
4540 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4541 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4542 * vector of options; at present, only bit 0 is used, and if set tells
4543 * trim unixpath to try the current default directory as a prefix when
4544 * presented with a possibly ambiguous ... wildcard.
4546 * Returns !=0 on success, with trimmed filespec replacing contents of
4547 * fspec, and 0 on failure, with contents of fpsec unchanged.
4549 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4551 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4553 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4554 *template, *base, *end, *cp1, *cp2;
4555 register int tmplen, reslen = 0, dirs = 0;
4557 if (!wildspec || !fspec) return 0;
4558 if (strpbrk(wildspec,"]>:") != NULL) {
4559 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4560 else template = unixwild;
4562 else template = wildspec;
4563 if (strpbrk(fspec,"]>:") != NULL) {
4564 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4565 else base = unixified;
4566 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4567 * check to see that final result fits into (isn't longer than) fspec */
4568 reslen = strlen(fspec);
4572 /* No prefix or absolute path on wildcard, so nothing to remove */
4573 if (!*template || *template == '/') {
4574 if (base == fspec) return 1;
4575 tmplen = strlen(unixified);
4576 if (tmplen > reslen) return 0; /* not enough space */
4577 /* Copy unixified resultant, including trailing NUL */
4578 memmove(fspec,unixified,tmplen+1);
4582 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4583 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4584 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4585 for (cp1 = end ;cp1 >= base; cp1--)
4586 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4588 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4592 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4593 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4594 int ells = 1, totells, segdirs, match;
4595 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4596 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4598 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4600 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4601 if (ellipsis == template && opts & 1) {
4602 /* Template begins with an ellipsis. Since we can't tell how many
4603 * directory names at the front of the resultant to keep for an
4604 * arbitrary starting point, we arbitrarily choose the current
4605 * default directory as a starting point. If it's there as a prefix,
4606 * clip it off. If not, fall through and act as if the leading
4607 * ellipsis weren't there (i.e. return shortest possible path that
4608 * could match template).
4610 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4611 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4612 if (_tolower(*cp1) != _tolower(*cp2)) break;
4613 segdirs = dirs - totells; /* Min # of dirs we must have left */
4614 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4615 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4616 memcpy(fspec,cp2+1,end - cp2);
4620 /* First off, back up over constant elements at end of path */
4622 for (front = end ; front >= base; front--)
4623 if (*front == '/' && !dirs--) { front++; break; }
4625 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4626 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4627 if (cp1 != '\0') return 0; /* Path too long. */
4629 *cp2 = '\0'; /* Pick up with memcpy later */
4630 lcfront = lcres + (front - base);
4631 /* Now skip over each ellipsis and try to match the path in front of it. */
4633 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4634 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4635 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4636 if (cp1 < template) break; /* template started with an ellipsis */
4637 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4638 ellipsis = cp1; continue;
4640 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4642 for (segdirs = 0, cp2 = tpl;
4643 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4645 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4646 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4647 if (*cp2 == '/') segdirs++;
4649 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4650 /* Back up at least as many dirs as in template before matching */
4651 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4652 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4653 for (match = 0; cp1 > lcres;) {
4654 resdsc.dsc$a_pointer = cp1;
4655 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4657 if (match == 1) lcfront = cp1;
4659 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4661 if (!match) return 0; /* Can't find prefix ??? */
4662 if (match > 1 && opts & 1) {
4663 /* This ... wildcard could cover more than one set of dirs (i.e.
4664 * a set of similar dir names is repeated). If the template
4665 * contains more than 1 ..., upstream elements could resolve the
4666 * ambiguity, but it's not worth a full backtracking setup here.
4667 * As a quick heuristic, clip off the current default directory
4668 * if it's present to find the trimmed spec, else use the
4669 * shortest string that this ... could cover.
4671 char def[NAM$C_MAXRSS+1], *st;
4673 if (getcwd(def, sizeof def,0) == NULL) return 0;
4674 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4675 if (_tolower(*cp1) != _tolower(*cp2)) break;
4676 segdirs = dirs - totells; /* Min # of dirs we must have left */
4677 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4678 if (*cp1 == '\0' && *cp2 == '/') {
4679 memcpy(fspec,cp2+1,end - cp2);
4682 /* Nope -- stick with lcfront from above and keep going. */
4685 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4690 } /* end of trim_unixpath() */
4695 * VMS readdir() routines.
4696 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4698 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4699 * Minor modifications to original routines.
4702 /* Number of elements in vms_versions array */
4703 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4706 * Open a directory, return a handle for later use.
4708 /*{{{ DIR *opendir(char*name) */
4710 Perl_opendir(pTHX_ char *name)
4713 char dir[NAM$C_MAXRSS+1];
4716 if (do_tovmspath(name,dir,0) == NULL) {
4719 /* Check access before stat; otherwise stat does not
4720 * accurately report whether it's a directory.
4722 if (!cando_by_name(S_IRUSR,0,dir)) {
4723 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4726 if (flex_stat(dir,&sb) == -1) return NULL;
4727 if (!S_ISDIR(sb.st_mode)) {
4728 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4731 /* Get memory for the handle, and the pattern. */
4733 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4735 /* Fill in the fields; mainly playing with the descriptor. */
4736 (void)sprintf(dd->pattern, "%s*.*",dir);
4739 dd->vms_wantversions = 0;
4740 dd->pat.dsc$a_pointer = dd->pattern;
4741 dd->pat.dsc$w_length = strlen(dd->pattern);
4742 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4743 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4746 } /* end of opendir() */
4750 * Set the flag to indicate we want versions or not.
4752 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4754 vmsreaddirversions(DIR *dd, int flag)
4756 dd->vms_wantversions = flag;
4761 * Free up an opened directory.
4763 /*{{{ void closedir(DIR *dd)*/
4767 (void)lib$find_file_end(&dd->context);
4768 Safefree(dd->pattern);
4769 Safefree((char *)dd);
4774 * Collect all the version numbers for the current file.
4777 collectversions(pTHX_ DIR *dd)
4779 struct dsc$descriptor_s pat;
4780 struct dsc$descriptor_s res;
4782 char *p, *text, buff[sizeof dd->entry.d_name];
4784 unsigned long context, tmpsts;
4786 /* Convenient shorthand. */
4789 /* Add the version wildcard, ignoring the "*.*" put on before */
4790 i = strlen(dd->pattern);
4791 New(1308,text,i + e->d_namlen + 3,char);
4792 (void)strcpy(text, dd->pattern);
4793 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4795 /* Set up the pattern descriptor. */
4796 pat.dsc$a_pointer = text;
4797 pat.dsc$w_length = i + e->d_namlen - 1;
4798 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4799 pat.dsc$b_class = DSC$K_CLASS_S;
4801 /* Set up result descriptor. */
4802 res.dsc$a_pointer = buff;
4803 res.dsc$w_length = sizeof buff - 2;
4804 res.dsc$b_dtype = DSC$K_DTYPE_T;
4805 res.dsc$b_class = DSC$K_CLASS_S;
4807 /* Read files, collecting versions. */
4808 for (context = 0, e->vms_verscount = 0;
4809 e->vms_verscount < VERSIZE(e);
4810 e->vms_verscount++) {
4811 tmpsts = lib$find_file(&pat, &res, &context);
4812 if (tmpsts == RMS$_NMF || context == 0) break;
4814 buff[sizeof buff - 1] = '\0';
4815 if ((p = strchr(buff, ';')))
4816 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4818 e->vms_versions[e->vms_verscount] = -1;
4821 _ckvmssts(lib$find_file_end(&context));
4824 } /* end of collectversions() */
4827 * Read the next entry from the directory.
4829 /*{{{ struct dirent *readdir(DIR *dd)*/
4831 Perl_readdir(pTHX_ DIR *dd)
4833 struct dsc$descriptor_s res;
4834 char *p, buff[sizeof dd->entry.d_name];
4835 unsigned long int tmpsts;
4837 /* Set up result descriptor, and get next file. */
4838 res.dsc$a_pointer = buff;
4839 res.dsc$w_length = sizeof buff - 2;
4840 res.dsc$b_dtype = DSC$K_DTYPE_T;
4841 res.dsc$b_class = DSC$K_CLASS_S;
4842 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4843 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4844 if (!(tmpsts & 1)) {
4845 set_vaxc_errno(tmpsts);
4848 set_errno(EACCES); break;
4850 set_errno(ENODEV); break;
4852 set_errno(ENOTDIR); break;
4853 case RMS$_FNF: case RMS$_DNF:
4854 set_errno(ENOENT); break;
4861 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4862 buff[sizeof buff - 1] = '\0';
4863 for (p = buff; *p; p++) *p = _tolower(*p);
4864 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4867 /* Skip any directory component and just copy the name. */
4868 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4869 else (void)strcpy(dd->entry.d_name, buff);
4871 /* Clobber the version. */
4872 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4874 dd->entry.d_namlen = strlen(dd->entry.d_name);
4875 dd->entry.vms_verscount = 0;
4876 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4879 } /* end of readdir() */
4883 * Return something that can be used in a seekdir later.
4885 /*{{{ long telldir(DIR *dd)*/
4894 * Return to a spot where we used to be. Brute force.
4896 /*{{{ void seekdir(DIR *dd,long count)*/
4898 Perl_seekdir(pTHX_ DIR *dd, long count)
4900 int vms_wantversions;
4902 /* If we haven't done anything yet... */
4906 /* Remember some state, and clear it. */
4907 vms_wantversions = dd->vms_wantversions;
4908 dd->vms_wantversions = 0;
4909 _ckvmssts(lib$find_file_end(&dd->context));
4912 /* The increment is in readdir(). */
4913 for (dd->count = 0; dd->count < count; )
4916 dd->vms_wantversions = vms_wantversions;
4918 } /* end of seekdir() */
4921 /* VMS subprocess management
4923 * my_vfork() - just a vfork(), after setting a flag to record that
4924 * the current script is trying a Unix-style fork/exec.
4926 * vms_do_aexec() and vms_do_exec() are called in response to the
4927 * perl 'exec' function. If this follows a vfork call, then they
4928 * call out the the regular perl routines in doio.c which do an
4929 * execvp (for those who really want to try this under VMS).
4930 * Otherwise, they do exactly what the perl docs say exec should
4931 * do - terminate the current script and invoke a new command
4932 * (See below for notes on command syntax.)
4934 * do_aspawn() and do_spawn() implement the VMS side of the perl
4935 * 'system' function.
4937 * Note on command arguments to perl 'exec' and 'system': When handled
4938 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4939 * are concatenated to form a DCL command string. If the first arg
4940 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4941 * the the command string is handed off to DCL directly. Otherwise,
4942 * the first token of the command is taken as the filespec of an image
4943 * to run. The filespec is expanded using a default type of '.EXE' and
4944 * the process defaults for device, directory, etc., and if found, the resultant
4945 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4946 * the command string as parameters. This is perhaps a bit complicated,
4947 * but I hope it will form a happy medium between what VMS folks expect
4948 * from lib$spawn and what Unix folks expect from exec.
4951 static int vfork_called;
4953 /*{{{int my_vfork()*/
4964 vms_execfree(struct dsc$descriptor_s *vmscmd)
4967 if (vmscmd->dsc$a_pointer) {
4968 Safefree(vmscmd->dsc$a_pointer);
4975 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4977 char *junk, *tmps = Nullch;
4978 register size_t cmdlen = 0;
4985 tmps = SvPV(really,rlen);
4992 for (idx++; idx <= sp; idx++) {
4994 junk = SvPVx(*idx,rlen);
4995 cmdlen += rlen ? rlen + 1 : 0;
4998 New(401,PL_Cmd,cmdlen+1,char);
5000 if (tmps && *tmps) {
5001 strcpy(PL_Cmd,tmps);
5004 else *PL_Cmd = '\0';
5005 while (++mark <= sp) {
5007 char *s = SvPVx(*mark,n_a);
5009 if (*PL_Cmd) strcat(PL_Cmd," ");
5015 } /* end of setup_argstr() */
5018 static unsigned long int
5019 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5020 struct dsc$descriptor_s **pvmscmd)
5022 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5023 $DESCRIPTOR(defdsc,".EXE");
5024 $DESCRIPTOR(defdsc2,".");
5025 $DESCRIPTOR(resdsc,resspec);
5026 struct dsc$descriptor_s *vmscmd;
5027 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5028 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5029 register char *s, *rest, *cp, *wordbreak;
5032 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5033 vmscmd->dsc$a_pointer = NULL;
5034 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5035 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5036 vmscmd->dsc$w_length = 0;
5037 if (pvmscmd) *pvmscmd = vmscmd;
5039 if (suggest_quote) *suggest_quote = 0;
5041 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5042 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5044 while (*s && isspace(*s)) s++;
5046 if (*s == '@' || *s == '$') {
5047 vmsspec[0] = *s; rest = s + 1;
5048 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5050 else { cp = vmsspec; rest = s; }
5051 if (*rest == '.' || *rest == '/') {
5054 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5055 rest++, cp2++) *cp2 = *rest;
5057 if (do_tovmsspec(resspec,cp,0)) {
5060 for (cp2 = vmsspec + strlen(vmsspec);
5061 *rest && cp2 - vmsspec < sizeof vmsspec;
5062 rest++, cp2++) *cp2 = *rest;
5067 /* Intuit whether verb (first word of cmd) is a DCL command:
5068 * - if first nonspace char is '@', it's a DCL indirection
5070 * - if verb contains a filespec separator, it's not a DCL command
5071 * - if it doesn't, caller tells us whether to default to a DCL
5072 * command, or to a local image unless told it's DCL (by leading '$')
5076 if (suggest_quote) *suggest_quote = 1;
5078 register char *filespec = strpbrk(s,":<[.;");
5079 rest = wordbreak = strpbrk(s," \"\t/");
5080 if (!wordbreak) wordbreak = s + strlen(s);
5081 if (*s == '$') check_img = 0;
5082 if (filespec && (filespec < wordbreak)) isdcl = 0;
5083 else isdcl = !check_img;
5087 imgdsc.dsc$a_pointer = s;
5088 imgdsc.dsc$w_length = wordbreak - s;
5089 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5091 _ckvmssts(lib$find_file_end(&cxt));
5092 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5093 if (!(retsts & 1) && *s == '$') {
5094 _ckvmssts(lib$find_file_end(&cxt));
5095 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5096 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5098 _ckvmssts(lib$find_file_end(&cxt));
5099 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5103 _ckvmssts(lib$find_file_end(&cxt));
5108 while (*s && !isspace(*s)) s++;
5111 /* check that it's really not DCL with no file extension */
5112 fp = fopen(resspec,"r","ctx=bin,shr=get");
5114 char b[4] = {0,0,0,0};
5115 read(fileno(fp),b,4);
5116 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5119 if (check_img && isdcl) return RMS$_FNF;
5121 if (cando_by_name(S_IXUSR,0,resspec)) {
5122 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5124 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5125 if (suggest_quote) *suggest_quote = 1;
5127 strcpy(vmscmd->dsc$a_pointer,"@");
5128 if (suggest_quote) *suggest_quote = 1;
5130 strcat(vmscmd->dsc$a_pointer,resspec);
5131 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5132 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5133 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5135 else retsts = RMS$_PRV;
5138 /* It's either a DCL command or we couldn't find a suitable image */
5139 vmscmd->dsc$w_length = strlen(cmd);
5140 /* if (cmd == PL_Cmd) {
5141 vmscmd->dsc$a_pointer = PL_Cmd;
5142 if (suggest_quote) *suggest_quote = 1;
5145 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5147 /* check if it's a symbol (for quoting purposes) */
5148 if (suggest_quote && !*suggest_quote) {
5150 char equiv[LNM$C_NAMLENGTH];
5151 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5152 eqvdsc.dsc$a_pointer = equiv;
5154 iss = lib$get_symbol(vmscmd,&eqvdsc);
5155 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5157 if (!(retsts & 1)) {
5158 /* just hand off status values likely to be due to user error */
5159 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5160 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5161 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5162 else { _ckvmssts(retsts); }
5165 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5167 } /* end of setup_cmddsc() */
5170 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5172 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5175 if (vfork_called) { /* this follows a vfork - act Unixish */
5177 if (vfork_called < 0) {
5178 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5181 else return do_aexec(really,mark,sp);
5183 /* no vfork - act VMSish */
5184 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5189 } /* end of vms_do_aexec() */
5192 /* {{{bool vms_do_exec(char *cmd) */
5194 Perl_vms_do_exec(pTHX_ char *cmd)
5196 struct dsc$descriptor_s *vmscmd;
5198 if (vfork_called) { /* this follows a vfork - act Unixish */
5200 if (vfork_called < 0) {
5201 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5204 else return do_exec(cmd);
5207 { /* no vfork - act VMSish */
5208 unsigned long int retsts;
5211 TAINT_PROPER("exec");
5212 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5213 retsts = lib$do_command(vmscmd);
5216 case RMS$_FNF: case RMS$_DNF:
5217 set_errno(ENOENT); break;
5219 set_errno(ENOTDIR); break;
5221 set_errno(ENODEV); break;
5223 set_errno(EACCES); break;
5225 set_errno(EINVAL); break;
5226 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5227 set_errno(E2BIG); break;
5228 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5229 _ckvmssts(retsts); /* fall through */
5230 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5233 set_vaxc_errno(retsts);
5234 if (ckWARN(WARN_EXEC)) {
5235 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5236 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5238 vms_execfree(vmscmd);
5243 } /* end of vms_do_exec() */
5246 unsigned long int Perl_do_spawn(pTHX_ char *);
5248 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5250 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5252 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5255 } /* end of do_aspawn() */
5258 /* {{{unsigned long int do_spawn(char *cmd) */
5260 Perl_do_spawn(pTHX_ char *cmd)
5262 unsigned long int sts, substs;
5265 TAINT_PROPER("spawn");
5266 if (!cmd || !*cmd) {
5267 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5270 case RMS$_FNF: case RMS$_DNF:
5271 set_errno(ENOENT); break;
5273 set_errno(ENOTDIR); break;
5275 set_errno(ENODEV); break;
5277 set_errno(EACCES); break;
5279 set_errno(EINVAL); break;
5280 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5281 set_errno(E2BIG); break;
5282 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5283 _ckvmssts(sts); /* fall through */
5284 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5287 set_vaxc_errno(sts);
5288 if (ckWARN(WARN_EXEC)) {
5289 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5296 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5299 } /* end of do_spawn() */
5303 static unsigned int *sockflags, sockflagsize;
5306 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5307 * routines found in some versions of the CRTL can't deal with sockets.
5308 * We don't shim the other file open routines since a socket isn't
5309 * likely to be opened by a name.
5311 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5312 FILE *my_fdopen(int fd, const char *mode)
5314 FILE *fp = fdopen(fd, (char *) mode);
5317 unsigned int fdoff = fd / sizeof(unsigned int);
5318 struct stat sbuf; /* native stat; we don't need flex_stat */
5319 if (!sockflagsize || fdoff > sockflagsize) {
5320 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5321 else New (1324,sockflags,fdoff+2,unsigned int);
5322 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5323 sockflagsize = fdoff + 2;
5325 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5326 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5335 * Clear the corresponding bit when the (possibly) socket stream is closed.
5336 * There still a small hole: we miss an implicit close which might occur
5337 * via freopen(). >> Todo
5339 /*{{{ int my_fclose(FILE *fp)*/
5340 int my_fclose(FILE *fp) {
5342 unsigned int fd = fileno(fp);
5343 unsigned int fdoff = fd / sizeof(unsigned int);
5345 if (sockflagsize && fdoff <= sockflagsize)
5346 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5354 * A simple fwrite replacement which outputs itmsz*nitm chars without
5355 * introducing record boundaries every itmsz chars.
5356 * We are using fputs, which depends on a terminating null. We may
5357 * well be writing binary data, so we need to accommodate not only
5358 * data with nulls sprinkled in the middle but also data with no null
5361 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5363 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5365 register char *cp, *end, *cpd, *data;
5366 register unsigned int fd = fileno(dest);
5367 register unsigned int fdoff = fd / sizeof(unsigned int);
5369 int bufsize = itmsz * nitm + 1;
5371 if (fdoff < sockflagsize &&
5372 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5373 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5377 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5378 memcpy( data, src, itmsz*nitm );
5379 data[itmsz*nitm] = '\0';
5381 end = data + itmsz * nitm;
5382 retval = (int) nitm; /* on success return # items written */
5385 while (cpd <= end) {
5386 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5387 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5389 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5393 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5396 } /* end of my_fwrite() */
5399 /*{{{ int my_flush(FILE *fp)*/
5401 Perl_my_flush(pTHX_ FILE *fp)
5404 if ((res = fflush(fp)) == 0 && fp) {
5405 #ifdef VMS_DO_SOCKETS
5407 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5409 res = fsync(fileno(fp));
5412 * If the flush succeeded but set end-of-file, we need to clear
5413 * the error because our caller may check ferror(). BTW, this
5414 * probably means we just flushed an empty file.
5416 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5423 * Here are replacements for the following Unix routines in the VMS environment:
5424 * getpwuid Get information for a particular UIC or UID
5425 * getpwnam Get information for a named user
5426 * getpwent Get information for each user in the rights database
5427 * setpwent Reset search to the start of the rights database
5428 * endpwent Finish searching for users in the rights database
5430 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5431 * (defined in pwd.h), which contains the following fields:-
5433 * char *pw_name; Username (in lower case)
5434 * char *pw_passwd; Hashed password
5435 * unsigned int pw_uid; UIC
5436 * unsigned int pw_gid; UIC group number
5437 * char *pw_unixdir; Default device/directory (VMS-style)
5438 * char *pw_gecos; Owner name
5439 * char *pw_dir; Default device/directory (Unix-style)
5440 * char *pw_shell; Default CLI name (eg. DCL)
5442 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5444 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5445 * not the UIC member number (eg. what's returned by getuid()),
5446 * getpwuid() can accept either as input (if uid is specified, the caller's
5447 * UIC group is used), though it won't recognise gid=0.
5449 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5450 * information about other users in your group or in other groups, respectively.
5451 * If the required privilege is not available, then these routines fill only
5452 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5455 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5458 /* sizes of various UAF record fields */
5459 #define UAI$S_USERNAME 12
5460 #define UAI$S_IDENT 31
5461 #define UAI$S_OWNER 31
5462 #define UAI$S_DEFDEV 31
5463 #define UAI$S_DEFDIR 63
5464 #define UAI$S_DEFCLI 31
5467 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5468 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5469 (uic).uic$v_group != UIC$K_WILD_GROUP)
5471 static char __empty[]= "";
5472 static struct passwd __passwd_empty=
5473 {(char *) __empty, (char *) __empty, 0, 0,
5474 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5475 static int contxt= 0;
5476 static struct passwd __pwdcache;
5477 static char __pw_namecache[UAI$S_IDENT+1];
5480 * This routine does most of the work extracting the user information.
5482 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5485 unsigned char length;
5486 char pw_gecos[UAI$S_OWNER+1];
5488 static union uicdef uic;
5490 unsigned char length;
5491 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5494 unsigned char length;
5495 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5498 unsigned char length;
5499 char pw_shell[UAI$S_DEFCLI+1];
5501 static char pw_passwd[UAI$S_PWD+1];
5503 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5504 struct dsc$descriptor_s name_desc;
5505 unsigned long int sts;
5507 static struct itmlst_3 itmlst[]= {
5508 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5509 {sizeof(uic), UAI$_UIC, &uic, &luic},
5510 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5511 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5512 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5513 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5514 {0, 0, NULL, NULL}};
5516 name_desc.dsc$w_length= strlen(name);
5517 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5518 name_desc.dsc$b_class= DSC$K_CLASS_S;
5519 name_desc.dsc$a_pointer= (char *) name;
5521 /* Note that sys$getuai returns many fields as counted strings. */
5522 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5523 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5524 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5526 else { _ckvmssts(sts); }
5527 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5529 if ((int) owner.length < lowner) lowner= (int) owner.length;
5530 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5531 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5532 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5533 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5534 owner.pw_gecos[lowner]= '\0';
5535 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5536 defcli.pw_shell[ldefcli]= '\0';
5537 if (valid_uic(uic)) {
5538 pwd->pw_uid= uic.uic$l_uic;
5539 pwd->pw_gid= uic.uic$v_group;
5542 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5543 pwd->pw_passwd= pw_passwd;
5544 pwd->pw_gecos= owner.pw_gecos;
5545 pwd->pw_dir= defdev.pw_dir;
5546 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5547 pwd->pw_shell= defcli.pw_shell;
5548 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5550 ldir= strlen(pwd->pw_unixdir) - 1;
5551 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5554 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5555 __mystrtolower(pwd->pw_unixdir);
5560 * Get information for a named user.
5562 /*{{{struct passwd *getpwnam(char *name)*/
5563 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5565 struct dsc$descriptor_s name_desc;
5567 unsigned long int status, sts;
5569 __pwdcache = __passwd_empty;
5570 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5571 /* We still may be able to determine pw_uid and pw_gid */
5572 name_desc.dsc$w_length= strlen(name);
5573 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5574 name_desc.dsc$b_class= DSC$K_CLASS_S;
5575 name_desc.dsc$a_pointer= (char *) name;
5576 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5577 __pwdcache.pw_uid= uic.uic$l_uic;
5578 __pwdcache.pw_gid= uic.uic$v_group;
5581 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5582 set_vaxc_errno(sts);
5583 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5586 else { _ckvmssts(sts); }
5589 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5590 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5591 __pwdcache.pw_name= __pw_namecache;
5593 } /* end of my_getpwnam() */
5597 * Get information for a particular UIC or UID.
5598 * Called by my_getpwent with uid=-1 to list all users.
5600 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5601 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5603 const $DESCRIPTOR(name_desc,__pw_namecache);
5604 unsigned short lname;
5606 unsigned long int status;
5608 if (uid == (unsigned int) -1) {
5610 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5611 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5612 set_vaxc_errno(status);
5613 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5617 else { _ckvmssts(status); }
5618 } while (!valid_uic (uic));
5622 if (!uic.uic$v_group)
5623 uic.uic$v_group= PerlProc_getgid();
5625 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5626 else status = SS$_IVIDENT;
5627 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5628 status == RMS$_PRV) {
5629 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5632 else { _ckvmssts(status); }
5634 __pw_namecache[lname]= '\0';
5635 __mystrtolower(__pw_namecache);
5637 __pwdcache = __passwd_empty;
5638 __pwdcache.pw_name = __pw_namecache;
5640 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5641 The identifier's value is usually the UIC, but it doesn't have to be,
5642 so if we can, we let fillpasswd update this. */
5643 __pwdcache.pw_uid = uic.uic$l_uic;
5644 __pwdcache.pw_gid = uic.uic$v_group;
5646 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5649 } /* end of my_getpwuid() */
5653 * Get information for next user.
5655 /*{{{struct passwd *my_getpwent()*/
5656 struct passwd *Perl_my_getpwent(pTHX)
5658 return (my_getpwuid((unsigned int) -1));
5663 * Finish searching rights database for users.
5665 /*{{{void my_endpwent()*/
5666 void Perl_my_endpwent(pTHX)
5669 _ckvmssts(sys$finish_rdb(&contxt));
5675 #ifdef HOMEGROWN_POSIX_SIGNALS
5676 /* Signal handling routines, pulled into the core from POSIX.xs.
5678 * We need these for threads, so they've been rolled into the core,
5679 * rather than left in POSIX.xs.
5681 * (DRS, Oct 23, 1997)
5684 /* sigset_t is atomic under VMS, so these routines are easy */
5685 /*{{{int my_sigemptyset(sigset_t *) */
5686 int my_sigemptyset(sigset_t *set) {
5687 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5693 /*{{{int my_sigfillset(sigset_t *)*/
5694 int my_sigfillset(sigset_t *set) {
5696 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5697 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5703 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5704 int my_sigaddset(sigset_t *set, int sig) {
5705 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5706 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5707 *set |= (1 << (sig - 1));
5713 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5714 int my_sigdelset(sigset_t *set, int sig) {
5715 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5716 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5717 *set &= ~(1 << (sig - 1));
5723 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5724 int my_sigismember(sigset_t *set, int sig) {
5725 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5726 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5727 return *set & (1 << (sig - 1));
5732 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5733 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5736 /* If set and oset are both null, then things are badly wrong. Bail out. */
5737 if ((oset == NULL) && (set == NULL)) {
5738 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5742 /* If set's null, then we're just handling a fetch. */
5744 tempmask = sigblock(0);
5749 tempmask = sigsetmask(*set);
5752 tempmask = sigblock(*set);
5755 tempmask = sigblock(0);
5756 sigsetmask(*oset & ~tempmask);
5759 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5764 /* Did they pass us an oset? If so, stick our holding mask into it */
5771 #endif /* HOMEGROWN_POSIX_SIGNALS */
5774 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5775 * my_utime(), and flex_stat(), all of which operate on UTC unless
5776 * VMSISH_TIMES is true.
5778 /* method used to handle UTC conversions:
5779 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5781 static int gmtime_emulation_type;
5782 /* number of secs to add to UTC POSIX-style time to get local time */
5783 static long int utc_offset_secs;
5785 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5786 * in vmsish.h. #undef them here so we can call the CRTL routines
5795 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5796 * qualifier with the extern prefix pragma. This provisional
5797 * hack circumvents this prefix pragma problem in previous
5800 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5801 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5802 # pragma __extern_prefix save
5803 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5804 # define gmtime decc$__utctz_gmtime
5805 # define localtime decc$__utctz_localtime
5806 # define time decc$__utc_time
5807 # pragma __extern_prefix restore
5809 struct tm *gmtime(), *localtime();
5815 static time_t toutc_dst(time_t loc) {
5818 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5819 loc -= utc_offset_secs;
5820 if (rsltmp->tm_isdst) loc -= 3600;
5823 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5824 ((gmtime_emulation_type || my_time(NULL)), \
5825 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5826 ((secs) - utc_offset_secs))))
5828 static time_t toloc_dst(time_t utc) {
5831 utc += utc_offset_secs;
5832 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5833 if (rsltmp->tm_isdst) utc += 3600;
5836 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5837 ((gmtime_emulation_type || my_time(NULL)), \
5838 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5839 ((secs) + utc_offset_secs))))
5841 #ifndef RTL_USES_UTC
5844 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5845 DST starts on 1st sun of april at 02:00 std time
5846 ends on last sun of october at 02:00 dst time
5847 see the UCX management command reference, SET CONFIG TIMEZONE
5848 for formatting info.
5850 No, it's not as general as it should be, but then again, NOTHING
5851 will handle UK times in a sensible way.
5856 parse the DST start/end info:
5857 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5861 tz_parse_startend(char *s, struct tm *w, int *past)
5863 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5864 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5869 if (!past) return 0;
5872 if (w->tm_year % 4 == 0) ly = 1;
5873 if (w->tm_year % 100 == 0) ly = 0;
5874 if (w->tm_year+1900 % 400 == 0) ly = 1;
5877 dozjd = isdigit(*s);
5878 if (*s == 'J' || *s == 'j' || dozjd) {
5879 if (!dozjd && !isdigit(*++s)) return 0;
5882 d = d*10 + *s++ - '0';
5884 d = d*10 + *s++ - '0';
5887 if (d == 0) return 0;
5888 if (d > 366) return 0;
5890 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5893 } else if (*s == 'M' || *s == 'm') {
5894 if (!isdigit(*++s)) return 0;
5896 if (isdigit(*s)) m = 10*m + *s++ - '0';
5897 if (*s != '.') return 0;
5898 if (!isdigit(*++s)) return 0;
5900 if (n < 1 || n > 5) return 0;
5901 if (*s != '.') return 0;
5902 if (!isdigit(*++s)) return 0;
5904 if (d > 6) return 0;
5908 if (!isdigit(*++s)) return 0;
5910 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5912 if (!isdigit(*++s)) return 0;
5914 if (isdigit(*s)) min = 10*min + *s++ - '0';
5916 if (!isdigit(*++s)) return 0;
5918 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5928 if (w->tm_yday < d) goto before;
5929 if (w->tm_yday > d) goto after;
5931 if (w->tm_mon+1 < m) goto before;
5932 if (w->tm_mon+1 > m) goto after;
5934 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5935 k = d - j; /* mday of first d */
5937 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5938 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5939 if (w->tm_mday < k) goto before;
5940 if (w->tm_mday > k) goto after;
5943 if (w->tm_hour < hour) goto before;
5944 if (w->tm_hour > hour) goto after;
5945 if (w->tm_min < min) goto before;
5946 if (w->tm_min > min) goto after;
5947 if (w->tm_sec < sec) goto before;
5961 /* parse the offset: (+|-)hh[:mm[:ss]] */
5964 tz_parse_offset(char *s, int *offset)
5966 int hour = 0, min = 0, sec = 0;
5969 if (!offset) return 0;
5971 if (*s == '-') {neg++; s++;}
5973 if (!isdigit(*s)) return 0;
5975 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5976 if (hour > 24) return 0;
5978 if (!isdigit(*++s)) return 0;
5980 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5981 if (min > 59) return 0;
5983 if (!isdigit(*++s)) return 0;
5985 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5986 if (sec > 59) return 0;
5990 *offset = (hour*60+min)*60 + sec;
5991 if (neg) *offset = -*offset;
5996 input time is w, whatever type of time the CRTL localtime() uses.
5997 sets dst, the zone, and the gmtoff (seconds)
5999 caches the value of TZ and UCX$TZ env variables; note that
6000 my_setenv looks for these and sets a flag if they're changed
6003 We have to watch out for the "australian" case (dst starts in
6004 october, ends in april)...flagged by "reverse" and checked by
6005 scanning through the months of the previous year.
6010 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6015 char *dstzone, *tz, *s_start, *s_end;
6016 int std_off, dst_off, isdst;
6017 int y, dststart, dstend;
6018 static char envtz[1025]; /* longer than any logical, symbol, ... */
6019 static char ucxtz[1025];
6020 static char reversed = 0;
6026 reversed = -1; /* flag need to check */
6027 envtz[0] = ucxtz[0] = '\0';
6028 tz = my_getenv("TZ",0);
6029 if (tz) strcpy(envtz, tz);
6030 tz = my_getenv("UCX$TZ",0);
6031 if (tz) strcpy(ucxtz, tz);
6032 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6035 if (!*tz) tz = ucxtz;
6038 while (isalpha(*s)) s++;
6039 s = tz_parse_offset(s, &std_off);
6041 if (!*s) { /* no DST, hurray we're done! */
6047 while (isalpha(*s)) s++;
6048 s2 = tz_parse_offset(s, &dst_off);
6052 dst_off = std_off - 3600;
6055 if (!*s) { /* default dst start/end?? */
6056 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6057 s = strchr(ucxtz,',');
6059 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6061 if (*s != ',') return 0;
6064 when = _toutc(when); /* convert to utc */
6065 when = when - std_off; /* convert to pseudolocal time*/
6067 w2 = localtime(&when);
6070 s = tz_parse_startend(s_start,w2,&dststart);
6072 if (*s != ',') return 0;
6075 when = _toutc(when); /* convert to utc */
6076 when = when - dst_off; /* convert to pseudolocal time*/
6077 w2 = localtime(&when);
6078 if (w2->tm_year != y) { /* spans a year, just check one time */
6079 when += dst_off - std_off;
6080 w2 = localtime(&when);
6083 s = tz_parse_startend(s_end,w2,&dstend);
6086 if (reversed == -1) { /* need to check if start later than end */
6090 if (when < 2*365*86400) {
6091 when += 2*365*86400;
6095 w2 =localtime(&when);
6096 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6098 for (j = 0; j < 12; j++) {
6099 w2 =localtime(&when);
6100 (void) tz_parse_startend(s_start,w2,&ds);
6101 (void) tz_parse_startend(s_end,w2,&de);
6102 if (ds != de) break;
6106 if (de && !ds) reversed = 1;
6109 isdst = dststart && !dstend;
6110 if (reversed) isdst = dststart || !dstend;
6113 if (dst) *dst = isdst;
6114 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6115 if (isdst) tz = dstzone;
6117 while(isalpha(*tz)) *zone++ = *tz++;
6123 #endif /* !RTL_USES_UTC */
6125 /* my_time(), my_localtime(), my_gmtime()
6126 * By default traffic in UTC time values, using CRTL gmtime() or
6127 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6128 * Note: We need to use these functions even when the CRTL has working
6129 * UTC support, since they also handle C<use vmsish qw(times);>
6131 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6132 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6135 /*{{{time_t my_time(time_t *timep)*/
6136 time_t Perl_my_time(pTHX_ time_t *timep)
6141 if (gmtime_emulation_type == 0) {
6143 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6144 /* results of calls to gmtime() and localtime() */
6145 /* for same &base */
6147 gmtime_emulation_type++;
6148 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6149 char off[LNM$C_NAMLENGTH+1];;
6151 gmtime_emulation_type++;
6152 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6153 gmtime_emulation_type++;
6154 utc_offset_secs = 0;
6155 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6157 else { utc_offset_secs = atol(off); }
6159 else { /* We've got a working gmtime() */
6160 struct tm gmt, local;
6163 tm_p = localtime(&base);
6165 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6166 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6167 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6168 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6174 # ifdef RTL_USES_UTC
6175 if (VMSISH_TIME) when = _toloc(when);
6177 if (!VMSISH_TIME) when = _toutc(when);
6180 if (timep != NULL) *timep = when;
6183 } /* end of my_time() */
6187 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6189 Perl_my_gmtime(pTHX_ const time_t *timep)
6195 if (timep == NULL) {
6196 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6199 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6203 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6205 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6206 return gmtime(&when);
6208 /* CRTL localtime() wants local time as input, so does no tz correction */
6209 rsltmp = localtime(&when);
6210 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6213 } /* end of my_gmtime() */
6217 /*{{{struct tm *my_localtime(const time_t *timep)*/
6219 Perl_my_localtime(pTHX_ const time_t *timep)
6221 time_t when, whenutc;
6225 if (timep == NULL) {
6226 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6229 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6230 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6233 # ifdef RTL_USES_UTC
6235 if (VMSISH_TIME) when = _toutc(when);
6237 /* CRTL localtime() wants UTC as input, does tz correction itself */
6238 return localtime(&when);
6240 # else /* !RTL_USES_UTC */
6243 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6244 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6247 #ifndef RTL_USES_UTC
6248 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6249 when = whenutc - offset; /* pseudolocal time*/
6252 /* CRTL localtime() wants local time as input, so does no tz correction */
6253 rsltmp = localtime(&when);
6254 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6258 } /* end of my_localtime() */
6261 /* Reset definitions for later calls */
6262 #define gmtime(t) my_gmtime(t)
6263 #define localtime(t) my_localtime(t)
6264 #define time(t) my_time(t)
6267 /* my_utime - update modification time of a file
6268 * calling sequence is identical to POSIX utime(), but under
6269 * VMS only the modification time is changed; ODS-2 does not
6270 * maintain access times. Restrictions differ from the POSIX
6271 * definition in that the time can be changed as long as the
6272 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6273 * no separate checks are made to insure that the caller is the
6274 * owner of the file or has special privs enabled.
6275 * Code here is based on Joe Meadows' FILE utility.
6278 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6279 * to VMS epoch (01-JAN-1858 00:00:00.00)
6280 * in 100 ns intervals.
6282 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6284 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6285 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6288 long int bintime[2], len = 2, lowbit, unixtime,
6289 secscale = 10000000; /* seconds --> 100 ns intervals */
6290 unsigned long int chan, iosb[2], retsts;
6291 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6292 struct FAB myfab = cc$rms_fab;
6293 struct NAM mynam = cc$rms_nam;
6294 #if defined (__DECC) && defined (__VAX)
6295 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6296 * at least through VMS V6.1, which causes a type-conversion warning.
6298 # pragma message save
6299 # pragma message disable cvtdiftypes
6301 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6302 struct fibdef myfib;
6303 #if defined (__DECC) && defined (__VAX)
6304 /* This should be right after the declaration of myatr, but due
6305 * to a bug in VAX DEC C, this takes effect a statement early.
6307 # pragma message restore
6309 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6310 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6311 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6313 if (file == NULL || *file == '\0') {
6315 set_vaxc_errno(LIB$_INVARG);
6318 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6320 if (utimes != NULL) {
6321 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6322 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6323 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6324 * as input, we force the sign bit to be clear by shifting unixtime right
6325 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6327 lowbit = (utimes->modtime & 1) ? secscale : 0;
6328 unixtime = (long int) utimes->modtime;
6330 /* If input was UTC; convert to local for sys svc */
6331 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6333 unixtime >>= 1; secscale <<= 1;
6334 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6335 if (!(retsts & 1)) {
6337 set_vaxc_errno(retsts);
6340 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6341 if (!(retsts & 1)) {
6343 set_vaxc_errno(retsts);
6348 /* Just get the current time in VMS format directly */
6349 retsts = sys$gettim(bintime);
6350 if (!(retsts & 1)) {
6352 set_vaxc_errno(retsts);
6357 myfab.fab$l_fna = vmsspec;
6358 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6359 myfab.fab$l_nam = &mynam;
6360 mynam.nam$l_esa = esa;
6361 mynam.nam$b_ess = (unsigned char) sizeof esa;
6362 mynam.nam$l_rsa = rsa;
6363 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6365 /* Look for the file to be affected, letting RMS parse the file
6366 * specification for us as well. I have set errno using only
6367 * values documented in the utime() man page for VMS POSIX.
6369 retsts = sys$parse(&myfab,0,0);
6370 if (!(retsts & 1)) {
6371 set_vaxc_errno(retsts);
6372 if (retsts == RMS$_PRV) set_errno(EACCES);
6373 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6374 else set_errno(EVMSERR);
6377 retsts = sys$search(&myfab,0,0);
6378 if (!(retsts & 1)) {
6379 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6380 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6381 set_vaxc_errno(retsts);
6382 if (retsts == RMS$_PRV) set_errno(EACCES);
6383 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6384 else set_errno(EVMSERR);
6388 devdsc.dsc$w_length = mynam.nam$b_dev;
6389 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6391 retsts = sys$assign(&devdsc,&chan,0,0);
6392 if (!(retsts & 1)) {
6393 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6394 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6395 set_vaxc_errno(retsts);
6396 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6397 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6398 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6399 else set_errno(EVMSERR);
6403 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6404 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6406 memset((void *) &myfib, 0, sizeof myfib);
6407 #if defined(__DECC) || defined(__DECCXX)
6408 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6409 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6410 /* This prevents the revision time of the file being reset to the current
6411 * time as a result of our IO$_MODIFY $QIO. */
6412 myfib.fib$l_acctl = FIB$M_NORECORD;
6414 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6415 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6416 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6418 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6419 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6420 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6421 _ckvmssts(sys$dassgn(chan));
6422 if (retsts & 1) retsts = iosb[0];
6423 if (!(retsts & 1)) {
6424 set_vaxc_errno(retsts);
6425 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6426 else set_errno(EVMSERR);
6431 } /* end of my_utime() */
6435 * flex_stat, flex_fstat
6436 * basic stat, but gets it right when asked to stat
6437 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6440 /* encode_dev packs a VMS device name string into an integer to allow
6441 * simple comparisons. This can be used, for example, to check whether two
6442 * files are located on the same device, by comparing their encoded device
6443 * names. Even a string comparison would not do, because stat() reuses the
6444 * device name buffer for each call; so without encode_dev, it would be
6445 * necessary to save the buffer and use strcmp (this would mean a number of
6446 * changes to the standard Perl code, to say nothing of what a Perl script
6449 * The device lock id, if it exists, should be unique (unless perhaps compared
6450 * with lock ids transferred from other nodes). We have a lock id if the disk is
6451 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6452 * device names. Thus we use the lock id in preference, and only if that isn't
6453 * available, do we try to pack the device name into an integer (flagged by
6454 * the sign bit (LOCKID_MASK) being set).
6456 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6457 * name and its encoded form, but it seems very unlikely that we will find
6458 * two files on different disks that share the same encoded device names,
6459 * and even more remote that they will share the same file id (if the test
6460 * is to check for the same file).
6462 * A better method might be to use sys$device_scan on the first call, and to
6463 * search for the device, returning an index into the cached array.
6464 * The number returned would be more intelligable.
6465 * This is probably not worth it, and anyway would take quite a bit longer
6466 * on the first call.
6468 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6469 static mydev_t encode_dev (pTHX_ const char *dev)
6472 unsigned long int f;
6477 if (!dev || !dev[0]) return 0;
6481 struct dsc$descriptor_s dev_desc;
6482 unsigned long int status, lockid, item = DVI$_LOCKID;
6484 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6485 can try that first. */
6486 dev_desc.dsc$w_length = strlen (dev);
6487 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6488 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6489 dev_desc.dsc$a_pointer = (char *) dev;
6490 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6491 if (lockid) return (lockid & ~LOCKID_MASK);
6495 /* Otherwise we try to encode the device name */
6499 for (q = dev + strlen(dev); q--; q >= dev) {
6502 else if (isalpha (toupper (*q)))
6503 c= toupper (*q) - 'A' + (char)10;
6505 continue; /* Skip '$'s */
6507 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6509 enc += f * (unsigned long int) c;
6511 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6513 } /* end of encode_dev() */
6515 static char namecache[NAM$C_MAXRSS+1];
6518 is_null_device(name)
6521 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6522 The underscore prefix, controller letter, and unit number are
6523 independently optional; for our purposes, the colon punctuation
6524 is not. The colon can be trailed by optional directory and/or
6525 filename, but two consecutive colons indicates a nodename rather
6526 than a device. [pr] */
6527 if (*name == '_') ++name;
6528 if (tolower(*name++) != 'n') return 0;
6529 if (tolower(*name++) != 'l') return 0;
6530 if (tolower(*name) == 'a') ++name;
6531 if (*name == '0') ++name;
6532 return (*name++ == ':') && (*name != ':');
6535 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6536 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6537 * subset of the applicable information.
6540 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6542 char fname_phdev[NAM$C_MAXRSS+1];
6543 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6545 char fname[NAM$C_MAXRSS+1];
6546 unsigned long int retsts;
6547 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6548 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6550 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6551 device name on successive calls */
6552 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6553 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6554 namdsc.dsc$a_pointer = fname;
6555 namdsc.dsc$w_length = sizeof fname - 1;
6557 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6558 &namdsc,&namdsc.dsc$w_length,0,0);
6560 fname[namdsc.dsc$w_length] = '\0';
6562 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6563 * but if someone has redefined that logical, Perl gets very lost. Since
6564 * we have the physical device name from the stat buffer, just paste it on.
6566 strcpy( fname_phdev, statbufp->st_devnam );
6567 strcat( fname_phdev, strrchr(fname, ':') );
6569 return cando_by_name(bit,effective,fname_phdev);
6571 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6572 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6576 return FALSE; /* Should never get to here */
6578 } /* end of cando() */
6582 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6584 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6586 static char usrname[L_cuserid];
6587 static struct dsc$descriptor_s usrdsc =
6588 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6589 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6590 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6591 unsigned short int retlen, trnlnm_iter_count;
6592 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6593 union prvdef curprv;
6594 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6595 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6596 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6597 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6599 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6601 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6603 if (!fname || !*fname) return FALSE;
6604 /* Make sure we expand logical names, since sys$check_access doesn't */
6605 if (!strpbrk(fname,"/]>:")) {
6606 strcpy(fileified,fname);
6607 trnlnm_iter_count = 0;
6608 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6609 trnlnm_iter_count++;
6610 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6614 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6615 retlen = namdsc.dsc$w_length = strlen(vmsname);
6616 namdsc.dsc$a_pointer = vmsname;
6617 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6618 vmsname[retlen-1] == ':') {
6619 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6620 namdsc.dsc$w_length = strlen(fileified);
6621 namdsc.dsc$a_pointer = fileified;
6625 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6626 access = ARM$M_EXECUTE; break;
6627 case S_IRUSR: case S_IRGRP: case S_IROTH:
6628 access = ARM$M_READ; break;
6629 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6630 access = ARM$M_WRITE; break;
6631 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6632 access = ARM$M_DELETE; break;
6637 /* Before we call $check_access, create a user profile with the current
6638 * process privs since otherwise it just uses the default privs from the
6639 * UAF and might give false positives or negatives.
6642 /* get current process privs and username */
6643 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6646 /* find out the space required for the profile */
6647 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6648 &usrprodsc.dsc$w_length,0));
6650 /* allocate space for the profile and get it filled in */
6651 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6652 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6653 &usrprodsc.dsc$w_length,0));
6655 /* use the profile to check access to the file; free profile & analyze results */
6656 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6657 Safefree(usrprodsc.dsc$a_pointer);
6658 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6659 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6660 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6661 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6662 set_vaxc_errno(retsts);
6663 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6664 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6665 else set_errno(ENOENT);
6668 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6673 return FALSE; /* Should never get here */
6675 } /* end of cando_by_name() */
6679 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6681 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6683 if (!fstat(fd,(stat_t *) statbufp)) {
6684 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6685 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6686 # ifdef RTL_USES_UTC
6689 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6690 statbufp->st_atime = _toloc(statbufp->st_atime);
6691 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6696 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6700 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6701 statbufp->st_atime = _toutc(statbufp->st_atime);
6702 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6709 } /* end of flex_fstat() */
6712 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6714 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6716 char fileified[NAM$C_MAXRSS+1];
6717 char temp_fspec[NAM$C_MAXRSS+300];
6719 int saved_errno, saved_vaxc_errno;
6721 if (!fspec) return retval;
6722 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6723 strcpy(temp_fspec, fspec);
6724 if (statbufp == (Stat_t *) &PL_statcache)
6725 do_tovmsspec(temp_fspec,namecache,0);
6726 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6727 memset(statbufp,0,sizeof *statbufp);
6728 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6729 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6730 statbufp->st_uid = 0x00010001;
6731 statbufp->st_gid = 0x0001;
6732 time((time_t *)&statbufp->st_mtime);
6733 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6737 /* Try for a directory name first. If fspec contains a filename without
6738 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6739 * and sea:[wine.dark]water. exist, we prefer the directory here.
6740 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6741 * not sea:[wine.dark]., if the latter exists. If the intended target is
6742 * the file with null type, specify this by calling flex_stat() with
6743 * a '.' at the end of fspec.
6745 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6746 retval = stat(fileified,(stat_t *) statbufp);
6747 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6748 strcpy(namecache,fileified);
6750 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6752 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6753 # ifdef RTL_USES_UTC
6756 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6757 statbufp->st_atime = _toloc(statbufp->st_atime);
6758 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6763 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6767 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6768 statbufp->st_atime = _toutc(statbufp->st_atime);
6769 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6773 /* If we were successful, leave errno where we found it */
6774 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6777 } /* end of flex_stat() */
6781 /*{{{char *my_getlogin()*/
6782 /* VMS cuserid == Unix getlogin, except calling sequence */
6786 static char user[L_cuserid];
6787 return cuserid(user);
6792 /* rmscopy - copy a file using VMS RMS routines
6794 * Copies contents and attributes of spec_in to spec_out, except owner
6795 * and protection information. Name and type of spec_in are used as
6796 * defaults for spec_out. The third parameter specifies whether rmscopy()
6797 * should try to propagate timestamps from the input file to the output file.
6798 * If it is less than 0, no timestamps are preserved. If it is 0, then
6799 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6800 * propagated to the output file at creation iff the output file specification
6801 * did not contain an explicit name or type, and the revision date is always
6802 * updated at the end of the copy operation. If it is greater than 0, then
6803 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6804 * other than the revision date should be propagated, and bit 1 indicates
6805 * that the revision date should be propagated.
6807 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6809 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6810 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6811 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6812 * as part of the Perl standard distribution under the terms of the
6813 * GNU General Public License or the Perl Artistic License. Copies
6814 * of each may be found in the Perl standard distribution.
6816 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6818 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6820 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6821 rsa[NAM$C_MAXRSS], ubf[32256];
6822 unsigned long int i, sts, sts2;
6823 struct FAB fab_in, fab_out;
6824 struct RAB rab_in, rab_out;
6826 struct XABDAT xabdat;
6827 struct XABFHC xabfhc;
6828 struct XABRDT xabrdt;
6829 struct XABSUM xabsum;
6831 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6832 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6833 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6837 fab_in = cc$rms_fab;
6838 fab_in.fab$l_fna = vmsin;
6839 fab_in.fab$b_fns = strlen(vmsin);
6840 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6841 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6842 fab_in.fab$l_fop = FAB$M_SQO;
6843 fab_in.fab$l_nam = &nam;
6844 fab_in.fab$l_xab = (void *) &xabdat;
6847 nam.nam$l_rsa = rsa;
6848 nam.nam$b_rss = sizeof(rsa);
6849 nam.nam$l_esa = esa;
6850 nam.nam$b_ess = sizeof (esa);
6851 nam.nam$b_esl = nam.nam$b_rsl = 0;
6853 xabdat = cc$rms_xabdat; /* To get creation date */
6854 xabdat.xab$l_nxt = (void *) &xabfhc;
6856 xabfhc = cc$rms_xabfhc; /* To get record length */
6857 xabfhc.xab$l_nxt = (void *) &xabsum;
6859 xabsum = cc$rms_xabsum; /* To get key and area information */
6861 if (!((sts = sys$open(&fab_in)) & 1)) {
6862 set_vaxc_errno(sts);
6864 case RMS$_FNF: case RMS$_DNF:
6865 set_errno(ENOENT); break;
6867 set_errno(ENOTDIR); break;
6869 set_errno(ENODEV); break;
6871 set_errno(EINVAL); break;
6873 set_errno(EACCES); break;
6881 fab_out.fab$w_ifi = 0;
6882 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6883 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6884 fab_out.fab$l_fop = FAB$M_SQO;
6885 fab_out.fab$l_fna = vmsout;
6886 fab_out.fab$b_fns = strlen(vmsout);
6887 fab_out.fab$l_dna = nam.nam$l_name;
6888 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6890 if (preserve_dates == 0) { /* Act like DCL COPY */
6891 nam.nam$b_nop = NAM$M_SYNCHK;
6892 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6893 if (!((sts = sys$parse(&fab_out)) & 1)) {
6894 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6895 set_vaxc_errno(sts);
6898 fab_out.fab$l_xab = (void *) &xabdat;
6899 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6901 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6902 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6903 preserve_dates =0; /* bitmask from this point forward */
6905 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6906 if (!((sts = sys$create(&fab_out)) & 1)) {
6907 set_vaxc_errno(sts);
6910 set_errno(ENOENT); break;
6912 set_errno(ENOTDIR); break;
6914 set_errno(ENODEV); break;
6916 set_errno(EINVAL); break;
6918 set_errno(EACCES); break;
6924 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6925 if (preserve_dates & 2) {
6926 /* sys$close() will process xabrdt, not xabdat */
6927 xabrdt = cc$rms_xabrdt;
6929 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6931 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6932 * is unsigned long[2], while DECC & VAXC use a struct */
6933 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6935 fab_out.fab$l_xab = (void *) &xabrdt;
6938 rab_in = cc$rms_rab;
6939 rab_in.rab$l_fab = &fab_in;
6940 rab_in.rab$l_rop = RAB$M_BIO;
6941 rab_in.rab$l_ubf = ubf;
6942 rab_in.rab$w_usz = sizeof ubf;
6943 if (!((sts = sys$connect(&rab_in)) & 1)) {
6944 sys$close(&fab_in); sys$close(&fab_out);
6945 set_errno(EVMSERR); set_vaxc_errno(sts);
6949 rab_out = cc$rms_rab;
6950 rab_out.rab$l_fab = &fab_out;
6951 rab_out.rab$l_rbf = ubf;
6952 if (!((sts = sys$connect(&rab_out)) & 1)) {
6953 sys$close(&fab_in); sys$close(&fab_out);
6954 set_errno(EVMSERR); set_vaxc_errno(sts);
6958 while ((sts = sys$read(&rab_in))) { /* always true */
6959 if (sts == RMS$_EOF) break;
6960 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6961 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6962 sys$close(&fab_in); sys$close(&fab_out);
6963 set_errno(EVMSERR); set_vaxc_errno(sts);
6968 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6969 sys$close(&fab_in); sys$close(&fab_out);
6970 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6972 set_errno(EVMSERR); set_vaxc_errno(sts);
6978 } /* end of rmscopy() */
6982 /*** The following glue provides 'hooks' to make some of the routines
6983 * from this file available from Perl. These routines are sufficiently
6984 * basic, and are required sufficiently early in the build process,
6985 * that's it's nice to have them available to miniperl as well as the
6986 * full Perl, so they're set up here instead of in an extension. The
6987 * Perl code which handles importation of these names into a given
6988 * package lives in [.VMS]Filespec.pm in @INC.
6992 rmsexpand_fromperl(pTHX_ CV *cv)
6995 char *fspec, *defspec = NULL, *rslt;
6998 if (!items || items > 2)
6999 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7000 fspec = SvPV(ST(0),n_a);
7001 if (!fspec || !*fspec) XSRETURN_UNDEF;
7002 if (items == 2) defspec = SvPV(ST(1),n_a);
7004 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7005 ST(0) = sv_newmortal();
7006 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7011 vmsify_fromperl(pTHX_ CV *cv)
7017 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7018 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7019 ST(0) = sv_newmortal();
7020 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7025 unixify_fromperl(pTHX_ CV *cv)
7031 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7032 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7033 ST(0) = sv_newmortal();
7034 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7039 fileify_fromperl(pTHX_ CV *cv)
7045 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7046 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7047 ST(0) = sv_newmortal();
7048 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7053 pathify_fromperl(pTHX_ CV *cv)
7059 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7060 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7061 ST(0) = sv_newmortal();
7062 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7067 vmspath_fromperl(pTHX_ CV *cv)
7073 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7074 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7075 ST(0) = sv_newmortal();
7076 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7081 unixpath_fromperl(pTHX_ CV *cv)
7087 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7088 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7089 ST(0) = sv_newmortal();
7090 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7095 candelete_fromperl(pTHX_ CV *cv)
7098 char fspec[NAM$C_MAXRSS+1], *fsp;
7103 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7105 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7106 if (SvTYPE(mysv) == SVt_PVGV) {
7107 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7108 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7115 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7116 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7122 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7127 rmscopy_fromperl(pTHX_ CV *cv)
7130 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7132 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7133 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7134 unsigned long int sts;
7139 if (items < 2 || items > 3)
7140 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7142 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7143 if (SvTYPE(mysv) == SVt_PVGV) {
7144 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7145 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7152 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7153 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7158 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7159 if (SvTYPE(mysv) == SVt_PVGV) {
7160 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7161 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7168 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7169 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7174 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7176 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7182 mod2fname(pTHX_ CV *cv)
7185 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7186 workbuff[NAM$C_MAXRSS*1 + 1];
7187 int total_namelen = 3, counter, num_entries;
7188 /* ODS-5 ups this, but we want to be consistent, so... */
7189 int max_name_len = 39;
7190 AV *in_array = (AV *)SvRV(ST(0));
7192 num_entries = av_len(in_array);
7194 /* All the names start with PL_. */
7195 strcpy(ultimate_name, "PL_");
7197 /* Clean up our working buffer */
7198 Zero(work_name, sizeof(work_name), char);
7200 /* Run through the entries and build up a working name */
7201 for(counter = 0; counter <= num_entries; counter++) {
7202 /* If it's not the first name then tack on a __ */
7204 strcat(work_name, "__");
7206 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7210 /* Check to see if we actually have to bother...*/
7211 if (strlen(work_name) + 3 <= max_name_len) {
7212 strcat(ultimate_name, work_name);
7214 /* It's too darned big, so we need to go strip. We use the same */
7215 /* algorithm as xsubpp does. First, strip out doubled __ */
7216 char *source, *dest, last;
7219 for (source = work_name; *source; source++) {
7220 if (last == *source && last == '_') {
7226 /* Go put it back */
7227 strcpy(work_name, workbuff);
7228 /* Is it still too big? */
7229 if (strlen(work_name) + 3 > max_name_len) {
7230 /* Strip duplicate letters */
7233 for (source = work_name; *source; source++) {
7234 if (last == toupper(*source)) {
7238 last = toupper(*source);
7240 strcpy(work_name, workbuff);
7243 /* Is it *still* too big? */
7244 if (strlen(work_name) + 3 > max_name_len) {
7245 /* Too bad, we truncate */
7246 work_name[max_name_len - 2] = 0;
7248 strcat(ultimate_name, work_name);
7251 /* Okay, return it */
7252 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7257 hushexit_fromperl(pTHX_ CV *cv)
7262 VMSISH_HUSHED = SvTRUE(ST(0));
7264 ST(0) = boolSV(VMSISH_HUSHED);
7269 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7270 struct interp_intern *dst)
7272 memcpy(dst,src,sizeof(struct interp_intern));
7276 Perl_sys_intern_clear(pTHX)
7281 Perl_sys_intern_init(pTHX)
7283 unsigned int ix = RAND_MAX;
7289 MY_INV_RAND_MAX = 1./x;
7296 char* file = __FILE__;
7297 char temp_buff[512];
7298 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7299 no_translate_barewords = TRUE;
7301 no_translate_barewords = FALSE;
7304 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7305 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7306 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7307 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7308 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7309 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7310 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7311 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7312 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7313 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7314 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7316 store_pipelocs(aTHX); /* will redo any earlier attempts */