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
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
41 #include <str$routines.h>
46 /* Older versions of ssdef.h don't have these */
47 #ifndef SS$_INVFILFOROP
48 # define SS$_INVFILFOROP 3930
50 #ifndef SS$_NOSUCHOBJECT
51 # define SS$_NOSUCHOBJECT 2696
54 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
55 #define PERLIO_NOT_STDIO 0
57 /* Don't replace system definitions of vfork, getenv, and stat,
58 * code below needs to get to the underlying CRTL routines. */
59 #define DONT_MASK_RTL_CALLS
63 /* Anticipating future expansion in lexical warnings . . . */
65 # define WARN_INTERNAL WARN_MISC
68 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
69 # define RTL_USES_UTC 1
73 /* gcc's header files don't #define direct access macros
74 * corresponding to VAXC's variant structs */
76 # define uic$v_format uic$r_uic_form.uic$v_format
77 # define uic$v_group uic$r_uic_form.uic$v_group
78 # define uic$v_member uic$r_uic_form.uic$v_member
79 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
80 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
81 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
82 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
85 #if defined(NEED_AN_H_ERRNO)
90 unsigned short int buflen;
91 unsigned short int itmcode;
93 unsigned short int *retlen;
96 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
97 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
98 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
99 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
100 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
101 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
102 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
103 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
104 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
106 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
107 #define PERL_LNM_MAX_ALLOWED_INDEX 127
109 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
110 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
112 static char *__mystrtolower(char *str)
114 if (str) for (; *str; ++str) *str= tolower(*str);
118 static struct dsc$descriptor_s fildevdsc =
119 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
120 static struct dsc$descriptor_s crtlenvdsc =
121 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
122 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
123 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
124 static struct dsc$descriptor_s **env_tables = defenv;
125 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
127 /* True if we shouldn't treat barewords as logicals during directory */
129 static int no_translate_barewords;
132 static int tz_updated = 1;
135 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
137 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
138 struct dsc$descriptor_s **tabvec, unsigned long int flags)
140 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
141 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
142 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
143 unsigned char acmode;
144 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
146 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
147 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
149 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
150 #if defined(PERL_IMPLICIT_CONTEXT)
152 # if defined(USE_5005THREADS)
153 /* We jump through these hoops because we can be called at */
154 /* platform-specific initialization time, which is before anything is */
155 /* set up--we can't even do a plain dTHX since that relies on the */
156 /* interpreter structure to be initialized */
158 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
164 aTHX = PERL_GET_INTERP;
172 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
175 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
176 *cp2 = _toupper(*cp1);
177 if (cp1 - lnm > LNM$C_NAMLENGTH) {
178 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
182 lnmdsc.dsc$w_length = cp1 - lnm;
183 lnmdsc.dsc$a_pointer = uplnm;
184 uplnm[lnmdsc.dsc$w_length] = '\0';
185 secure = flags & PERL__TRNENV_SECURE;
186 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
187 if (!tabvec || !*tabvec) tabvec = env_tables;
189 for (curtab = 0; tabvec[curtab]; curtab++) {
190 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
191 if (!ivenv && !secure) {
196 Perl_warn(aTHX_ "Can't read CRTL environ\n");
199 retsts = SS$_NOLOGNAM;
200 for (i = 0; environ[i]; i++) {
201 if ((eq = strchr(environ[i],'=')) &&
202 !strncmp(environ[i],uplnm,eq - environ[i])) {
204 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
205 if (!eqvlen) continue;
210 if (retsts != SS$_NOLOGNAM) break;
213 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
214 !str$case_blind_compare(&tmpdsc,&clisym)) {
215 if (!ivsym && !secure) {
216 unsigned short int deflen = LNM$C_NAMLENGTH;
217 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
218 /* dynamic dsc to accomodate possible long value */
219 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
220 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
223 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
225 /* Special hack--we might be called before the interpreter's */
226 /* fully initialized, in which case either thr or PL_curcop */
227 /* might be bogus. We have to check, since ckWARN needs them */
228 /* both to be valid if running threaded */
229 #if defined(USE_5005THREADS)
230 if (thr && PL_curcop) {
232 if (ckWARN(WARN_MISC)) {
233 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
235 #if defined(USE_5005THREADS)
237 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
242 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
244 _ckvmssts(lib$sfree1_dd(&eqvdsc));
245 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
246 if (retsts == LIB$_NOSUCHSYM) continue;
251 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
252 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
253 if (retsts == SS$_NOLOGNAM) continue;
254 /* PPFs have a prefix */
257 *((int *)uplnm) == *((int *)"SYS$") &&
259 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
260 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
261 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
262 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
263 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
264 memcpy(eqv,eqv+4,eqvlen-4);
270 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
271 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
272 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
273 retsts == SS$_NOLOGNAM) {
274 set_errno(EINVAL); set_vaxc_errno(retsts);
276 else _ckvmssts(retsts);
278 } /* end of vmstrnenv */
281 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
282 /* Define as a function so we can access statics. */
283 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
285 return vmstrnenv(lnm,eqv,idx,fildev,
286 #ifdef SECURE_INTERNAL_GETENV
287 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
296 * Note: Uses Perl temp to store result so char * can be returned to
297 * caller; this pointer will be invalidated at next Perl statement
299 * We define this as a function rather than a macro in terms of my_getenv_len()
300 * so that it'll work when PL_curinterp is undefined (and we therefore can't
303 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
305 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
307 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
308 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
309 unsigned long int idx = 0;
310 int trnsuccess, success, secure, saverr, savvmserr;
313 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
314 /* Set up a temporary buffer for the return value; Perl will
315 * clean it up at the next statement transition */
316 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
317 if (!tmpsv) return NULL;
320 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
321 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
322 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
323 getcwd(eqv,LNM$C_NAMLENGTH);
327 if ((cp2 = strchr(lnm,';')) != NULL) {
329 uplnm[cp2-lnm] = '\0';
330 idx = strtoul(cp2+1,NULL,0);
333 /* Impose security constraints only if tainting */
335 /* Impose security constraints only if tainting */
336 secure = PL_curinterp ? PL_tainting : will_taint;
337 saverr = errno; savvmserr = vaxc$errno;
340 success = vmstrnenv(lnm,eqv,idx,
341 secure ? fildev : NULL,
342 #ifdef SECURE_INTERNAL_GETENV
343 secure ? PERL__TRNENV_SECURE : 0
348 /* Discard NOLOGNAM on internal calls since we're often looking
349 * for an optional name, and this "error" often shows up as the
350 * (bogus) exit status for a die() call later on. */
351 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
352 return success ? eqv : Nullch;
355 } /* end of my_getenv() */
359 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
361 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
363 char *buf, *cp1, *cp2;
364 unsigned long idx = 0;
365 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
366 int secure, saverr, savvmserr;
369 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
370 /* Set up a temporary buffer for the return value; Perl will
371 * clean it up at the next statement transition */
372 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
373 if (!tmpsv) return NULL;
376 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
377 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
378 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
379 getcwd(buf,LNM$C_NAMLENGTH);
384 if ((cp2 = strchr(lnm,';')) != NULL) {
387 idx = strtoul(cp2+1,NULL,0);
391 /* Impose security constraints only if tainting */
392 secure = PL_curinterp ? PL_tainting : will_taint;
393 saverr = errno; savvmserr = vaxc$errno;
396 *len = vmstrnenv(lnm,buf,idx,
397 secure ? fildev : NULL,
398 #ifdef SECURE_INTERNAL_GETENV
399 secure ? PERL__TRNENV_SECURE : 0
404 /* Discard NOLOGNAM on internal calls since we're often looking
405 * for an optional name, and this "error" often shows up as the
406 * (bogus) exit status for a die() call later on. */
407 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
408 return *len ? buf : Nullch;
411 } /* end of my_getenv_len() */
414 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
416 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
418 /*{{{ void prime_env_iter() */
421 /* Fill the %ENV associative array with all logical names we can
422 * find, in preparation for iterating over it.
425 static int primed = 0;
426 HV *seenhv = NULL, *envhv;
428 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
429 unsigned short int chan;
430 #ifndef CLI$M_TRUSTED
431 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
433 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
434 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
436 bool have_sym = FALSE, have_lnm = FALSE;
437 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
438 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
439 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
440 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
441 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
442 #if defined(PERL_IMPLICIT_CONTEXT)
445 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
446 static perl_mutex primenv_mutex;
447 MUTEX_INIT(&primenv_mutex);
450 #if defined(PERL_IMPLICIT_CONTEXT)
451 /* We jump through these hoops because we can be called at */
452 /* platform-specific initialization time, which is before anything is */
453 /* set up--we can't even do a plain dTHX since that relies on the */
454 /* interpreter structure to be initialized */
455 #if defined(USE_5005THREADS)
457 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
463 aTHX = PERL_GET_INTERP;
470 if (primed || !PL_envgv) return;
471 MUTEX_LOCK(&primenv_mutex);
472 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
473 envhv = GvHVn(PL_envgv);
474 /* Perform a dummy fetch as an lval to insure that the hash table is
475 * set up. Otherwise, the hv_store() will turn into a nullop. */
476 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
478 for (i = 0; env_tables[i]; i++) {
479 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
480 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
481 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
483 if (have_sym || have_lnm) {
484 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
485 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
486 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
487 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
490 for (i--; i >= 0; i--) {
491 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
494 for (j = 0; environ[j]; j++) {
495 if (!(start = strchr(environ[j],'='))) {
496 if (ckWARN(WARN_INTERNAL))
497 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
501 sv = newSVpv(start,0);
503 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
508 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
509 !str$case_blind_compare(&tmpdsc,&clisym)) {
510 strcpy(cmd,"Show Symbol/Global *");
511 cmddsc.dsc$w_length = 20;
512 if (env_tables[i]->dsc$w_length == 12 &&
513 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
514 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
515 flags = defflags | CLI$M_NOLOGNAM;
518 strcpy(cmd,"Show Logical *");
519 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
520 strcat(cmd," /Table=");
521 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
522 cmddsc.dsc$w_length = strlen(cmd);
524 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
525 flags = defflags | CLI$M_NOCLISYM;
528 /* Create a new subprocess to execute each command, to exclude the
529 * remote possibility that someone could subvert a mbx or file used
530 * to write multiple commands to a single subprocess.
533 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
534 0,&riseandshine,0,0,&clidsc,&clitabdsc);
535 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
536 defflags &= ~CLI$M_TRUSTED;
537 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
539 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
540 if (seenhv) SvREFCNT_dec(seenhv);
543 char *cp1, *cp2, *key;
544 unsigned long int sts, iosb[2], retlen, keylen;
547 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
548 if (sts & 1) sts = iosb[0] & 0xffff;
549 if (sts == SS$_ENDOFFILE) {
551 while (substs == 0) { sys$hiber(); wakect++;}
552 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
557 retlen = iosb[0] >> 16;
558 if (!retlen) continue; /* blank line */
560 if (iosb[1] != subpid) {
562 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
566 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
567 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
569 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
570 if (*cp1 == '(' || /* Logical name table name */
571 *cp1 == '=' /* Next eqv of searchlist */) continue;
572 if (*cp1 == '"') cp1++;
573 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
574 key = cp1; keylen = cp2 - cp1;
575 if (keylen && hv_exists(seenhv,key,keylen)) continue;
576 while (*cp2 && *cp2 != '=') cp2++;
577 while (*cp2 && *cp2 == '=') cp2++;
578 while (*cp2 && *cp2 == ' ') cp2++;
579 if (*cp2 == '"') { /* String translation; may embed "" */
580 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
581 cp2++; cp1--; /* Skip "" surrounding translation */
583 else { /* Numeric translation */
584 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
585 cp1--; /* stop on last non-space char */
587 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
588 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
591 PERL_HASH(hash,key,keylen);
592 sv = newSVpvn(cp2,cp1 - cp2 + 1);
594 hv_store(envhv,key,keylen,sv,hash);
595 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
597 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
598 /* get the PPFs for this process, not the subprocess */
599 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
600 char eqv[LNM$C_NAMLENGTH+1];
602 for (i = 0; ppfs[i]; i++) {
603 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
604 sv = newSVpv(eqv,trnlen);
606 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
611 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
612 if (buf) Safefree(buf);
613 if (seenhv) SvREFCNT_dec(seenhv);
614 MUTEX_UNLOCK(&primenv_mutex);
617 } /* end of prime_env_iter */
621 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
622 /* Define or delete an element in the same "environment" as
623 * vmstrnenv(). If an element is to be deleted, it's removed from
624 * the first place it's found. If it's to be set, it's set in the
625 * place designated by the first element of the table vector.
626 * Like setenv() returns 0 for success, non-zero on error.
629 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
631 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
632 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
633 unsigned long int retsts, usermode = PSL$C_USER;
634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
638 $DESCRIPTOR(local,"_LOCAL");
640 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
641 *cp2 = _toupper(*cp1);
642 if (cp1 - lnm > LNM$C_NAMLENGTH) {
643 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
647 lnmdsc.dsc$w_length = cp1 - lnm;
648 if (!tabvec || !*tabvec) tabvec = env_tables;
650 if (!eqv) { /* we're deleting n element */
651 for (curtab = 0; tabvec[curtab]; curtab++) {
652 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
654 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
655 if ((cp1 = strchr(environ[i],'=')) &&
656 !strncmp(environ[i],lnm,cp1 - environ[i])) {
658 return setenv(lnm,"",1) ? vaxc$errno : 0;
661 ivenv = 1; retsts = SS$_NOLOGNAM;
663 if (ckWARN(WARN_INTERNAL))
664 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
665 ivenv = 1; retsts = SS$_NOSUCHPGM;
671 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
672 !str$case_blind_compare(&tmpdsc,&clisym)) {
673 unsigned int symtype;
674 if (tabvec[curtab]->dsc$w_length == 12 &&
675 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
676 !str$case_blind_compare(&tmpdsc,&local))
677 symtype = LIB$K_CLI_LOCAL_SYM;
678 else symtype = LIB$K_CLI_GLOBAL_SYM;
679 retsts = lib$delete_symbol(&lnmdsc,&symtype);
680 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
681 if (retsts == LIB$_NOSUCHSYM) continue;
685 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
686 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
687 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
688 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
689 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
693 else { /* we're defining a value */
694 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
696 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
698 if (ckWARN(WARN_INTERNAL))
699 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
700 retsts = SS$_NOSUCHPGM;
704 eqvdsc.dsc$a_pointer = eqv;
705 eqvdsc.dsc$w_length = strlen(eqv);
706 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
707 !str$case_blind_compare(&tmpdsc,&clisym)) {
708 unsigned int symtype;
709 if (tabvec[0]->dsc$w_length == 12 &&
710 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
711 !str$case_blind_compare(&tmpdsc,&local))
712 symtype = LIB$K_CLI_LOCAL_SYM;
713 else symtype = LIB$K_CLI_GLOBAL_SYM;
714 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
717 if (!*eqv) eqvdsc.dsc$w_length = 1;
718 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
719 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
720 if (ckWARN(WARN_MISC)) {
721 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
724 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
730 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
731 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
732 set_errno(EVMSERR); break;
733 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
734 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
735 set_errno(EINVAL); break;
742 set_vaxc_errno(retsts);
743 return (int) retsts || 44; /* retsts should never be 0, but just in case */
746 /* We reset error values on success because Perl does an hv_fetch()
747 * before each hv_store(), and if the thing we're setting didn't
748 * previously exist, we've got a leftover error message. (Of course,
749 * this fails in the face of
750 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
751 * in that the error reported in $! isn't spurious,
752 * but it's right more often than not.)
754 set_errno(0); set_vaxc_errno(retsts);
758 } /* end of vmssetenv() */
761 /*{{{ void my_setenv(char *lnm, char *eqv)*/
762 /* This has to be a function since there's a prototype for it in proto.h */
764 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
767 int len = strlen(lnm);
771 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
772 if (!strcmp(uplnm,"DEFAULT")) {
773 if (eqv && *eqv) chdir(eqv);
778 if (len == 6 || len == 2) {
781 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
783 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
784 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
788 (void) vmssetenv(lnm,eqv,NULL);
792 /*{{{static void vmssetuserlnm(char *name, char *eqv);
794 * sets a user-mode logical in the process logical name table
795 * used for redirection of sys$error
798 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
800 $DESCRIPTOR(d_tab, "LNM$PROCESS");
801 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
802 unsigned long int iss, attr = LNM$M_CONFINE;
803 unsigned char acmode = PSL$C_USER;
804 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
806 d_name.dsc$a_pointer = name;
807 d_name.dsc$w_length = strlen(name);
809 lnmlst[0].buflen = strlen(eqv);
810 lnmlst[0].bufadr = eqv;
812 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
813 if (!(iss&1)) lib$signal(iss);
818 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
819 /* my_crypt - VMS password hashing
820 * my_crypt() provides an interface compatible with the Unix crypt()
821 * C library function, and uses sys$hash_password() to perform VMS
822 * password hashing. The quadword hashed password value is returned
823 * as a NUL-terminated 8 character string. my_crypt() does not change
824 * the case of its string arguments; in order to match the behavior
825 * of LOGINOUT et al., alphabetic characters in both arguments must
826 * be upcased by the caller.
829 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
831 # ifndef UAI$C_PREFERRED_ALGORITHM
832 # define UAI$C_PREFERRED_ALGORITHM 127
834 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
835 unsigned short int salt = 0;
836 unsigned long int sts;
838 unsigned short int dsc$w_length;
839 unsigned char dsc$b_type;
840 unsigned char dsc$b_class;
841 const char * dsc$a_pointer;
842 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
843 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
844 struct itmlst_3 uailst[3] = {
845 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
846 { sizeof salt, UAI$_SALT, &salt, 0},
847 { 0, 0, NULL, NULL}};
850 usrdsc.dsc$w_length = strlen(usrname);
851 usrdsc.dsc$a_pointer = usrname;
852 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
854 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
858 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
864 if (sts != RMS$_RNF) return NULL;
867 txtdsc.dsc$w_length = strlen(textpasswd);
868 txtdsc.dsc$a_pointer = textpasswd;
869 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
870 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
873 return (char *) hash;
875 } /* end of my_crypt() */
879 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
880 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
881 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
883 /*{{{int do_rmdir(char *name)*/
885 Perl_do_rmdir(pTHX_ char *name)
887 char dirfile[NAM$C_MAXRSS+1];
891 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
892 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
893 else retval = kill_file(dirfile);
896 } /* end of do_rmdir */
900 * Delete any file to which user has control access, regardless of whether
901 * delete access is explicitly allowed.
902 * Limitations: User must have write access to parent directory.
903 * Does not block signals or ASTs; if interrupted in midstream
904 * may leave file with an altered ACL.
907 /*{{{int kill_file(char *name)*/
909 Perl_kill_file(pTHX_ char *name)
911 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
912 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
913 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
914 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
916 unsigned char myace$b_length;
917 unsigned char myace$b_type;
918 unsigned short int myace$w_flags;
919 unsigned long int myace$l_access;
920 unsigned long int myace$l_ident;
921 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
922 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
923 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
925 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
926 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
927 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
928 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
929 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
930 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
932 /* Expand the input spec using RMS, since the CRTL remove() and
933 * system services won't do this by themselves, so we may miss
934 * a file "hiding" behind a logical name or search list. */
935 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
936 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
937 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
938 /* If not, can changing protections help? */
939 if (vaxc$errno != RMS$_PRV) return -1;
941 /* No, so we get our own UIC to use as a rights identifier,
942 * and the insert an ACE at the head of the ACL which allows us
943 * to delete the file.
945 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
946 fildsc.dsc$w_length = strlen(rspec);
947 fildsc.dsc$a_pointer = rspec;
949 newace.myace$l_ident = oldace.myace$l_ident;
950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
952 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
953 set_errno(ENOENT); break;
955 set_errno(ENOTDIR); break;
957 set_errno(ENODEV); break;
958 case RMS$_SYN: case SS$_INVFILFOROP:
959 set_errno(EINVAL); break;
961 set_errno(EACCES); break;
965 set_vaxc_errno(aclsts);
968 /* Grab any existing ACEs with this identifier in case we fail */
969 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
970 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
971 || fndsts == SS$_NOMOREACE ) {
972 /* Add the new ACE . . . */
973 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
975 if ((rmsts = remove(name))) {
976 /* We blew it - dir with files in it, no write priv for
977 * parent directory, etc. Put things back the way they were. */
978 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
981 addlst[0].bufadr = &oldace;
982 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
989 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
990 /* We just deleted it, so of course it's not there. Some versions of
991 * VMS seem to return success on the unlock operation anyhow (after all
992 * the unlock is successful), but others don't.
994 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
995 if (aclsts & 1) aclsts = fndsts;
998 set_vaxc_errno(aclsts);
1004 } /* end of kill_file() */
1008 /*{{{int my_mkdir(char *,Mode_t)*/
1010 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1012 STRLEN dirlen = strlen(dir);
1014 /* zero length string sometimes gives ACCVIO */
1015 if (dirlen == 0) return -1;
1017 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1018 * null file name/type. However, it's commonplace under Unix,
1019 * so we'll allow it for a gain in portability.
1021 if (dir[dirlen-1] == '/') {
1022 char *newdir = savepvn(dir,dirlen-1);
1023 int ret = mkdir(newdir,mode);
1027 else return mkdir(dir,mode);
1028 } /* end of my_mkdir */
1031 /*{{{int my_chdir(char *)*/
1033 Perl_my_chdir(pTHX_ char *dir)
1035 STRLEN dirlen = strlen(dir);
1037 /* zero length string sometimes gives ACCVIO */
1038 if (dirlen == 0) return -1;
1040 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1042 * null file name/type. However, it's commonplace under Unix,
1043 * so we'll allow it for a gain in portability.
1045 if (dir[dirlen-1] == '/') {
1046 char *newdir = savepvn(dir,dirlen-1);
1047 int ret = chdir(newdir);
1051 else return chdir(dir);
1052 } /* end of my_chdir */
1056 /*{{{FILE *my_tmpfile()*/
1063 if ((fp = tmpfile())) return fp;
1065 New(1323,cp,L_tmpnam+24,char);
1066 strcpy(cp,"Sys$Scratch:");
1067 tmpnam(cp+strlen(cp));
1068 strcat(cp,".Perltmp");
1069 fp = fopen(cp,"w+","fop=dlt");
1076 #ifndef HOMEGROWN_POSIX_SIGNALS
1078 * The C RTL's sigaction fails to check for invalid signal numbers so we
1079 * help it out a bit. The docs are correct, but the actual routine doesn't
1080 * do what the docs say it will.
1082 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1084 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1085 struct sigaction* oact)
1087 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1088 SETERRNO(EINVAL, SS$_INVARG);
1091 return sigaction(sig, act, oact);
1096 #ifdef KILL_BY_SIGPRC
1097 #include <errnodef.h>
1099 /* okay, this is some BLATENT hackery ...
1100 we use this if the kill() in the CRTL uses sys$forcex, causing the
1101 target process to do a sys$exit, which usually can't be handled
1102 gracefully...certainly not by Perl and the %SIG{} mechanism.
1104 Instead we use the (undocumented) system service sys$sigprc.
1105 It has the same parameters as sys$forcex, but throws an exception
1106 in the target process rather than calling sys$exit.
1108 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1109 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1110 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1111 with condition codes C$_SIG0+nsig*8, catching the exception on the
1112 target process and resignaling with appropriate arguments.
1114 But we don't have that VMS 7.0+ exception handler, so if you
1115 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1117 Also note that SIGTERM is listed in the docs as being "unimplemented",
1118 yet always seems to be signaled with a VMS condition code of 4 (and
1119 correctly handled for that code). So we hardwire it in.
1121 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1122 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1123 than signalling with an unrecognized (and unhandled by CRTL) code.
1126 #define _MY_SIG_MAX 17
1129 Perl_sig_to_vmscondition(int sig)
1131 static unsigned int sig_code[_MY_SIG_MAX+1] =
1134 SS$_HANGUP, /* 1 SIGHUP */
1135 SS$_CONTROLC, /* 2 SIGINT */
1136 SS$_CONTROLY, /* 3 SIGQUIT */
1137 SS$_RADRMOD, /* 4 SIGILL */
1138 SS$_BREAK, /* 5 SIGTRAP */
1139 SS$_OPCCUS, /* 6 SIGABRT */
1140 SS$_COMPAT, /* 7 SIGEMT */
1142 SS$_FLTOVF, /* 8 SIGFPE VAX */
1144 SS$_HPARITH, /* 8 SIGFPE AXP */
1146 SS$_ABORT, /* 9 SIGKILL */
1147 SS$_ACCVIO, /* 10 SIGBUS */
1148 SS$_ACCVIO, /* 11 SIGSEGV */
1149 SS$_BADPARAM, /* 12 SIGSYS */
1150 SS$_NOMBX, /* 13 SIGPIPE */
1151 SS$_ASTFLT, /* 14 SIGALRM */
1157 #if __VMS_VER >= 60200000
1158 static int initted = 0;
1161 sig_code[16] = C$_SIGUSR1;
1162 sig_code[17] = C$_SIGUSR2;
1166 if (sig < _SIG_MIN) return 0;
1167 if (sig > _MY_SIG_MAX) return 0;
1168 return sig_code[sig];
1173 Perl_my_kill(int pid, int sig)
1177 int sys$sigprc(unsigned int *pidadr,
1178 struct dsc$descriptor_s *prcname,
1181 code = Perl_sig_to_vmscondition(sig);
1183 if (!pid || !code) {
1187 iss = sys$sigprc((unsigned int *)&pid,0,code);
1188 if (iss&1) return 0;
1192 set_errno(EPERM); break;
1194 case SS$_NOSUCHNODE:
1195 case SS$_UNREACHABLE:
1196 set_errno(ESRCH); break;
1198 set_errno(ENOMEM); break;
1203 set_vaxc_errno(iss);
1209 /* default piping mailbox size */
1210 #define PERL_BUFSIZ 512
1214 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1216 unsigned long int mbxbufsiz;
1217 static unsigned long int syssize = 0;
1218 unsigned long int dviitm = DVI$_DEVNAM;
1219 char csize[LNM$C_NAMLENGTH+1];
1222 unsigned long syiitm = SYI$_MAXBUF;
1224 * Get the SYSGEN parameter MAXBUF
1226 * If the logical 'PERL_MBX_SIZE' is defined
1227 * use the value of the logical instead of PERL_BUFSIZ, but
1228 * keep the size between 128 and MAXBUF.
1231 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1234 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1235 mbxbufsiz = atoi(csize);
1237 mbxbufsiz = PERL_BUFSIZ;
1239 if (mbxbufsiz < 128) mbxbufsiz = 128;
1240 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1242 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1244 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1245 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1247 } /* end of create_mbx() */
1250 /*{{{ my_popen and my_pclose*/
1252 typedef struct _iosb IOSB;
1253 typedef struct _iosb* pIOSB;
1254 typedef struct _pipe Pipe;
1255 typedef struct _pipe* pPipe;
1256 typedef struct pipe_details Info;
1257 typedef struct pipe_details* pInfo;
1258 typedef struct _srqp RQE;
1259 typedef struct _srqp* pRQE;
1260 typedef struct _tochildbuf CBuf;
1261 typedef struct _tochildbuf* pCBuf;
1264 unsigned short status;
1265 unsigned short count;
1266 unsigned long dvispec;
1269 #pragma member_alignment save
1270 #pragma nomember_alignment quadword
1271 struct _srqp { /* VMS self-relative queue entry */
1272 unsigned long qptr[2];
1274 #pragma member_alignment restore
1275 static RQE RQE_ZERO = {0,0};
1277 struct _tochildbuf {
1280 unsigned short size;
1288 unsigned short chan_in;
1289 unsigned short chan_out;
1291 unsigned int bufsize;
1303 #if defined(PERL_IMPLICIT_CONTEXT)
1304 void *thx; /* Either a thread or an interpreter */
1305 /* pointer, depending on how we're built */
1313 PerlIO *fp; /* file pointer to pipe mailbox */
1314 int useFILE; /* using stdio, not perlio */
1315 int pid; /* PID of subprocess */
1316 int mode; /* == 'r' if pipe open for reading */
1317 int done; /* subprocess has completed */
1318 int waiting; /* waiting for completion/closure */
1319 int closing; /* my_pclose is closing this pipe */
1320 unsigned long completion; /* termination status of subprocess */
1321 pPipe in; /* pipe in to sub */
1322 pPipe out; /* pipe out of sub */
1323 pPipe err; /* pipe of sub's sys$error */
1324 int in_done; /* true when in pipe finished */
1329 struct exit_control_block
1331 struct exit_control_block *flink;
1332 unsigned long int (*exit_routine)();
1333 unsigned long int arg_count;
1334 unsigned long int *status_address;
1335 unsigned long int exit_status;
1338 #define RETRY_DELAY "0 ::0.20"
1339 #define MAX_RETRY 50
1341 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1342 static unsigned long mypid;
1343 static unsigned long delaytime[2];
1345 static pInfo open_pipes = NULL;
1346 static $DESCRIPTOR(nl_desc, "NL:");
1348 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1352 static unsigned long int
1353 pipe_exit_routine(pTHX)
1356 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1357 int sts, did_stuff, need_eof, j;
1360 flush any pending i/o
1366 PerlIO_flush(info->fp); /* first, flush data */
1368 fflush((FILE *)info->fp);
1374 next we try sending an EOF...ignore if doesn't work, make sure we
1382 _ckvmssts(sys$setast(0));
1383 if (info->in && !info->in->shut_on_empty) {
1384 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1389 _ckvmssts(sys$setast(1));
1393 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1395 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1400 _ckvmssts(sys$setast(0));
1401 if (info->waiting && info->done)
1403 nwait += info->waiting;
1404 _ckvmssts(sys$setast(1));
1414 _ckvmssts(sys$setast(0));
1415 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1416 sts = sys$forcex(&info->pid,0,&abort);
1417 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1420 _ckvmssts(sys$setast(1));
1424 /* again, wait for effect */
1426 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1431 _ckvmssts(sys$setast(0));
1432 if (info->waiting && info->done)
1434 nwait += info->waiting;
1435 _ckvmssts(sys$setast(1));
1444 _ckvmssts(sys$setast(0));
1445 if (!info->done) { /* We tried to be nice . . . */
1446 sts = sys$delprc(&info->pid,0);
1447 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1449 _ckvmssts(sys$setast(1));
1454 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1455 else if (!(sts & 1)) retsts = sts;
1460 static struct exit_control_block pipe_exitblock =
1461 {(struct exit_control_block *) 0,
1462 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1464 static void pipe_mbxtofd_ast(pPipe p);
1465 static void pipe_tochild1_ast(pPipe p);
1466 static void pipe_tochild2_ast(pPipe p);
1469 popen_completion_ast(pInfo info)
1471 pInfo i = open_pipes;
1475 if (i == info) break;
1478 if (!i) return; /* unlinked, probably freed too */
1480 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1484 Writing to subprocess ...
1485 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1487 chan_out may be waiting for "done" flag, or hung waiting
1488 for i/o completion to child...cancel the i/o. This will
1489 put it into "snarf mode" (done but no EOF yet) that discards
1492 Output from subprocess (stdout, stderr) needs to be flushed and
1493 shut down. We try sending an EOF, but if the mbx is full the pipe
1494 routine should still catch the "shut_on_empty" flag, telling it to
1495 use immediate-style reads so that "mbx empty" -> EOF.
1499 if (info->in && !info->in_done) { /* only for mode=w */
1500 if (info->in->shut_on_empty && info->in->need_wake) {
1501 info->in->need_wake = FALSE;
1502 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1504 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1508 if (info->out && !info->out_done) { /* were we also piping output? */
1509 info->out->shut_on_empty = TRUE;
1510 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1511 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1512 _ckvmssts_noperl(iss);
1515 if (info->err && !info->err_done) { /* we were piping stderr */
1516 info->err->shut_on_empty = TRUE;
1517 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1518 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1519 _ckvmssts_noperl(iss);
1521 _ckvmssts_noperl(sys$setef(pipe_ef));
1525 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
1526 static void vms_execfree(pTHX);
1529 we actually differ from vmstrnenv since we use this to
1530 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1531 are pointing to the same thing
1534 static unsigned short
1535 popen_translate(pTHX_ char *logical, char *result)
1538 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1539 $DESCRIPTOR(d_log,"");
1541 unsigned short length;
1542 unsigned short code;
1544 unsigned short *retlenaddr;
1546 unsigned short l, ifi;
1548 d_log.dsc$a_pointer = logical;
1549 d_log.dsc$w_length = strlen(logical);
1551 itmlst[0].code = LNM$_STRING;
1552 itmlst[0].length = 255;
1553 itmlst[0].buffer_addr = result;
1554 itmlst[0].retlenaddr = &l;
1557 itmlst[1].length = 0;
1558 itmlst[1].buffer_addr = 0;
1559 itmlst[1].retlenaddr = 0;
1561 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1562 if (iss == SS$_NOLOGNAM) {
1566 if (!(iss&1)) lib$signal(iss);
1569 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1570 strip it off and return the ifi, if any
1573 if (result[0] == 0x1b && result[1] == 0x00) {
1574 memcpy(&ifi,result+2,2);
1575 strcpy(result,result+4);
1577 return ifi; /* this is the RMS internal file id */
1580 static void pipe_infromchild_ast(pPipe p);
1583 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1584 inside an AST routine without worrying about reentrancy and which Perl
1585 memory allocator is being used.
1587 We read data and queue up the buffers, then spit them out one at a
1588 time to the output mailbox when the output mailbox is ready for one.
1591 #define INITIAL_TOCHILDQUEUE 2
1594 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1598 char mbx1[64], mbx2[64];
1599 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1600 DSC$K_CLASS_S, mbx1},
1601 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1602 DSC$K_CLASS_S, mbx2};
1603 unsigned int dviitm = DVI$_DEVBUFSIZ;
1606 New(1368, p, 1, Pipe);
1608 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1609 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1610 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1613 p->shut_on_empty = FALSE;
1614 p->need_wake = FALSE;
1617 p->iosb.status = SS$_NORMAL;
1618 p->iosb2.status = SS$_NORMAL;
1624 #ifdef PERL_IMPLICIT_CONTEXT
1628 n = sizeof(CBuf) + p->bufsize;
1630 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1631 _ckvmssts(lib$get_vm(&n, &b));
1632 b->buf = (char *) b + sizeof(CBuf);
1633 _ckvmssts(lib$insqhi(b, &p->free));
1636 pipe_tochild2_ast(p);
1637 pipe_tochild1_ast(p);
1643 /* reads the MBX Perl is writing, and queues */
1646 pipe_tochild1_ast(pPipe p)
1649 int iss = p->iosb.status;
1650 int eof = (iss == SS$_ENDOFFILE);
1651 #ifdef PERL_IMPLICIT_CONTEXT
1657 p->shut_on_empty = TRUE;
1659 _ckvmssts(sys$dassgn(p->chan_in));
1665 b->size = p->iosb.count;
1666 _ckvmssts(lib$insqhi(b, &p->wait));
1668 p->need_wake = FALSE;
1669 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1672 p->retry = 1; /* initial call */
1675 if (eof) { /* flush the free queue, return when done */
1676 int n = sizeof(CBuf) + p->bufsize;
1678 iss = lib$remqti(&p->free, &b);
1679 if (iss == LIB$_QUEWASEMP) return;
1681 _ckvmssts(lib$free_vm(&n, &b));
1685 iss = lib$remqti(&p->free, &b);
1686 if (iss == LIB$_QUEWASEMP) {
1687 int n = sizeof(CBuf) + p->bufsize;
1688 _ckvmssts(lib$get_vm(&n, &b));
1689 b->buf = (char *) b + sizeof(CBuf);
1695 iss = sys$qio(0,p->chan_in,
1696 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1698 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1699 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1704 /* writes queued buffers to output, waits for each to complete before
1708 pipe_tochild2_ast(pPipe p)
1711 int iss = p->iosb2.status;
1712 int n = sizeof(CBuf) + p->bufsize;
1713 int done = (p->info && p->info->done) ||
1714 iss == SS$_CANCEL || iss == SS$_ABORT;
1715 #if defined(PERL_IMPLICIT_CONTEXT)
1720 if (p->type) { /* type=1 has old buffer, dispose */
1721 if (p->shut_on_empty) {
1722 _ckvmssts(lib$free_vm(&n, &b));
1724 _ckvmssts(lib$insqhi(b, &p->free));
1729 iss = lib$remqti(&p->wait, &b);
1730 if (iss == LIB$_QUEWASEMP) {
1731 if (p->shut_on_empty) {
1733 _ckvmssts(sys$dassgn(p->chan_out));
1734 *p->pipe_done = TRUE;
1735 _ckvmssts(sys$setef(pipe_ef));
1737 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1738 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1742 p->need_wake = TRUE;
1752 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1753 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1755 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1756 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1765 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1768 char mbx1[64], mbx2[64];
1769 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1770 DSC$K_CLASS_S, mbx1},
1771 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1772 DSC$K_CLASS_S, mbx2};
1773 unsigned int dviitm = DVI$_DEVBUFSIZ;
1775 New(1367, p, 1, Pipe);
1776 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1777 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1779 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1780 New(1367, p->buf, p->bufsize, char);
1781 p->shut_on_empty = FALSE;
1784 p->iosb.status = SS$_NORMAL;
1785 #if defined(PERL_IMPLICIT_CONTEXT)
1788 pipe_infromchild_ast(p);
1796 pipe_infromchild_ast(pPipe p)
1798 int iss = p->iosb.status;
1799 int eof = (iss == SS$_ENDOFFILE);
1800 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1801 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1802 #if defined(PERL_IMPLICIT_CONTEXT)
1806 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1807 _ckvmssts(sys$dassgn(p->chan_out));
1812 input shutdown if EOF from self (done or shut_on_empty)
1813 output shutdown if closing flag set (my_pclose)
1814 send data/eof from child or eof from self
1815 otherwise, re-read (snarf of data from child)
1820 if (myeof && p->chan_in) { /* input shutdown */
1821 _ckvmssts(sys$dassgn(p->chan_in));
1826 if (myeof || kideof) { /* pass EOF to parent */
1827 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1828 pipe_infromchild_ast, p,
1831 } else if (eof) { /* eat EOF --- fall through to read*/
1833 } else { /* transmit data */
1834 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1835 pipe_infromchild_ast,p,
1836 p->buf, p->iosb.count, 0, 0, 0, 0));
1842 /* everything shut? flag as done */
1844 if (!p->chan_in && !p->chan_out) {
1845 *p->pipe_done = TRUE;
1846 _ckvmssts(sys$setef(pipe_ef));
1850 /* write completed (or read, if snarfing from child)
1851 if still have input active,
1852 queue read...immediate mode if shut_on_empty so we get EOF if empty
1854 check if Perl reading, generate EOFs as needed
1860 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1861 pipe_infromchild_ast,p,
1862 p->buf, p->bufsize, 0, 0, 0, 0);
1863 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1865 } else { /* send EOFs for extra reads */
1866 p->iosb.status = SS$_ENDOFFILE;
1867 p->iosb.dvispec = 0;
1868 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1870 pipe_infromchild_ast, p, 0, 0, 0, 0));
1876 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1880 unsigned long dviitm = DVI$_DEVBUFSIZ;
1882 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1883 DSC$K_CLASS_S, mbx};
1885 /* things like terminals and mbx's don't need this filter */
1886 if (fd && fstat(fd,&s) == 0) {
1887 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1888 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1889 DSC$K_CLASS_S, s.st_dev};
1891 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1892 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1893 strcpy(out, s.st_dev);
1898 New(1366, p, 1, Pipe);
1899 p->fd_out = dup(fd);
1900 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1901 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1902 New(1366, p->buf, p->bufsize+1, char);
1903 p->shut_on_empty = FALSE;
1908 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1909 pipe_mbxtofd_ast, p,
1910 p->buf, p->bufsize, 0, 0, 0, 0));
1916 pipe_mbxtofd_ast(pPipe p)
1918 int iss = p->iosb.status;
1919 int done = p->info->done;
1921 int eof = (iss == SS$_ENDOFFILE);
1922 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1923 int err = !(iss&1) && !eof;
1924 #if defined(PERL_IMPLICIT_CONTEXT)
1928 if (done && myeof) { /* end piping */
1930 sys$dassgn(p->chan_in);
1931 *p->pipe_done = TRUE;
1932 _ckvmssts(sys$setef(pipe_ef));
1936 if (!err && !eof) { /* good data to send to file */
1937 p->buf[p->iosb.count] = '\n';
1938 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1941 if (p->retry < MAX_RETRY) {
1942 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1952 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1953 pipe_mbxtofd_ast, p,
1954 p->buf, p->bufsize, 0, 0, 0, 0);
1955 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1960 typedef struct _pipeloc PLOC;
1961 typedef struct _pipeloc* pPLOC;
1965 char dir[NAM$C_MAXRSS+1];
1967 static pPLOC head_PLOC = 0;
1970 free_pipelocs(pTHX_ void *head)
1973 pPLOC *pHead = (pPLOC *)head;
1985 store_pipelocs(pTHX)
1994 char temp[NAM$C_MAXRSS+1];
1998 free_pipelocs(&head_PLOC);
2000 /* the . directory from @INC comes last */
2003 p->next = head_PLOC;
2005 strcpy(p->dir,"./");
2007 /* get the directory from $^X */
2009 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2010 strcpy(temp, PL_origargv[0]);
2011 x = strrchr(temp,']');
2014 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2016 p->next = head_PLOC;
2018 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2019 p->dir[NAM$C_MAXRSS] = '\0';
2023 /* reverse order of @INC entries, skip "." since entered above */
2025 if (PL_incgv) av = GvAVn(PL_incgv);
2027 for (i = 0; av && i <= AvFILL(av); i++) {
2028 dirsv = *av_fetch(av,i,TRUE);
2030 if (SvROK(dirsv)) continue;
2031 dir = SvPVx(dirsv,n_a);
2032 if (strcmp(dir,".") == 0) continue;
2033 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2037 p->next = head_PLOC;
2039 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2040 p->dir[NAM$C_MAXRSS] = '\0';
2043 /* most likely spot (ARCHLIB) put first in the list */
2046 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2048 p->next = head_PLOC;
2050 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2051 p->dir[NAM$C_MAXRSS] = '\0';
2054 Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
2061 static int vmspipe_file_status = 0;
2062 static char vmspipe_file[NAM$C_MAXRSS+1];
2064 /* already found? Check and use ... need read+execute permission */
2066 if (vmspipe_file_status == 1) {
2067 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2068 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2069 return vmspipe_file;
2071 vmspipe_file_status = 0;
2074 /* scan through stored @INC, $^X */
2076 if (vmspipe_file_status == 0) {
2077 char file[NAM$C_MAXRSS+1];
2078 pPLOC p = head_PLOC;
2081 strcpy(file, p->dir);
2082 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2083 file[NAM$C_MAXRSS] = '\0';
2086 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2088 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2089 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2090 vmspipe_file_status = 1;
2091 return vmspipe_file;
2094 vmspipe_file_status = -1; /* failed, use tempfiles */
2101 vmspipe_tempfile(pTHX)
2103 char file[NAM$C_MAXRSS+1];
2105 static int index = 0;
2108 /* create a tempfile */
2110 /* we can't go from W, shr=get to R, shr=get without
2111 an intermediate vulnerable state, so don't bother trying...
2113 and lib$spawn doesn't shr=put, so have to close the write
2115 So... match up the creation date/time and the FID to
2116 make sure we're dealing with the same file
2121 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2122 fp = fopen(file,"w");
2124 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2125 fp = fopen(file,"w");
2127 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2128 fp = fopen(file,"w");
2131 if (!fp) return 0; /* we're hosed */
2133 fprintf(fp,"$! 'f$verify(0)\n");
2134 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2135 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2136 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2137 fprintf(fp,"$ perl_on = \"set noon\"\n");
2138 fprintf(fp,"$ perl_exit = \"exit\"\n");
2139 fprintf(fp,"$ perl_del = \"delete\"\n");
2140 fprintf(fp,"$ pif = \"if\"\n");
2141 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2142 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2143 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2144 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2145 fprintf(fp,"$! --- build command line to get max possible length\n");
2146 fprintf(fp,"$c=perl_popen_cmd0\n");
2147 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2148 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2149 fprintf(fp,"$x=perl_popen_cmd3\n");
2150 fprintf(fp,"$c=c+x\n");
2151 fprintf(fp,"$! --- get rid of global symbols\n");
2152 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2153 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2154 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2155 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2156 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2157 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2158 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2159 fprintf(fp,"$ perl_on\n");
2160 fprintf(fp,"$ 'c\n");
2161 fprintf(fp,"$ perl_status = $STATUS\n");
2162 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2163 fprintf(fp,"$ perl_exit 'perl_status'\n");
2166 fgetname(fp, file, 1);
2167 fstat(fileno(fp), &s0);
2170 fp = fopen(file,"r","shr=get");
2172 fstat(fileno(fp), &s1);
2174 if (s0.st_ino[0] != s1.st_ino[0] ||
2175 s0.st_ino[1] != s1.st_ino[1] ||
2176 s0.st_ino[2] != s1.st_ino[2] ||
2177 s0.st_ctime != s1.st_ctime ) {
2188 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2190 static int handler_set_up = FALSE;
2191 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2192 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2194 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2195 char in[512], out[512], err[512], mbx[512];
2197 char tfilebuf[NAM$C_MAXRSS+1];
2199 char cmd_sym_name[20];
2200 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2201 DSC$K_CLASS_S, symbol};
2202 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2204 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2205 DSC$K_CLASS_S, cmd_sym_name};
2206 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2207 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2208 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2210 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2212 /* once-per-program initialization...
2213 note that the SETAST calls and the dual test of pipe_ef
2214 makes sure that only the FIRST thread through here does
2215 the initialization...all other threads wait until it's
2218 Yeah, uglier than a pthread call, it's got all the stuff inline
2219 rather than in a separate routine.
2223 _ckvmssts(sys$setast(0));
2225 unsigned long int pidcode = JPI$_PID;
2226 $DESCRIPTOR(d_delay, RETRY_DELAY);
2227 _ckvmssts(lib$get_ef(&pipe_ef));
2228 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2229 _ckvmssts(sys$bintim(&d_delay, delaytime));
2231 if (!handler_set_up) {
2232 _ckvmssts(sys$dclexh(&pipe_exitblock));
2233 handler_set_up = TRUE;
2235 _ckvmssts(sys$setast(1));
2238 /* see if we can find a VMSPIPE.COM */
2241 vmspipe = find_vmspipe(aTHX);
2243 strcpy(tfilebuf+1,vmspipe);
2244 } else { /* uh, oh...we're in tempfile hell */
2245 tpipe = vmspipe_tempfile(aTHX);
2246 if (!tpipe) { /* a fish popular in Boston */
2247 if (ckWARN(WARN_PIPE)) {
2248 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2252 fgetname(tpipe,tfilebuf+1,1);
2254 vmspipedsc.dsc$a_pointer = tfilebuf;
2255 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2257 sts = setup_cmddsc(aTHX_ cmd,0,0);
2260 case RMS$_FNF: case RMS$_DNF:
2261 set_errno(ENOENT); break;
2263 set_errno(ENOTDIR); break;
2265 set_errno(ENODEV); break;
2267 set_errno(EACCES); break;
2269 set_errno(EINVAL); break;
2270 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2271 set_errno(E2BIG); break;
2272 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2273 _ckvmssts(sts); /* fall through */
2274 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2277 set_vaxc_errno(sts);
2278 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2279 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2284 New(1301,info,1,Info);
2286 strcpy(mode,in_mode);
2289 info->completion = 0;
2290 info->closing = FALSE;
2297 info->in_done = TRUE;
2298 info->out_done = TRUE;
2299 info->err_done = TRUE;
2300 in[0] = out[0] = err[0] = '\0';
2302 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2306 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2311 if (*mode == 'r') { /* piping from subroutine */
2313 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2315 info->out->pipe_done = &info->out_done;
2316 info->out_done = FALSE;
2317 info->out->info = info;
2319 if (!info->useFILE) {
2320 info->fp = PerlIO_open(mbx, mode);
2322 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2323 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2326 if (!info->fp && info->out) {
2327 sys$cancel(info->out->chan_out);
2329 while (!info->out_done) {
2331 _ckvmssts(sys$setast(0));
2332 done = info->out_done;
2333 if (!done) _ckvmssts(sys$clref(pipe_ef));
2334 _ckvmssts(sys$setast(1));
2335 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2338 if (info->out->buf) Safefree(info->out->buf);
2339 Safefree(info->out);
2345 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2347 info->err->pipe_done = &info->err_done;
2348 info->err_done = FALSE;
2349 info->err->info = info;
2352 } else if (*mode == 'w') { /* piping to subroutine */
2354 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2356 info->out->pipe_done = &info->out_done;
2357 info->out_done = FALSE;
2358 info->out->info = info;
2361 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2363 info->err->pipe_done = &info->err_done;
2364 info->err_done = FALSE;
2365 info->err->info = info;
2368 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2369 if (!info->useFILE) {
2370 info->fp = PerlIO_open(mbx, mode);
2372 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2373 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2377 info->in->pipe_done = &info->in_done;
2378 info->in_done = FALSE;
2379 info->in->info = info;
2383 if (!info->fp && info->in) {
2385 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2386 0, 0, 0, 0, 0, 0, 0, 0));
2388 while (!info->in_done) {
2390 _ckvmssts(sys$setast(0));
2391 done = info->in_done;
2392 if (!done) _ckvmssts(sys$clref(pipe_ef));
2393 _ckvmssts(sys$setast(1));
2394 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2397 if (info->in->buf) Safefree(info->in->buf);
2405 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2406 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2408 info->out->pipe_done = &info->out_done;
2409 info->out_done = FALSE;
2410 info->out->info = info;
2413 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2415 info->err->pipe_done = &info->err_done;
2416 info->err_done = FALSE;
2417 info->err->info = info;
2421 symbol[MAX_DCL_SYMBOL] = '\0';
2423 strncpy(symbol, in, MAX_DCL_SYMBOL);
2424 d_symbol.dsc$w_length = strlen(symbol);
2425 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2427 strncpy(symbol, err, MAX_DCL_SYMBOL);
2428 d_symbol.dsc$w_length = strlen(symbol);
2429 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2431 strncpy(symbol, out, MAX_DCL_SYMBOL);
2432 d_symbol.dsc$w_length = strlen(symbol);
2433 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2435 p = VMSCMD.dsc$a_pointer;
2436 while (*p && *p != '\n') p++;
2437 *p = '\0'; /* truncate on \n */
2438 p = VMSCMD.dsc$a_pointer;
2439 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2440 if (*p == '$') p++; /* remove leading $ */
2441 while (*p == ' ' || *p == '\t') p++;
2443 for (j = 0; j < 4; j++) {
2444 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2445 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2447 strncpy(symbol, p, MAX_DCL_SYMBOL);
2448 d_symbol.dsc$w_length = strlen(symbol);
2449 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2451 if (strlen(p) > MAX_DCL_SYMBOL) {
2452 p += MAX_DCL_SYMBOL;
2457 _ckvmssts(sys$setast(0));
2458 info->next=open_pipes; /* prepend to list */
2460 _ckvmssts(sys$setast(1));
2461 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2462 0, &info->pid, &info->completion,
2463 0, popen_completion_ast,info,0,0,0));
2465 /* if we were using a tempfile, close it now */
2467 if (tpipe) fclose(tpipe);
2469 /* once the subprocess is spawned, it has copied the symbols and
2470 we can get rid of ours */
2472 for (j = 0; j < 4; j++) {
2473 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2474 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2475 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2477 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2478 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2479 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2482 PL_forkprocess = info->pid;
2486 _ckvmssts(sys$setast(0));
2488 if (!done) _ckvmssts(sys$clref(pipe_ef));
2489 _ckvmssts(sys$setast(1));
2490 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2492 *psts = info->completion;
2493 my_pclose(info->fp);
2498 } /* end of safe_popen */
2501 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2503 Perl_my_popen(pTHX_ char *cmd, char *mode)
2507 TAINT_PROPER("popen");
2508 PERL_FLUSHALL_FOR_CHILD;
2509 return safe_popen(aTHX_ cmd,mode,&sts);
2514 /*{{{ I32 my_pclose(PerlIO *fp)*/
2515 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2517 pInfo info, last = NULL;
2518 unsigned long int retsts;
2521 for (info = open_pipes; info != NULL; last = info, info = info->next)
2522 if (info->fp == fp) break;
2524 if (info == NULL) { /* no such pipe open */
2525 set_errno(ECHILD); /* quoth POSIX */
2526 set_vaxc_errno(SS$_NONEXPR);
2530 /* If we were writing to a subprocess, insure that someone reading from
2531 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2532 * produce an EOF record in the mailbox.
2534 * well, at least sometimes it *does*, so we have to watch out for
2535 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2539 PerlIO_flush(info->fp); /* first, flush data */
2541 fflush((FILE *)info->fp);
2544 _ckvmssts(sys$setast(0));
2545 info->closing = TRUE;
2546 done = info->done && info->in_done && info->out_done && info->err_done;
2547 /* hanging on write to Perl's input? cancel it */
2548 if (info->mode == 'r' && info->out && !info->out_done) {
2549 if (info->out->chan_out) {
2550 _ckvmssts(sys$cancel(info->out->chan_out));
2551 if (!info->out->chan_in) { /* EOF generation, need AST */
2552 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2556 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2557 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2559 _ckvmssts(sys$setast(1));
2562 PerlIO_close(info->fp);
2564 fclose((FILE *)info->fp);
2567 we have to wait until subprocess completes, but ALSO wait until all
2568 the i/o completes...otherwise we'll be freeing the "info" structure
2569 that the i/o ASTs could still be using...
2573 _ckvmssts(sys$setast(0));
2574 done = info->done && info->in_done && info->out_done && info->err_done;
2575 if (!done) _ckvmssts(sys$clref(pipe_ef));
2576 _ckvmssts(sys$setast(1));
2577 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2579 retsts = info->completion;
2581 /* remove from list of open pipes */
2582 _ckvmssts(sys$setast(0));
2583 if (last) last->next = info->next;
2584 else open_pipes = info->next;
2585 _ckvmssts(sys$setast(1));
2587 /* free buffers and structures */
2590 if (info->in->buf) Safefree(info->in->buf);
2594 if (info->out->buf) Safefree(info->out->buf);
2595 Safefree(info->out);
2598 if (info->err->buf) Safefree(info->err->buf);
2599 Safefree(info->err);
2605 } /* end of my_pclose() */
2607 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2608 /* Roll our own prototype because we want this regardless of whether
2609 * _VMS_WAIT is defined.
2611 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2613 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2614 created with popen(); otherwise partially emulate waitpid() unless
2615 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2616 Also check processes not considered by the CRTL waitpid().
2618 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2620 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2626 if (statusp) *statusp = 0;
2628 for (info = open_pipes; info != NULL; info = info->next)
2629 if (info->pid == pid) break;
2631 if (info != NULL) { /* we know about this child */
2632 while (!info->done) {
2633 _ckvmssts(sys$setast(0));
2635 if (!done) _ckvmssts(sys$clref(pipe_ef));
2636 _ckvmssts(sys$setast(1));
2637 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2640 if (statusp) *statusp = info->completion;
2644 else { /* this child is not one of our own pipe children */
2646 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2648 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2649 * in 7.2 did we get a version that fills in the VMS completion
2650 * status as Perl has always tried to do.
2653 sts = __vms_waitpid( pid, statusp, flags );
2655 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2658 /* If the real waitpid tells us the child does not exist, we
2659 * fall through here to implement waiting for a child that
2660 * was created by some means other than exec() (say, spawned
2661 * from DCL) or to wait for a process that is not a subprocess
2662 * of the current process.
2665 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2667 $DESCRIPTOR(intdsc,"0 00:00:01");
2668 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2669 unsigned long int pidcode = JPI$_PID, mypid;
2670 unsigned long int interval[2];
2671 int termination_mbu = 0;
2672 unsigned short qio_iosb[4];
2673 unsigned int jpi_iosb[2];
2674 struct itmlst_3 jpilist[3] = {
2675 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2676 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2679 char trmmbx[NAM$C_DVI+1];
2680 $DESCRIPTOR(trmmbxdsc,trmmbx);
2681 struct accdef trmmsg;
2682 unsigned short int mbxchan;
2685 /* Sorry folks, we don't presently implement rooting around for
2686 the first child we can find, and we definitely don't want to
2687 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2693 /* Get the owner of the child so I can warn if it's not mine, plus
2694 * get the termination mailbox. If the process doesn't exist or I
2695 * don't have the privs to look at it, I can go home early.
2697 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2698 if (sts & 1) sts = jpi_iosb[0];
2710 set_vaxc_errno(sts);
2714 if (ckWARN(WARN_EXEC)) {
2715 /* remind folks they are asking for non-standard waitpid behavior */
2716 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2717 if (ownerpid != mypid)
2718 Perl_warner(aTHX_ WARN_EXEC,
2719 "waitpid: process %x is not a child of process %x",
2723 /* It's possible to have a mailbox unit number but no actual mailbox; we
2724 * check for this by assigning a channel to it, which we need anyway.
2726 if (termination_mbu != 0) {
2727 sprintf(trmmbx, "MBA%d:", termination_mbu);
2728 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2729 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2730 if (sts == SS$_NOSUCHDEV) {
2731 termination_mbu = 0; /* set up to take "no mailbox" case */
2736 /* If the process doesn't have a termination mailbox, then simply check
2737 * on it once a second until it's not there anymore.
2739 if (termination_mbu == 0) {
2740 _ckvmssts(sys$bintim(&intdsc,interval));
2741 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2742 _ckvmssts(sys$schdwk(0,0,interval,0));
2743 _ckvmssts(sys$hiber());
2745 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2748 /* If we do have a termination mailbox, post reads to it until we get a
2749 * termination message, discarding messages of the wrong type or for other
2750 * processes. If there is a place to put the final status, then do so.
2754 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2755 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2756 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2757 if (sts & 1) sts = qio_iosb[0];
2760 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2761 && trmmsg.acc$l_pid == pid ) {
2763 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2764 sts = sys$dassgn(mbxchan);
2768 } /* termination_mbu ? */
2773 } /* else one of our own pipe children */
2775 } /* end of waitpid() */
2780 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2782 my_gconvert(double val, int ndig, int trail, char *buf)
2784 static char __gcvtbuf[DBL_DIG+1];
2787 loc = buf ? buf : __gcvtbuf;
2789 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2791 sprintf(loc,"%.*g",ndig,val);
2797 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2798 return gcvt(val,ndig,loc);
2801 loc[0] = '0'; loc[1] = '\0';
2809 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2810 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2811 * to expand file specification. Allows for a single default file
2812 * specification and a simple mask of options. If outbuf is non-NULL,
2813 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2814 * the resultant file specification is placed. If outbuf is NULL, the
2815 * resultant file specification is placed into a static buffer.
2816 * The third argument, if non-NULL, is taken to be a default file
2817 * specification string. The fourth argument is unused at present.
2818 * rmesexpand() returns the address of the resultant string if
2819 * successful, and NULL on error.
2821 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2824 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2826 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2827 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2828 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2829 struct FAB myfab = cc$rms_fab;
2830 struct NAM mynam = cc$rms_nam;
2832 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2834 if (!filespec || !*filespec) {
2835 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2839 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2840 else outbuf = __rmsexpand_retbuf;
2842 if ((isunix = (strchr(filespec,'/') != NULL))) {
2843 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2844 filespec = vmsfspec;
2847 myfab.fab$l_fna = filespec;
2848 myfab.fab$b_fns = strlen(filespec);
2849 myfab.fab$l_nam = &mynam;
2851 if (defspec && *defspec) {
2852 if (strchr(defspec,'/') != NULL) {
2853 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2856 myfab.fab$l_dna = defspec;
2857 myfab.fab$b_dns = strlen(defspec);
2860 mynam.nam$l_esa = esa;
2861 mynam.nam$b_ess = sizeof esa;
2862 mynam.nam$l_rsa = outbuf;
2863 mynam.nam$b_rss = NAM$C_MAXRSS;
2865 retsts = sys$parse(&myfab,0,0);
2866 if (!(retsts & 1)) {
2867 mynam.nam$b_nop |= NAM$M_SYNCHK;
2868 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2869 retsts = sys$parse(&myfab,0,0);
2870 if (retsts & 1) goto expanded;
2872 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2873 (void) sys$parse(&myfab,0,0); /* Free search context */
2874 if (out) Safefree(out);
2875 set_vaxc_errno(retsts);
2876 if (retsts == RMS$_PRV) set_errno(EACCES);
2877 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2878 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2879 else set_errno(EVMSERR);
2882 retsts = sys$search(&myfab,0,0);
2883 if (!(retsts & 1) && retsts != RMS$_FNF) {
2884 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2885 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2886 if (out) Safefree(out);
2887 set_vaxc_errno(retsts);
2888 if (retsts == RMS$_PRV) set_errno(EACCES);
2889 else set_errno(EVMSERR);
2893 /* If the input filespec contained any lowercase characters,
2894 * downcase the result for compatibility with Unix-minded code. */
2896 for (out = myfab.fab$l_fna; *out; out++)
2897 if (islower(*out)) { haslower = 1; break; }
2898 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2899 else { out = esa; speclen = mynam.nam$b_esl; }
2900 /* Trim off null fields added by $PARSE
2901 * If type > 1 char, must have been specified in original or default spec
2902 * (not true for version; $SEARCH may have added version of existing file).
2904 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2905 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2906 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2907 if (trimver || trimtype) {
2908 if (defspec && *defspec) {
2909 char defesa[NAM$C_MAXRSS];
2910 struct FAB deffab = cc$rms_fab;
2911 struct NAM defnam = cc$rms_nam;
2913 deffab.fab$l_nam = &defnam;
2914 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2915 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2916 defnam.nam$b_nop = NAM$M_SYNCHK;
2917 if (sys$parse(&deffab,0,0) & 1) {
2918 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2919 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2922 if (trimver) speclen = mynam.nam$l_ver - out;
2924 /* If we didn't already trim version, copy down */
2925 if (speclen > mynam.nam$l_ver - out)
2926 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2927 speclen - (mynam.nam$l_ver - out));
2928 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2931 /* If we just had a directory spec on input, $PARSE "helpfully"
2932 * adds an empty name and type for us */
2933 if (mynam.nam$l_name == mynam.nam$l_type &&
2934 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2935 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2936 speclen = mynam.nam$l_name - out;
2937 out[speclen] = '\0';
2938 if (haslower) __mystrtolower(out);
2940 /* Have we been working with an expanded, but not resultant, spec? */
2941 /* Also, convert back to Unix syntax if necessary. */
2942 if (!mynam.nam$b_rsl) {
2944 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2946 else strcpy(outbuf,esa);
2949 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2950 strcpy(outbuf,tmpfspec);
2952 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2953 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2954 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2958 /* External entry points */
2959 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2960 { return do_rmsexpand(spec,buf,0,def,opt); }
2961 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2962 { return do_rmsexpand(spec,buf,1,def,opt); }
2966 ** The following routines are provided to make life easier when
2967 ** converting among VMS-style and Unix-style directory specifications.
2968 ** All will take input specifications in either VMS or Unix syntax. On
2969 ** failure, all return NULL. If successful, the routines listed below
2970 ** return a pointer to a buffer containing the appropriately
2971 ** reformatted spec (and, therefore, subsequent calls to that routine
2972 ** will clobber the result), while the routines of the same names with
2973 ** a _ts suffix appended will return a pointer to a mallocd string
2974 ** containing the appropriately reformatted spec.
2975 ** In all cases, only explicit syntax is altered; no check is made that
2976 ** the resulting string is valid or that the directory in question
2979 ** fileify_dirspec() - convert a directory spec into the name of the
2980 ** directory file (i.e. what you can stat() to see if it's a dir).
2981 ** The style (VMS or Unix) of the result is the same as the style
2982 ** of the parameter passed in.
2983 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2984 ** what you prepend to a filename to indicate what directory it's in).
2985 ** The style (VMS or Unix) of the result is the same as the style
2986 ** of the parameter passed in.
2987 ** tounixpath() - convert a directory spec into a Unix-style path.
2988 ** tovmspath() - convert a directory spec into a VMS-style path.
2989 ** tounixspec() - convert any file spec into a Unix-style file spec.
2990 ** tovmsspec() - convert any file spec into a VMS-style spec.
2992 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2993 ** Permission is given to distribute this code as part of the Perl
2994 ** standard distribution under the terms of the GNU General Public
2995 ** License or the Perl Artistic License. Copies of each may be
2996 ** found in the Perl standard distribution.
2999 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3000 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3002 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3003 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3004 char *retspec, *cp1, *cp2, *lastdir;
3005 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3007 if (!dir || !*dir) {
3008 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3010 dirlen = strlen(dir);
3011 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3012 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3013 strcpy(trndir,"/sys$disk/000000");
3017 if (dirlen > NAM$C_MAXRSS) {
3018 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3020 if (!strpbrk(dir+1,"/]>:")) {
3021 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3022 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
3024 dirlen = strlen(dir);
3027 strncpy(trndir,dir,dirlen);
3028 trndir[dirlen] = '\0';
3031 /* If we were handed a rooted logical name or spec, treat it like a
3032 * simple directory, so that
3033 * $ Define myroot dev:[dir.]
3034 * ... do_fileify_dirspec("myroot",buf,1) ...
3035 * does something useful.
3037 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3038 dir[--dirlen] = '\0';
3039 dir[dirlen-1] = ']';
3041 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3042 dir[--dirlen] = '\0';
3043 dir[dirlen-1] = '>';
3046 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3047 /* If we've got an explicit filename, we can just shuffle the string. */
3048 if (*(cp1+1)) hasfilename = 1;
3049 /* Similarly, we can just back up a level if we've got multiple levels
3050 of explicit directories in a VMS spec which ends with directories. */
3052 for (cp2 = cp1; cp2 > dir; cp2--) {
3054 *cp2 = *cp1; *cp1 = '\0';
3058 if (*cp2 == '[' || *cp2 == '<') break;
3063 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3064 if (dir[0] == '.') {
3065 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3066 return do_fileify_dirspec("[]",buf,ts);
3067 else if (dir[1] == '.' &&
3068 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3069 return do_fileify_dirspec("[-]",buf,ts);
3071 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3072 dirlen -= 1; /* to last element */
3073 lastdir = strrchr(dir,'/');
3075 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3076 /* If we have "/." or "/..", VMSify it and let the VMS code
3077 * below expand it, rather than repeating the code to handle
3078 * relative components of a filespec here */
3080 if (*(cp1+2) == '.') cp1++;
3081 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3082 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3083 if (strchr(vmsdir,'/') != NULL) {
3084 /* If do_tovmsspec() returned it, it must have VMS syntax
3085 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3086 * the time to check this here only so we avoid a recursion
3087 * loop; otherwise, gigo.
3089 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3091 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3092 return do_tounixspec(trndir,buf,ts);
3095 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3096 lastdir = strrchr(dir,'/');
3098 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3099 /* Ditto for specs that end in an MFD -- let the VMS code
3100 * figure out whether it's a real device or a rooted logical. */
3101 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3102 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3103 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3104 return do_tounixspec(trndir,buf,ts);
3107 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3108 !(lastdir = cp1 = strrchr(dir,']')) &&
3109 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3110 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3112 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3113 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3114 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3115 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3116 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3117 (ver || *cp3)))))) {
3119 set_vaxc_errno(RMS$_DIR);
3125 /* If we lead off with a device or rooted logical, add the MFD
3126 if we're specifying a top-level directory. */
3127 if (lastdir && *dir == '/') {
3129 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3136 retlen = dirlen + (addmfd ? 13 : 6);
3137 if (buf) retspec = buf;
3138 else if (ts) New(1309,retspec,retlen+1,char);
3139 else retspec = __fileify_retbuf;
3141 dirlen = lastdir - dir;
3142 memcpy(retspec,dir,dirlen);
3143 strcpy(&retspec[dirlen],"/000000");
3144 strcpy(&retspec[dirlen+7],lastdir);
3147 memcpy(retspec,dir,dirlen);
3148 retspec[dirlen] = '\0';
3150 /* We've picked up everything up to the directory file name.
3151 Now just add the type and version, and we're set. */
3152 strcat(retspec,".dir;1");
3155 else { /* VMS-style directory spec */
3156 char esa[NAM$C_MAXRSS+1], term, *cp;
3157 unsigned long int sts, cmplen, haslower = 0;
3158 struct FAB dirfab = cc$rms_fab;
3159 struct NAM savnam, dirnam = cc$rms_nam;
3161 dirfab.fab$b_fns = strlen(dir);
3162 dirfab.fab$l_fna = dir;
3163 dirfab.fab$l_nam = &dirnam;
3164 dirfab.fab$l_dna = ".DIR;1";
3165 dirfab.fab$b_dns = 6;
3166 dirnam.nam$b_ess = NAM$C_MAXRSS;
3167 dirnam.nam$l_esa = esa;
3169 for (cp = dir; *cp; cp++)
3170 if (islower(*cp)) { haslower = 1; break; }
3171 if (!((sts = sys$parse(&dirfab))&1)) {
3172 if (dirfab.fab$l_sts == RMS$_DIR) {
3173 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3174 sts = sys$parse(&dirfab) & 1;
3178 set_vaxc_errno(dirfab.fab$l_sts);
3184 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3185 /* Yes; fake the fnb bits so we'll check type below */
3186 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3188 else { /* No; just work with potential name */
3189 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3191 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3192 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3193 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3198 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3199 cp1 = strchr(esa,']');
3200 if (!cp1) cp1 = strchr(esa,'>');
3201 if (cp1) { /* Should always be true */
3202 dirnam.nam$b_esl -= cp1 - esa - 1;
3203 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3206 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3207 /* Yep; check version while we're at it, if it's there. */
3208 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3209 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3210 /* Something other than .DIR[;1]. Bzzt. */
3211 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3212 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3214 set_vaxc_errno(RMS$_DIR);
3218 esa[dirnam.nam$b_esl] = '\0';
3219 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3220 /* They provided at least the name; we added the type, if necessary, */
3221 if (buf) retspec = buf; /* in sys$parse() */
3222 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3223 else retspec = __fileify_retbuf;
3224 strcpy(retspec,esa);
3225 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3226 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3229 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3230 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3232 dirnam.nam$b_esl -= 9;
3234 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3235 if (cp1 == NULL) { /* should never happen */
3236 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3237 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3242 retlen = strlen(esa);
3243 if ((cp1 = strrchr(esa,'.')) != NULL) {
3244 /* There's more than one directory in the path. Just roll back. */
3246 if (buf) retspec = buf;
3247 else if (ts) New(1311,retspec,retlen+7,char);
3248 else retspec = __fileify_retbuf;
3249 strcpy(retspec,esa);
3252 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3253 /* Go back and expand rooted logical name */
3254 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3255 if (!(sys$parse(&dirfab) & 1)) {
3256 dirnam.nam$l_rlf = NULL;
3257 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3259 set_vaxc_errno(dirfab.fab$l_sts);
3262 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3263 if (buf) retspec = buf;
3264 else if (ts) New(1312,retspec,retlen+16,char);
3265 else retspec = __fileify_retbuf;
3266 cp1 = strstr(esa,"][");
3267 if (!cp1) cp1 = strstr(esa,"]<");
3269 memcpy(retspec,esa,dirlen);
3270 if (!strncmp(cp1+2,"000000]",7)) {
3271 retspec[dirlen-1] = '\0';
3272 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3273 if (*cp1 == '.') *cp1 = ']';
3275 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3276 memcpy(cp1+1,"000000]",7);
3280 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3281 retspec[retlen] = '\0';
3282 /* Convert last '.' to ']' */
3283 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3284 if (*cp1 == '.') *cp1 = ']';
3286 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3287 memcpy(cp1+1,"000000]",7);
3291 else { /* This is a top-level dir. Add the MFD to the path. */
3292 if (buf) retspec = buf;
3293 else if (ts) New(1312,retspec,retlen+16,char);
3294 else retspec = __fileify_retbuf;
3297 while (*cp1 != ':') *(cp2++) = *(cp1++);
3298 strcpy(cp2,":[000000]");
3303 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3304 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3305 /* We've set up the string up through the filename. Add the
3306 type and version, and we're done. */
3307 strcat(retspec,".DIR;1");
3309 /* $PARSE may have upcased filespec, so convert output to lower
3310 * case if input contained any lowercase characters. */
3311 if (haslower) __mystrtolower(retspec);
3314 } /* end of do_fileify_dirspec() */
3316 /* External entry points */
3317 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3318 { return do_fileify_dirspec(dir,buf,0); }
3319 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3320 { return do_fileify_dirspec(dir,buf,1); }
3322 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3323 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3325 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3326 unsigned long int retlen;
3327 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3329 if (!dir || !*dir) {
3330 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3333 if (*dir) strcpy(trndir,dir);
3334 else getcwd(trndir,sizeof trndir - 1);
3336 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3337 && my_trnlnm(trndir,trndir,0)) {
3338 STRLEN trnlen = strlen(trndir);
3340 /* Trap simple rooted lnms, and return lnm:[000000] */
3341 if (!strcmp(trndir+trnlen-2,".]")) {
3342 if (buf) retpath = buf;
3343 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3344 else retpath = __pathify_retbuf;
3345 strcpy(retpath,dir);
3346 strcat(retpath,":[000000]");
3352 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3353 if (*dir == '.' && (*(dir+1) == '\0' ||
3354 (*(dir+1) == '.' && *(dir+2) == '\0')))
3355 retlen = 2 + (*(dir+1) != '\0');
3357 if ( !(cp1 = strrchr(dir,'/')) &&
3358 !(cp1 = strrchr(dir,']')) &&
3359 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3360 if ((cp2 = strchr(cp1,'.')) != NULL &&
3361 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3362 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3363 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3364 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3366 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3367 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3368 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3369 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3370 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3371 (ver || *cp3)))))) {
3373 set_vaxc_errno(RMS$_DIR);
3376 retlen = cp2 - dir + 1;
3378 else { /* No file type present. Treat the filename as a directory. */
3379 retlen = strlen(dir) + 1;
3382 if (buf) retpath = buf;
3383 else if (ts) New(1313,retpath,retlen+1,char);
3384 else retpath = __pathify_retbuf;
3385 strncpy(retpath,dir,retlen-1);
3386 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3387 retpath[retlen-1] = '/'; /* with '/', add it. */
3388 retpath[retlen] = '\0';
3390 else retpath[retlen-1] = '\0';
3392 else { /* VMS-style directory spec */
3393 char esa[NAM$C_MAXRSS+1], *cp;
3394 unsigned long int sts, cmplen, haslower;
3395 struct FAB dirfab = cc$rms_fab;
3396 struct NAM savnam, dirnam = cc$rms_nam;
3398 /* If we've got an explicit filename, we can just shuffle the string. */
3399 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3400 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3401 if ((cp2 = strchr(cp1,'.')) != NULL) {
3403 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3404 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3405 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3406 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3407 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3408 (ver || *cp3)))))) {
3410 set_vaxc_errno(RMS$_DIR);
3414 else { /* No file type, so just draw name into directory part */
3415 for (cp2 = cp1; *cp2; cp2++) ;
3418 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3420 /* We've now got a VMS 'path'; fall through */
3422 dirfab.fab$b_fns = strlen(dir);
3423 dirfab.fab$l_fna = dir;
3424 if (dir[dirfab.fab$b_fns-1] == ']' ||
3425 dir[dirfab.fab$b_fns-1] == '>' ||
3426 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3427 if (buf) retpath = buf;
3428 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3429 else retpath = __pathify_retbuf;
3430 strcpy(retpath,dir);
3433 dirfab.fab$l_dna = ".DIR;1";
3434 dirfab.fab$b_dns = 6;
3435 dirfab.fab$l_nam = &dirnam;
3436 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3437 dirnam.nam$l_esa = esa;
3439 for (cp = dir; *cp; cp++)
3440 if (islower(*cp)) { haslower = 1; break; }
3442 if (!(sts = (sys$parse(&dirfab)&1))) {
3443 if (dirfab.fab$l_sts == RMS$_DIR) {
3444 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3445 sts = sys$parse(&dirfab) & 1;
3449 set_vaxc_errno(dirfab.fab$l_sts);
3455 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3456 if (dirfab.fab$l_sts != RMS$_FNF) {
3457 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3458 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3460 set_vaxc_errno(dirfab.fab$l_sts);
3463 dirnam = savnam; /* No; just work with potential name */
3466 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3467 /* Yep; check version while we're at it, if it's there. */
3468 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3469 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3470 /* Something other than .DIR[;1]. Bzzt. */
3471 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3472 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3474 set_vaxc_errno(RMS$_DIR);
3478 /* OK, the type was fine. Now pull any file name into the
3480 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3482 cp1 = strrchr(esa,'>');
3483 *dirnam.nam$l_type = '>';
3486 *(dirnam.nam$l_type + 1) = '\0';
3487 retlen = dirnam.nam$l_type - esa + 2;
3488 if (buf) retpath = buf;
3489 else if (ts) New(1314,retpath,retlen,char);
3490 else retpath = __pathify_retbuf;
3491 strcpy(retpath,esa);
3492 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3493 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3494 /* $PARSE may have upcased filespec, so convert output to lower
3495 * case if input contained any lowercase characters. */
3496 if (haslower) __mystrtolower(retpath);
3500 } /* end of do_pathify_dirspec() */
3502 /* External entry points */
3503 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3504 { return do_pathify_dirspec(dir,buf,0); }
3505 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3506 { return do_pathify_dirspec(dir,buf,1); }
3508 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3509 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3511 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3512 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3513 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3515 if (spec == NULL) return NULL;
3516 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3517 if (buf) rslt = buf;
3519 retlen = strlen(spec);
3520 cp1 = strchr(spec,'[');
3521 if (!cp1) cp1 = strchr(spec,'<');
3523 for (cp1++; *cp1; cp1++) {
3524 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3525 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3526 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3529 New(1315,rslt,retlen+2+2*expand,char);
3531 else rslt = __tounixspec_retbuf;
3532 if (strchr(spec,'/') != NULL) {
3539 dirend = strrchr(spec,']');
3540 if (dirend == NULL) dirend = strrchr(spec,'>');
3541 if (dirend == NULL) dirend = strchr(spec,':');
3542 if (dirend == NULL) {
3546 if (*cp2 != '[' && *cp2 != '<') {
3549 else { /* the VMS spec begins with directories */
3551 if (*cp2 == ']' || *cp2 == '>') {
3552 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3555 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3556 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3557 if (ts) Safefree(rslt);
3562 while (*cp3 != ':' && *cp3) cp3++;
3564 if (strchr(cp3,']') != NULL) break;
3565 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3567 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3568 retlen = devlen + dirlen;
3569 Renew(rslt,retlen+1+2*expand,char);
3575 *(cp1++) = *(cp3++);
3576 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3580 else if ( *cp2 == '.') {
3581 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3582 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3588 for (; cp2 <= dirend; cp2++) {
3591 if (*(cp2+1) == '[') cp2++;
3593 else if (*cp2 == ']' || *cp2 == '>') {
3594 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3596 else if (*cp2 == '.') {
3598 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3599 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3600 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3601 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3602 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3604 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3605 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3609 else if (*cp2 == '-') {
3610 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3611 while (*cp2 == '-') {
3613 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3615 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3616 if (ts) Safefree(rslt); /* filespecs like */
3617 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3621 else *(cp1++) = *cp2;
3623 else *(cp1++) = *cp2;
3625 while (*cp2) *(cp1++) = *(cp2++);
3630 } /* end of do_tounixspec() */
3632 /* External entry points */
3633 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3634 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3636 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3637 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3638 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3639 char *rslt, *dirend;
3640 register char *cp1, *cp2;
3641 unsigned long int infront = 0, hasdir = 1;
3643 if (path == NULL) return NULL;
3644 if (buf) rslt = buf;
3645 else if (ts) New(1316,rslt,strlen(path)+9,char);
3646 else rslt = __tovmsspec_retbuf;
3647 if (strpbrk(path,"]:>") ||
3648 (dirend = strrchr(path,'/')) == NULL) {
3649 if (path[0] == '.') {
3650 if (path[1] == '\0') strcpy(rslt,"[]");
3651 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3652 else strcpy(rslt,path); /* probably garbage */
3654 else strcpy(rslt,path);
3657 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3658 if (!*(dirend+2)) dirend +=2;
3659 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3660 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3665 char trndev[NAM$C_MAXRSS+1];
3669 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3671 if (!buf & ts) Renew(rslt,18,char);
3672 strcpy(rslt,"sys$disk:[000000]");
3675 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3677 islnm = my_trnlnm(rslt,trndev,0);
3678 trnend = islnm ? strlen(trndev) - 1 : 0;
3679 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3680 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3681 /* If the first element of the path is a logical name, determine
3682 * whether it has to be translated so we can add more directories. */
3683 if (!islnm || rooted) {
3686 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3690 if (cp2 != dirend) {
3691 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3692 strcpy(rslt,trndev);
3693 cp1 = rslt + trnend;
3706 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3707 cp2 += 2; /* skip over "./" - it's redundant */
3708 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3710 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3711 *(cp1++) = '-'; /* "../" --> "-" */
3714 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3715 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3716 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3717 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3720 if (cp2 > dirend) cp2 = dirend;
3722 else *(cp1++) = '.';
3724 for (; cp2 < dirend; cp2++) {
3726 if (*(cp2-1) == '/') continue;
3727 if (*(cp1-1) != '.') *(cp1++) = '.';
3730 else if (!infront && *cp2 == '.') {
3731 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3732 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3733 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3734 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3735 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3736 else { /* back up over previous directory name */
3738 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3739 if (*(cp1-1) == '[') {
3740 memcpy(cp1,"000000.",7);
3745 if (cp2 == dirend) break;
3747 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3748 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3749 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3750 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3752 *(cp1++) = '.'; /* Simulate trailing '/' */
3753 cp2 += 2; /* for loop will incr this to == dirend */
3755 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3757 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3760 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3761 if (*cp2 == '.') *(cp1++) = '_';
3762 else *(cp1++) = *cp2;
3766 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3767 if (hasdir) *(cp1++) = ']';
3768 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3769 while (*cp2) *(cp1++) = *(cp2++);
3774 } /* end of do_tovmsspec() */
3776 /* External entry points */
3777 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3778 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3780 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3781 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3782 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3784 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3786 if (path == NULL) return NULL;
3787 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3788 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3789 if (buf) return buf;
3791 vmslen = strlen(vmsified);
3792 New(1317,cp,vmslen+1,char);
3793 memcpy(cp,vmsified,vmslen);
3798 strcpy(__tovmspath_retbuf,vmsified);
3799 return __tovmspath_retbuf;
3802 } /* end of do_tovmspath() */
3804 /* External entry points */
3805 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3806 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3809 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3810 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3811 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3813 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3815 if (path == NULL) return NULL;
3816 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3817 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3818 if (buf) return buf;
3820 unixlen = strlen(unixified);
3821 New(1317,cp,unixlen+1,char);
3822 memcpy(cp,unixified,unixlen);
3827 strcpy(__tounixpath_retbuf,unixified);
3828 return __tounixpath_retbuf;
3831 } /* end of do_tounixpath() */
3833 /* External entry points */
3834 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3835 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3838 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3840 *****************************************************************************
3842 * Copyright (C) 1989-1994 by *
3843 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3845 * Permission is hereby granted for the reproduction of this software, *
3846 * on condition that this copyright notice is included in the reproduction, *
3847 * and that such reproduction is not for purposes of profit or material *
3850 * 27-Aug-1994 Modified for inclusion in perl5 *
3851 * by Charles Bailey bailey@newman.upenn.edu *
3852 *****************************************************************************
3856 * getredirection() is intended to aid in porting C programs
3857 * to VMS (Vax-11 C). The native VMS environment does not support
3858 * '>' and '<' I/O redirection, or command line wild card expansion,
3859 * or a command line pipe mechanism using the '|' AND background
3860 * command execution '&'. All of these capabilities are provided to any
3861 * C program which calls this procedure as the first thing in the
3863 * The piping mechanism will probably work with almost any 'filter' type
3864 * of program. With suitable modification, it may useful for other
3865 * portability problems as well.
3867 * Author: Mark Pizzolato mark@infocomm.com
3871 struct list_item *next;
3875 static void add_item(struct list_item **head,
3876 struct list_item **tail,
3880 static void mp_expand_wild_cards(pTHX_ char *item,
3881 struct list_item **head,
3882 struct list_item **tail,
3885 static int background_process(int argc, char **argv);
3887 static void pipe_and_fork(pTHX_ char **cmargv);
3889 /*{{{ void getredirection(int *ac, char ***av)*/
3891 mp_getredirection(pTHX_ int *ac, char ***av)
3893 * Process vms redirection arg's. Exit if any error is seen.
3894 * If getredirection() processes an argument, it is erased
3895 * from the vector. getredirection() returns a new argc and argv value.
3896 * In the event that a background command is requested (by a trailing "&"),
3897 * this routine creates a background subprocess, and simply exits the program.
3899 * Warning: do not try to simplify the code for vms. The code
3900 * presupposes that getredirection() is called before any data is
3901 * read from stdin or written to stdout.
3903 * Normal usage is as follows:
3909 * getredirection(&argc, &argv);
3913 int argc = *ac; /* Argument Count */
3914 char **argv = *av; /* Argument Vector */
3915 char *ap; /* Argument pointer */
3916 int j; /* argv[] index */
3917 int item_count = 0; /* Count of Items in List */
3918 struct list_item *list_head = 0; /* First Item in List */
3919 struct list_item *list_tail; /* Last Item in List */
3920 char *in = NULL; /* Input File Name */
3921 char *out = NULL; /* Output File Name */
3922 char *outmode = "w"; /* Mode to Open Output File */
3923 char *err = NULL; /* Error File Name */
3924 char *errmode = "w"; /* Mode to Open Error File */
3925 int cmargc = 0; /* Piped Command Arg Count */
3926 char **cmargv = NULL;/* Piped Command Arg Vector */
3929 * First handle the case where the last thing on the line ends with
3930 * a '&'. This indicates the desire for the command to be run in a
3931 * subprocess, so we satisfy that desire.
3934 if (0 == strcmp("&", ap))
3935 exit(background_process(--argc, argv));
3936 if (*ap && '&' == ap[strlen(ap)-1])
3938 ap[strlen(ap)-1] = '\0';
3939 exit(background_process(argc, argv));
3942 * Now we handle the general redirection cases that involve '>', '>>',
3943 * '<', and pipes '|'.
3945 for (j = 0; j < argc; ++j)
3947 if (0 == strcmp("<", argv[j]))
3951 fprintf(stderr,"No input file after < on command line");
3952 exit(LIB$_WRONUMARG);
3957 if ('<' == *(ap = argv[j]))
3962 if (0 == strcmp(">", ap))
3966 fprintf(stderr,"No output file after > on command line");
3967 exit(LIB$_WRONUMARG);
3986 fprintf(stderr,"No output file after > or >> on command line");
3987 exit(LIB$_WRONUMARG);
3991 if (('2' == *ap) && ('>' == ap[1]))
4008 fprintf(stderr,"No output file after 2> or 2>> on command line");
4009 exit(LIB$_WRONUMARG);
4013 if (0 == strcmp("|", argv[j]))
4017 fprintf(stderr,"No command into which to pipe on command line");
4018 exit(LIB$_WRONUMARG);
4020 cmargc = argc-(j+1);
4021 cmargv = &argv[j+1];
4025 if ('|' == *(ap = argv[j]))
4033 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4036 * Allocate and fill in the new argument vector, Some Unix's terminate
4037 * the list with an extra null pointer.
4039 New(1302, argv, item_count+1, char *);
4041 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4042 argv[j] = list_head->value;
4048 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4049 exit(LIB$_INVARGORD);
4051 pipe_and_fork(aTHX_ cmargv);
4054 /* Check for input from a pipe (mailbox) */
4056 if (in == NULL && 1 == isapipe(0))
4058 char mbxname[L_tmpnam];
4060 long int dvi_item = DVI$_DEVBUFSIZ;
4061 $DESCRIPTOR(mbxnam, "");
4062 $DESCRIPTOR(mbxdevnam, "");
4064 /* Input from a pipe, reopen it in binary mode to disable */
4065 /* carriage control processing. */
4067 fgetname(stdin, mbxname);
4068 mbxnam.dsc$a_pointer = mbxname;
4069 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4070 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4071 mbxdevnam.dsc$a_pointer = mbxname;
4072 mbxdevnam.dsc$w_length = sizeof(mbxname);
4073 dvi_item = DVI$_DEVNAM;
4074 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4075 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4078 freopen(mbxname, "rb", stdin);
4081 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4085 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4087 fprintf(stderr,"Can't open input file %s as stdin",in);
4090 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4092 fprintf(stderr,"Can't open output file %s as stdout",out);
4095 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4098 if (strcmp(err,"&1") == 0) {
4099 dup2(fileno(stdout), fileno(stderr));
4100 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4103 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4105 fprintf(stderr,"Can't open error file %s as stderr",err);
4109 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4113 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4116 #ifdef ARGPROC_DEBUG
4117 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4118 for (j = 0; j < *ac; ++j)
4119 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4121 /* Clear errors we may have hit expanding wildcards, so they don't
4122 show up in Perl's $! later */
4123 set_errno(0); set_vaxc_errno(1);
4124 } /* end of getredirection() */
4127 static void add_item(struct list_item **head,
4128 struct list_item **tail,
4134 New(1303,*head,1,struct list_item);
4138 New(1304,(*tail)->next,1,struct list_item);
4139 *tail = (*tail)->next;
4141 (*tail)->value = value;
4145 static void mp_expand_wild_cards(pTHX_ char *item,
4146 struct list_item **head,
4147 struct list_item **tail,
4151 unsigned long int context = 0;
4157 char vmsspec[NAM$C_MAXRSS+1];
4158 $DESCRIPTOR(filespec, "");
4159 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4160 $DESCRIPTOR(resultspec, "");
4161 unsigned long int zero = 0, sts;
4163 for (cp = item; *cp; cp++) {
4164 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4165 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4167 if (!*cp || isspace(*cp))
4169 add_item(head, tail, item, count);
4172 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4173 resultspec.dsc$b_class = DSC$K_CLASS_D;
4174 resultspec.dsc$a_pointer = NULL;
4175 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4176 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4177 if (!isunix || !filespec.dsc$a_pointer)
4178 filespec.dsc$a_pointer = item;
4179 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4181 * Only return version specs, if the caller specified a version
4183 had_version = strchr(item, ';');
4185 * Only return device and directory specs, if the caller specifed either.
4187 had_device = strchr(item, ':');
4188 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4190 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4191 &defaultspec, 0, 0, &zero))))
4196 New(1305,string,resultspec.dsc$w_length+1,char);
4197 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4198 string[resultspec.dsc$w_length] = '\0';
4199 if (NULL == had_version)
4200 *((char *)strrchr(string, ';')) = '\0';
4201 if ((!had_directory) && (had_device == NULL))
4203 if (NULL == (devdir = strrchr(string, ']')))
4204 devdir = strrchr(string, '>');
4205 strcpy(string, devdir + 1);
4208 * Be consistent with what the C RTL has already done to the rest of
4209 * the argv items and lowercase all of these names.
4211 for (c = string; *c; ++c)
4214 if (isunix) trim_unixpath(string,item,1);
4215 add_item(head, tail, string, count);
4218 if (sts != RMS$_NMF)
4220 set_vaxc_errno(sts);
4223 case RMS$_FNF: case RMS$_DNF:
4224 set_errno(ENOENT); break;
4226 set_errno(ENOTDIR); break;
4228 set_errno(ENODEV); break;
4229 case RMS$_FNM: case RMS$_SYN:
4230 set_errno(EINVAL); break;
4232 set_errno(EACCES); break;
4234 _ckvmssts_noperl(sts);
4238 add_item(head, tail, item, count);
4239 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4240 _ckvmssts_noperl(lib$find_file_end(&context));
4243 static int child_st[2];/* Event Flag set when child process completes */
4245 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4247 static unsigned long int exit_handler(int *status)
4251 if (0 == child_st[0])
4253 #ifdef ARGPROC_DEBUG
4254 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4256 fflush(stdout); /* Have to flush pipe for binary data to */
4257 /* terminate properly -- <tp@mccall.com> */
4258 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4259 sys$dassgn(child_chan);
4261 sys$synch(0, child_st);
4266 static void sig_child(int chan)
4268 #ifdef ARGPROC_DEBUG
4269 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4271 if (child_st[0] == 0)
4275 static struct exit_control_block exit_block =
4280 &exit_block.exit_status,
4285 pipe_and_fork(pTHX_ char **cmargv)
4288 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4289 int sts, j, l, ismcr, quote, tquote = 0;
4291 sts = setup_cmddsc(cmargv[0],0,"e);
4296 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4297 && toupper(*(q+2)) == 'R' && !*(q+3);
4299 while (q && l < MAX_DCL_LINE_LENGTH) {
4301 if (j > 0 && quote) {
4307 if (ismcr && j > 1) quote = 1;
4308 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4311 if (quote || tquote) {
4317 if ((quote||tquote) && *q == '"') {
4327 fp = safe_popen(subcmd,"wbF",&sts);
4329 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4333 static int background_process(int argc, char **argv)
4335 char command[2048] = "$";
4336 $DESCRIPTOR(value, "");
4337 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4338 static $DESCRIPTOR(null, "NLA0:");
4339 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4341 $DESCRIPTOR(pidstr, "");
4343 unsigned long int flags = 17, one = 1, retsts;
4345 strcat(command, argv[0]);
4348 strcat(command, " \"");
4349 strcat(command, *(++argv));
4350 strcat(command, "\"");
4352 value.dsc$a_pointer = command;
4353 value.dsc$w_length = strlen(value.dsc$a_pointer);
4354 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4355 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4356 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4357 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4360 _ckvmssts_noperl(retsts);
4362 #ifdef ARGPROC_DEBUG
4363 PerlIO_printf(Perl_debug_log, "%s\n", command);
4365 sprintf(pidstring, "%08X", pid);
4366 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4367 pidstr.dsc$a_pointer = pidstring;
4368 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4369 lib$set_symbol(&pidsymbol, &pidstr);
4373 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4376 /* OS-specific initialization at image activation (not thread startup) */
4377 /* Older VAXC header files lack these constants */
4378 #ifndef JPI$_RIGHTS_SIZE
4379 # define JPI$_RIGHTS_SIZE 817
4381 #ifndef KGB$M_SUBSYSTEM
4382 # define KGB$M_SUBSYSTEM 0x8
4385 /*{{{void vms_image_init(int *, char ***)*/
4387 vms_image_init(int *argcp, char ***argvp)
4389 char eqv[LNM$C_NAMLENGTH+1] = "";
4390 unsigned int len, tabct = 8, tabidx = 0;
4391 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4392 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4393 unsigned short int dummy, rlen;
4394 struct dsc$descriptor_s **tabvec;
4395 #if defined(PERL_IMPLICIT_CONTEXT)
4398 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4399 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4400 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4403 #ifdef KILL_BY_SIGPRC
4404 (void) Perl_csighandler_init();
4407 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4408 _ckvmssts_noperl(iosb[0]);
4409 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4410 if (iprv[i]) { /* Running image installed with privs? */
4411 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4416 /* Rights identifiers might trigger tainting as well. */
4417 if (!will_taint && (rlen || rsz)) {
4418 while (rlen < rsz) {
4419 /* We didn't get all the identifiers on the first pass. Allocate a
4420 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4421 * were needed to hold all identifiers at time of last call; we'll
4422 * allocate that many unsigned long ints), and go back and get 'em.
4423 * If it gave us less than it wanted to despite ample buffer space,
4424 * something's broken. Is your system missing a system identifier?
4426 if (rsz <= jpilist[1].buflen) {
4427 /* Perl_croak accvios when used this early in startup. */
4428 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4429 rsz, (unsigned long) jpilist[1].buflen,
4430 "Check your rights database for corruption.\n");
4433 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4434 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4435 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4436 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4437 _ckvmssts_noperl(iosb[0]);
4439 mask = jpilist[1].bufadr;
4440 /* Check attribute flags for each identifier (2nd longword); protected
4441 * subsystem identifiers trigger tainting.
4443 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4444 if (mask[i] & KGB$M_SUBSYSTEM) {
4449 if (mask != rlst) Safefree(mask);
4451 /* We need to use this hack to tell Perl it should run with tainting,
4452 * since its tainting flag may be part of the PL_curinterp struct, which
4453 * hasn't been allocated when vms_image_init() is called.
4457 New(1320,newap,*argcp+2,char **);
4458 newap[0] = argvp[0];
4460 Copy(argvp[1],newap[2],*argcp-1,char **);
4461 /* We orphan the old argv, since we don't know where it's come from,
4462 * so we don't know how to free it.
4464 *argcp++; argvp = newap;
4466 else { /* Did user explicitly request tainting? */
4468 char *cp, **av = *argvp;
4469 for (i = 1; i < *argcp; i++) {
4470 if (*av[i] != '-') break;
4471 for (cp = av[i]+1; *cp; cp++) {
4472 if (*cp == 'T') { will_taint = 1; break; }
4473 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4474 strchr("DFIiMmx",*cp)) break;
4476 if (will_taint) break;
4481 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4483 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4484 else if (tabidx >= tabct) {
4486 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4488 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4489 tabvec[tabidx]->dsc$w_length = 0;
4490 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4491 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4492 tabvec[tabidx]->dsc$a_pointer = NULL;
4493 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4495 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4497 getredirection(argcp,argvp);
4498 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4500 # include <reentrancy.h>
4501 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4510 * Trim Unix-style prefix off filespec, so it looks like what a shell
4511 * glob expansion would return (i.e. from specified prefix on, not
4512 * full path). Note that returned filespec is Unix-style, regardless
4513 * of whether input filespec was VMS-style or Unix-style.
4515 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4516 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4517 * vector of options; at present, only bit 0 is used, and if set tells
4518 * trim unixpath to try the current default directory as a prefix when
4519 * presented with a possibly ambiguous ... wildcard.
4521 * Returns !=0 on success, with trimmed filespec replacing contents of
4522 * fspec, and 0 on failure, with contents of fpsec unchanged.
4524 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4526 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4528 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4529 *template, *base, *end, *cp1, *cp2;
4530 register int tmplen, reslen = 0, dirs = 0;
4532 if (!wildspec || !fspec) return 0;
4533 if (strpbrk(wildspec,"]>:") != NULL) {
4534 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4535 else template = unixwild;
4537 else template = wildspec;
4538 if (strpbrk(fspec,"]>:") != NULL) {
4539 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4540 else base = unixified;
4541 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4542 * check to see that final result fits into (isn't longer than) fspec */
4543 reslen = strlen(fspec);
4547 /* No prefix or absolute path on wildcard, so nothing to remove */
4548 if (!*template || *template == '/') {
4549 if (base == fspec) return 1;
4550 tmplen = strlen(unixified);
4551 if (tmplen > reslen) return 0; /* not enough space */
4552 /* Copy unixified resultant, including trailing NUL */
4553 memmove(fspec,unixified,tmplen+1);
4557 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4558 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4559 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4560 for (cp1 = end ;cp1 >= base; cp1--)
4561 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4563 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4567 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4568 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4569 int ells = 1, totells, segdirs, match;
4570 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4571 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4573 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4575 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4576 if (ellipsis == template && opts & 1) {
4577 /* Template begins with an ellipsis. Since we can't tell how many
4578 * directory names at the front of the resultant to keep for an
4579 * arbitrary starting point, we arbitrarily choose the current
4580 * default directory as a starting point. If it's there as a prefix,
4581 * clip it off. If not, fall through and act as if the leading
4582 * ellipsis weren't there (i.e. return shortest possible path that
4583 * could match template).
4585 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4586 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4587 if (_tolower(*cp1) != _tolower(*cp2)) break;
4588 segdirs = dirs - totells; /* Min # of dirs we must have left */
4589 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4590 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4591 memcpy(fspec,cp2+1,end - cp2);
4595 /* First off, back up over constant elements at end of path */
4597 for (front = end ; front >= base; front--)
4598 if (*front == '/' && !dirs--) { front++; break; }
4600 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4601 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4602 if (cp1 != '\0') return 0; /* Path too long. */
4604 *cp2 = '\0'; /* Pick up with memcpy later */
4605 lcfront = lcres + (front - base);
4606 /* Now skip over each ellipsis and try to match the path in front of it. */
4608 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4609 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4610 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4611 if (cp1 < template) break; /* template started with an ellipsis */
4612 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4613 ellipsis = cp1; continue;
4615 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4617 for (segdirs = 0, cp2 = tpl;
4618 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4620 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4621 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4622 if (*cp2 == '/') segdirs++;
4624 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4625 /* Back up at least as many dirs as in template before matching */
4626 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4627 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4628 for (match = 0; cp1 > lcres;) {
4629 resdsc.dsc$a_pointer = cp1;
4630 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4632 if (match == 1) lcfront = cp1;
4634 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4636 if (!match) return 0; /* Can't find prefix ??? */
4637 if (match > 1 && opts & 1) {
4638 /* This ... wildcard could cover more than one set of dirs (i.e.
4639 * a set of similar dir names is repeated). If the template
4640 * contains more than 1 ..., upstream elements could resolve the
4641 * ambiguity, but it's not worth a full backtracking setup here.
4642 * As a quick heuristic, clip off the current default directory
4643 * if it's present to find the trimmed spec, else use the
4644 * shortest string that this ... could cover.
4646 char def[NAM$C_MAXRSS+1], *st;
4648 if (getcwd(def, sizeof def,0) == NULL) return 0;
4649 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4650 if (_tolower(*cp1) != _tolower(*cp2)) break;
4651 segdirs = dirs - totells; /* Min # of dirs we must have left */
4652 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4653 if (*cp1 == '\0' && *cp2 == '/') {
4654 memcpy(fspec,cp2+1,end - cp2);
4657 /* Nope -- stick with lcfront from above and keep going. */
4660 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4665 } /* end of trim_unixpath() */
4670 * VMS readdir() routines.
4671 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4673 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4674 * Minor modifications to original routines.
4677 /* Number of elements in vms_versions array */
4678 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4681 * Open a directory, return a handle for later use.
4683 /*{{{ DIR *opendir(char*name) */
4685 Perl_opendir(pTHX_ char *name)
4688 char dir[NAM$C_MAXRSS+1];
4691 if (do_tovmspath(name,dir,0) == NULL) {
4694 if (flex_stat(dir,&sb) == -1) return NULL;
4695 if (!S_ISDIR(sb.st_mode)) {
4696 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4699 if (!cando_by_name(S_IRUSR,0,dir)) {
4700 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4703 /* Get memory for the handle, and the pattern. */
4705 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4707 /* Fill in the fields; mainly playing with the descriptor. */
4708 (void)sprintf(dd->pattern, "%s*.*",dir);
4711 dd->vms_wantversions = 0;
4712 dd->pat.dsc$a_pointer = dd->pattern;
4713 dd->pat.dsc$w_length = strlen(dd->pattern);
4714 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4715 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4718 } /* end of opendir() */
4722 * Set the flag to indicate we want versions or not.
4724 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4726 vmsreaddirversions(DIR *dd, int flag)
4728 dd->vms_wantversions = flag;
4733 * Free up an opened directory.
4735 /*{{{ void closedir(DIR *dd)*/
4739 (void)lib$find_file_end(&dd->context);
4740 Safefree(dd->pattern);
4741 Safefree((char *)dd);
4746 * Collect all the version numbers for the current file.
4749 collectversions(pTHX_ DIR *dd)
4751 struct dsc$descriptor_s pat;
4752 struct dsc$descriptor_s res;
4754 char *p, *text, buff[sizeof dd->entry.d_name];
4756 unsigned long context, tmpsts;
4758 /* Convenient shorthand. */
4761 /* Add the version wildcard, ignoring the "*.*" put on before */
4762 i = strlen(dd->pattern);
4763 New(1308,text,i + e->d_namlen + 3,char);
4764 (void)strcpy(text, dd->pattern);
4765 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4767 /* Set up the pattern descriptor. */
4768 pat.dsc$a_pointer = text;
4769 pat.dsc$w_length = i + e->d_namlen - 1;
4770 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4771 pat.dsc$b_class = DSC$K_CLASS_S;
4773 /* Set up result descriptor. */
4774 res.dsc$a_pointer = buff;
4775 res.dsc$w_length = sizeof buff - 2;
4776 res.dsc$b_dtype = DSC$K_DTYPE_T;
4777 res.dsc$b_class = DSC$K_CLASS_S;
4779 /* Read files, collecting versions. */
4780 for (context = 0, e->vms_verscount = 0;
4781 e->vms_verscount < VERSIZE(e);
4782 e->vms_verscount++) {
4783 tmpsts = lib$find_file(&pat, &res, &context);
4784 if (tmpsts == RMS$_NMF || context == 0) break;
4786 buff[sizeof buff - 1] = '\0';
4787 if ((p = strchr(buff, ';')))
4788 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4790 e->vms_versions[e->vms_verscount] = -1;
4793 _ckvmssts(lib$find_file_end(&context));
4796 } /* end of collectversions() */
4799 * Read the next entry from the directory.
4801 /*{{{ struct dirent *readdir(DIR *dd)*/
4803 Perl_readdir(pTHX_ DIR *dd)
4805 struct dsc$descriptor_s res;
4806 char *p, buff[sizeof dd->entry.d_name];
4807 unsigned long int tmpsts;
4809 /* Set up result descriptor, and get next file. */
4810 res.dsc$a_pointer = buff;
4811 res.dsc$w_length = sizeof buff - 2;
4812 res.dsc$b_dtype = DSC$K_DTYPE_T;
4813 res.dsc$b_class = DSC$K_CLASS_S;
4814 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4815 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4816 if (!(tmpsts & 1)) {
4817 set_vaxc_errno(tmpsts);
4820 set_errno(EACCES); break;
4822 set_errno(ENODEV); break;
4824 set_errno(ENOTDIR); break;
4825 case RMS$_FNF: case RMS$_DNF:
4826 set_errno(ENOENT); break;
4833 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4834 buff[sizeof buff - 1] = '\0';
4835 for (p = buff; *p; p++) *p = _tolower(*p);
4836 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4839 /* Skip any directory component and just copy the name. */
4840 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4841 else (void)strcpy(dd->entry.d_name, buff);
4843 /* Clobber the version. */
4844 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4846 dd->entry.d_namlen = strlen(dd->entry.d_name);
4847 dd->entry.vms_verscount = 0;
4848 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4851 } /* end of readdir() */
4855 * Return something that can be used in a seekdir later.
4857 /*{{{ long telldir(DIR *dd)*/
4866 * Return to a spot where we used to be. Brute force.
4868 /*{{{ void seekdir(DIR *dd,long count)*/
4870 Perl_seekdir(pTHX_ DIR *dd, long count)
4872 int vms_wantversions;
4874 /* If we haven't done anything yet... */
4878 /* Remember some state, and clear it. */
4879 vms_wantversions = dd->vms_wantversions;
4880 dd->vms_wantversions = 0;
4881 _ckvmssts(lib$find_file_end(&dd->context));
4884 /* The increment is in readdir(). */
4885 for (dd->count = 0; dd->count < count; )
4888 dd->vms_wantversions = vms_wantversions;
4890 } /* end of seekdir() */
4893 /* VMS subprocess management
4895 * my_vfork() - just a vfork(), after setting a flag to record that
4896 * the current script is trying a Unix-style fork/exec.
4898 * vms_do_aexec() and vms_do_exec() are called in response to the
4899 * perl 'exec' function. If this follows a vfork call, then they
4900 * call out the the regular perl routines in doio.c which do an
4901 * execvp (for those who really want to try this under VMS).
4902 * Otherwise, they do exactly what the perl docs say exec should
4903 * do - terminate the current script and invoke a new command
4904 * (See below for notes on command syntax.)
4906 * do_aspawn() and do_spawn() implement the VMS side of the perl
4907 * 'system' function.
4909 * Note on command arguments to perl 'exec' and 'system': When handled
4910 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4911 * are concatenated to form a DCL command string. If the first arg
4912 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4913 * the the command string is handed off to DCL directly. Otherwise,
4914 * the first token of the command is taken as the filespec of an image
4915 * to run. The filespec is expanded using a default type of '.EXE' and
4916 * the process defaults for device, directory, etc., and if found, the resultant
4917 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4918 * the command string as parameters. This is perhaps a bit complicated,
4919 * but I hope it will form a happy medium between what VMS folks expect
4920 * from lib$spawn and what Unix folks expect from exec.
4923 static int vfork_called;
4925 /*{{{int my_vfork()*/
4936 vms_execfree(pTHX) {
4938 if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
4941 if (VMSCMD.dsc$a_pointer) {
4942 Safefree(VMSCMD.dsc$a_pointer);
4943 VMSCMD.dsc$w_length = 0;
4944 VMSCMD.dsc$a_pointer = Nullch;
4949 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4951 char *junk, *tmps = Nullch;
4952 register size_t cmdlen = 0;
4959 tmps = SvPV(really,rlen);
4966 for (idx++; idx <= sp; idx++) {
4968 junk = SvPVx(*idx,rlen);
4969 cmdlen += rlen ? rlen + 1 : 0;
4972 New(401,PL_Cmd,cmdlen+1,char);
4974 if (tmps && *tmps) {
4975 strcpy(PL_Cmd,tmps);
4978 else *PL_Cmd = '\0';
4979 while (++mark <= sp) {
4981 char *s = SvPVx(*mark,n_a);
4983 if (*PL_Cmd) strcat(PL_Cmd," ");
4989 } /* end of setup_argstr() */
4992 static unsigned long int
4993 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
4995 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4996 $DESCRIPTOR(defdsc,".EXE");
4997 $DESCRIPTOR(defdsc2,".");
4998 $DESCRIPTOR(resdsc,resspec);
4999 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5000 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5001 register char *s, *rest, *cp, *wordbreak;
5004 if (suggest_quote) *suggest_quote = 0;
5006 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5007 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5009 while (*s && isspace(*s)) s++;
5011 if (*s == '@' || *s == '$') {
5012 vmsspec[0] = *s; rest = s + 1;
5013 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5015 else { cp = vmsspec; rest = s; }
5016 if (*rest == '.' || *rest == '/') {
5019 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5020 rest++, cp2++) *cp2 = *rest;
5022 if (do_tovmsspec(resspec,cp,0)) {
5025 for (cp2 = vmsspec + strlen(vmsspec);
5026 *rest && cp2 - vmsspec < sizeof vmsspec;
5027 rest++, cp2++) *cp2 = *rest;
5032 /* Intuit whether verb (first word of cmd) is a DCL command:
5033 * - if first nonspace char is '@', it's a DCL indirection
5035 * - if verb contains a filespec separator, it's not a DCL command
5036 * - if it doesn't, caller tells us whether to default to a DCL
5037 * command, or to a local image unless told it's DCL (by leading '$')
5041 if (suggest_quote) *suggest_quote = 1;
5043 register char *filespec = strpbrk(s,":<[.;");
5044 rest = wordbreak = strpbrk(s," \"\t/");
5045 if (!wordbreak) wordbreak = s + strlen(s);
5046 if (*s == '$') check_img = 0;
5047 if (filespec && (filespec < wordbreak)) isdcl = 0;
5048 else isdcl = !check_img;
5052 imgdsc.dsc$a_pointer = s;
5053 imgdsc.dsc$w_length = wordbreak - s;
5054 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5056 _ckvmssts(lib$find_file_end(&cxt));
5057 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5058 if (!(retsts & 1) && *s == '$') {
5059 _ckvmssts(lib$find_file_end(&cxt));
5060 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5061 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5063 _ckvmssts(lib$find_file_end(&cxt));
5064 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5068 _ckvmssts(lib$find_file_end(&cxt));
5073 while (*s && !isspace(*s)) s++;
5076 /* check that it's really not DCL with no file extension */
5077 fp = fopen(resspec,"r","ctx=bin,shr=get");
5079 char b[4] = {0,0,0,0};
5080 read(fileno(fp),b,4);
5081 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5084 if (check_img && isdcl) return RMS$_FNF;
5086 if (cando_by_name(S_IXUSR,0,resspec)) {
5087 New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5089 strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
5090 if (suggest_quote) *suggest_quote = 1;
5092 strcpy(VMSCMD.dsc$a_pointer,"@");
5093 if (suggest_quote) *suggest_quote = 1;
5095 strcat(VMSCMD.dsc$a_pointer,resspec);
5096 if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
5097 VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
5098 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5100 else retsts = RMS$_PRV;
5103 /* It's either a DCL command or we couldn't find a suitable image */
5104 VMSCMD.dsc$w_length = strlen(cmd);
5105 if (cmd == PL_Cmd) {
5106 VMSCMD.dsc$a_pointer = PL_Cmd;
5107 if (suggest_quote) *suggest_quote = 1;
5109 else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
5111 /* check if it's a symbol (for quoting purposes) */
5112 if (suggest_quote && !*suggest_quote) {
5114 char equiv[LNM$C_NAMLENGTH];
5115 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5116 eqvdsc.dsc$a_pointer = equiv;
5118 iss = lib$get_symbol(&VMSCMD,&eqvdsc);
5119 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5121 if (!(retsts & 1)) {
5122 /* just hand off status values likely to be due to user error */
5123 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5124 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5125 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5126 else { _ckvmssts(retsts); }
5129 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5131 } /* end of setup_cmddsc() */
5134 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5136 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5139 if (vfork_called) { /* this follows a vfork - act Unixish */
5141 if (vfork_called < 0) {
5142 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5145 else return do_aexec(really,mark,sp);
5147 /* no vfork - act VMSish */
5148 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5153 } /* end of vms_do_aexec() */
5156 /* {{{bool vms_do_exec(char *cmd) */
5158 Perl_vms_do_exec(pTHX_ char *cmd)
5161 if (vfork_called) { /* this follows a vfork - act Unixish */
5163 if (vfork_called < 0) {
5164 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5167 else return do_exec(cmd);
5170 { /* no vfork - act VMSish */
5171 unsigned long int retsts;
5174 TAINT_PROPER("exec");
5175 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
5176 retsts = lib$do_command(&VMSCMD);
5179 case RMS$_FNF: case RMS$_DNF:
5180 set_errno(ENOENT); break;
5182 set_errno(ENOTDIR); break;
5184 set_errno(ENODEV); break;
5186 set_errno(EACCES); break;
5188 set_errno(EINVAL); break;
5189 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5190 set_errno(E2BIG); break;
5191 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5192 _ckvmssts(retsts); /* fall through */
5193 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5196 set_vaxc_errno(retsts);
5197 if (ckWARN(WARN_EXEC)) {
5198 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
5199 VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
5206 } /* end of vms_do_exec() */
5209 unsigned long int Perl_do_spawn(pTHX_ char *);
5211 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5213 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5215 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5218 } /* end of do_aspawn() */
5221 /* {{{unsigned long int do_spawn(char *cmd) */
5223 Perl_do_spawn(pTHX_ char *cmd)
5225 unsigned long int sts, substs;
5228 TAINT_PROPER("spawn");
5229 if (!cmd || !*cmd) {
5230 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5233 case RMS$_FNF: case RMS$_DNF:
5234 set_errno(ENOENT); break;
5236 set_errno(ENOTDIR); break;
5238 set_errno(ENODEV); break;
5240 set_errno(EACCES); break;
5242 set_errno(EINVAL); break;
5243 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5244 set_errno(E2BIG); break;
5245 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5246 _ckvmssts(sts); /* fall through */
5247 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5250 set_vaxc_errno(sts);
5251 if (ckWARN(WARN_EXEC)) {
5252 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
5259 (void) safe_popen(cmd, "nW", (int *)&sts);
5262 } /* end of do_spawn() */
5266 static unsigned int *sockflags, sockflagsize;
5269 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5270 * routines found in some versions of the CRTL can't deal with sockets.
5271 * We don't shim the other file open routines since a socket isn't
5272 * likely to be opened by a name.
5274 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5275 FILE *my_fdopen(int fd, const char *mode)
5277 FILE *fp = fdopen(fd, (char *) mode);
5280 unsigned int fdoff = fd / sizeof(unsigned int);
5281 struct stat sbuf; /* native stat; we don't need flex_stat */
5282 if (!sockflagsize || fdoff > sockflagsize) {
5283 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5284 else New (1324,sockflags,fdoff+2,unsigned int);
5285 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5286 sockflagsize = fdoff + 2;
5288 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5289 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5298 * Clear the corresponding bit when the (possibly) socket stream is closed.
5299 * There still a small hole: we miss an implicit close which might occur
5300 * via freopen(). >> Todo
5302 /*{{{ int my_fclose(FILE *fp)*/
5303 int my_fclose(FILE *fp) {
5305 unsigned int fd = fileno(fp);
5306 unsigned int fdoff = fd / sizeof(unsigned int);
5308 if (sockflagsize && fdoff <= sockflagsize)
5309 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5317 * A simple fwrite replacement which outputs itmsz*nitm chars without
5318 * introducing record boundaries every itmsz chars.
5319 * We are using fputs, which depends on a terminating null. We may
5320 * well be writing binary data, so we need to accommodate not only
5321 * data with nulls sprinkled in the middle but also data with no null
5324 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5326 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5328 register char *cp, *end, *cpd, *data;
5329 register unsigned int fd = fileno(dest);
5330 register unsigned int fdoff = fd / sizeof(unsigned int);
5332 int bufsize = itmsz * nitm + 1;
5334 if (fdoff < sockflagsize &&
5335 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5336 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5340 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5341 memcpy( data, src, itmsz*nitm );
5342 data[itmsz*nitm] = '\0';
5344 end = data + itmsz * nitm;
5345 retval = (int) nitm; /* on success return # items written */
5348 while (cpd <= end) {
5349 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5350 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5352 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5356 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5359 } /* end of my_fwrite() */
5362 /*{{{ int my_flush(FILE *fp)*/
5364 Perl_my_flush(pTHX_ FILE *fp)
5367 if ((res = fflush(fp)) == 0 && fp) {
5368 #ifdef VMS_DO_SOCKETS
5370 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5372 res = fsync(fileno(fp));
5375 * If the flush succeeded but set end-of-file, we need to clear
5376 * the error because our caller may check ferror(). BTW, this
5377 * probably means we just flushed an empty file.
5379 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5386 * Here are replacements for the following Unix routines in the VMS environment:
5387 * getpwuid Get information for a particular UIC or UID
5388 * getpwnam Get information for a named user
5389 * getpwent Get information for each user in the rights database
5390 * setpwent Reset search to the start of the rights database
5391 * endpwent Finish searching for users in the rights database
5393 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5394 * (defined in pwd.h), which contains the following fields:-
5396 * char *pw_name; Username (in lower case)
5397 * char *pw_passwd; Hashed password
5398 * unsigned int pw_uid; UIC
5399 * unsigned int pw_gid; UIC group number
5400 * char *pw_unixdir; Default device/directory (VMS-style)
5401 * char *pw_gecos; Owner name
5402 * char *pw_dir; Default device/directory (Unix-style)
5403 * char *pw_shell; Default CLI name (eg. DCL)
5405 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5407 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5408 * not the UIC member number (eg. what's returned by getuid()),
5409 * getpwuid() can accept either as input (if uid is specified, the caller's
5410 * UIC group is used), though it won't recognise gid=0.
5412 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5413 * information about other users in your group or in other groups, respectively.
5414 * If the required privilege is not available, then these routines fill only
5415 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5418 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5421 /* sizes of various UAF record fields */
5422 #define UAI$S_USERNAME 12
5423 #define UAI$S_IDENT 31
5424 #define UAI$S_OWNER 31
5425 #define UAI$S_DEFDEV 31
5426 #define UAI$S_DEFDIR 63
5427 #define UAI$S_DEFCLI 31
5430 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5431 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5432 (uic).uic$v_group != UIC$K_WILD_GROUP)
5434 static char __empty[]= "";
5435 static struct passwd __passwd_empty=
5436 {(char *) __empty, (char *) __empty, 0, 0,
5437 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5438 static int contxt= 0;
5439 static struct passwd __pwdcache;
5440 static char __pw_namecache[UAI$S_IDENT+1];
5443 * This routine does most of the work extracting the user information.
5445 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5448 unsigned char length;
5449 char pw_gecos[UAI$S_OWNER+1];
5451 static union uicdef uic;
5453 unsigned char length;
5454 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5457 unsigned char length;
5458 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5461 unsigned char length;
5462 char pw_shell[UAI$S_DEFCLI+1];
5464 static char pw_passwd[UAI$S_PWD+1];
5466 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5467 struct dsc$descriptor_s name_desc;
5468 unsigned long int sts;
5470 static struct itmlst_3 itmlst[]= {
5471 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5472 {sizeof(uic), UAI$_UIC, &uic, &luic},
5473 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5474 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5475 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5476 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5477 {0, 0, NULL, NULL}};
5479 name_desc.dsc$w_length= strlen(name);
5480 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5481 name_desc.dsc$b_class= DSC$K_CLASS_S;
5482 name_desc.dsc$a_pointer= (char *) name;
5484 /* Note that sys$getuai returns many fields as counted strings. */
5485 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5486 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5487 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5489 else { _ckvmssts(sts); }
5490 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5492 if ((int) owner.length < lowner) lowner= (int) owner.length;
5493 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5494 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5495 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5496 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5497 owner.pw_gecos[lowner]= '\0';
5498 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5499 defcli.pw_shell[ldefcli]= '\0';
5500 if (valid_uic(uic)) {
5501 pwd->pw_uid= uic.uic$l_uic;
5502 pwd->pw_gid= uic.uic$v_group;
5505 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5506 pwd->pw_passwd= pw_passwd;
5507 pwd->pw_gecos= owner.pw_gecos;
5508 pwd->pw_dir= defdev.pw_dir;
5509 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5510 pwd->pw_shell= defcli.pw_shell;
5511 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5513 ldir= strlen(pwd->pw_unixdir) - 1;
5514 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5517 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5518 __mystrtolower(pwd->pw_unixdir);
5523 * Get information for a named user.
5525 /*{{{struct passwd *getpwnam(char *name)*/
5526 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5528 struct dsc$descriptor_s name_desc;
5530 unsigned long int status, sts;
5532 __pwdcache = __passwd_empty;
5533 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5534 /* We still may be able to determine pw_uid and pw_gid */
5535 name_desc.dsc$w_length= strlen(name);
5536 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5537 name_desc.dsc$b_class= DSC$K_CLASS_S;
5538 name_desc.dsc$a_pointer= (char *) name;
5539 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5540 __pwdcache.pw_uid= uic.uic$l_uic;
5541 __pwdcache.pw_gid= uic.uic$v_group;
5544 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5545 set_vaxc_errno(sts);
5546 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5549 else { _ckvmssts(sts); }
5552 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5553 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5554 __pwdcache.pw_name= __pw_namecache;
5556 } /* end of my_getpwnam() */
5560 * Get information for a particular UIC or UID.
5561 * Called by my_getpwent with uid=-1 to list all users.
5563 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5564 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5566 const $DESCRIPTOR(name_desc,__pw_namecache);
5567 unsigned short lname;
5569 unsigned long int status;
5571 if (uid == (unsigned int) -1) {
5573 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5574 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5575 set_vaxc_errno(status);
5576 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5580 else { _ckvmssts(status); }
5581 } while (!valid_uic (uic));
5585 if (!uic.uic$v_group)
5586 uic.uic$v_group= PerlProc_getgid();
5588 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5589 else status = SS$_IVIDENT;
5590 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5591 status == RMS$_PRV) {
5592 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5595 else { _ckvmssts(status); }
5597 __pw_namecache[lname]= '\0';
5598 __mystrtolower(__pw_namecache);
5600 __pwdcache = __passwd_empty;
5601 __pwdcache.pw_name = __pw_namecache;
5603 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5604 The identifier's value is usually the UIC, but it doesn't have to be,
5605 so if we can, we let fillpasswd update this. */
5606 __pwdcache.pw_uid = uic.uic$l_uic;
5607 __pwdcache.pw_gid = uic.uic$v_group;
5609 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5612 } /* end of my_getpwuid() */
5616 * Get information for next user.
5618 /*{{{struct passwd *my_getpwent()*/
5619 struct passwd *Perl_my_getpwent(pTHX)
5621 return (my_getpwuid((unsigned int) -1));
5626 * Finish searching rights database for users.
5628 /*{{{void my_endpwent()*/
5629 void Perl_my_endpwent(pTHX)
5632 _ckvmssts(sys$finish_rdb(&contxt));
5638 #ifdef HOMEGROWN_POSIX_SIGNALS
5639 /* Signal handling routines, pulled into the core from POSIX.xs.
5641 * We need these for threads, so they've been rolled into the core,
5642 * rather than left in POSIX.xs.
5644 * (DRS, Oct 23, 1997)
5647 /* sigset_t is atomic under VMS, so these routines are easy */
5648 /*{{{int my_sigemptyset(sigset_t *) */
5649 int my_sigemptyset(sigset_t *set) {
5650 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5656 /*{{{int my_sigfillset(sigset_t *)*/
5657 int my_sigfillset(sigset_t *set) {
5659 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5660 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5666 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5667 int my_sigaddset(sigset_t *set, int sig) {
5668 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5669 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5670 *set |= (1 << (sig - 1));
5676 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5677 int my_sigdelset(sigset_t *set, int sig) {
5678 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5679 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5680 *set &= ~(1 << (sig - 1));
5686 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5687 int my_sigismember(sigset_t *set, int sig) {
5688 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5689 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5690 return *set & (1 << (sig - 1));
5695 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5696 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5699 /* If set and oset are both null, then things are badly wrong. Bail out. */
5700 if ((oset == NULL) && (set == NULL)) {
5701 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5705 /* If set's null, then we're just handling a fetch. */
5707 tempmask = sigblock(0);
5712 tempmask = sigsetmask(*set);
5715 tempmask = sigblock(*set);
5718 tempmask = sigblock(0);
5719 sigsetmask(*oset & ~tempmask);
5722 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5727 /* Did they pass us an oset? If so, stick our holding mask into it */
5734 #endif /* HOMEGROWN_POSIX_SIGNALS */
5737 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5738 * my_utime(), and flex_stat(), all of which operate on UTC unless
5739 * VMSISH_TIMES is true.
5741 /* method used to handle UTC conversions:
5742 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5744 static int gmtime_emulation_type;
5745 /* number of secs to add to UTC POSIX-style time to get local time */
5746 static long int utc_offset_secs;
5748 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5749 * in vmsish.h. #undef them here so we can call the CRTL routines
5758 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5759 * qualifier with the extern prefix pragma. This provisional
5760 * hack circumvents this prefix pragma problem in previous
5763 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5764 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5765 # pragma __extern_prefix save
5766 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5767 # define gmtime decc$__utctz_gmtime
5768 # define localtime decc$__utctz_localtime
5769 # define time decc$__utc_time
5770 # pragma __extern_prefix restore
5772 struct tm *gmtime(), *localtime();
5778 static time_t toutc_dst(time_t loc) {
5781 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5782 loc -= utc_offset_secs;
5783 if (rsltmp->tm_isdst) loc -= 3600;
5786 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5787 ((gmtime_emulation_type || my_time(NULL)), \
5788 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5789 ((secs) - utc_offset_secs))))
5791 static time_t toloc_dst(time_t utc) {
5794 utc += utc_offset_secs;
5795 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5796 if (rsltmp->tm_isdst) utc += 3600;
5799 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5800 ((gmtime_emulation_type || my_time(NULL)), \
5801 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5802 ((secs) + utc_offset_secs))))
5804 #ifndef RTL_USES_UTC
5807 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5808 DST starts on 1st sun of april at 02:00 std time
5809 ends on last sun of october at 02:00 dst time
5810 see the UCX management command reference, SET CONFIG TIMEZONE
5811 for formatting info.
5813 No, it's not as general as it should be, but then again, NOTHING
5814 will handle UK times in a sensible way.
5819 parse the DST start/end info:
5820 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5824 tz_parse_startend(char *s, struct tm *w, int *past)
5826 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5827 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5832 if (!past) return 0;
5835 if (w->tm_year % 4 == 0) ly = 1;
5836 if (w->tm_year % 100 == 0) ly = 0;
5837 if (w->tm_year+1900 % 400 == 0) ly = 1;
5840 dozjd = isdigit(*s);
5841 if (*s == 'J' || *s == 'j' || dozjd) {
5842 if (!dozjd && !isdigit(*++s)) return 0;
5845 d = d*10 + *s++ - '0';
5847 d = d*10 + *s++ - '0';
5850 if (d == 0) return 0;
5851 if (d > 366) return 0;
5853 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5856 } else if (*s == 'M' || *s == 'm') {
5857 if (!isdigit(*++s)) return 0;
5859 if (isdigit(*s)) m = 10*m + *s++ - '0';
5860 if (*s != '.') return 0;
5861 if (!isdigit(*++s)) return 0;
5863 if (n < 1 || n > 5) return 0;
5864 if (*s != '.') return 0;
5865 if (!isdigit(*++s)) return 0;
5867 if (d > 6) return 0;
5871 if (!isdigit(*++s)) return 0;
5873 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5875 if (!isdigit(*++s)) return 0;
5877 if (isdigit(*s)) min = 10*min + *s++ - '0';
5879 if (!isdigit(*++s)) return 0;
5881 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5891 if (w->tm_yday < d) goto before;
5892 if (w->tm_yday > d) goto after;
5894 if (w->tm_mon+1 < m) goto before;
5895 if (w->tm_mon+1 > m) goto after;
5897 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5898 k = d - j; /* mday of first d */
5900 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5901 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5902 if (w->tm_mday < k) goto before;
5903 if (w->tm_mday > k) goto after;
5906 if (w->tm_hour < hour) goto before;
5907 if (w->tm_hour > hour) goto after;
5908 if (w->tm_min < min) goto before;
5909 if (w->tm_min > min) goto after;
5910 if (w->tm_sec < sec) goto before;
5924 /* parse the offset: (+|-)hh[:mm[:ss]] */
5927 tz_parse_offset(char *s, int *offset)
5929 int hour = 0, min = 0, sec = 0;
5932 if (!offset) return 0;
5934 if (*s == '-') {neg++; s++;}
5936 if (!isdigit(*s)) return 0;
5938 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5939 if (hour > 24) return 0;
5941 if (!isdigit(*++s)) return 0;
5943 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5944 if (min > 59) return 0;
5946 if (!isdigit(*++s)) return 0;
5948 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5949 if (sec > 59) return 0;
5953 *offset = (hour*60+min)*60 + sec;
5954 if (neg) *offset = -*offset;
5959 input time is w, whatever type of time the CRTL localtime() uses.
5960 sets dst, the zone, and the gmtoff (seconds)
5962 caches the value of TZ and UCX$TZ env variables; note that
5963 my_setenv looks for these and sets a flag if they're changed
5966 We have to watch out for the "australian" case (dst starts in
5967 october, ends in april)...flagged by "reverse" and checked by
5968 scanning through the months of the previous year.
5973 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5978 char *dstzone, *tz, *s_start, *s_end;
5979 int std_off, dst_off, isdst;
5980 int y, dststart, dstend;
5981 static char envtz[1025]; /* longer than any logical, symbol, ... */
5982 static char ucxtz[1025];
5983 static char reversed = 0;
5989 reversed = -1; /* flag need to check */
5990 envtz[0] = ucxtz[0] = '\0';
5991 tz = my_getenv("TZ",0);
5992 if (tz) strcpy(envtz, tz);
5993 tz = my_getenv("UCX$TZ",0);
5994 if (tz) strcpy(ucxtz, tz);
5995 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5998 if (!*tz) tz = ucxtz;
6001 while (isalpha(*s)) s++;
6002 s = tz_parse_offset(s, &std_off);
6004 if (!*s) { /* no DST, hurray we're done! */
6010 while (isalpha(*s)) s++;
6011 s2 = tz_parse_offset(s, &dst_off);
6015 dst_off = std_off - 3600;
6018 if (!*s) { /* default dst start/end?? */
6019 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6020 s = strchr(ucxtz,',');
6022 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6024 if (*s != ',') return 0;
6027 when = _toutc(when); /* convert to utc */
6028 when = when - std_off; /* convert to pseudolocal time*/
6030 w2 = localtime(&when);
6033 s = tz_parse_startend(s_start,w2,&dststart);
6035 if (*s != ',') return 0;
6038 when = _toutc(when); /* convert to utc */
6039 when = when - dst_off; /* convert to pseudolocal time*/
6040 w2 = localtime(&when);
6041 if (w2->tm_year != y) { /* spans a year, just check one time */
6042 when += dst_off - std_off;
6043 w2 = localtime(&when);
6046 s = tz_parse_startend(s_end,w2,&dstend);
6049 if (reversed == -1) { /* need to check if start later than end */
6053 if (when < 2*365*86400) {
6054 when += 2*365*86400;
6058 w2 =localtime(&when);
6059 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6061 for (j = 0; j < 12; j++) {
6062 w2 =localtime(&when);
6063 (void) tz_parse_startend(s_start,w2,&ds);
6064 (void) tz_parse_startend(s_end,w2,&de);
6065 if (ds != de) break;
6069 if (de && !ds) reversed = 1;
6072 isdst = dststart && !dstend;
6073 if (reversed) isdst = dststart || !dstend;
6076 if (dst) *dst = isdst;
6077 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6078 if (isdst) tz = dstzone;
6080 while(isalpha(*tz)) *zone++ = *tz++;
6086 #endif /* !RTL_USES_UTC */
6088 /* my_time(), my_localtime(), my_gmtime()
6089 * By default traffic in UTC time values, using CRTL gmtime() or
6090 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6091 * Note: We need to use these functions even when the CRTL has working
6092 * UTC support, since they also handle C<use vmsish qw(times);>
6094 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6095 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6098 /*{{{time_t my_time(time_t *timep)*/
6099 time_t Perl_my_time(pTHX_ time_t *timep)
6104 if (gmtime_emulation_type == 0) {
6106 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6107 /* results of calls to gmtime() and localtime() */
6108 /* for same &base */
6110 gmtime_emulation_type++;
6111 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6112 char off[LNM$C_NAMLENGTH+1];;
6114 gmtime_emulation_type++;
6115 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6116 gmtime_emulation_type++;
6117 utc_offset_secs = 0;
6118 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6120 else { utc_offset_secs = atol(off); }
6122 else { /* We've got a working gmtime() */
6123 struct tm gmt, local;
6126 tm_p = localtime(&base);
6128 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6129 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6130 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6131 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6137 # ifdef RTL_USES_UTC
6138 if (VMSISH_TIME) when = _toloc(when);
6140 if (!VMSISH_TIME) when = _toutc(when);
6143 if (timep != NULL) *timep = when;
6146 } /* end of my_time() */
6150 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6152 Perl_my_gmtime(pTHX_ const time_t *timep)
6158 if (timep == NULL) {
6159 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6162 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6166 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6168 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6169 return gmtime(&when);
6171 /* CRTL localtime() wants local time as input, so does no tz correction */
6172 rsltmp = localtime(&when);
6173 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6176 } /* end of my_gmtime() */
6180 /*{{{struct tm *my_localtime(const time_t *timep)*/
6182 Perl_my_localtime(pTHX_ const time_t *timep)
6184 time_t when, whenutc;
6188 if (timep == NULL) {
6189 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6192 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6193 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6196 # ifdef RTL_USES_UTC
6198 if (VMSISH_TIME) when = _toutc(when);
6200 /* CRTL localtime() wants UTC as input, does tz correction itself */
6201 return localtime(&when);
6203 # else /* !RTL_USES_UTC */
6206 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6207 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6210 #ifndef RTL_USES_UTC
6211 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6212 when = whenutc - offset; /* pseudolocal time*/
6215 /* CRTL localtime() wants local time as input, so does no tz correction */
6216 rsltmp = localtime(&when);
6217 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6221 } /* end of my_localtime() */
6224 /* Reset definitions for later calls */
6225 #define gmtime(t) my_gmtime(t)
6226 #define localtime(t) my_localtime(t)
6227 #define time(t) my_time(t)
6230 /* my_utime - update modification time of a file
6231 * calling sequence is identical to POSIX utime(), but under
6232 * VMS only the modification time is changed; ODS-2 does not
6233 * maintain access times. Restrictions differ from the POSIX
6234 * definition in that the time can be changed as long as the
6235 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6236 * no separate checks are made to insure that the caller is the
6237 * owner of the file or has special privs enabled.
6238 * Code here is based on Joe Meadows' FILE utility.
6241 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6242 * to VMS epoch (01-JAN-1858 00:00:00.00)
6243 * in 100 ns intervals.
6245 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6247 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6248 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6251 long int bintime[2], len = 2, lowbit, unixtime,
6252 secscale = 10000000; /* seconds --> 100 ns intervals */
6253 unsigned long int chan, iosb[2], retsts;
6254 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6255 struct FAB myfab = cc$rms_fab;
6256 struct NAM mynam = cc$rms_nam;
6257 #if defined (__DECC) && defined (__VAX)
6258 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6259 * at least through VMS V6.1, which causes a type-conversion warning.
6261 # pragma message save
6262 # pragma message disable cvtdiftypes
6264 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6265 struct fibdef myfib;
6266 #if defined (__DECC) && defined (__VAX)
6267 /* This should be right after the declaration of myatr, but due
6268 * to a bug in VAX DEC C, this takes effect a statement early.
6270 # pragma message restore
6272 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6273 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6274 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6276 if (file == NULL || *file == '\0') {
6278 set_vaxc_errno(LIB$_INVARG);
6281 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6283 if (utimes != NULL) {
6284 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6285 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6286 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6287 * as input, we force the sign bit to be clear by shifting unixtime right
6288 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6290 lowbit = (utimes->modtime & 1) ? secscale : 0;
6291 unixtime = (long int) utimes->modtime;
6293 /* If input was UTC; convert to local for sys svc */
6294 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6296 unixtime >>= 1; secscale <<= 1;
6297 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6298 if (!(retsts & 1)) {
6300 set_vaxc_errno(retsts);
6303 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6304 if (!(retsts & 1)) {
6306 set_vaxc_errno(retsts);
6311 /* Just get the current time in VMS format directly */
6312 retsts = sys$gettim(bintime);
6313 if (!(retsts & 1)) {
6315 set_vaxc_errno(retsts);
6320 myfab.fab$l_fna = vmsspec;
6321 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6322 myfab.fab$l_nam = &mynam;
6323 mynam.nam$l_esa = esa;
6324 mynam.nam$b_ess = (unsigned char) sizeof esa;
6325 mynam.nam$l_rsa = rsa;
6326 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6328 /* Look for the file to be affected, letting RMS parse the file
6329 * specification for us as well. I have set errno using only
6330 * values documented in the utime() man page for VMS POSIX.
6332 retsts = sys$parse(&myfab,0,0);
6333 if (!(retsts & 1)) {
6334 set_vaxc_errno(retsts);
6335 if (retsts == RMS$_PRV) set_errno(EACCES);
6336 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6337 else set_errno(EVMSERR);
6340 retsts = sys$search(&myfab,0,0);
6341 if (!(retsts & 1)) {
6342 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6343 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6344 set_vaxc_errno(retsts);
6345 if (retsts == RMS$_PRV) set_errno(EACCES);
6346 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6347 else set_errno(EVMSERR);
6351 devdsc.dsc$w_length = mynam.nam$b_dev;
6352 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6354 retsts = sys$assign(&devdsc,&chan,0,0);
6355 if (!(retsts & 1)) {
6356 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6357 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6358 set_vaxc_errno(retsts);
6359 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6360 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6361 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6362 else set_errno(EVMSERR);
6366 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6367 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6369 memset((void *) &myfib, 0, sizeof myfib);
6370 #if defined(__DECC) || defined(__DECCXX)
6371 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6372 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6373 /* This prevents the revision time of the file being reset to the current
6374 * time as a result of our IO$_MODIFY $QIO. */
6375 myfib.fib$l_acctl = FIB$M_NORECORD;
6377 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6378 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6379 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6381 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6382 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6383 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6384 _ckvmssts(sys$dassgn(chan));
6385 if (retsts & 1) retsts = iosb[0];
6386 if (!(retsts & 1)) {
6387 set_vaxc_errno(retsts);
6388 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6389 else set_errno(EVMSERR);
6394 } /* end of my_utime() */
6398 * flex_stat, flex_fstat
6399 * basic stat, but gets it right when asked to stat
6400 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6403 /* encode_dev packs a VMS device name string into an integer to allow
6404 * simple comparisons. This can be used, for example, to check whether two
6405 * files are located on the same device, by comparing their encoded device
6406 * names. Even a string comparison would not do, because stat() reuses the
6407 * device name buffer for each call; so without encode_dev, it would be
6408 * necessary to save the buffer and use strcmp (this would mean a number of
6409 * changes to the standard Perl code, to say nothing of what a Perl script
6412 * The device lock id, if it exists, should be unique (unless perhaps compared
6413 * with lock ids transferred from other nodes). We have a lock id if the disk is
6414 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6415 * device names. Thus we use the lock id in preference, and only if that isn't
6416 * available, do we try to pack the device name into an integer (flagged by
6417 * the sign bit (LOCKID_MASK) being set).
6419 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6420 * name and its encoded form, but it seems very unlikely that we will find
6421 * two files on different disks that share the same encoded device names,
6422 * and even more remote that they will share the same file id (if the test
6423 * is to check for the same file).
6425 * A better method might be to use sys$device_scan on the first call, and to
6426 * search for the device, returning an index into the cached array.
6427 * The number returned would be more intelligable.
6428 * This is probably not worth it, and anyway would take quite a bit longer
6429 * on the first call.
6431 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6432 static mydev_t encode_dev (pTHX_ const char *dev)
6435 unsigned long int f;
6440 if (!dev || !dev[0]) return 0;
6444 struct dsc$descriptor_s dev_desc;
6445 unsigned long int status, lockid, item = DVI$_LOCKID;
6447 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6448 can try that first. */
6449 dev_desc.dsc$w_length = strlen (dev);
6450 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6451 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6452 dev_desc.dsc$a_pointer = (char *) dev;
6453 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6454 if (lockid) return (lockid & ~LOCKID_MASK);
6458 /* Otherwise we try to encode the device name */
6462 for (q = dev + strlen(dev); q--; q >= dev) {
6465 else if (isalpha (toupper (*q)))
6466 c= toupper (*q) - 'A' + (char)10;
6468 continue; /* Skip '$'s */
6470 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6472 enc += f * (unsigned long int) c;
6474 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6476 } /* end of encode_dev() */
6478 static char namecache[NAM$C_MAXRSS+1];
6481 is_null_device(name)
6484 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6485 The underscore prefix, controller letter, and unit number are
6486 independently optional; for our purposes, the colon punctuation
6487 is not. The colon can be trailed by optional directory and/or
6488 filename, but two consecutive colons indicates a nodename rather
6489 than a device. [pr] */
6490 if (*name == '_') ++name;
6491 if (tolower(*name++) != 'n') return 0;
6492 if (tolower(*name++) != 'l') return 0;
6493 if (tolower(*name) == 'a') ++name;
6494 if (*name == '0') ++name;
6495 return (*name++ == ':') && (*name != ':');
6498 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6499 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6500 * subset of the applicable information.
6503 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6505 char fname_phdev[NAM$C_MAXRSS+1];
6506 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6508 char fname[NAM$C_MAXRSS+1];
6509 unsigned long int retsts;
6510 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6511 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6513 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6514 device name on successive calls */
6515 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6516 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6517 namdsc.dsc$a_pointer = fname;
6518 namdsc.dsc$w_length = sizeof fname - 1;
6520 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6521 &namdsc,&namdsc.dsc$w_length,0,0);
6523 fname[namdsc.dsc$w_length] = '\0';
6525 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6526 * but if someone has redefined that logical, Perl gets very lost. Since
6527 * we have the physical device name from the stat buffer, just paste it on.
6529 strcpy( fname_phdev, statbufp->st_devnam );
6530 strcat( fname_phdev, strrchr(fname, ':') );
6532 return cando_by_name(bit,effective,fname_phdev);
6534 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6535 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6539 return FALSE; /* Should never get to here */
6541 } /* end of cando() */
6545 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6547 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6549 static char usrname[L_cuserid];
6550 static struct dsc$descriptor_s usrdsc =
6551 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6552 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6553 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6554 unsigned short int retlen;
6555 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6556 union prvdef curprv;
6557 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6558 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6559 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6562 if (!fname || !*fname) return FALSE;
6563 /* Make sure we expand logical names, since sys$check_access doesn't */
6564 if (!strpbrk(fname,"/]>:")) {
6565 strcpy(fileified,fname);
6566 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6569 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6570 retlen = namdsc.dsc$w_length = strlen(vmsname);
6571 namdsc.dsc$a_pointer = vmsname;
6572 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6573 vmsname[retlen-1] == ':') {
6574 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6575 namdsc.dsc$w_length = strlen(fileified);
6576 namdsc.dsc$a_pointer = fileified;
6579 if (!usrdsc.dsc$w_length) {
6581 usrdsc.dsc$w_length = strlen(usrname);
6585 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6586 access = ARM$M_EXECUTE; break;
6587 case S_IRUSR: case S_IRGRP: case S_IROTH:
6588 access = ARM$M_READ; break;
6589 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6590 access = ARM$M_WRITE; break;
6591 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6592 access = ARM$M_DELETE; break;
6597 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6598 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6599 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6600 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6601 set_vaxc_errno(retsts);
6602 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6603 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6604 else set_errno(ENOENT);
6607 if (retsts == SS$_NORMAL) {
6608 if (!privused) return TRUE;
6609 /* We can get access, but only by using privs. Do we have the
6610 necessary privs currently enabled? */
6611 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6612 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6613 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6614 !curprv.prv$v_bypass) return FALSE;
6615 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6616 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6617 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6620 if (retsts == SS$_ACCONFLICT) {
6625 return FALSE; /* Should never get here */
6627 } /* end of cando_by_name() */
6631 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6633 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6635 if (!fstat(fd,(stat_t *) statbufp)) {
6636 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6637 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6638 # ifdef RTL_USES_UTC
6641 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6642 statbufp->st_atime = _toloc(statbufp->st_atime);
6643 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6648 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6652 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6653 statbufp->st_atime = _toutc(statbufp->st_atime);
6654 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6661 } /* end of flex_fstat() */
6664 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6666 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6668 char fileified[NAM$C_MAXRSS+1];
6669 char temp_fspec[NAM$C_MAXRSS+300];
6672 if (!fspec) return retval;
6673 strcpy(temp_fspec, fspec);
6674 if (statbufp == (Stat_t *) &PL_statcache)
6675 do_tovmsspec(temp_fspec,namecache,0);
6676 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6677 memset(statbufp,0,sizeof *statbufp);
6678 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6679 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6680 statbufp->st_uid = 0x00010001;
6681 statbufp->st_gid = 0x0001;
6682 time((time_t *)&statbufp->st_mtime);
6683 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6687 /* Try for a directory name first. If fspec contains a filename without
6688 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6689 * and sea:[wine.dark]water. exist, we prefer the directory here.
6690 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6691 * not sea:[wine.dark]., if the latter exists. If the intended target is
6692 * the file with null type, specify this by calling flex_stat() with
6693 * a '.' at the end of fspec.
6695 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6696 retval = stat(fileified,(stat_t *) statbufp);
6697 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6698 strcpy(namecache,fileified);
6700 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6702 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6703 # ifdef RTL_USES_UTC
6706 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6707 statbufp->st_atime = _toloc(statbufp->st_atime);
6708 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6713 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6717 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6718 statbufp->st_atime = _toutc(statbufp->st_atime);
6719 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6725 } /* end of flex_stat() */
6729 /*{{{char *my_getlogin()*/
6730 /* VMS cuserid == Unix getlogin, except calling sequence */
6734 static char user[L_cuserid];
6735 return cuserid(user);
6740 /* rmscopy - copy a file using VMS RMS routines
6742 * Copies contents and attributes of spec_in to spec_out, except owner
6743 * and protection information. Name and type of spec_in are used as
6744 * defaults for spec_out. The third parameter specifies whether rmscopy()
6745 * should try to propagate timestamps from the input file to the output file.
6746 * If it is less than 0, no timestamps are preserved. If it is 0, then
6747 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6748 * propagated to the output file at creation iff the output file specification
6749 * did not contain an explicit name or type, and the revision date is always
6750 * updated at the end of the copy operation. If it is greater than 0, then
6751 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6752 * other than the revision date should be propagated, and bit 1 indicates
6753 * that the revision date should be propagated.
6755 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6757 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6758 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6759 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6760 * as part of the Perl standard distribution under the terms of the
6761 * GNU General Public License or the Perl Artistic License. Copies
6762 * of each may be found in the Perl standard distribution.
6764 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6766 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6768 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6769 rsa[NAM$C_MAXRSS], ubf[32256];
6770 unsigned long int i, sts, sts2;
6771 struct FAB fab_in, fab_out;
6772 struct RAB rab_in, rab_out;
6774 struct XABDAT xabdat;
6775 struct XABFHC xabfhc;
6776 struct XABRDT xabrdt;
6777 struct XABSUM xabsum;
6779 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6780 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6781 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6785 fab_in = cc$rms_fab;
6786 fab_in.fab$l_fna = vmsin;
6787 fab_in.fab$b_fns = strlen(vmsin);
6788 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6789 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6790 fab_in.fab$l_fop = FAB$M_SQO;
6791 fab_in.fab$l_nam = &nam;
6792 fab_in.fab$l_xab = (void *) &xabdat;
6795 nam.nam$l_rsa = rsa;
6796 nam.nam$b_rss = sizeof(rsa);
6797 nam.nam$l_esa = esa;
6798 nam.nam$b_ess = sizeof (esa);
6799 nam.nam$b_esl = nam.nam$b_rsl = 0;
6801 xabdat = cc$rms_xabdat; /* To get creation date */
6802 xabdat.xab$l_nxt = (void *) &xabfhc;
6804 xabfhc = cc$rms_xabfhc; /* To get record length */
6805 xabfhc.xab$l_nxt = (void *) &xabsum;
6807 xabsum = cc$rms_xabsum; /* To get key and area information */
6809 if (!((sts = sys$open(&fab_in)) & 1)) {
6810 set_vaxc_errno(sts);
6812 case RMS$_FNF: case RMS$_DNF:
6813 set_errno(ENOENT); break;
6815 set_errno(ENOTDIR); break;
6817 set_errno(ENODEV); break;
6819 set_errno(EINVAL); break;
6821 set_errno(EACCES); break;
6829 fab_out.fab$w_ifi = 0;
6830 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6831 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6832 fab_out.fab$l_fop = FAB$M_SQO;
6833 fab_out.fab$l_fna = vmsout;
6834 fab_out.fab$b_fns = strlen(vmsout);
6835 fab_out.fab$l_dna = nam.nam$l_name;
6836 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6838 if (preserve_dates == 0) { /* Act like DCL COPY */
6839 nam.nam$b_nop = NAM$M_SYNCHK;
6840 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6841 if (!((sts = sys$parse(&fab_out)) & 1)) {
6842 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6843 set_vaxc_errno(sts);
6846 fab_out.fab$l_xab = (void *) &xabdat;
6847 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6849 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6850 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6851 preserve_dates =0; /* bitmask from this point forward */
6853 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6854 if (!((sts = sys$create(&fab_out)) & 1)) {
6855 set_vaxc_errno(sts);
6858 set_errno(ENOENT); break;
6860 set_errno(ENOTDIR); break;
6862 set_errno(ENODEV); break;
6864 set_errno(EINVAL); break;
6866 set_errno(EACCES); break;
6872 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6873 if (preserve_dates & 2) {
6874 /* sys$close() will process xabrdt, not xabdat */
6875 xabrdt = cc$rms_xabrdt;
6877 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6879 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6880 * is unsigned long[2], while DECC & VAXC use a struct */
6881 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6883 fab_out.fab$l_xab = (void *) &xabrdt;
6886 rab_in = cc$rms_rab;
6887 rab_in.rab$l_fab = &fab_in;
6888 rab_in.rab$l_rop = RAB$M_BIO;
6889 rab_in.rab$l_ubf = ubf;
6890 rab_in.rab$w_usz = sizeof ubf;
6891 if (!((sts = sys$connect(&rab_in)) & 1)) {
6892 sys$close(&fab_in); sys$close(&fab_out);
6893 set_errno(EVMSERR); set_vaxc_errno(sts);
6897 rab_out = cc$rms_rab;
6898 rab_out.rab$l_fab = &fab_out;
6899 rab_out.rab$l_rbf = ubf;
6900 if (!((sts = sys$connect(&rab_out)) & 1)) {
6901 sys$close(&fab_in); sys$close(&fab_out);
6902 set_errno(EVMSERR); set_vaxc_errno(sts);
6906 while ((sts = sys$read(&rab_in))) { /* always true */
6907 if (sts == RMS$_EOF) break;
6908 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6909 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6910 sys$close(&fab_in); sys$close(&fab_out);
6911 set_errno(EVMSERR); set_vaxc_errno(sts);
6916 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6917 sys$close(&fab_in); sys$close(&fab_out);
6918 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6920 set_errno(EVMSERR); set_vaxc_errno(sts);
6926 } /* end of rmscopy() */
6930 /*** The following glue provides 'hooks' to make some of the routines
6931 * from this file available from Perl. These routines are sufficiently
6932 * basic, and are required sufficiently early in the build process,
6933 * that's it's nice to have them available to miniperl as well as the
6934 * full Perl, so they're set up here instead of in an extension. The
6935 * Perl code which handles importation of these names into a given
6936 * package lives in [.VMS]Filespec.pm in @INC.
6940 rmsexpand_fromperl(pTHX_ CV *cv)
6943 char *fspec, *defspec = NULL, *rslt;
6946 if (!items || items > 2)
6947 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6948 fspec = SvPV(ST(0),n_a);
6949 if (!fspec || !*fspec) XSRETURN_UNDEF;
6950 if (items == 2) defspec = SvPV(ST(1),n_a);
6952 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6953 ST(0) = sv_newmortal();
6954 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6959 vmsify_fromperl(pTHX_ CV *cv)
6965 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6966 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6967 ST(0) = sv_newmortal();
6968 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6973 unixify_fromperl(pTHX_ CV *cv)
6979 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6980 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6981 ST(0) = sv_newmortal();
6982 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6987 fileify_fromperl(pTHX_ CV *cv)
6993 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6994 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6995 ST(0) = sv_newmortal();
6996 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7001 pathify_fromperl(pTHX_ CV *cv)
7007 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7008 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7009 ST(0) = sv_newmortal();
7010 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7015 vmspath_fromperl(pTHX_ CV *cv)
7021 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7022 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7023 ST(0) = sv_newmortal();
7024 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7029 unixpath_fromperl(pTHX_ CV *cv)
7035 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7036 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7037 ST(0) = sv_newmortal();
7038 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7043 candelete_fromperl(pTHX_ CV *cv)
7046 char fspec[NAM$C_MAXRSS+1], *fsp;
7051 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7053 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7054 if (SvTYPE(mysv) == SVt_PVGV) {
7055 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7056 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7063 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7064 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7070 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7075 rmscopy_fromperl(pTHX_ CV *cv)
7078 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7080 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7081 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7082 unsigned long int sts;
7087 if (items < 2 || items > 3)
7088 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7090 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7091 if (SvTYPE(mysv) == SVt_PVGV) {
7092 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7093 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7100 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7101 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7106 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7107 if (SvTYPE(mysv) == SVt_PVGV) {
7108 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7109 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7116 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7117 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7122 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7124 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7130 mod2fname(pTHX_ CV *cv)
7133 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7134 workbuff[NAM$C_MAXRSS*1 + 1];
7135 int total_namelen = 3, counter, num_entries;
7136 /* ODS-5 ups this, but we want to be consistent, so... */
7137 int max_name_len = 39;
7138 AV *in_array = (AV *)SvRV(ST(0));
7140 num_entries = av_len(in_array);
7142 /* All the names start with PL_. */
7143 strcpy(ultimate_name, "PL_");
7145 /* Clean up our working buffer */
7146 Zero(work_name, sizeof(work_name), char);
7148 /* Run through the entries and build up a working name */
7149 for(counter = 0; counter <= num_entries; counter++) {
7150 /* If it's not the first name then tack on a __ */
7152 strcat(work_name, "__");
7154 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7158 /* Check to see if we actually have to bother...*/
7159 if (strlen(work_name) + 3 <= max_name_len) {
7160 strcat(ultimate_name, work_name);
7162 /* It's too darned big, so we need to go strip. We use the same */
7163 /* algorithm as xsubpp does. First, strip out doubled __ */
7164 char *source, *dest, last;
7167 for (source = work_name; *source; source++) {
7168 if (last == *source && last == '_') {
7174 /* Go put it back */
7175 strcpy(work_name, workbuff);
7176 /* Is it still too big? */
7177 if (strlen(work_name) + 3 > max_name_len) {
7178 /* Strip duplicate letters */
7181 for (source = work_name; *source; source++) {
7182 if (last == toupper(*source)) {
7186 last = toupper(*source);
7188 strcpy(work_name, workbuff);
7191 /* Is it *still* too big? */
7192 if (strlen(work_name) + 3 > max_name_len) {
7193 /* Too bad, we truncate */
7194 work_name[max_name_len - 2] = 0;
7196 strcat(ultimate_name, work_name);
7199 /* Okay, return it */
7200 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7205 hushexit_fromperl(pTHX_ CV *cv)
7210 VMSISH_HUSHED = SvTRUE(ST(0));
7212 ST(0) = boolSV(VMSISH_HUSHED);
7217 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7218 struct interp_intern *dst)
7220 memcpy(dst,src,sizeof(struct interp_intern));
7224 Perl_sys_intern_clear(pTHX)
7229 Perl_sys_intern_init(pTHX)
7237 MY_INV_RAND_MAX = 1./x;
7239 VMSCMD.dsc$a_pointer = NULL;
7240 VMSCMD.dsc$w_length = 0;
7241 VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
7242 VMSCMD.dsc$b_class = DSC$K_CLASS_S;
7249 char* file = __FILE__;
7250 char temp_buff[512];
7251 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7252 no_translate_barewords = TRUE;
7254 no_translate_barewords = FALSE;
7257 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7258 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7259 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7260 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7261 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7262 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7263 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7264 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7265 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7266 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7267 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7269 store_pipelocs(aTHX); /* will redo any earlier attempts */