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;
3346 if (!dir || !*dir) {
3347 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3350 if (*dir) strcpy(trndir,dir);
3351 else getcwd(trndir,sizeof trndir - 1);
3353 trnlnm_iter_count = 0;
3354 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3355 && my_trnlnm(trndir,trndir,0)) {
3356 trnlnm_iter_count++;
3357 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3358 trnlen = strlen(trndir);
3360 /* Trap simple rooted lnms, and return lnm:[000000] */
3361 if (!strcmp(trndir+trnlen-2,".]")) {
3362 if (buf) retpath = buf;
3363 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3364 else retpath = __pathify_retbuf;
3365 strcpy(retpath,dir);
3366 strcat(retpath,":[000000]");
3372 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3373 if (*dir == '.' && (*(dir+1) == '\0' ||
3374 (*(dir+1) == '.' && *(dir+2) == '\0')))
3375 retlen = 2 + (*(dir+1) != '\0');
3377 if ( !(cp1 = strrchr(dir,'/')) &&
3378 !(cp1 = strrchr(dir,']')) &&
3379 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3380 if ((cp2 = strchr(cp1,'.')) != NULL &&
3381 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3382 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3383 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3384 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3386 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3387 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3388 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3389 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3390 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3391 (ver || *cp3)))))) {
3393 set_vaxc_errno(RMS$_DIR);
3396 retlen = cp2 - dir + 1;
3398 else { /* No file type present. Treat the filename as a directory. */
3399 retlen = strlen(dir) + 1;
3402 if (buf) retpath = buf;
3403 else if (ts) New(1313,retpath,retlen+1,char);
3404 else retpath = __pathify_retbuf;
3405 strncpy(retpath,dir,retlen-1);
3406 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3407 retpath[retlen-1] = '/'; /* with '/', add it. */
3408 retpath[retlen] = '\0';
3410 else retpath[retlen-1] = '\0';
3412 else { /* VMS-style directory spec */
3413 char esa[NAM$C_MAXRSS+1], *cp;
3414 unsigned long int sts, cmplen, haslower;
3415 struct FAB dirfab = cc$rms_fab;
3416 struct NAM savnam, dirnam = cc$rms_nam;
3418 /* If we've got an explicit filename, we can just shuffle the string. */
3419 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3420 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3421 if ((cp2 = strchr(cp1,'.')) != NULL) {
3423 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3424 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3425 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3426 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3427 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3428 (ver || *cp3)))))) {
3430 set_vaxc_errno(RMS$_DIR);
3434 else { /* No file type, so just draw name into directory part */
3435 for (cp2 = cp1; *cp2; cp2++) ;
3438 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3440 /* We've now got a VMS 'path'; fall through */
3442 dirfab.fab$b_fns = strlen(dir);
3443 dirfab.fab$l_fna = dir;
3444 if (dir[dirfab.fab$b_fns-1] == ']' ||
3445 dir[dirfab.fab$b_fns-1] == '>' ||
3446 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3447 if (buf) retpath = buf;
3448 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3449 else retpath = __pathify_retbuf;
3450 strcpy(retpath,dir);
3453 dirfab.fab$l_dna = ".DIR;1";
3454 dirfab.fab$b_dns = 6;
3455 dirfab.fab$l_nam = &dirnam;
3456 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3457 dirnam.nam$l_esa = esa;
3459 for (cp = dir; *cp; cp++)
3460 if (islower(*cp)) { haslower = 1; break; }
3462 if (!(sts = (sys$parse(&dirfab)&1))) {
3463 if (dirfab.fab$l_sts == RMS$_DIR) {
3464 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3465 sts = sys$parse(&dirfab) & 1;
3469 set_vaxc_errno(dirfab.fab$l_sts);
3475 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3476 if (dirfab.fab$l_sts != RMS$_FNF) {
3477 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3478 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3480 set_vaxc_errno(dirfab.fab$l_sts);
3483 dirnam = savnam; /* No; just work with potential name */
3486 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3487 /* Yep; check version while we're at it, if it's there. */
3488 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3489 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3490 /* Something other than .DIR[;1]. Bzzt. */
3491 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3492 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3494 set_vaxc_errno(RMS$_DIR);
3498 /* OK, the type was fine. Now pull any file name into the
3500 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3502 cp1 = strrchr(esa,'>');
3503 *dirnam.nam$l_type = '>';
3506 *(dirnam.nam$l_type + 1) = '\0';
3507 retlen = dirnam.nam$l_type - esa + 2;
3508 if (buf) retpath = buf;
3509 else if (ts) New(1314,retpath,retlen,char);
3510 else retpath = __pathify_retbuf;
3511 strcpy(retpath,esa);
3512 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3513 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3514 /* $PARSE may have upcased filespec, so convert output to lower
3515 * case if input contained any lowercase characters. */
3516 if (haslower) __mystrtolower(retpath);
3520 } /* end of do_pathify_dirspec() */
3522 /* External entry points */
3523 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3524 { return do_pathify_dirspec(dir,buf,0); }
3525 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3526 { return do_pathify_dirspec(dir,buf,1); }
3528 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3529 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3531 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3532 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3533 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3534 unsigned short int trnlnm_iter_count;
3536 if (spec == NULL) return NULL;
3537 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3538 if (buf) rslt = buf;
3540 retlen = strlen(spec);
3541 cp1 = strchr(spec,'[');
3542 if (!cp1) cp1 = strchr(spec,'<');
3544 for (cp1++; *cp1; cp1++) {
3545 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3546 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3547 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3550 New(1315,rslt,retlen+2+2*expand,char);
3552 else rslt = __tounixspec_retbuf;
3553 if (strchr(spec,'/') != NULL) {
3560 dirend = strrchr(spec,']');
3561 if (dirend == NULL) dirend = strrchr(spec,'>');
3562 if (dirend == NULL) dirend = strchr(spec,':');
3563 if (dirend == NULL) {
3567 if (*cp2 != '[' && *cp2 != '<') {
3570 else { /* the VMS spec begins with directories */
3572 if (*cp2 == ']' || *cp2 == '>') {
3573 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3576 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3577 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3578 if (ts) Safefree(rslt);
3581 trnlnm_iter_count = 0;
3584 while (*cp3 != ':' && *cp3) cp3++;
3586 if (strchr(cp3,']') != NULL) break;
3587 trnlnm_iter_count++;
3588 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3589 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3591 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3592 retlen = devlen + dirlen;
3593 Renew(rslt,retlen+1+2*expand,char);
3599 *(cp1++) = *(cp3++);
3600 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3604 else if ( *cp2 == '.') {
3605 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3606 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3612 for (; cp2 <= dirend; cp2++) {
3615 if (*(cp2+1) == '[') cp2++;
3617 else if (*cp2 == ']' || *cp2 == '>') {
3618 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3620 else if (*cp2 == '.') {
3622 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3623 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3624 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3625 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3626 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3628 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3629 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3633 else if (*cp2 == '-') {
3634 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3635 while (*cp2 == '-') {
3637 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3639 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3640 if (ts) Safefree(rslt); /* filespecs like */
3641 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3645 else *(cp1++) = *cp2;
3647 else *(cp1++) = *cp2;
3649 while (*cp2) *(cp1++) = *(cp2++);
3654 } /* end of do_tounixspec() */
3656 /* External entry points */
3657 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3658 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3660 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3661 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3662 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3663 char *rslt, *dirend;
3664 register char *cp1, *cp2;
3665 unsigned long int infront = 0, hasdir = 1;
3667 if (path == NULL) return NULL;
3668 if (buf) rslt = buf;
3669 else if (ts) New(1316,rslt,strlen(path)+9,char);
3670 else rslt = __tovmsspec_retbuf;
3671 if (strpbrk(path,"]:>") ||
3672 (dirend = strrchr(path,'/')) == NULL) {
3673 if (path[0] == '.') {
3674 if (path[1] == '\0') strcpy(rslt,"[]");
3675 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3676 else strcpy(rslt,path); /* probably garbage */
3678 else strcpy(rslt,path);
3681 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3682 if (!*(dirend+2)) dirend +=2;
3683 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3684 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3689 char trndev[NAM$C_MAXRSS+1];
3693 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3695 if (!buf & ts) Renew(rslt,18,char);
3696 strcpy(rslt,"sys$disk:[000000]");
3699 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3701 islnm = my_trnlnm(rslt,trndev,0);
3702 trnend = islnm ? strlen(trndev) - 1 : 0;
3703 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3704 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3705 /* If the first element of the path is a logical name, determine
3706 * whether it has to be translated so we can add more directories. */
3707 if (!islnm || rooted) {
3710 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3714 if (cp2 != dirend) {
3715 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3716 strcpy(rslt,trndev);
3717 cp1 = rslt + trnend;
3730 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3731 cp2 += 2; /* skip over "./" - it's redundant */
3732 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3734 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3735 *(cp1++) = '-'; /* "../" --> "-" */
3738 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3739 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3740 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3741 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3744 if (cp2 > dirend) cp2 = dirend;
3746 else *(cp1++) = '.';
3748 for (; cp2 < dirend; cp2++) {
3750 if (*(cp2-1) == '/') continue;
3751 if (*(cp1-1) != '.') *(cp1++) = '.';
3754 else if (!infront && *cp2 == '.') {
3755 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3756 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3757 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3758 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3759 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3760 else { /* back up over previous directory name */
3762 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3763 if (*(cp1-1) == '[') {
3764 memcpy(cp1,"000000.",7);
3769 if (cp2 == dirend) break;
3771 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3772 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3773 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3774 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3776 *(cp1++) = '.'; /* Simulate trailing '/' */
3777 cp2 += 2; /* for loop will incr this to == dirend */
3779 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3781 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3784 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3785 if (*cp2 == '.') *(cp1++) = '_';
3786 else *(cp1++) = *cp2;
3790 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3791 if (hasdir) *(cp1++) = ']';
3792 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3793 while (*cp2) *(cp1++) = *(cp2++);
3798 } /* end of do_tovmsspec() */
3800 /* External entry points */
3801 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3802 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3804 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3805 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3806 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3808 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3810 if (path == NULL) return NULL;
3811 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3812 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3813 if (buf) return buf;
3815 vmslen = strlen(vmsified);
3816 New(1317,cp,vmslen+1,char);
3817 memcpy(cp,vmsified,vmslen);
3822 strcpy(__tovmspath_retbuf,vmsified);
3823 return __tovmspath_retbuf;
3826 } /* end of do_tovmspath() */
3828 /* External entry points */
3829 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3830 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3833 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3834 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3835 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3837 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3839 if (path == NULL) return NULL;
3840 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3841 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3842 if (buf) return buf;
3844 unixlen = strlen(unixified);
3845 New(1317,cp,unixlen+1,char);
3846 memcpy(cp,unixified,unixlen);
3851 strcpy(__tounixpath_retbuf,unixified);
3852 return __tounixpath_retbuf;
3855 } /* end of do_tounixpath() */
3857 /* External entry points */
3858 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3859 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3862 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3864 *****************************************************************************
3866 * Copyright (C) 1989-1994 by *
3867 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3869 * Permission is hereby granted for the reproduction of this software, *
3870 * on condition that this copyright notice is included in the reproduction, *
3871 * and that such reproduction is not for purposes of profit or material *
3874 * 27-Aug-1994 Modified for inclusion in perl5 *
3875 * by Charles Bailey bailey@newman.upenn.edu *
3876 *****************************************************************************
3880 * getredirection() is intended to aid in porting C programs
3881 * to VMS (Vax-11 C). The native VMS environment does not support
3882 * '>' and '<' I/O redirection, or command line wild card expansion,
3883 * or a command line pipe mechanism using the '|' AND background
3884 * command execution '&'. All of these capabilities are provided to any
3885 * C program which calls this procedure as the first thing in the
3887 * The piping mechanism will probably work with almost any 'filter' type
3888 * of program. With suitable modification, it may useful for other
3889 * portability problems as well.
3891 * Author: Mark Pizzolato mark@infocomm.com
3895 struct list_item *next;
3899 static void add_item(struct list_item **head,
3900 struct list_item **tail,
3904 static void mp_expand_wild_cards(pTHX_ char *item,
3905 struct list_item **head,
3906 struct list_item **tail,
3909 static int background_process(pTHX_ int argc, char **argv);
3911 static void pipe_and_fork(pTHX_ char **cmargv);
3913 /*{{{ void getredirection(int *ac, char ***av)*/
3915 mp_getredirection(pTHX_ int *ac, char ***av)
3917 * Process vms redirection arg's. Exit if any error is seen.
3918 * If getredirection() processes an argument, it is erased
3919 * from the vector. getredirection() returns a new argc and argv value.
3920 * In the event that a background command is requested (by a trailing "&"),
3921 * this routine creates a background subprocess, and simply exits the program.
3923 * Warning: do not try to simplify the code for vms. The code
3924 * presupposes that getredirection() is called before any data is
3925 * read from stdin or written to stdout.
3927 * Normal usage is as follows:
3933 * getredirection(&argc, &argv);
3937 int argc = *ac; /* Argument Count */
3938 char **argv = *av; /* Argument Vector */
3939 char *ap; /* Argument pointer */
3940 int j; /* argv[] index */
3941 int item_count = 0; /* Count of Items in List */
3942 struct list_item *list_head = 0; /* First Item in List */
3943 struct list_item *list_tail; /* Last Item in List */
3944 char *in = NULL; /* Input File Name */
3945 char *out = NULL; /* Output File Name */
3946 char *outmode = "w"; /* Mode to Open Output File */
3947 char *err = NULL; /* Error File Name */
3948 char *errmode = "w"; /* Mode to Open Error File */
3949 int cmargc = 0; /* Piped Command Arg Count */
3950 char **cmargv = NULL;/* Piped Command Arg Vector */
3953 * First handle the case where the last thing on the line ends with
3954 * a '&'. This indicates the desire for the command to be run in a
3955 * subprocess, so we satisfy that desire.
3958 if (0 == strcmp("&", ap))
3959 exit(background_process(aTHX_ --argc, argv));
3960 if (*ap && '&' == ap[strlen(ap)-1])
3962 ap[strlen(ap)-1] = '\0';
3963 exit(background_process(aTHX_ argc, argv));
3966 * Now we handle the general redirection cases that involve '>', '>>',
3967 * '<', and pipes '|'.
3969 for (j = 0; j < argc; ++j)
3971 if (0 == strcmp("<", argv[j]))
3975 fprintf(stderr,"No input file after < on command line");
3976 exit(LIB$_WRONUMARG);
3981 if ('<' == *(ap = argv[j]))
3986 if (0 == strcmp(">", ap))
3990 fprintf(stderr,"No output file after > on command line");
3991 exit(LIB$_WRONUMARG);
4010 fprintf(stderr,"No output file after > or >> on command line");
4011 exit(LIB$_WRONUMARG);
4015 if (('2' == *ap) && ('>' == ap[1]))
4032 fprintf(stderr,"No output file after 2> or 2>> on command line");
4033 exit(LIB$_WRONUMARG);
4037 if (0 == strcmp("|", argv[j]))
4041 fprintf(stderr,"No command into which to pipe on command line");
4042 exit(LIB$_WRONUMARG);
4044 cmargc = argc-(j+1);
4045 cmargv = &argv[j+1];
4049 if ('|' == *(ap = argv[j]))
4057 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4060 * Allocate and fill in the new argument vector, Some Unix's terminate
4061 * the list with an extra null pointer.
4063 New(1302, argv, item_count+1, char *);
4065 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4066 argv[j] = list_head->value;
4072 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4073 exit(LIB$_INVARGORD);
4075 pipe_and_fork(aTHX_ cmargv);
4078 /* Check for input from a pipe (mailbox) */
4080 if (in == NULL && 1 == isapipe(0))
4082 char mbxname[L_tmpnam];
4084 long int dvi_item = DVI$_DEVBUFSIZ;
4085 $DESCRIPTOR(mbxnam, "");
4086 $DESCRIPTOR(mbxdevnam, "");
4088 /* Input from a pipe, reopen it in binary mode to disable */
4089 /* carriage control processing. */
4091 fgetname(stdin, mbxname);
4092 mbxnam.dsc$a_pointer = mbxname;
4093 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4094 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4095 mbxdevnam.dsc$a_pointer = mbxname;
4096 mbxdevnam.dsc$w_length = sizeof(mbxname);
4097 dvi_item = DVI$_DEVNAM;
4098 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4099 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4102 freopen(mbxname, "rb", stdin);
4105 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4109 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4111 fprintf(stderr,"Can't open input file %s as stdin",in);
4114 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4116 fprintf(stderr,"Can't open output file %s as stdout",out);
4119 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4122 if (strcmp(err,"&1") == 0) {
4123 dup2(fileno(stdout), fileno(stderr));
4124 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4127 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4129 fprintf(stderr,"Can't open error file %s as stderr",err);
4133 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4137 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4140 #ifdef ARGPROC_DEBUG
4141 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4142 for (j = 0; j < *ac; ++j)
4143 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4145 /* Clear errors we may have hit expanding wildcards, so they don't
4146 show up in Perl's $! later */
4147 set_errno(0); set_vaxc_errno(1);
4148 } /* end of getredirection() */
4151 static void add_item(struct list_item **head,
4152 struct list_item **tail,
4158 New(1303,*head,1,struct list_item);
4162 New(1304,(*tail)->next,1,struct list_item);
4163 *tail = (*tail)->next;
4165 (*tail)->value = value;
4169 static void mp_expand_wild_cards(pTHX_ char *item,
4170 struct list_item **head,
4171 struct list_item **tail,
4175 unsigned long int context = 0;
4181 char vmsspec[NAM$C_MAXRSS+1];
4182 $DESCRIPTOR(filespec, "");
4183 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4184 $DESCRIPTOR(resultspec, "");
4185 unsigned long int zero = 0, sts;
4187 for (cp = item; *cp; cp++) {
4188 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4189 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4191 if (!*cp || isspace(*cp))
4193 add_item(head, tail, item, count);
4196 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4197 resultspec.dsc$b_class = DSC$K_CLASS_D;
4198 resultspec.dsc$a_pointer = NULL;
4199 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4200 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4201 if (!isunix || !filespec.dsc$a_pointer)
4202 filespec.dsc$a_pointer = item;
4203 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4205 * Only return version specs, if the caller specified a version
4207 had_version = strchr(item, ';');
4209 * Only return device and directory specs, if the caller specifed either.
4211 had_device = strchr(item, ':');
4212 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4214 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4215 &defaultspec, 0, 0, &zero))))
4220 New(1305,string,resultspec.dsc$w_length+1,char);
4221 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4222 string[resultspec.dsc$w_length] = '\0';
4223 if (NULL == had_version)
4224 *((char *)strrchr(string, ';')) = '\0';
4225 if ((!had_directory) && (had_device == NULL))
4227 if (NULL == (devdir = strrchr(string, ']')))
4228 devdir = strrchr(string, '>');
4229 strcpy(string, devdir + 1);
4232 * Be consistent with what the C RTL has already done to the rest of
4233 * the argv items and lowercase all of these names.
4235 for (c = string; *c; ++c)
4238 if (isunix) trim_unixpath(string,item,1);
4239 add_item(head, tail, string, count);
4242 if (sts != RMS$_NMF)
4244 set_vaxc_errno(sts);
4247 case RMS$_FNF: case RMS$_DNF:
4248 set_errno(ENOENT); break;
4250 set_errno(ENOTDIR); break;
4252 set_errno(ENODEV); break;
4253 case RMS$_FNM: case RMS$_SYN:
4254 set_errno(EINVAL); break;
4256 set_errno(EACCES); break;
4258 _ckvmssts_noperl(sts);
4262 add_item(head, tail, item, count);
4263 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4264 _ckvmssts_noperl(lib$find_file_end(&context));
4267 static int child_st[2];/* Event Flag set when child process completes */
4269 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4271 static unsigned long int exit_handler(int *status)
4275 if (0 == child_st[0])
4277 #ifdef ARGPROC_DEBUG
4278 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4280 fflush(stdout); /* Have to flush pipe for binary data to */
4281 /* terminate properly -- <tp@mccall.com> */
4282 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4283 sys$dassgn(child_chan);
4285 sys$synch(0, child_st);
4290 static void sig_child(int chan)
4292 #ifdef ARGPROC_DEBUG
4293 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4295 if (child_st[0] == 0)
4299 static struct exit_control_block exit_block =
4304 &exit_block.exit_status,
4309 pipe_and_fork(pTHX_ char **cmargv)
4312 struct dsc$descriptor_s *vmscmd;
4313 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4314 int sts, j, l, ismcr, quote, tquote = 0;
4316 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4317 vms_execfree(vmscmd);
4322 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4323 && toupper(*(q+2)) == 'R' && !*(q+3);
4325 while (q && l < MAX_DCL_LINE_LENGTH) {
4327 if (j > 0 && quote) {
4333 if (ismcr && j > 1) quote = 1;
4334 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4337 if (quote || tquote) {
4343 if ((quote||tquote) && *q == '"') {
4353 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4355 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4359 static int background_process(pTHX_ int argc, char **argv)
4361 char command[2048] = "$";
4362 $DESCRIPTOR(value, "");
4363 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4364 static $DESCRIPTOR(null, "NLA0:");
4365 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4367 $DESCRIPTOR(pidstr, "");
4369 unsigned long int flags = 17, one = 1, retsts;
4371 strcat(command, argv[0]);
4374 strcat(command, " \"");
4375 strcat(command, *(++argv));
4376 strcat(command, "\"");
4378 value.dsc$a_pointer = command;
4379 value.dsc$w_length = strlen(value.dsc$a_pointer);
4380 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4381 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4382 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4383 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4386 _ckvmssts_noperl(retsts);
4388 #ifdef ARGPROC_DEBUG
4389 PerlIO_printf(Perl_debug_log, "%s\n", command);
4391 sprintf(pidstring, "%08X", pid);
4392 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4393 pidstr.dsc$a_pointer = pidstring;
4394 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4395 lib$set_symbol(&pidsymbol, &pidstr);
4399 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4402 /* OS-specific initialization at image activation (not thread startup) */
4403 /* Older VAXC header files lack these constants */
4404 #ifndef JPI$_RIGHTS_SIZE
4405 # define JPI$_RIGHTS_SIZE 817
4407 #ifndef KGB$M_SUBSYSTEM
4408 # define KGB$M_SUBSYSTEM 0x8
4411 /*{{{void vms_image_init(int *, char ***)*/
4413 vms_image_init(int *argcp, char ***argvp)
4415 char eqv[LNM$C_NAMLENGTH+1] = "";
4416 unsigned int len, tabct = 8, tabidx = 0;
4417 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4418 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4419 unsigned short int dummy, rlen;
4420 struct dsc$descriptor_s **tabvec;
4421 #if defined(PERL_IMPLICIT_CONTEXT)
4424 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4425 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4426 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4429 #ifdef KILL_BY_SIGPRC
4430 (void) Perl_csighandler_init();
4433 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4434 _ckvmssts_noperl(iosb[0]);
4435 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4436 if (iprv[i]) { /* Running image installed with privs? */
4437 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4442 /* Rights identifiers might trigger tainting as well. */
4443 if (!will_taint && (rlen || rsz)) {
4444 while (rlen < rsz) {
4445 /* We didn't get all the identifiers on the first pass. Allocate a
4446 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4447 * were needed to hold all identifiers at time of last call; we'll
4448 * allocate that many unsigned long ints), and go back and get 'em.
4449 * If it gave us less than it wanted to despite ample buffer space,
4450 * something's broken. Is your system missing a system identifier?
4452 if (rsz <= jpilist[1].buflen) {
4453 /* Perl_croak accvios when used this early in startup. */
4454 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4455 rsz, (unsigned long) jpilist[1].buflen,
4456 "Check your rights database for corruption.\n");
4459 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4460 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4461 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4462 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4463 _ckvmssts_noperl(iosb[0]);
4465 mask = jpilist[1].bufadr;
4466 /* Check attribute flags for each identifier (2nd longword); protected
4467 * subsystem identifiers trigger tainting.
4469 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4470 if (mask[i] & KGB$M_SUBSYSTEM) {
4475 if (mask != rlst) Safefree(mask);
4477 /* We need to use this hack to tell Perl it should run with tainting,
4478 * since its tainting flag may be part of the PL_curinterp struct, which
4479 * hasn't been allocated when vms_image_init() is called.
4483 New(1320,newap,*argcp+2,char **);
4484 newap[0] = argvp[0];
4486 Copy(argvp[1],newap[2],*argcp-1,char **);
4487 /* We orphan the old argv, since we don't know where it's come from,
4488 * so we don't know how to free it.
4490 *argcp++; argvp = newap;
4492 else { /* Did user explicitly request tainting? */
4494 char *cp, **av = *argvp;
4495 for (i = 1; i < *argcp; i++) {
4496 if (*av[i] != '-') break;
4497 for (cp = av[i]+1; *cp; cp++) {
4498 if (*cp == 'T') { will_taint = 1; break; }
4499 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4500 strchr("DFIiMmx",*cp)) break;
4502 if (will_taint) break;
4507 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4509 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4510 else if (tabidx >= tabct) {
4512 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4514 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4515 tabvec[tabidx]->dsc$w_length = 0;
4516 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4517 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4518 tabvec[tabidx]->dsc$a_pointer = NULL;
4519 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4521 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4523 getredirection(argcp,argvp);
4524 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4526 # include <reentrancy.h>
4527 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4536 * Trim Unix-style prefix off filespec, so it looks like what a shell
4537 * glob expansion would return (i.e. from specified prefix on, not
4538 * full path). Note that returned filespec is Unix-style, regardless
4539 * of whether input filespec was VMS-style or Unix-style.
4541 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4542 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4543 * vector of options; at present, only bit 0 is used, and if set tells
4544 * trim unixpath to try the current default directory as a prefix when
4545 * presented with a possibly ambiguous ... wildcard.
4547 * Returns !=0 on success, with trimmed filespec replacing contents of
4548 * fspec, and 0 on failure, with contents of fpsec unchanged.
4550 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4552 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4554 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4555 *template, *base, *end, *cp1, *cp2;
4556 register int tmplen, reslen = 0, dirs = 0;
4558 if (!wildspec || !fspec) return 0;
4559 if (strpbrk(wildspec,"]>:") != NULL) {
4560 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4561 else template = unixwild;
4563 else template = wildspec;
4564 if (strpbrk(fspec,"]>:") != NULL) {
4565 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4566 else base = unixified;
4567 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4568 * check to see that final result fits into (isn't longer than) fspec */
4569 reslen = strlen(fspec);
4573 /* No prefix or absolute path on wildcard, so nothing to remove */
4574 if (!*template || *template == '/') {
4575 if (base == fspec) return 1;
4576 tmplen = strlen(unixified);
4577 if (tmplen > reslen) return 0; /* not enough space */
4578 /* Copy unixified resultant, including trailing NUL */
4579 memmove(fspec,unixified,tmplen+1);
4583 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4584 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4585 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4586 for (cp1 = end ;cp1 >= base; cp1--)
4587 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4589 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4593 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4594 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4595 int ells = 1, totells, segdirs, match;
4596 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4597 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4599 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4601 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4602 if (ellipsis == template && opts & 1) {
4603 /* Template begins with an ellipsis. Since we can't tell how many
4604 * directory names at the front of the resultant to keep for an
4605 * arbitrary starting point, we arbitrarily choose the current
4606 * default directory as a starting point. If it's there as a prefix,
4607 * clip it off. If not, fall through and act as if the leading
4608 * ellipsis weren't there (i.e. return shortest possible path that
4609 * could match template).
4611 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4612 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4613 if (_tolower(*cp1) != _tolower(*cp2)) break;
4614 segdirs = dirs - totells; /* Min # of dirs we must have left */
4615 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4616 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4617 memcpy(fspec,cp2+1,end - cp2);
4621 /* First off, back up over constant elements at end of path */
4623 for (front = end ; front >= base; front--)
4624 if (*front == '/' && !dirs--) { front++; break; }
4626 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4627 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4628 if (cp1 != '\0') return 0; /* Path too long. */
4630 *cp2 = '\0'; /* Pick up with memcpy later */
4631 lcfront = lcres + (front - base);
4632 /* Now skip over each ellipsis and try to match the path in front of it. */
4634 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4635 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4636 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4637 if (cp1 < template) break; /* template started with an ellipsis */
4638 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4639 ellipsis = cp1; continue;
4641 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4643 for (segdirs = 0, cp2 = tpl;
4644 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4646 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4647 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4648 if (*cp2 == '/') segdirs++;
4650 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4651 /* Back up at least as many dirs as in template before matching */
4652 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4653 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4654 for (match = 0; cp1 > lcres;) {
4655 resdsc.dsc$a_pointer = cp1;
4656 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4658 if (match == 1) lcfront = cp1;
4660 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4662 if (!match) return 0; /* Can't find prefix ??? */
4663 if (match > 1 && opts & 1) {
4664 /* This ... wildcard could cover more than one set of dirs (i.e.
4665 * a set of similar dir names is repeated). If the template
4666 * contains more than 1 ..., upstream elements could resolve the
4667 * ambiguity, but it's not worth a full backtracking setup here.
4668 * As a quick heuristic, clip off the current default directory
4669 * if it's present to find the trimmed spec, else use the
4670 * shortest string that this ... could cover.
4672 char def[NAM$C_MAXRSS+1], *st;
4674 if (getcwd(def, sizeof def,0) == NULL) return 0;
4675 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4676 if (_tolower(*cp1) != _tolower(*cp2)) break;
4677 segdirs = dirs - totells; /* Min # of dirs we must have left */
4678 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4679 if (*cp1 == '\0' && *cp2 == '/') {
4680 memcpy(fspec,cp2+1,end - cp2);
4683 /* Nope -- stick with lcfront from above and keep going. */
4686 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4691 } /* end of trim_unixpath() */
4696 * VMS readdir() routines.
4697 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4699 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4700 * Minor modifications to original routines.
4703 /* Number of elements in vms_versions array */
4704 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4707 * Open a directory, return a handle for later use.
4709 /*{{{ DIR *opendir(char*name) */
4711 Perl_opendir(pTHX_ char *name)
4714 char dir[NAM$C_MAXRSS+1];
4717 if (do_tovmspath(name,dir,0) == NULL) {
4720 /* Check access before stat; otherwise stat does not
4721 * accurately report whether it's a directory.
4723 if (!cando_by_name(S_IRUSR,0,dir)) {
4724 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4727 if (flex_stat(dir,&sb) == -1) return NULL;
4728 if (!S_ISDIR(sb.st_mode)) {
4729 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4732 /* Get memory for the handle, and the pattern. */
4734 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4736 /* Fill in the fields; mainly playing with the descriptor. */
4737 (void)sprintf(dd->pattern, "%s*.*",dir);
4740 dd->vms_wantversions = 0;
4741 dd->pat.dsc$a_pointer = dd->pattern;
4742 dd->pat.dsc$w_length = strlen(dd->pattern);
4743 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4744 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4747 } /* end of opendir() */
4751 * Set the flag to indicate we want versions or not.
4753 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4755 vmsreaddirversions(DIR *dd, int flag)
4757 dd->vms_wantversions = flag;
4762 * Free up an opened directory.
4764 /*{{{ void closedir(DIR *dd)*/
4768 (void)lib$find_file_end(&dd->context);
4769 Safefree(dd->pattern);
4770 Safefree((char *)dd);
4775 * Collect all the version numbers for the current file.
4778 collectversions(pTHX_ DIR *dd)
4780 struct dsc$descriptor_s pat;
4781 struct dsc$descriptor_s res;
4783 char *p, *text, buff[sizeof dd->entry.d_name];
4785 unsigned long context, tmpsts;
4787 /* Convenient shorthand. */
4790 /* Add the version wildcard, ignoring the "*.*" put on before */
4791 i = strlen(dd->pattern);
4792 New(1308,text,i + e->d_namlen + 3,char);
4793 (void)strcpy(text, dd->pattern);
4794 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4796 /* Set up the pattern descriptor. */
4797 pat.dsc$a_pointer = text;
4798 pat.dsc$w_length = i + e->d_namlen - 1;
4799 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4800 pat.dsc$b_class = DSC$K_CLASS_S;
4802 /* Set up result descriptor. */
4803 res.dsc$a_pointer = buff;
4804 res.dsc$w_length = sizeof buff - 2;
4805 res.dsc$b_dtype = DSC$K_DTYPE_T;
4806 res.dsc$b_class = DSC$K_CLASS_S;
4808 /* Read files, collecting versions. */
4809 for (context = 0, e->vms_verscount = 0;
4810 e->vms_verscount < VERSIZE(e);
4811 e->vms_verscount++) {
4812 tmpsts = lib$find_file(&pat, &res, &context);
4813 if (tmpsts == RMS$_NMF || context == 0) break;
4815 buff[sizeof buff - 1] = '\0';
4816 if ((p = strchr(buff, ';')))
4817 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4819 e->vms_versions[e->vms_verscount] = -1;
4822 _ckvmssts(lib$find_file_end(&context));
4825 } /* end of collectversions() */
4828 * Read the next entry from the directory.
4830 /*{{{ struct dirent *readdir(DIR *dd)*/
4832 Perl_readdir(pTHX_ DIR *dd)
4834 struct dsc$descriptor_s res;
4835 char *p, buff[sizeof dd->entry.d_name];
4836 unsigned long int tmpsts;
4838 /* Set up result descriptor, and get next file. */
4839 res.dsc$a_pointer = buff;
4840 res.dsc$w_length = sizeof buff - 2;
4841 res.dsc$b_dtype = DSC$K_DTYPE_T;
4842 res.dsc$b_class = DSC$K_CLASS_S;
4843 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4844 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4845 if (!(tmpsts & 1)) {
4846 set_vaxc_errno(tmpsts);
4849 set_errno(EACCES); break;
4851 set_errno(ENODEV); break;
4853 set_errno(ENOTDIR); break;
4854 case RMS$_FNF: case RMS$_DNF:
4855 set_errno(ENOENT); break;
4862 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4863 buff[sizeof buff - 1] = '\0';
4864 for (p = buff; *p; p++) *p = _tolower(*p);
4865 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4868 /* Skip any directory component and just copy the name. */
4869 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4870 else (void)strcpy(dd->entry.d_name, buff);
4872 /* Clobber the version. */
4873 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4875 dd->entry.d_namlen = strlen(dd->entry.d_name);
4876 dd->entry.vms_verscount = 0;
4877 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4880 } /* end of readdir() */
4884 * Return something that can be used in a seekdir later.
4886 /*{{{ long telldir(DIR *dd)*/
4895 * Return to a spot where we used to be. Brute force.
4897 /*{{{ void seekdir(DIR *dd,long count)*/
4899 Perl_seekdir(pTHX_ DIR *dd, long count)
4901 int vms_wantversions;
4903 /* If we haven't done anything yet... */
4907 /* Remember some state, and clear it. */
4908 vms_wantversions = dd->vms_wantversions;
4909 dd->vms_wantversions = 0;
4910 _ckvmssts(lib$find_file_end(&dd->context));
4913 /* The increment is in readdir(). */
4914 for (dd->count = 0; dd->count < count; )
4917 dd->vms_wantversions = vms_wantversions;
4919 } /* end of seekdir() */
4922 /* VMS subprocess management
4924 * my_vfork() - just a vfork(), after setting a flag to record that
4925 * the current script is trying a Unix-style fork/exec.
4927 * vms_do_aexec() and vms_do_exec() are called in response to the
4928 * perl 'exec' function. If this follows a vfork call, then they
4929 * call out the the regular perl routines in doio.c which do an
4930 * execvp (for those who really want to try this under VMS).
4931 * Otherwise, they do exactly what the perl docs say exec should
4932 * do - terminate the current script and invoke a new command
4933 * (See below for notes on command syntax.)
4935 * do_aspawn() and do_spawn() implement the VMS side of the perl
4936 * 'system' function.
4938 * Note on command arguments to perl 'exec' and 'system': When handled
4939 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4940 * are concatenated to form a DCL command string. If the first arg
4941 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4942 * the the command string is handed off to DCL directly. Otherwise,
4943 * the first token of the command is taken as the filespec of an image
4944 * to run. The filespec is expanded using a default type of '.EXE' and
4945 * the process defaults for device, directory, etc., and if found, the resultant
4946 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4947 * the command string as parameters. This is perhaps a bit complicated,
4948 * but I hope it will form a happy medium between what VMS folks expect
4949 * from lib$spawn and what Unix folks expect from exec.
4952 static int vfork_called;
4954 /*{{{int my_vfork()*/
4965 vms_execfree(struct dsc$descriptor_s *vmscmd)
4968 if (vmscmd->dsc$a_pointer) {
4969 Safefree(vmscmd->dsc$a_pointer);
4976 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4978 char *junk, *tmps = Nullch;
4979 register size_t cmdlen = 0;
4986 tmps = SvPV(really,rlen);
4993 for (idx++; idx <= sp; idx++) {
4995 junk = SvPVx(*idx,rlen);
4996 cmdlen += rlen ? rlen + 1 : 0;
4999 New(401,PL_Cmd,cmdlen+1,char);
5001 if (tmps && *tmps) {
5002 strcpy(PL_Cmd,tmps);
5005 else *PL_Cmd = '\0';
5006 while (++mark <= sp) {
5008 char *s = SvPVx(*mark,n_a);
5010 if (*PL_Cmd) strcat(PL_Cmd," ");
5016 } /* end of setup_argstr() */
5019 static unsigned long int
5020 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5021 struct dsc$descriptor_s **pvmscmd)
5023 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5024 $DESCRIPTOR(defdsc,".EXE");
5025 $DESCRIPTOR(defdsc2,".");
5026 $DESCRIPTOR(resdsc,resspec);
5027 struct dsc$descriptor_s *vmscmd;
5028 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5029 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5030 register char *s, *rest, *cp, *wordbreak;
5033 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5034 vmscmd->dsc$a_pointer = NULL;
5035 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5036 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5037 vmscmd->dsc$w_length = 0;
5038 if (pvmscmd) *pvmscmd = vmscmd;
5040 if (suggest_quote) *suggest_quote = 0;
5042 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5043 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5045 while (*s && isspace(*s)) s++;
5047 if (*s == '@' || *s == '$') {
5048 vmsspec[0] = *s; rest = s + 1;
5049 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5051 else { cp = vmsspec; rest = s; }
5052 if (*rest == '.' || *rest == '/') {
5055 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5056 rest++, cp2++) *cp2 = *rest;
5058 if (do_tovmsspec(resspec,cp,0)) {
5061 for (cp2 = vmsspec + strlen(vmsspec);
5062 *rest && cp2 - vmsspec < sizeof vmsspec;
5063 rest++, cp2++) *cp2 = *rest;
5068 /* Intuit whether verb (first word of cmd) is a DCL command:
5069 * - if first nonspace char is '@', it's a DCL indirection
5071 * - if verb contains a filespec separator, it's not a DCL command
5072 * - if it doesn't, caller tells us whether to default to a DCL
5073 * command, or to a local image unless told it's DCL (by leading '$')
5077 if (suggest_quote) *suggest_quote = 1;
5079 register char *filespec = strpbrk(s,":<[.;");
5080 rest = wordbreak = strpbrk(s," \"\t/");
5081 if (!wordbreak) wordbreak = s + strlen(s);
5082 if (*s == '$') check_img = 0;
5083 if (filespec && (filespec < wordbreak)) isdcl = 0;
5084 else isdcl = !check_img;
5088 imgdsc.dsc$a_pointer = s;
5089 imgdsc.dsc$w_length = wordbreak - s;
5090 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5092 _ckvmssts(lib$find_file_end(&cxt));
5093 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5094 if (!(retsts & 1) && *s == '$') {
5095 _ckvmssts(lib$find_file_end(&cxt));
5096 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5097 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5099 _ckvmssts(lib$find_file_end(&cxt));
5100 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5104 _ckvmssts(lib$find_file_end(&cxt));
5109 while (*s && !isspace(*s)) s++;
5112 /* check that it's really not DCL with no file extension */
5113 fp = fopen(resspec,"r","ctx=bin,shr=get");
5115 char b[4] = {0,0,0,0};
5116 read(fileno(fp),b,4);
5117 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5120 if (check_img && isdcl) return RMS$_FNF;
5122 if (cando_by_name(S_IXUSR,0,resspec)) {
5123 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5125 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5126 if (suggest_quote) *suggest_quote = 1;
5128 strcpy(vmscmd->dsc$a_pointer,"@");
5129 if (suggest_quote) *suggest_quote = 1;
5131 strcat(vmscmd->dsc$a_pointer,resspec);
5132 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5133 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5134 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5136 else retsts = RMS$_PRV;
5139 /* It's either a DCL command or we couldn't find a suitable image */
5140 vmscmd->dsc$w_length = strlen(cmd);
5141 /* if (cmd == PL_Cmd) {
5142 vmscmd->dsc$a_pointer = PL_Cmd;
5143 if (suggest_quote) *suggest_quote = 1;
5146 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5148 /* check if it's a symbol (for quoting purposes) */
5149 if (suggest_quote && !*suggest_quote) {
5151 char equiv[LNM$C_NAMLENGTH];
5152 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5153 eqvdsc.dsc$a_pointer = equiv;
5155 iss = lib$get_symbol(vmscmd,&eqvdsc);
5156 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5158 if (!(retsts & 1)) {
5159 /* just hand off status values likely to be due to user error */
5160 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5161 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5162 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5163 else { _ckvmssts(retsts); }
5166 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5168 } /* end of setup_cmddsc() */
5171 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5173 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5176 if (vfork_called) { /* this follows a vfork - act Unixish */
5178 if (vfork_called < 0) {
5179 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5182 else return do_aexec(really,mark,sp);
5184 /* no vfork - act VMSish */
5185 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5190 } /* end of vms_do_aexec() */
5193 /* {{{bool vms_do_exec(char *cmd) */
5195 Perl_vms_do_exec(pTHX_ char *cmd)
5197 struct dsc$descriptor_s *vmscmd;
5199 if (vfork_called) { /* this follows a vfork - act Unixish */
5201 if (vfork_called < 0) {
5202 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5205 else return do_exec(cmd);
5208 { /* no vfork - act VMSish */
5209 unsigned long int retsts;
5212 TAINT_PROPER("exec");
5213 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5214 retsts = lib$do_command(vmscmd);
5217 case RMS$_FNF: case RMS$_DNF:
5218 set_errno(ENOENT); break;
5220 set_errno(ENOTDIR); break;
5222 set_errno(ENODEV); break;
5224 set_errno(EACCES); break;
5226 set_errno(EINVAL); break;
5227 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5228 set_errno(E2BIG); break;
5229 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5230 _ckvmssts(retsts); /* fall through */
5231 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5234 set_vaxc_errno(retsts);
5235 if (ckWARN(WARN_EXEC)) {
5236 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5237 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5239 vms_execfree(vmscmd);
5244 } /* end of vms_do_exec() */
5247 unsigned long int Perl_do_spawn(pTHX_ char *);
5249 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5251 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5253 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5256 } /* end of do_aspawn() */
5259 /* {{{unsigned long int do_spawn(char *cmd) */
5261 Perl_do_spawn(pTHX_ char *cmd)
5263 unsigned long int sts, substs;
5266 TAINT_PROPER("spawn");
5267 if (!cmd || !*cmd) {
5268 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5271 case RMS$_FNF: case RMS$_DNF:
5272 set_errno(ENOENT); break;
5274 set_errno(ENOTDIR); break;
5276 set_errno(ENODEV); break;
5278 set_errno(EACCES); break;
5280 set_errno(EINVAL); break;
5281 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5282 set_errno(E2BIG); break;
5283 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5284 _ckvmssts(sts); /* fall through */
5285 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5288 set_vaxc_errno(sts);
5289 if (ckWARN(WARN_EXEC)) {
5290 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5297 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5300 } /* end of do_spawn() */
5304 static unsigned int *sockflags, sockflagsize;
5307 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5308 * routines found in some versions of the CRTL can't deal with sockets.
5309 * We don't shim the other file open routines since a socket isn't
5310 * likely to be opened by a name.
5312 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5313 FILE *my_fdopen(int fd, const char *mode)
5315 FILE *fp = fdopen(fd, (char *) mode);
5318 unsigned int fdoff = fd / sizeof(unsigned int);
5319 struct stat sbuf; /* native stat; we don't need flex_stat */
5320 if (!sockflagsize || fdoff > sockflagsize) {
5321 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5322 else New (1324,sockflags,fdoff+2,unsigned int);
5323 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5324 sockflagsize = fdoff + 2;
5326 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5327 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5336 * Clear the corresponding bit when the (possibly) socket stream is closed.
5337 * There still a small hole: we miss an implicit close which might occur
5338 * via freopen(). >> Todo
5340 /*{{{ int my_fclose(FILE *fp)*/
5341 int my_fclose(FILE *fp) {
5343 unsigned int fd = fileno(fp);
5344 unsigned int fdoff = fd / sizeof(unsigned int);
5346 if (sockflagsize && fdoff <= sockflagsize)
5347 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5355 * A simple fwrite replacement which outputs itmsz*nitm chars without
5356 * introducing record boundaries every itmsz chars.
5357 * We are using fputs, which depends on a terminating null. We may
5358 * well be writing binary data, so we need to accommodate not only
5359 * data with nulls sprinkled in the middle but also data with no null
5362 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5364 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5366 register char *cp, *end, *cpd, *data;
5367 register unsigned int fd = fileno(dest);
5368 register unsigned int fdoff = fd / sizeof(unsigned int);
5370 int bufsize = itmsz * nitm + 1;
5372 if (fdoff < sockflagsize &&
5373 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5374 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5378 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5379 memcpy( data, src, itmsz*nitm );
5380 data[itmsz*nitm] = '\0';
5382 end = data + itmsz * nitm;
5383 retval = (int) nitm; /* on success return # items written */
5386 while (cpd <= end) {
5387 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5388 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5390 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5394 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5397 } /* end of my_fwrite() */
5400 /*{{{ int my_flush(FILE *fp)*/
5402 Perl_my_flush(pTHX_ FILE *fp)
5405 if ((res = fflush(fp)) == 0 && fp) {
5406 #ifdef VMS_DO_SOCKETS
5408 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5410 res = fsync(fileno(fp));
5413 * If the flush succeeded but set end-of-file, we need to clear
5414 * the error because our caller may check ferror(). BTW, this
5415 * probably means we just flushed an empty file.
5417 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5424 * Here are replacements for the following Unix routines in the VMS environment:
5425 * getpwuid Get information for a particular UIC or UID
5426 * getpwnam Get information for a named user
5427 * getpwent Get information for each user in the rights database
5428 * setpwent Reset search to the start of the rights database
5429 * endpwent Finish searching for users in the rights database
5431 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5432 * (defined in pwd.h), which contains the following fields:-
5434 * char *pw_name; Username (in lower case)
5435 * char *pw_passwd; Hashed password
5436 * unsigned int pw_uid; UIC
5437 * unsigned int pw_gid; UIC group number
5438 * char *pw_unixdir; Default device/directory (VMS-style)
5439 * char *pw_gecos; Owner name
5440 * char *pw_dir; Default device/directory (Unix-style)
5441 * char *pw_shell; Default CLI name (eg. DCL)
5443 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5445 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5446 * not the UIC member number (eg. what's returned by getuid()),
5447 * getpwuid() can accept either as input (if uid is specified, the caller's
5448 * UIC group is used), though it won't recognise gid=0.
5450 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5451 * information about other users in your group or in other groups, respectively.
5452 * If the required privilege is not available, then these routines fill only
5453 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5456 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5459 /* sizes of various UAF record fields */
5460 #define UAI$S_USERNAME 12
5461 #define UAI$S_IDENT 31
5462 #define UAI$S_OWNER 31
5463 #define UAI$S_DEFDEV 31
5464 #define UAI$S_DEFDIR 63
5465 #define UAI$S_DEFCLI 31
5468 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5469 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5470 (uic).uic$v_group != UIC$K_WILD_GROUP)
5472 static char __empty[]= "";
5473 static struct passwd __passwd_empty=
5474 {(char *) __empty, (char *) __empty, 0, 0,
5475 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5476 static int contxt= 0;
5477 static struct passwd __pwdcache;
5478 static char __pw_namecache[UAI$S_IDENT+1];
5481 * This routine does most of the work extracting the user information.
5483 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5486 unsigned char length;
5487 char pw_gecos[UAI$S_OWNER+1];
5489 static union uicdef uic;
5491 unsigned char length;
5492 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5495 unsigned char length;
5496 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5499 unsigned char length;
5500 char pw_shell[UAI$S_DEFCLI+1];
5502 static char pw_passwd[UAI$S_PWD+1];
5504 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5505 struct dsc$descriptor_s name_desc;
5506 unsigned long int sts;
5508 static struct itmlst_3 itmlst[]= {
5509 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5510 {sizeof(uic), UAI$_UIC, &uic, &luic},
5511 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5512 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5513 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5514 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5515 {0, 0, NULL, NULL}};
5517 name_desc.dsc$w_length= strlen(name);
5518 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5519 name_desc.dsc$b_class= DSC$K_CLASS_S;
5520 name_desc.dsc$a_pointer= (char *) name;
5522 /* Note that sys$getuai returns many fields as counted strings. */
5523 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5524 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5525 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5527 else { _ckvmssts(sts); }
5528 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5530 if ((int) owner.length < lowner) lowner= (int) owner.length;
5531 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5532 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5533 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5534 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5535 owner.pw_gecos[lowner]= '\0';
5536 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5537 defcli.pw_shell[ldefcli]= '\0';
5538 if (valid_uic(uic)) {
5539 pwd->pw_uid= uic.uic$l_uic;
5540 pwd->pw_gid= uic.uic$v_group;
5543 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5544 pwd->pw_passwd= pw_passwd;
5545 pwd->pw_gecos= owner.pw_gecos;
5546 pwd->pw_dir= defdev.pw_dir;
5547 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5548 pwd->pw_shell= defcli.pw_shell;
5549 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5551 ldir= strlen(pwd->pw_unixdir) - 1;
5552 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5555 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5556 __mystrtolower(pwd->pw_unixdir);
5561 * Get information for a named user.
5563 /*{{{struct passwd *getpwnam(char *name)*/
5564 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5566 struct dsc$descriptor_s name_desc;
5568 unsigned long int status, sts;
5570 __pwdcache = __passwd_empty;
5571 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5572 /* We still may be able to determine pw_uid and pw_gid */
5573 name_desc.dsc$w_length= strlen(name);
5574 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5575 name_desc.dsc$b_class= DSC$K_CLASS_S;
5576 name_desc.dsc$a_pointer= (char *) name;
5577 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5578 __pwdcache.pw_uid= uic.uic$l_uic;
5579 __pwdcache.pw_gid= uic.uic$v_group;
5582 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5583 set_vaxc_errno(sts);
5584 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5587 else { _ckvmssts(sts); }
5590 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5591 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5592 __pwdcache.pw_name= __pw_namecache;
5594 } /* end of my_getpwnam() */
5598 * Get information for a particular UIC or UID.
5599 * Called by my_getpwent with uid=-1 to list all users.
5601 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5602 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5604 const $DESCRIPTOR(name_desc,__pw_namecache);
5605 unsigned short lname;
5607 unsigned long int status;
5609 if (uid == (unsigned int) -1) {
5611 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5612 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5613 set_vaxc_errno(status);
5614 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5618 else { _ckvmssts(status); }
5619 } while (!valid_uic (uic));
5623 if (!uic.uic$v_group)
5624 uic.uic$v_group= PerlProc_getgid();
5626 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5627 else status = SS$_IVIDENT;
5628 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5629 status == RMS$_PRV) {
5630 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5633 else { _ckvmssts(status); }
5635 __pw_namecache[lname]= '\0';
5636 __mystrtolower(__pw_namecache);
5638 __pwdcache = __passwd_empty;
5639 __pwdcache.pw_name = __pw_namecache;
5641 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5642 The identifier's value is usually the UIC, but it doesn't have to be,
5643 so if we can, we let fillpasswd update this. */
5644 __pwdcache.pw_uid = uic.uic$l_uic;
5645 __pwdcache.pw_gid = uic.uic$v_group;
5647 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5650 } /* end of my_getpwuid() */
5654 * Get information for next user.
5656 /*{{{struct passwd *my_getpwent()*/
5657 struct passwd *Perl_my_getpwent(pTHX)
5659 return (my_getpwuid((unsigned int) -1));
5664 * Finish searching rights database for users.
5666 /*{{{void my_endpwent()*/
5667 void Perl_my_endpwent(pTHX)
5670 _ckvmssts(sys$finish_rdb(&contxt));
5676 #ifdef HOMEGROWN_POSIX_SIGNALS
5677 /* Signal handling routines, pulled into the core from POSIX.xs.
5679 * We need these for threads, so they've been rolled into the core,
5680 * rather than left in POSIX.xs.
5682 * (DRS, Oct 23, 1997)
5685 /* sigset_t is atomic under VMS, so these routines are easy */
5686 /*{{{int my_sigemptyset(sigset_t *) */
5687 int my_sigemptyset(sigset_t *set) {
5688 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5694 /*{{{int my_sigfillset(sigset_t *)*/
5695 int my_sigfillset(sigset_t *set) {
5697 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5698 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5704 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5705 int my_sigaddset(sigset_t *set, int sig) {
5706 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5707 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5708 *set |= (1 << (sig - 1));
5714 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5715 int my_sigdelset(sigset_t *set, int sig) {
5716 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5717 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5718 *set &= ~(1 << (sig - 1));
5724 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5725 int my_sigismember(sigset_t *set, int sig) {
5726 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5727 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5728 return *set & (1 << (sig - 1));
5733 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5734 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5737 /* If set and oset are both null, then things are badly wrong. Bail out. */
5738 if ((oset == NULL) && (set == NULL)) {
5739 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5743 /* If set's null, then we're just handling a fetch. */
5745 tempmask = sigblock(0);
5750 tempmask = sigsetmask(*set);
5753 tempmask = sigblock(*set);
5756 tempmask = sigblock(0);
5757 sigsetmask(*oset & ~tempmask);
5760 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5765 /* Did they pass us an oset? If so, stick our holding mask into it */
5772 #endif /* HOMEGROWN_POSIX_SIGNALS */
5775 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5776 * my_utime(), and flex_stat(), all of which operate on UTC unless
5777 * VMSISH_TIMES is true.
5779 /* method used to handle UTC conversions:
5780 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5782 static int gmtime_emulation_type;
5783 /* number of secs to add to UTC POSIX-style time to get local time */
5784 static long int utc_offset_secs;
5786 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5787 * in vmsish.h. #undef them here so we can call the CRTL routines
5796 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5797 * qualifier with the extern prefix pragma. This provisional
5798 * hack circumvents this prefix pragma problem in previous
5801 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5802 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5803 # pragma __extern_prefix save
5804 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5805 # define gmtime decc$__utctz_gmtime
5806 # define localtime decc$__utctz_localtime
5807 # define time decc$__utc_time
5808 # pragma __extern_prefix restore
5810 struct tm *gmtime(), *localtime();
5816 static time_t toutc_dst(time_t loc) {
5819 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5820 loc -= utc_offset_secs;
5821 if (rsltmp->tm_isdst) loc -= 3600;
5824 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5825 ((gmtime_emulation_type || my_time(NULL)), \
5826 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5827 ((secs) - utc_offset_secs))))
5829 static time_t toloc_dst(time_t utc) {
5832 utc += utc_offset_secs;
5833 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5834 if (rsltmp->tm_isdst) utc += 3600;
5837 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5838 ((gmtime_emulation_type || my_time(NULL)), \
5839 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5840 ((secs) + utc_offset_secs))))
5842 #ifndef RTL_USES_UTC
5845 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5846 DST starts on 1st sun of april at 02:00 std time
5847 ends on last sun of october at 02:00 dst time
5848 see the UCX management command reference, SET CONFIG TIMEZONE
5849 for formatting info.
5851 No, it's not as general as it should be, but then again, NOTHING
5852 will handle UK times in a sensible way.
5857 parse the DST start/end info:
5858 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5862 tz_parse_startend(char *s, struct tm *w, int *past)
5864 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5865 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5870 if (!past) return 0;
5873 if (w->tm_year % 4 == 0) ly = 1;
5874 if (w->tm_year % 100 == 0) ly = 0;
5875 if (w->tm_year+1900 % 400 == 0) ly = 1;
5878 dozjd = isdigit(*s);
5879 if (*s == 'J' || *s == 'j' || dozjd) {
5880 if (!dozjd && !isdigit(*++s)) return 0;
5883 d = d*10 + *s++ - '0';
5885 d = d*10 + *s++ - '0';
5888 if (d == 0) return 0;
5889 if (d > 366) return 0;
5891 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5894 } else if (*s == 'M' || *s == 'm') {
5895 if (!isdigit(*++s)) return 0;
5897 if (isdigit(*s)) m = 10*m + *s++ - '0';
5898 if (*s != '.') return 0;
5899 if (!isdigit(*++s)) return 0;
5901 if (n < 1 || n > 5) return 0;
5902 if (*s != '.') return 0;
5903 if (!isdigit(*++s)) return 0;
5905 if (d > 6) return 0;
5909 if (!isdigit(*++s)) return 0;
5911 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5913 if (!isdigit(*++s)) return 0;
5915 if (isdigit(*s)) min = 10*min + *s++ - '0';
5917 if (!isdigit(*++s)) return 0;
5919 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5929 if (w->tm_yday < d) goto before;
5930 if (w->tm_yday > d) goto after;
5932 if (w->tm_mon+1 < m) goto before;
5933 if (w->tm_mon+1 > m) goto after;
5935 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5936 k = d - j; /* mday of first d */
5938 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5939 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5940 if (w->tm_mday < k) goto before;
5941 if (w->tm_mday > k) goto after;
5944 if (w->tm_hour < hour) goto before;
5945 if (w->tm_hour > hour) goto after;
5946 if (w->tm_min < min) goto before;
5947 if (w->tm_min > min) goto after;
5948 if (w->tm_sec < sec) goto before;
5962 /* parse the offset: (+|-)hh[:mm[:ss]] */
5965 tz_parse_offset(char *s, int *offset)
5967 int hour = 0, min = 0, sec = 0;
5970 if (!offset) return 0;
5972 if (*s == '-') {neg++; s++;}
5974 if (!isdigit(*s)) return 0;
5976 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5977 if (hour > 24) return 0;
5979 if (!isdigit(*++s)) return 0;
5981 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5982 if (min > 59) return 0;
5984 if (!isdigit(*++s)) return 0;
5986 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5987 if (sec > 59) return 0;
5991 *offset = (hour*60+min)*60 + sec;
5992 if (neg) *offset = -*offset;
5997 input time is w, whatever type of time the CRTL localtime() uses.
5998 sets dst, the zone, and the gmtoff (seconds)
6000 caches the value of TZ and UCX$TZ env variables; note that
6001 my_setenv looks for these and sets a flag if they're changed
6004 We have to watch out for the "australian" case (dst starts in
6005 october, ends in april)...flagged by "reverse" and checked by
6006 scanning through the months of the previous year.
6011 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6016 char *dstzone, *tz, *s_start, *s_end;
6017 int std_off, dst_off, isdst;
6018 int y, dststart, dstend;
6019 static char envtz[1025]; /* longer than any logical, symbol, ... */
6020 static char ucxtz[1025];
6021 static char reversed = 0;
6027 reversed = -1; /* flag need to check */
6028 envtz[0] = ucxtz[0] = '\0';
6029 tz = my_getenv("TZ",0);
6030 if (tz) strcpy(envtz, tz);
6031 tz = my_getenv("UCX$TZ",0);
6032 if (tz) strcpy(ucxtz, tz);
6033 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6036 if (!*tz) tz = ucxtz;
6039 while (isalpha(*s)) s++;
6040 s = tz_parse_offset(s, &std_off);
6042 if (!*s) { /* no DST, hurray we're done! */
6048 while (isalpha(*s)) s++;
6049 s2 = tz_parse_offset(s, &dst_off);
6053 dst_off = std_off - 3600;
6056 if (!*s) { /* default dst start/end?? */
6057 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6058 s = strchr(ucxtz,',');
6060 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6062 if (*s != ',') return 0;
6065 when = _toutc(when); /* convert to utc */
6066 when = when - std_off; /* convert to pseudolocal time*/
6068 w2 = localtime(&when);
6071 s = tz_parse_startend(s_start,w2,&dststart);
6073 if (*s != ',') return 0;
6076 when = _toutc(when); /* convert to utc */
6077 when = when - dst_off; /* convert to pseudolocal time*/
6078 w2 = localtime(&when);
6079 if (w2->tm_year != y) { /* spans a year, just check one time */
6080 when += dst_off - std_off;
6081 w2 = localtime(&when);
6084 s = tz_parse_startend(s_end,w2,&dstend);
6087 if (reversed == -1) { /* need to check if start later than end */
6091 if (when < 2*365*86400) {
6092 when += 2*365*86400;
6096 w2 =localtime(&when);
6097 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6099 for (j = 0; j < 12; j++) {
6100 w2 =localtime(&when);
6101 (void) tz_parse_startend(s_start,w2,&ds);
6102 (void) tz_parse_startend(s_end,w2,&de);
6103 if (ds != de) break;
6107 if (de && !ds) reversed = 1;
6110 isdst = dststart && !dstend;
6111 if (reversed) isdst = dststart || !dstend;
6114 if (dst) *dst = isdst;
6115 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6116 if (isdst) tz = dstzone;
6118 while(isalpha(*tz)) *zone++ = *tz++;
6124 #endif /* !RTL_USES_UTC */
6126 /* my_time(), my_localtime(), my_gmtime()
6127 * By default traffic in UTC time values, using CRTL gmtime() or
6128 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6129 * Note: We need to use these functions even when the CRTL has working
6130 * UTC support, since they also handle C<use vmsish qw(times);>
6132 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6133 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6136 /*{{{time_t my_time(time_t *timep)*/
6137 time_t Perl_my_time(pTHX_ time_t *timep)
6142 if (gmtime_emulation_type == 0) {
6144 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6145 /* results of calls to gmtime() and localtime() */
6146 /* for same &base */
6148 gmtime_emulation_type++;
6149 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6150 char off[LNM$C_NAMLENGTH+1];;
6152 gmtime_emulation_type++;
6153 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6154 gmtime_emulation_type++;
6155 utc_offset_secs = 0;
6156 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6158 else { utc_offset_secs = atol(off); }
6160 else { /* We've got a working gmtime() */
6161 struct tm gmt, local;
6164 tm_p = localtime(&base);
6166 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6167 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6168 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6169 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6175 # ifdef RTL_USES_UTC
6176 if (VMSISH_TIME) when = _toloc(when);
6178 if (!VMSISH_TIME) when = _toutc(when);
6181 if (timep != NULL) *timep = when;
6184 } /* end of my_time() */
6188 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6190 Perl_my_gmtime(pTHX_ const time_t *timep)
6196 if (timep == NULL) {
6197 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6200 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6204 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6206 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6207 return gmtime(&when);
6209 /* CRTL localtime() wants local time as input, so does no tz correction */
6210 rsltmp = localtime(&when);
6211 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6214 } /* end of my_gmtime() */
6218 /*{{{struct tm *my_localtime(const time_t *timep)*/
6220 Perl_my_localtime(pTHX_ const time_t *timep)
6222 time_t when, whenutc;
6226 if (timep == NULL) {
6227 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6230 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6231 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6234 # ifdef RTL_USES_UTC
6236 if (VMSISH_TIME) when = _toutc(when);
6238 /* CRTL localtime() wants UTC as input, does tz correction itself */
6239 return localtime(&when);
6241 # else /* !RTL_USES_UTC */
6244 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6245 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6248 #ifndef RTL_USES_UTC
6249 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6250 when = whenutc - offset; /* pseudolocal time*/
6253 /* CRTL localtime() wants local time as input, so does no tz correction */
6254 rsltmp = localtime(&when);
6255 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6259 } /* end of my_localtime() */
6262 /* Reset definitions for later calls */
6263 #define gmtime(t) my_gmtime(t)
6264 #define localtime(t) my_localtime(t)
6265 #define time(t) my_time(t)
6268 /* my_utime - update modification time of a file
6269 * calling sequence is identical to POSIX utime(), but under
6270 * VMS only the modification time is changed; ODS-2 does not
6271 * maintain access times. Restrictions differ from the POSIX
6272 * definition in that the time can be changed as long as the
6273 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6274 * no separate checks are made to insure that the caller is the
6275 * owner of the file or has special privs enabled.
6276 * Code here is based on Joe Meadows' FILE utility.
6279 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6280 * to VMS epoch (01-JAN-1858 00:00:00.00)
6281 * in 100 ns intervals.
6283 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6285 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6286 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6289 long int bintime[2], len = 2, lowbit, unixtime,
6290 secscale = 10000000; /* seconds --> 100 ns intervals */
6291 unsigned long int chan, iosb[2], retsts;
6292 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6293 struct FAB myfab = cc$rms_fab;
6294 struct NAM mynam = cc$rms_nam;
6295 #if defined (__DECC) && defined (__VAX)
6296 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6297 * at least through VMS V6.1, which causes a type-conversion warning.
6299 # pragma message save
6300 # pragma message disable cvtdiftypes
6302 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6303 struct fibdef myfib;
6304 #if defined (__DECC) && defined (__VAX)
6305 /* This should be right after the declaration of myatr, but due
6306 * to a bug in VAX DEC C, this takes effect a statement early.
6308 # pragma message restore
6310 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6311 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6312 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6314 if (file == NULL || *file == '\0') {
6316 set_vaxc_errno(LIB$_INVARG);
6319 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6321 if (utimes != NULL) {
6322 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6323 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6324 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6325 * as input, we force the sign bit to be clear by shifting unixtime right
6326 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6328 lowbit = (utimes->modtime & 1) ? secscale : 0;
6329 unixtime = (long int) utimes->modtime;
6331 /* If input was UTC; convert to local for sys svc */
6332 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6334 unixtime >>= 1; secscale <<= 1;
6335 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6336 if (!(retsts & 1)) {
6338 set_vaxc_errno(retsts);
6341 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6342 if (!(retsts & 1)) {
6344 set_vaxc_errno(retsts);
6349 /* Just get the current time in VMS format directly */
6350 retsts = sys$gettim(bintime);
6351 if (!(retsts & 1)) {
6353 set_vaxc_errno(retsts);
6358 myfab.fab$l_fna = vmsspec;
6359 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6360 myfab.fab$l_nam = &mynam;
6361 mynam.nam$l_esa = esa;
6362 mynam.nam$b_ess = (unsigned char) sizeof esa;
6363 mynam.nam$l_rsa = rsa;
6364 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6366 /* Look for the file to be affected, letting RMS parse the file
6367 * specification for us as well. I have set errno using only
6368 * values documented in the utime() man page for VMS POSIX.
6370 retsts = sys$parse(&myfab,0,0);
6371 if (!(retsts & 1)) {
6372 set_vaxc_errno(retsts);
6373 if (retsts == RMS$_PRV) set_errno(EACCES);
6374 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6375 else set_errno(EVMSERR);
6378 retsts = sys$search(&myfab,0,0);
6379 if (!(retsts & 1)) {
6380 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6381 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6382 set_vaxc_errno(retsts);
6383 if (retsts == RMS$_PRV) set_errno(EACCES);
6384 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6385 else set_errno(EVMSERR);
6389 devdsc.dsc$w_length = mynam.nam$b_dev;
6390 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6392 retsts = sys$assign(&devdsc,&chan,0,0);
6393 if (!(retsts & 1)) {
6394 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6395 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6396 set_vaxc_errno(retsts);
6397 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6398 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6399 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6400 else set_errno(EVMSERR);
6404 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6405 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6407 memset((void *) &myfib, 0, sizeof myfib);
6408 #if defined(__DECC) || defined(__DECCXX)
6409 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6410 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6411 /* This prevents the revision time of the file being reset to the current
6412 * time as a result of our IO$_MODIFY $QIO. */
6413 myfib.fib$l_acctl = FIB$M_NORECORD;
6415 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6416 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6417 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6419 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6420 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6421 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6422 _ckvmssts(sys$dassgn(chan));
6423 if (retsts & 1) retsts = iosb[0];
6424 if (!(retsts & 1)) {
6425 set_vaxc_errno(retsts);
6426 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6427 else set_errno(EVMSERR);
6432 } /* end of my_utime() */
6436 * flex_stat, flex_fstat
6437 * basic stat, but gets it right when asked to stat
6438 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6441 /* encode_dev packs a VMS device name string into an integer to allow
6442 * simple comparisons. This can be used, for example, to check whether two
6443 * files are located on the same device, by comparing their encoded device
6444 * names. Even a string comparison would not do, because stat() reuses the
6445 * device name buffer for each call; so without encode_dev, it would be
6446 * necessary to save the buffer and use strcmp (this would mean a number of
6447 * changes to the standard Perl code, to say nothing of what a Perl script
6450 * The device lock id, if it exists, should be unique (unless perhaps compared
6451 * with lock ids transferred from other nodes). We have a lock id if the disk is
6452 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6453 * device names. Thus we use the lock id in preference, and only if that isn't
6454 * available, do we try to pack the device name into an integer (flagged by
6455 * the sign bit (LOCKID_MASK) being set).
6457 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6458 * name and its encoded form, but it seems very unlikely that we will find
6459 * two files on different disks that share the same encoded device names,
6460 * and even more remote that they will share the same file id (if the test
6461 * is to check for the same file).
6463 * A better method might be to use sys$device_scan on the first call, and to
6464 * search for the device, returning an index into the cached array.
6465 * The number returned would be more intelligable.
6466 * This is probably not worth it, and anyway would take quite a bit longer
6467 * on the first call.
6469 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6470 static mydev_t encode_dev (pTHX_ const char *dev)
6473 unsigned long int f;
6478 if (!dev || !dev[0]) return 0;
6482 struct dsc$descriptor_s dev_desc;
6483 unsigned long int status, lockid, item = DVI$_LOCKID;
6485 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6486 can try that first. */
6487 dev_desc.dsc$w_length = strlen (dev);
6488 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6489 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6490 dev_desc.dsc$a_pointer = (char *) dev;
6491 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6492 if (lockid) return (lockid & ~LOCKID_MASK);
6496 /* Otherwise we try to encode the device name */
6500 for (q = dev + strlen(dev); q--; q >= dev) {
6503 else if (isalpha (toupper (*q)))
6504 c= toupper (*q) - 'A' + (char)10;
6506 continue; /* Skip '$'s */
6508 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6510 enc += f * (unsigned long int) c;
6512 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6514 } /* end of encode_dev() */
6516 static char namecache[NAM$C_MAXRSS+1];
6519 is_null_device(name)
6522 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6523 The underscore prefix, controller letter, and unit number are
6524 independently optional; for our purposes, the colon punctuation
6525 is not. The colon can be trailed by optional directory and/or
6526 filename, but two consecutive colons indicates a nodename rather
6527 than a device. [pr] */
6528 if (*name == '_') ++name;
6529 if (tolower(*name++) != 'n') return 0;
6530 if (tolower(*name++) != 'l') return 0;
6531 if (tolower(*name) == 'a') ++name;
6532 if (*name == '0') ++name;
6533 return (*name++ == ':') && (*name != ':');
6536 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6537 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6538 * subset of the applicable information.
6541 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6543 char fname_phdev[NAM$C_MAXRSS+1];
6544 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6546 char fname[NAM$C_MAXRSS+1];
6547 unsigned long int retsts;
6548 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6549 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6551 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6552 device name on successive calls */
6553 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6554 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6555 namdsc.dsc$a_pointer = fname;
6556 namdsc.dsc$w_length = sizeof fname - 1;
6558 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6559 &namdsc,&namdsc.dsc$w_length,0,0);
6561 fname[namdsc.dsc$w_length] = '\0';
6563 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6564 * but if someone has redefined that logical, Perl gets very lost. Since
6565 * we have the physical device name from the stat buffer, just paste it on.
6567 strcpy( fname_phdev, statbufp->st_devnam );
6568 strcat( fname_phdev, strrchr(fname, ':') );
6570 return cando_by_name(bit,effective,fname_phdev);
6572 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6573 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6577 return FALSE; /* Should never get to here */
6579 } /* end of cando() */
6583 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6585 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6587 static char usrname[L_cuserid];
6588 static struct dsc$descriptor_s usrdsc =
6589 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6590 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6591 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6592 unsigned short int retlen, trnlnm_iter_count;
6593 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6594 union prvdef curprv;
6595 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6596 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6597 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6598 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6600 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6602 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6604 if (!fname || !*fname) return FALSE;
6605 /* Make sure we expand logical names, since sys$check_access doesn't */
6606 if (!strpbrk(fname,"/]>:")) {
6607 strcpy(fileified,fname);
6608 trnlnm_iter_count = 0;
6609 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6610 trnlnm_iter_count++;
6611 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6615 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6616 retlen = namdsc.dsc$w_length = strlen(vmsname);
6617 namdsc.dsc$a_pointer = vmsname;
6618 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6619 vmsname[retlen-1] == ':') {
6620 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6621 namdsc.dsc$w_length = strlen(fileified);
6622 namdsc.dsc$a_pointer = fileified;
6626 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6627 access = ARM$M_EXECUTE; break;
6628 case S_IRUSR: case S_IRGRP: case S_IROTH:
6629 access = ARM$M_READ; break;
6630 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6631 access = ARM$M_WRITE; break;
6632 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6633 access = ARM$M_DELETE; break;
6638 /* Before we call $check_access, create a user profile with the current
6639 * process privs since otherwise it just uses the default privs from the
6640 * UAF and might give false positives or negatives. This only works on
6641 * VMS versions v6.0 and later since that's when sys$create_user_profile
6645 /* get current process privs and username */
6646 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6649 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6651 /* find out the space required for the profile */
6652 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6653 &usrprodsc.dsc$w_length,0));
6655 /* allocate space for the profile and get it filled in */
6656 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6657 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6658 &usrprodsc.dsc$w_length,0));
6660 /* use the profile to check access to the file; free profile & analyze results */
6661 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6662 Safefree(usrprodsc.dsc$a_pointer);
6663 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6667 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6671 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6672 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6673 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6674 set_vaxc_errno(retsts);
6675 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6676 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6677 else set_errno(ENOENT);
6680 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6685 return FALSE; /* Should never get here */
6687 } /* end of cando_by_name() */
6691 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6693 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6695 if (!fstat(fd,(stat_t *) statbufp)) {
6696 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6697 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6698 # ifdef RTL_USES_UTC
6701 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6702 statbufp->st_atime = _toloc(statbufp->st_atime);
6703 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6708 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6712 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6713 statbufp->st_atime = _toutc(statbufp->st_atime);
6714 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6721 } /* end of flex_fstat() */
6724 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6726 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6728 char fileified[NAM$C_MAXRSS+1];
6729 char temp_fspec[NAM$C_MAXRSS+300];
6731 int saved_errno, saved_vaxc_errno;
6733 if (!fspec) return retval;
6734 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6735 strcpy(temp_fspec, fspec);
6736 if (statbufp == (Stat_t *) &PL_statcache)
6737 do_tovmsspec(temp_fspec,namecache,0);
6738 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6739 memset(statbufp,0,sizeof *statbufp);
6740 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6741 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6742 statbufp->st_uid = 0x00010001;
6743 statbufp->st_gid = 0x0001;
6744 time((time_t *)&statbufp->st_mtime);
6745 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6749 /* Try for a directory name first. If fspec contains a filename without
6750 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6751 * and sea:[wine.dark]water. exist, we prefer the directory here.
6752 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6753 * not sea:[wine.dark]., if the latter exists. If the intended target is
6754 * the file with null type, specify this by calling flex_stat() with
6755 * a '.' at the end of fspec.
6757 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6758 retval = stat(fileified,(stat_t *) statbufp);
6759 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6760 strcpy(namecache,fileified);
6762 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6764 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6765 # ifdef RTL_USES_UTC
6768 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6769 statbufp->st_atime = _toloc(statbufp->st_atime);
6770 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6775 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6779 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6780 statbufp->st_atime = _toutc(statbufp->st_atime);
6781 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6785 /* If we were successful, leave errno where we found it */
6786 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6789 } /* end of flex_stat() */
6793 /*{{{char *my_getlogin()*/
6794 /* VMS cuserid == Unix getlogin, except calling sequence */
6798 static char user[L_cuserid];
6799 return cuserid(user);
6804 /* rmscopy - copy a file using VMS RMS routines
6806 * Copies contents and attributes of spec_in to spec_out, except owner
6807 * and protection information. Name and type of spec_in are used as
6808 * defaults for spec_out. The third parameter specifies whether rmscopy()
6809 * should try to propagate timestamps from the input file to the output file.
6810 * If it is less than 0, no timestamps are preserved. If it is 0, then
6811 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6812 * propagated to the output file at creation iff the output file specification
6813 * did not contain an explicit name or type, and the revision date is always
6814 * updated at the end of the copy operation. If it is greater than 0, then
6815 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6816 * other than the revision date should be propagated, and bit 1 indicates
6817 * that the revision date should be propagated.
6819 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6821 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6822 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6823 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6824 * as part of the Perl standard distribution under the terms of the
6825 * GNU General Public License or the Perl Artistic License. Copies
6826 * of each may be found in the Perl standard distribution.
6828 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6830 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6832 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6833 rsa[NAM$C_MAXRSS], ubf[32256];
6834 unsigned long int i, sts, sts2;
6835 struct FAB fab_in, fab_out;
6836 struct RAB rab_in, rab_out;
6838 struct XABDAT xabdat;
6839 struct XABFHC xabfhc;
6840 struct XABRDT xabrdt;
6841 struct XABSUM xabsum;
6843 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6844 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6845 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6849 fab_in = cc$rms_fab;
6850 fab_in.fab$l_fna = vmsin;
6851 fab_in.fab$b_fns = strlen(vmsin);
6852 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6853 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6854 fab_in.fab$l_fop = FAB$M_SQO;
6855 fab_in.fab$l_nam = &nam;
6856 fab_in.fab$l_xab = (void *) &xabdat;
6859 nam.nam$l_rsa = rsa;
6860 nam.nam$b_rss = sizeof(rsa);
6861 nam.nam$l_esa = esa;
6862 nam.nam$b_ess = sizeof (esa);
6863 nam.nam$b_esl = nam.nam$b_rsl = 0;
6865 xabdat = cc$rms_xabdat; /* To get creation date */
6866 xabdat.xab$l_nxt = (void *) &xabfhc;
6868 xabfhc = cc$rms_xabfhc; /* To get record length */
6869 xabfhc.xab$l_nxt = (void *) &xabsum;
6871 xabsum = cc$rms_xabsum; /* To get key and area information */
6873 if (!((sts = sys$open(&fab_in)) & 1)) {
6874 set_vaxc_errno(sts);
6876 case RMS$_FNF: case RMS$_DNF:
6877 set_errno(ENOENT); break;
6879 set_errno(ENOTDIR); break;
6881 set_errno(ENODEV); break;
6883 set_errno(EINVAL); break;
6885 set_errno(EACCES); break;
6893 fab_out.fab$w_ifi = 0;
6894 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6895 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6896 fab_out.fab$l_fop = FAB$M_SQO;
6897 fab_out.fab$l_fna = vmsout;
6898 fab_out.fab$b_fns = strlen(vmsout);
6899 fab_out.fab$l_dna = nam.nam$l_name;
6900 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6902 if (preserve_dates == 0) { /* Act like DCL COPY */
6903 nam.nam$b_nop = NAM$M_SYNCHK;
6904 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6905 if (!((sts = sys$parse(&fab_out)) & 1)) {
6906 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6907 set_vaxc_errno(sts);
6910 fab_out.fab$l_xab = (void *) &xabdat;
6911 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6913 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6914 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6915 preserve_dates =0; /* bitmask from this point forward */
6917 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6918 if (!((sts = sys$create(&fab_out)) & 1)) {
6919 set_vaxc_errno(sts);
6922 set_errno(ENOENT); break;
6924 set_errno(ENOTDIR); break;
6926 set_errno(ENODEV); break;
6928 set_errno(EINVAL); break;
6930 set_errno(EACCES); break;
6936 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6937 if (preserve_dates & 2) {
6938 /* sys$close() will process xabrdt, not xabdat */
6939 xabrdt = cc$rms_xabrdt;
6941 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6943 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6944 * is unsigned long[2], while DECC & VAXC use a struct */
6945 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6947 fab_out.fab$l_xab = (void *) &xabrdt;
6950 rab_in = cc$rms_rab;
6951 rab_in.rab$l_fab = &fab_in;
6952 rab_in.rab$l_rop = RAB$M_BIO;
6953 rab_in.rab$l_ubf = ubf;
6954 rab_in.rab$w_usz = sizeof ubf;
6955 if (!((sts = sys$connect(&rab_in)) & 1)) {
6956 sys$close(&fab_in); sys$close(&fab_out);
6957 set_errno(EVMSERR); set_vaxc_errno(sts);
6961 rab_out = cc$rms_rab;
6962 rab_out.rab$l_fab = &fab_out;
6963 rab_out.rab$l_rbf = ubf;
6964 if (!((sts = sys$connect(&rab_out)) & 1)) {
6965 sys$close(&fab_in); sys$close(&fab_out);
6966 set_errno(EVMSERR); set_vaxc_errno(sts);
6970 while ((sts = sys$read(&rab_in))) { /* always true */
6971 if (sts == RMS$_EOF) break;
6972 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6973 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6974 sys$close(&fab_in); sys$close(&fab_out);
6975 set_errno(EVMSERR); set_vaxc_errno(sts);
6980 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6981 sys$close(&fab_in); sys$close(&fab_out);
6982 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6984 set_errno(EVMSERR); set_vaxc_errno(sts);
6990 } /* end of rmscopy() */
6994 /*** The following glue provides 'hooks' to make some of the routines
6995 * from this file available from Perl. These routines are sufficiently
6996 * basic, and are required sufficiently early in the build process,
6997 * that's it's nice to have them available to miniperl as well as the
6998 * full Perl, so they're set up here instead of in an extension. The
6999 * Perl code which handles importation of these names into a given
7000 * package lives in [.VMS]Filespec.pm in @INC.
7004 rmsexpand_fromperl(pTHX_ CV *cv)
7007 char *fspec, *defspec = NULL, *rslt;
7010 if (!items || items > 2)
7011 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
7012 fspec = SvPV(ST(0),n_a);
7013 if (!fspec || !*fspec) XSRETURN_UNDEF;
7014 if (items == 2) defspec = SvPV(ST(1),n_a);
7016 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
7017 ST(0) = sv_newmortal();
7018 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
7023 vmsify_fromperl(pTHX_ CV *cv)
7029 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7030 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7031 ST(0) = sv_newmortal();
7032 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7037 unixify_fromperl(pTHX_ CV *cv)
7043 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7044 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7045 ST(0) = sv_newmortal();
7046 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7051 fileify_fromperl(pTHX_ CV *cv)
7057 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7058 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7059 ST(0) = sv_newmortal();
7060 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7065 pathify_fromperl(pTHX_ CV *cv)
7071 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7072 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7073 ST(0) = sv_newmortal();
7074 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7079 vmspath_fromperl(pTHX_ CV *cv)
7085 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7086 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7087 ST(0) = sv_newmortal();
7088 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7093 unixpath_fromperl(pTHX_ CV *cv)
7099 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7100 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7101 ST(0) = sv_newmortal();
7102 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7107 candelete_fromperl(pTHX_ CV *cv)
7110 char fspec[NAM$C_MAXRSS+1], *fsp;
7115 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7117 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7118 if (SvTYPE(mysv) == SVt_PVGV) {
7119 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7120 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7127 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7128 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7134 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7139 rmscopy_fromperl(pTHX_ CV *cv)
7142 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7144 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7145 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7146 unsigned long int sts;
7151 if (items < 2 || items > 3)
7152 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7154 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7155 if (SvTYPE(mysv) == SVt_PVGV) {
7156 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7157 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7164 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7165 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7170 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7171 if (SvTYPE(mysv) == SVt_PVGV) {
7172 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7173 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7180 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7181 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7186 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7188 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7194 mod2fname(pTHX_ CV *cv)
7197 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7198 workbuff[NAM$C_MAXRSS*1 + 1];
7199 int total_namelen = 3, counter, num_entries;
7200 /* ODS-5 ups this, but we want to be consistent, so... */
7201 int max_name_len = 39;
7202 AV *in_array = (AV *)SvRV(ST(0));
7204 num_entries = av_len(in_array);
7206 /* All the names start with PL_. */
7207 strcpy(ultimate_name, "PL_");
7209 /* Clean up our working buffer */
7210 Zero(work_name, sizeof(work_name), char);
7212 /* Run through the entries and build up a working name */
7213 for(counter = 0; counter <= num_entries; counter++) {
7214 /* If it's not the first name then tack on a __ */
7216 strcat(work_name, "__");
7218 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7222 /* Check to see if we actually have to bother...*/
7223 if (strlen(work_name) + 3 <= max_name_len) {
7224 strcat(ultimate_name, work_name);
7226 /* It's too darned big, so we need to go strip. We use the same */
7227 /* algorithm as xsubpp does. First, strip out doubled __ */
7228 char *source, *dest, last;
7231 for (source = work_name; *source; source++) {
7232 if (last == *source && last == '_') {
7238 /* Go put it back */
7239 strcpy(work_name, workbuff);
7240 /* Is it still too big? */
7241 if (strlen(work_name) + 3 > max_name_len) {
7242 /* Strip duplicate letters */
7245 for (source = work_name; *source; source++) {
7246 if (last == toupper(*source)) {
7250 last = toupper(*source);
7252 strcpy(work_name, workbuff);
7255 /* Is it *still* too big? */
7256 if (strlen(work_name) + 3 > max_name_len) {
7257 /* Too bad, we truncate */
7258 work_name[max_name_len - 2] = 0;
7260 strcat(ultimate_name, work_name);
7263 /* Okay, return it */
7264 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7269 hushexit_fromperl(pTHX_ CV *cv)
7274 VMSISH_HUSHED = SvTRUE(ST(0));
7276 ST(0) = boolSV(VMSISH_HUSHED);
7281 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7282 struct interp_intern *dst)
7284 memcpy(dst,src,sizeof(struct interp_intern));
7288 Perl_sys_intern_clear(pTHX)
7293 Perl_sys_intern_init(pTHX)
7295 unsigned int ix = RAND_MAX;
7301 MY_INV_RAND_MAX = 1./x;
7308 char* file = __FILE__;
7309 char temp_buff[512];
7310 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7311 no_translate_barewords = TRUE;
7313 no_translate_barewords = FALSE;
7316 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7317 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7318 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7319 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7320 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7321 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7322 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7323 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7324 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7325 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7326 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7328 store_pipelocs(aTHX); /* will redo any earlier attempts */