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 static char *__mystrtolower(char *str)
111 if (str) for (; *str; ++str) *str= tolower(*str);
115 static struct dsc$descriptor_s fildevdsc =
116 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
117 static struct dsc$descriptor_s crtlenvdsc =
118 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
119 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
120 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
121 static struct dsc$descriptor_s **env_tables = defenv;
122 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
124 /* True if we shouldn't treat barewords as logicals during directory */
126 static int no_translate_barewords;
128 /* Temp for subprocess commands */
129 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
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 /* default piping mailbox size */
1097 #define PERL_BUFSIZ 512
1101 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1103 unsigned long int mbxbufsiz;
1104 static unsigned long int syssize = 0;
1105 unsigned long int dviitm = DVI$_DEVNAM;
1106 char csize[LNM$C_NAMLENGTH+1];
1109 unsigned long syiitm = SYI$_MAXBUF;
1111 * Get the SYSGEN parameter MAXBUF
1113 * If the logical 'PERL_MBX_SIZE' is defined
1114 * use the value of the logical instead of PERL_BUFSIZ, but
1115 * keep the size between 128 and MAXBUF.
1118 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1121 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1122 mbxbufsiz = atoi(csize);
1124 mbxbufsiz = PERL_BUFSIZ;
1126 if (mbxbufsiz < 128) mbxbufsiz = 128;
1127 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1129 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1131 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1132 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1134 } /* end of create_mbx() */
1137 /*{{{ my_popen and my_pclose*/
1139 typedef struct _iosb IOSB;
1140 typedef struct _iosb* pIOSB;
1141 typedef struct _pipe Pipe;
1142 typedef struct _pipe* pPipe;
1143 typedef struct pipe_details Info;
1144 typedef struct pipe_details* pInfo;
1145 typedef struct _srqp RQE;
1146 typedef struct _srqp* pRQE;
1147 typedef struct _tochildbuf CBuf;
1148 typedef struct _tochildbuf* pCBuf;
1151 unsigned short status;
1152 unsigned short count;
1153 unsigned long dvispec;
1156 #pragma member_alignment save
1157 #pragma nomember_alignment quadword
1158 struct _srqp { /* VMS self-relative queue entry */
1159 unsigned long qptr[2];
1161 #pragma member_alignment restore
1162 static RQE RQE_ZERO = {0,0};
1164 struct _tochildbuf {
1167 unsigned short size;
1175 unsigned short chan_in;
1176 unsigned short chan_out;
1178 unsigned int bufsize;
1190 #if defined(PERL_IMPLICIT_CONTEXT)
1191 void *thx; /* Either a thread or an interpreter */
1192 /* pointer, depending on how we're built */
1200 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1201 int pid; /* PID of subprocess */
1202 int mode; /* == 'r' if pipe open for reading */
1203 int done; /* subprocess has completed */
1204 int closing; /* my_pclose is closing this pipe */
1205 unsigned long completion; /* termination status of subprocess */
1206 pPipe in; /* pipe in to sub */
1207 pPipe out; /* pipe out of sub */
1208 pPipe err; /* pipe of sub's sys$error */
1209 int in_done; /* true when in pipe finished */
1214 struct exit_control_block
1216 struct exit_control_block *flink;
1217 unsigned long int (*exit_routine)();
1218 unsigned long int arg_count;
1219 unsigned long int *status_address;
1220 unsigned long int exit_status;
1223 #define RETRY_DELAY "0 ::0.20"
1224 #define MAX_RETRY 50
1226 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1227 static unsigned long mypid;
1228 static unsigned long delaytime[2];
1230 static pInfo open_pipes = NULL;
1231 static $DESCRIPTOR(nl_desc, "NL:");
1234 static unsigned long int
1235 pipe_exit_routine(pTHX)
1238 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1239 int sts, did_stuff, need_eof;
1242 first we try sending an EOF...ignore if doesn't work, make sure we
1250 _ckvmssts(sys$setast(0));
1251 if (info->in && !info->in->shut_on_empty) {
1252 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1256 _ckvmssts(sys$setast(1));
1259 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1264 _ckvmssts(sys$setast(0));
1265 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1266 sts = sys$forcex(&info->pid,0,&abort);
1267 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1270 _ckvmssts(sys$setast(1));
1273 if (did_stuff) sleep(1); /* wait for them to respond */
1277 _ckvmssts(sys$setast(0));
1278 if (!info->done) { /* We tried to be nice . . . */
1279 sts = sys$delprc(&info->pid,0);
1280 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1282 _ckvmssts(sys$setast(1));
1287 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1288 else if (!(sts & 1)) retsts = sts;
1293 static struct exit_control_block pipe_exitblock =
1294 {(struct exit_control_block *) 0,
1295 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1297 static void pipe_mbxtofd_ast(pPipe p);
1298 static void pipe_tochild1_ast(pPipe p);
1299 static void pipe_tochild2_ast(pPipe p);
1302 popen_completion_ast(pInfo info)
1304 pInfo i = open_pipes;
1308 if (i == info) break;
1311 if (!i) return; /* unlinked, probably freed too */
1313 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1317 Writing to subprocess ...
1318 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1320 chan_out may be waiting for "done" flag, or hung waiting
1321 for i/o completion to child...cancel the i/o. This will
1322 put it into "snarf mode" (done but no EOF yet) that discards
1325 Output from subprocess (stdout, stderr) needs to be flushed and
1326 shut down. We try sending an EOF, but if the mbx is full the pipe
1327 routine should still catch the "shut_on_empty" flag, telling it to
1328 use immediate-style reads so that "mbx empty" -> EOF.
1332 if (info->in && !info->in_done) { /* only for mode=w */
1333 if (info->in->shut_on_empty && info->in->need_wake) {
1334 info->in->need_wake = FALSE;
1335 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1337 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1341 if (info->out && !info->out_done) { /* were we also piping output? */
1342 info->out->shut_on_empty = TRUE;
1343 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1344 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1345 _ckvmssts_noperl(iss);
1348 if (info->err && !info->err_done) { /* we were piping stderr */
1349 info->err->shut_on_empty = TRUE;
1350 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1351 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1352 _ckvmssts_noperl(iss);
1354 _ckvmssts_noperl(sys$setef(pipe_ef));
1358 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1359 static void vms_execfree(pTHX);
1362 we actually differ from vmstrnenv since we use this to
1363 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1364 are pointing to the same thing
1367 static unsigned short
1368 popen_translate(pTHX_ char *logical, char *result)
1371 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1372 $DESCRIPTOR(d_log,"");
1374 unsigned short length;
1375 unsigned short code;
1377 unsigned short *retlenaddr;
1379 unsigned short l, ifi;
1381 d_log.dsc$a_pointer = logical;
1382 d_log.dsc$w_length = strlen(logical);
1384 itmlst[0].code = LNM$_STRING;
1385 itmlst[0].length = 255;
1386 itmlst[0].buffer_addr = result;
1387 itmlst[0].retlenaddr = &l;
1390 itmlst[1].length = 0;
1391 itmlst[1].buffer_addr = 0;
1392 itmlst[1].retlenaddr = 0;
1394 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1395 if (iss == SS$_NOLOGNAM) {
1399 if (!(iss&1)) lib$signal(iss);
1402 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1403 strip it off and return the ifi, if any
1406 if (result[0] == 0x1b && result[1] == 0x00) {
1407 memcpy(&ifi,result+2,2);
1408 strcpy(result,result+4);
1410 return ifi; /* this is the RMS internal file id */
1413 #define MAX_DCL_SYMBOL 255
1414 static void pipe_infromchild_ast(pPipe p);
1417 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1418 inside an AST routine without worrying about reentrancy and which Perl
1419 memory allocator is being used.
1421 We read data and queue up the buffers, then spit them out one at a
1422 time to the output mailbox when the output mailbox is ready for one.
1425 #define INITIAL_TOCHILDQUEUE 2
1428 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1432 char mbx1[64], mbx2[64];
1433 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1434 DSC$K_CLASS_S, mbx1},
1435 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1436 DSC$K_CLASS_S, mbx2};
1437 unsigned int dviitm = DVI$_DEVBUFSIZ;
1440 New(1368, p, 1, Pipe);
1442 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1443 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1444 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1447 p->shut_on_empty = FALSE;
1448 p->need_wake = FALSE;
1451 p->iosb.status = SS$_NORMAL;
1452 p->iosb2.status = SS$_NORMAL;
1458 #ifdef PERL_IMPLICIT_CONTEXT
1462 n = sizeof(CBuf) + p->bufsize;
1464 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1465 _ckvmssts(lib$get_vm(&n, &b));
1466 b->buf = (char *) b + sizeof(CBuf);
1467 _ckvmssts(lib$insqhi(b, &p->free));
1470 pipe_tochild2_ast(p);
1471 pipe_tochild1_ast(p);
1477 /* reads the MBX Perl is writing, and queues */
1480 pipe_tochild1_ast(pPipe p)
1483 int iss = p->iosb.status;
1484 int eof = (iss == SS$_ENDOFFILE);
1485 #ifdef PERL_IMPLICIT_CONTEXT
1491 p->shut_on_empty = TRUE;
1493 _ckvmssts(sys$dassgn(p->chan_in));
1499 b->size = p->iosb.count;
1500 _ckvmssts(lib$insqhi(b, &p->wait));
1502 p->need_wake = FALSE;
1503 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1506 p->retry = 1; /* initial call */
1509 if (eof) { /* flush the free queue, return when done */
1510 int n = sizeof(CBuf) + p->bufsize;
1512 iss = lib$remqti(&p->free, &b);
1513 if (iss == LIB$_QUEWASEMP) return;
1515 _ckvmssts(lib$free_vm(&n, &b));
1519 iss = lib$remqti(&p->free, &b);
1520 if (iss == LIB$_QUEWASEMP) {
1521 int n = sizeof(CBuf) + p->bufsize;
1522 _ckvmssts(lib$get_vm(&n, &b));
1523 b->buf = (char *) b + sizeof(CBuf);
1529 iss = sys$qio(0,p->chan_in,
1530 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1532 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1533 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1538 /* writes queued buffers to output, waits for each to complete before
1542 pipe_tochild2_ast(pPipe p)
1545 int iss = p->iosb2.status;
1546 int n = sizeof(CBuf) + p->bufsize;
1547 int done = (p->info && p->info->done) ||
1548 iss == SS$_CANCEL || iss == SS$_ABORT;
1549 #if defined(PERL_IMPLICIT_CONTEXT)
1554 if (p->type) { /* type=1 has old buffer, dispose */
1555 if (p->shut_on_empty) {
1556 _ckvmssts(lib$free_vm(&n, &b));
1558 _ckvmssts(lib$insqhi(b, &p->free));
1563 iss = lib$remqti(&p->wait, &b);
1564 if (iss == LIB$_QUEWASEMP) {
1565 if (p->shut_on_empty) {
1567 _ckvmssts(sys$dassgn(p->chan_out));
1568 *p->pipe_done = TRUE;
1569 _ckvmssts(sys$setef(pipe_ef));
1571 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1572 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1576 p->need_wake = TRUE;
1586 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1587 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1589 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1590 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1599 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1602 char mbx1[64], mbx2[64];
1603 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1604 DSC$K_CLASS_S, mbx1},
1605 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1606 DSC$K_CLASS_S, mbx2};
1607 unsigned int dviitm = DVI$_DEVBUFSIZ;
1609 New(1367, p, 1, Pipe);
1610 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1611 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1613 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1614 New(1367, p->buf, p->bufsize, char);
1615 p->shut_on_empty = FALSE;
1618 p->iosb.status = SS$_NORMAL;
1619 #if defined(PERL_IMPLICIT_CONTEXT)
1622 pipe_infromchild_ast(p);
1630 pipe_infromchild_ast(pPipe p)
1632 int iss = p->iosb.status;
1633 int eof = (iss == SS$_ENDOFFILE);
1634 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1635 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1636 #if defined(PERL_IMPLICIT_CONTEXT)
1640 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1641 _ckvmssts(sys$dassgn(p->chan_out));
1646 input shutdown if EOF from self (done or shut_on_empty)
1647 output shutdown if closing flag set (my_pclose)
1648 send data/eof from child or eof from self
1649 otherwise, re-read (snarf of data from child)
1654 if (myeof && p->chan_in) { /* input shutdown */
1655 _ckvmssts(sys$dassgn(p->chan_in));
1660 if (myeof || kideof) { /* pass EOF to parent */
1661 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1662 pipe_infromchild_ast, p,
1665 } else if (eof) { /* eat EOF --- fall through to read*/
1667 } else { /* transmit data */
1668 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1669 pipe_infromchild_ast,p,
1670 p->buf, p->iosb.count, 0, 0, 0, 0));
1676 /* everything shut? flag as done */
1678 if (!p->chan_in && !p->chan_out) {
1679 *p->pipe_done = TRUE;
1680 _ckvmssts(sys$setef(pipe_ef));
1684 /* write completed (or read, if snarfing from child)
1685 if still have input active,
1686 queue read...immediate mode if shut_on_empty so we get EOF if empty
1688 check if Perl reading, generate EOFs as needed
1694 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1695 pipe_infromchild_ast,p,
1696 p->buf, p->bufsize, 0, 0, 0, 0);
1697 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1699 } else { /* send EOFs for extra reads */
1700 p->iosb.status = SS$_ENDOFFILE;
1701 p->iosb.dvispec = 0;
1702 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1704 pipe_infromchild_ast, p, 0, 0, 0, 0));
1710 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1714 unsigned long dviitm = DVI$_DEVBUFSIZ;
1716 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1717 DSC$K_CLASS_S, mbx};
1719 /* things like terminals and mbx's don't need this filter */
1720 if (fd && fstat(fd,&s) == 0) {
1721 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1722 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1723 DSC$K_CLASS_S, s.st_dev};
1725 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1726 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1727 strcpy(out, s.st_dev);
1732 New(1366, p, 1, Pipe);
1733 p->fd_out = dup(fd);
1734 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1735 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1736 New(1366, p->buf, p->bufsize+1, char);
1737 p->shut_on_empty = FALSE;
1742 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1743 pipe_mbxtofd_ast, p,
1744 p->buf, p->bufsize, 0, 0, 0, 0));
1750 pipe_mbxtofd_ast(pPipe p)
1752 int iss = p->iosb.status;
1753 int done = p->info->done;
1755 int eof = (iss == SS$_ENDOFFILE);
1756 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1757 int err = !(iss&1) && !eof;
1758 #if defined(PERL_IMPLICIT_CONTEXT)
1762 if (done && myeof) { /* end piping */
1764 sys$dassgn(p->chan_in);
1765 *p->pipe_done = TRUE;
1766 _ckvmssts(sys$setef(pipe_ef));
1770 if (!err && !eof) { /* good data to send to file */
1771 p->buf[p->iosb.count] = '\n';
1772 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1775 if (p->retry < MAX_RETRY) {
1776 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1786 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1787 pipe_mbxtofd_ast, p,
1788 p->buf, p->bufsize, 0, 0, 0, 0);
1789 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1794 typedef struct _pipeloc PLOC;
1795 typedef struct _pipeloc* pPLOC;
1799 char dir[NAM$C_MAXRSS+1];
1801 static pPLOC head_PLOC = 0;
1804 free_pipelocs(pTHX_ void *head)
1817 store_pipelocs(pTHX)
1821 AV *av = GvAVn(PL_incgv);
1826 char temp[NAM$C_MAXRSS+1];
1829 /* the . directory from @INC comes last */
1832 p->next = head_PLOC;
1834 strcpy(p->dir,"./");
1836 /* get the directory from $^X */
1838 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1839 strcpy(temp, PL_origargv[0]);
1840 x = strrchr(temp,']');
1843 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1845 p->next = head_PLOC;
1847 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1848 p->dir[NAM$C_MAXRSS] = '\0';
1852 /* reverse order of @INC entries, skip "." since entered above */
1854 for (i = 0; i <= AvFILL(av); i++) {
1855 dirsv = *av_fetch(av,i,TRUE);
1857 if (SvROK(dirsv)) continue;
1858 dir = SvPVx(dirsv,n_a);
1859 if (strcmp(dir,".") == 0) continue;
1860 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1864 p->next = head_PLOC;
1866 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1867 p->dir[NAM$C_MAXRSS] = '\0';
1870 /* most likely spot (ARCHLIB) put first in the list */
1873 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1875 p->next = head_PLOC;
1877 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1878 p->dir[NAM$C_MAXRSS] = '\0';
1881 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1888 static int vmspipe_file_status = 0;
1889 static char vmspipe_file[NAM$C_MAXRSS+1];
1891 /* already found? Check and use ... need read+execute permission */
1893 if (vmspipe_file_status == 1) {
1894 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1895 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1896 return vmspipe_file;
1898 vmspipe_file_status = 0;
1901 /* scan through stored @INC, $^X */
1903 if (vmspipe_file_status == 0) {
1904 char file[NAM$C_MAXRSS+1];
1905 pPLOC p = head_PLOC;
1908 strcpy(file, p->dir);
1909 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1910 file[NAM$C_MAXRSS] = '\0';
1913 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1915 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1916 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1917 vmspipe_file_status = 1;
1918 return vmspipe_file;
1921 vmspipe_file_status = -1; /* failed, use tempfiles */
1928 vmspipe_tempfile(pTHX)
1930 char file[NAM$C_MAXRSS+1];
1932 static int index = 0;
1935 /* create a tempfile */
1937 /* we can't go from W, shr=get to R, shr=get without
1938 an intermediate vulnerable state, so don't bother trying...
1940 and lib$spawn doesn't shr=put, so have to close the write
1942 So... match up the creation date/time and the FID to
1943 make sure we're dealing with the same file
1948 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1949 fp = fopen(file,"w");
1951 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1952 fp = fopen(file,"w");
1954 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1955 fp = fopen(file,"w");
1958 if (!fp) return 0; /* we're hosed */
1960 fprintf(fp,"$! 'f$verify(0)\n");
1961 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1962 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1963 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1964 fprintf(fp,"$ perl_on = \"set noon\"\n");
1965 fprintf(fp,"$ perl_exit = \"exit\"\n");
1966 fprintf(fp,"$ perl_del = \"delete\"\n");
1967 fprintf(fp,"$ pif = \"if\"\n");
1968 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1969 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1970 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
1971 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1972 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1973 fprintf(fp,"$! --- get rid of global symbols\n");
1974 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1975 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1976 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1977 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1978 fprintf(fp,"$ perl_on\n");
1979 fprintf(fp,"$ 'cmd\n");
1980 fprintf(fp,"$ perl_status = $STATUS\n");
1981 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1982 fprintf(fp,"$ perl_exit 'perl_status'\n");
1985 fgetname(fp, file, 1);
1986 fstat(fileno(fp), &s0);
1989 fp = fopen(file,"r","shr=get");
1991 fstat(fileno(fp), &s1);
1993 if (s0.st_ino[0] != s1.st_ino[0] ||
1994 s0.st_ino[1] != s1.st_ino[1] ||
1995 s0.st_ino[2] != s1.st_ino[2] ||
1996 s0.st_ctime != s1.st_ctime ) {
2007 safe_popen(pTHX_ char *cmd, char *mode)
2009 static int handler_set_up = FALSE;
2010 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2011 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2012 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2013 char in[512], out[512], err[512], mbx[512];
2015 char tfilebuf[NAM$C_MAXRSS+1];
2017 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2018 DSC$K_CLASS_S, symbol};
2019 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2022 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2023 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2024 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2025 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2027 /* once-per-program initialization...
2028 note that the SETAST calls and the dual test of pipe_ef
2029 makes sure that only the FIRST thread through here does
2030 the initialization...all other threads wait until it's
2033 Yeah, uglier than a pthread call, it's got all the stuff inline
2034 rather than in a separate routine.
2038 _ckvmssts(sys$setast(0));
2040 unsigned long int pidcode = JPI$_PID;
2041 $DESCRIPTOR(d_delay, RETRY_DELAY);
2042 _ckvmssts(lib$get_ef(&pipe_ef));
2043 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2044 _ckvmssts(sys$bintim(&d_delay, delaytime));
2046 if (!handler_set_up) {
2047 _ckvmssts(sys$dclexh(&pipe_exitblock));
2048 handler_set_up = TRUE;
2050 _ckvmssts(sys$setast(1));
2053 /* see if we can find a VMSPIPE.COM */
2056 vmspipe = find_vmspipe(aTHX);
2058 strcpy(tfilebuf+1,vmspipe);
2059 } else { /* uh, oh...we're in tempfile hell */
2060 tpipe = vmspipe_tempfile(aTHX);
2061 if (!tpipe) { /* a fish popular in Boston */
2062 if (ckWARN(WARN_PIPE)) {
2063 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2067 fgetname(tpipe,tfilebuf+1,1);
2069 vmspipedsc.dsc$a_pointer = tfilebuf;
2070 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2072 sts = setup_cmddsc(aTHX_ cmd,0);
2075 case RMS$_FNF: case RMS$_DNF:
2076 set_errno(ENOENT); break;
2078 set_errno(ENOTDIR); break;
2080 set_errno(ENODEV); break;
2082 set_errno(EACCES); break;
2084 set_errno(EINVAL); break;
2085 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2086 set_errno(E2BIG); break;
2087 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2088 _ckvmssts(sts); /* fall through */
2089 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2092 set_vaxc_errno(sts);
2093 if (ckWARN(WARN_PIPE)) {
2094 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2098 New(1301,info,1,Info);
2102 info->completion = 0;
2103 info->closing = FALSE;
2107 info->in_done = TRUE;
2108 info->out_done = TRUE;
2109 info->err_done = TRUE;
2110 in[0] = out[0] = err[0] = '\0';
2112 if (*mode == 'r') { /* piping from subroutine */
2114 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2116 info->out->pipe_done = &info->out_done;
2117 info->out_done = FALSE;
2118 info->out->info = info;
2120 info->fp = PerlIO_open(mbx, mode);
2121 if (!info->fp && info->out) {
2122 sys$cancel(info->out->chan_out);
2124 while (!info->out_done) {
2126 _ckvmssts(sys$setast(0));
2127 done = info->out_done;
2128 if (!done) _ckvmssts(sys$clref(pipe_ef));
2129 _ckvmssts(sys$setast(1));
2130 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2133 if (info->out->buf) Safefree(info->out->buf);
2134 Safefree(info->out);
2139 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2141 info->err->pipe_done = &info->err_done;
2142 info->err_done = FALSE;
2143 info->err->info = info;
2146 } else { /* piping to subroutine , mode=w*/
2148 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2149 info->fp = PerlIO_open(mbx, mode);
2151 info->in->pipe_done = &info->in_done;
2152 info->in_done = FALSE;
2153 info->in->info = info;
2157 if (!info->fp && info->in) {
2159 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2160 0, 0, 0, 0, 0, 0, 0, 0));
2162 while (!info->in_done) {
2164 _ckvmssts(sys$setast(0));
2165 done = info->in_done;
2166 if (!done) _ckvmssts(sys$clref(pipe_ef));
2167 _ckvmssts(sys$setast(1));
2168 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2171 if (info->in->buf) Safefree(info->in->buf);
2178 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2180 info->out->pipe_done = &info->out_done;
2181 info->out_done = FALSE;
2182 info->out->info = info;
2185 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2187 info->err->pipe_done = &info->err_done;
2188 info->err_done = FALSE;
2189 info->err->info = info;
2193 symbol[MAX_DCL_SYMBOL] = '\0';
2195 strncpy(symbol, in, MAX_DCL_SYMBOL);
2196 d_symbol.dsc$w_length = strlen(symbol);
2197 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2199 strncpy(symbol, err, MAX_DCL_SYMBOL);
2200 d_symbol.dsc$w_length = strlen(symbol);
2201 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2203 strncpy(symbol, out, MAX_DCL_SYMBOL);
2204 d_symbol.dsc$w_length = strlen(symbol);
2205 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2207 p = VMScmd.dsc$a_pointer;
2208 while (*p && *p != '\n') p++;
2209 *p = '\0'; /* truncate on \n */
2210 p = VMScmd.dsc$a_pointer;
2211 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2212 if (*p == '$') p++; /* remove leading $ */
2213 while (*p == ' ' || *p == '\t') p++;
2214 strncpy(symbol, p, MAX_DCL_SYMBOL);
2215 d_symbol.dsc$w_length = strlen(symbol);
2216 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2218 _ckvmssts(sys$setast(0));
2219 info->next=open_pipes; /* prepend to list */
2221 _ckvmssts(sys$setast(1));
2222 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2223 0, &info->pid, &info->completion,
2224 0, popen_completion_ast,info,0,0,0));
2226 /* if we were using a tempfile, close it now */
2228 if (tpipe) fclose(tpipe);
2230 /* once the subprocess is spawned, its copied the symbols and
2231 we can get rid of ours */
2233 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2234 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2235 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2236 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2239 PL_forkprocess = info->pid;
2241 } /* end of safe_popen */
2244 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2246 Perl_my_popen(pTHX_ char *cmd, char *mode)
2249 TAINT_PROPER("popen");
2250 PERL_FLUSHALL_FOR_CHILD;
2251 return safe_popen(aTHX_ cmd,mode);
2256 /*{{{ I32 my_pclose(PerlIO *fp)*/
2257 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2259 pInfo info, last = NULL;
2260 unsigned long int retsts;
2263 for (info = open_pipes; info != NULL; last = info, info = info->next)
2264 if (info->fp == fp) break;
2266 if (info == NULL) { /* no such pipe open */
2267 set_errno(ECHILD); /* quoth POSIX */
2268 set_vaxc_errno(SS$_NONEXPR);
2272 /* If we were writing to a subprocess, insure that someone reading from
2273 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2274 * produce an EOF record in the mailbox.
2276 * well, at least sometimes it *does*, so we have to watch out for
2277 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2280 PerlIO_flush(info->fp); /* first, flush data */
2282 _ckvmssts(sys$setast(0));
2283 info->closing = TRUE;
2284 done = info->done && info->in_done && info->out_done && info->err_done;
2285 /* hanging on write to Perl's input? cancel it */
2286 if (info->mode == 'r' && info->out && !info->out_done) {
2287 if (info->out->chan_out) {
2288 _ckvmssts(sys$cancel(info->out->chan_out));
2289 if (!info->out->chan_in) { /* EOF generation, need AST */
2290 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2294 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2295 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2297 _ckvmssts(sys$setast(1));
2298 PerlIO_close(info->fp);
2301 we have to wait until subprocess completes, but ALSO wait until all
2302 the i/o completes...otherwise we'll be freeing the "info" structure
2303 that the i/o ASTs could still be using...
2307 _ckvmssts(sys$setast(0));
2308 done = info->done && info->in_done && info->out_done && info->err_done;
2309 if (!done) _ckvmssts(sys$clref(pipe_ef));
2310 _ckvmssts(sys$setast(1));
2311 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2313 retsts = info->completion;
2315 /* remove from list of open pipes */
2316 _ckvmssts(sys$setast(0));
2317 if (last) last->next = info->next;
2318 else open_pipes = info->next;
2319 _ckvmssts(sys$setast(1));
2321 /* free buffers and structures */
2324 if (info->in->buf) Safefree(info->in->buf);
2328 if (info->out->buf) Safefree(info->out->buf);
2329 Safefree(info->out);
2332 if (info->err->buf) Safefree(info->err->buf);
2333 Safefree(info->err);
2339 } /* end of my_pclose() */
2341 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2342 /* Roll our own prototype because we want this regardless of whether
2343 * _VMS_WAIT is defined.
2345 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2347 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2348 created with popen(); otherwise partially emulate waitpid() unless
2349 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2350 Also check processes not considered by the CRTL waitpid().
2352 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2354 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2360 if (statusp) *statusp = 0;
2362 for (info = open_pipes; info != NULL; info = info->next)
2363 if (info->pid == pid) break;
2365 if (info != NULL) { /* we know about this child */
2366 while (!info->done) {
2367 _ckvmssts(sys$setast(0));
2369 if (!done) _ckvmssts(sys$clref(pipe_ef));
2370 _ckvmssts(sys$setast(1));
2371 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2374 if (statusp) *statusp = info->completion;
2378 else { /* this child is not one of our own pipe children */
2380 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2382 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2383 * in 7.2 did we get a version that fills in the VMS completion
2384 * status as Perl has always tried to do.
2387 sts = __vms_waitpid( pid, statusp, flags );
2389 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2392 /* If the real waitpid tells us the child does not exist, we
2393 * fall through here to implement waiting for a child that
2394 * was created by some means other than exec() (say, spawned
2395 * from DCL) or to wait for a process that is not a subprocess
2396 * of the current process.
2399 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2401 $DESCRIPTOR(intdsc,"0 00:00:01");
2402 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2403 unsigned long int pidcode = JPI$_PID, mypid;
2404 unsigned long int interval[2];
2405 int termination_mbu = 0;
2406 unsigned short qio_iosb[4];
2407 unsigned int jpi_iosb[2];
2408 struct itmlst_3 jpilist[3] = {
2409 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2410 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2413 char trmmbx[NAM$C_DVI+1];
2414 $DESCRIPTOR(trmmbxdsc,trmmbx);
2415 struct accdef trmmsg;
2416 unsigned short int mbxchan;
2419 /* Sorry folks, we don't presently implement rooting around for
2420 the first child we can find, and we definitely don't want to
2421 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2427 /* Get the owner of the child so I can warn if it's not mine, plus
2428 * get the termination mailbox. If the process doesn't exist or I
2429 * don't have the privs to look at it, I can go home early.
2431 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2432 if (sts & 1) sts = jpi_iosb[0];
2444 set_vaxc_errno(sts);
2448 if (ckWARN(WARN_EXEC)) {
2449 /* remind folks they are asking for non-standard waitpid behavior */
2450 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2451 if (ownerpid != mypid)
2452 Perl_warner(aTHX_ WARN_EXEC,
2453 "waitpid: process %x is not a child of process %x",
2457 /* It's possible to have a mailbox unit number but no actual mailbox; we
2458 * check for this by assigning a channel to it, which we need anyway.
2460 if (termination_mbu != 0) {
2461 sprintf(trmmbx, "MBA%d:", termination_mbu);
2462 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2463 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2464 if (sts == SS$_NOSUCHDEV) {
2465 termination_mbu = 0; /* set up to take "no mailbox" case */
2470 /* If the process doesn't have a termination mailbox, then simply check
2471 * on it once a second until it's not there anymore.
2473 if (termination_mbu == 0) {
2474 _ckvmssts(sys$bintim(&intdsc,interval));
2475 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2476 _ckvmssts(sys$schdwk(0,0,interval,0));
2477 _ckvmssts(sys$hiber());
2479 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2482 /* If we do have a termination mailbox, post reads to it until we get a
2483 * termination message, discarding messages of the wrong type or for other
2484 * processes. If there is a place to put the final status, then do so.
2488 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2489 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2490 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2491 if (sts & 1) sts = qio_iosb[0];
2494 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2495 && trmmsg.acc$l_pid == pid ) {
2497 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2498 sts = sys$dassgn(mbxchan);
2502 } /* termination_mbu ? */
2507 } /* else one of our own pipe children */
2509 } /* end of waitpid() */
2514 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2516 my_gconvert(double val, int ndig, int trail, char *buf)
2518 static char __gcvtbuf[DBL_DIG+1];
2521 loc = buf ? buf : __gcvtbuf;
2523 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2525 sprintf(loc,"%.*g",ndig,val);
2531 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2532 return gcvt(val,ndig,loc);
2535 loc[0] = '0'; loc[1] = '\0';
2543 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2544 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2545 * to expand file specification. Allows for a single default file
2546 * specification and a simple mask of options. If outbuf is non-NULL,
2547 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2548 * the resultant file specification is placed. If outbuf is NULL, the
2549 * resultant file specification is placed into a static buffer.
2550 * The third argument, if non-NULL, is taken to be a default file
2551 * specification string. The fourth argument is unused at present.
2552 * rmesexpand() returns the address of the resultant string if
2553 * successful, and NULL on error.
2555 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2558 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2560 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2561 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2562 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2563 struct FAB myfab = cc$rms_fab;
2564 struct NAM mynam = cc$rms_nam;
2566 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2568 if (!filespec || !*filespec) {
2569 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2573 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2574 else outbuf = __rmsexpand_retbuf;
2576 if ((isunix = (strchr(filespec,'/') != NULL))) {
2577 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2578 filespec = vmsfspec;
2581 myfab.fab$l_fna = filespec;
2582 myfab.fab$b_fns = strlen(filespec);
2583 myfab.fab$l_nam = &mynam;
2585 if (defspec && *defspec) {
2586 if (strchr(defspec,'/') != NULL) {
2587 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2590 myfab.fab$l_dna = defspec;
2591 myfab.fab$b_dns = strlen(defspec);
2594 mynam.nam$l_esa = esa;
2595 mynam.nam$b_ess = sizeof esa;
2596 mynam.nam$l_rsa = outbuf;
2597 mynam.nam$b_rss = NAM$C_MAXRSS;
2599 retsts = sys$parse(&myfab,0,0);
2600 if (!(retsts & 1)) {
2601 mynam.nam$b_nop |= NAM$M_SYNCHK;
2602 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2603 retsts = sys$parse(&myfab,0,0);
2604 if (retsts & 1) goto expanded;
2606 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2607 (void) sys$parse(&myfab,0,0); /* Free search context */
2608 if (out) Safefree(out);
2609 set_vaxc_errno(retsts);
2610 if (retsts == RMS$_PRV) set_errno(EACCES);
2611 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2612 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2613 else set_errno(EVMSERR);
2616 retsts = sys$search(&myfab,0,0);
2617 if (!(retsts & 1) && retsts != RMS$_FNF) {
2618 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2619 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2620 if (out) Safefree(out);
2621 set_vaxc_errno(retsts);
2622 if (retsts == RMS$_PRV) set_errno(EACCES);
2623 else set_errno(EVMSERR);
2627 /* If the input filespec contained any lowercase characters,
2628 * downcase the result for compatibility with Unix-minded code. */
2630 for (out = myfab.fab$l_fna; *out; out++)
2631 if (islower(*out)) { haslower = 1; break; }
2632 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2633 else { out = esa; speclen = mynam.nam$b_esl; }
2634 /* Trim off null fields added by $PARSE
2635 * If type > 1 char, must have been specified in original or default spec
2636 * (not true for version; $SEARCH may have added version of existing file).
2638 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2639 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2640 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2641 if (trimver || trimtype) {
2642 if (defspec && *defspec) {
2643 char defesa[NAM$C_MAXRSS];
2644 struct FAB deffab = cc$rms_fab;
2645 struct NAM defnam = cc$rms_nam;
2647 deffab.fab$l_nam = &defnam;
2648 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2649 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2650 defnam.nam$b_nop = NAM$M_SYNCHK;
2651 if (sys$parse(&deffab,0,0) & 1) {
2652 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2653 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2656 if (trimver) speclen = mynam.nam$l_ver - out;
2658 /* If we didn't already trim version, copy down */
2659 if (speclen > mynam.nam$l_ver - out)
2660 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2661 speclen - (mynam.nam$l_ver - out));
2662 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2665 /* If we just had a directory spec on input, $PARSE "helpfully"
2666 * adds an empty name and type for us */
2667 if (mynam.nam$l_name == mynam.nam$l_type &&
2668 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2669 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2670 speclen = mynam.nam$l_name - out;
2671 out[speclen] = '\0';
2672 if (haslower) __mystrtolower(out);
2674 /* Have we been working with an expanded, but not resultant, spec? */
2675 /* Also, convert back to Unix syntax if necessary. */
2676 if (!mynam.nam$b_rsl) {
2678 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2680 else strcpy(outbuf,esa);
2683 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2684 strcpy(outbuf,tmpfspec);
2686 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2687 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2688 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2692 /* External entry points */
2693 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2694 { return do_rmsexpand(spec,buf,0,def,opt); }
2695 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2696 { return do_rmsexpand(spec,buf,1,def,opt); }
2700 ** The following routines are provided to make life easier when
2701 ** converting among VMS-style and Unix-style directory specifications.
2702 ** All will take input specifications in either VMS or Unix syntax. On
2703 ** failure, all return NULL. If successful, the routines listed below
2704 ** return a pointer to a buffer containing the appropriately
2705 ** reformatted spec (and, therefore, subsequent calls to that routine
2706 ** will clobber the result), while the routines of the same names with
2707 ** a _ts suffix appended will return a pointer to a mallocd string
2708 ** containing the appropriately reformatted spec.
2709 ** In all cases, only explicit syntax is altered; no check is made that
2710 ** the resulting string is valid or that the directory in question
2713 ** fileify_dirspec() - convert a directory spec into the name of the
2714 ** directory file (i.e. what you can stat() to see if it's a dir).
2715 ** The style (VMS or Unix) of the result is the same as the style
2716 ** of the parameter passed in.
2717 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2718 ** what you prepend to a filename to indicate what directory it's in).
2719 ** The style (VMS or Unix) of the result is the same as the style
2720 ** of the parameter passed in.
2721 ** tounixpath() - convert a directory spec into a Unix-style path.
2722 ** tovmspath() - convert a directory spec into a VMS-style path.
2723 ** tounixspec() - convert any file spec into a Unix-style file spec.
2724 ** tovmsspec() - convert any file spec into a VMS-style spec.
2726 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2727 ** Permission is given to distribute this code as part of the Perl
2728 ** standard distribution under the terms of the GNU General Public
2729 ** License or the Perl Artistic License. Copies of each may be
2730 ** found in the Perl standard distribution.
2733 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2734 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2736 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2737 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2738 char *retspec, *cp1, *cp2, *lastdir;
2739 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2741 if (!dir || !*dir) {
2742 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2744 dirlen = strlen(dir);
2745 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2746 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2747 strcpy(trndir,"/sys$disk/000000");
2751 if (dirlen > NAM$C_MAXRSS) {
2752 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2754 if (!strpbrk(dir+1,"/]>:")) {
2755 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2756 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2758 dirlen = strlen(dir);
2761 strncpy(trndir,dir,dirlen);
2762 trndir[dirlen] = '\0';
2765 /* If we were handed a rooted logical name or spec, treat it like a
2766 * simple directory, so that
2767 * $ Define myroot dev:[dir.]
2768 * ... do_fileify_dirspec("myroot",buf,1) ...
2769 * does something useful.
2771 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2772 dir[--dirlen] = '\0';
2773 dir[dirlen-1] = ']';
2775 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2776 dir[--dirlen] = '\0';
2777 dir[dirlen-1] = '>';
2780 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2781 /* If we've got an explicit filename, we can just shuffle the string. */
2782 if (*(cp1+1)) hasfilename = 1;
2783 /* Similarly, we can just back up a level if we've got multiple levels
2784 of explicit directories in a VMS spec which ends with directories. */
2786 for (cp2 = cp1; cp2 > dir; cp2--) {
2788 *cp2 = *cp1; *cp1 = '\0';
2792 if (*cp2 == '[' || *cp2 == '<') break;
2797 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2798 if (dir[0] == '.') {
2799 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2800 return do_fileify_dirspec("[]",buf,ts);
2801 else if (dir[1] == '.' &&
2802 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2803 return do_fileify_dirspec("[-]",buf,ts);
2805 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2806 dirlen -= 1; /* to last element */
2807 lastdir = strrchr(dir,'/');
2809 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2810 /* If we have "/." or "/..", VMSify it and let the VMS code
2811 * below expand it, rather than repeating the code to handle
2812 * relative components of a filespec here */
2814 if (*(cp1+2) == '.') cp1++;
2815 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2816 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2817 if (strchr(vmsdir,'/') != NULL) {
2818 /* If do_tovmsspec() returned it, it must have VMS syntax
2819 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2820 * the time to check this here only so we avoid a recursion
2821 * loop; otherwise, gigo.
2823 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2825 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2826 return do_tounixspec(trndir,buf,ts);
2829 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2830 lastdir = strrchr(dir,'/');
2832 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2833 /* Ditto for specs that end in an MFD -- let the VMS code
2834 * figure out whether it's a real device or a rooted logical. */
2835 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2836 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2837 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2838 return do_tounixspec(trndir,buf,ts);
2841 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2842 !(lastdir = cp1 = strrchr(dir,']')) &&
2843 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2844 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2846 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2847 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2848 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2849 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2850 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2851 (ver || *cp3)))))) {
2853 set_vaxc_errno(RMS$_DIR);
2859 /* If we lead off with a device or rooted logical, add the MFD
2860 if we're specifying a top-level directory. */
2861 if (lastdir && *dir == '/') {
2863 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2870 retlen = dirlen + (addmfd ? 13 : 6);
2871 if (buf) retspec = buf;
2872 else if (ts) New(1309,retspec,retlen+1,char);
2873 else retspec = __fileify_retbuf;
2875 dirlen = lastdir - dir;
2876 memcpy(retspec,dir,dirlen);
2877 strcpy(&retspec[dirlen],"/000000");
2878 strcpy(&retspec[dirlen+7],lastdir);
2881 memcpy(retspec,dir,dirlen);
2882 retspec[dirlen] = '\0';
2884 /* We've picked up everything up to the directory file name.
2885 Now just add the type and version, and we're set. */
2886 strcat(retspec,".dir;1");
2889 else { /* VMS-style directory spec */
2890 char esa[NAM$C_MAXRSS+1], term, *cp;
2891 unsigned long int sts, cmplen, haslower = 0;
2892 struct FAB dirfab = cc$rms_fab;
2893 struct NAM savnam, dirnam = cc$rms_nam;
2895 dirfab.fab$b_fns = strlen(dir);
2896 dirfab.fab$l_fna = dir;
2897 dirfab.fab$l_nam = &dirnam;
2898 dirfab.fab$l_dna = ".DIR;1";
2899 dirfab.fab$b_dns = 6;
2900 dirnam.nam$b_ess = NAM$C_MAXRSS;
2901 dirnam.nam$l_esa = esa;
2903 for (cp = dir; *cp; cp++)
2904 if (islower(*cp)) { haslower = 1; break; }
2905 if (!((sts = sys$parse(&dirfab))&1)) {
2906 if (dirfab.fab$l_sts == RMS$_DIR) {
2907 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2908 sts = sys$parse(&dirfab) & 1;
2912 set_vaxc_errno(dirfab.fab$l_sts);
2918 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2919 /* Yes; fake the fnb bits so we'll check type below */
2920 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2922 else { /* No; just work with potential name */
2923 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2925 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2926 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2927 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2932 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2933 cp1 = strchr(esa,']');
2934 if (!cp1) cp1 = strchr(esa,'>');
2935 if (cp1) { /* Should always be true */
2936 dirnam.nam$b_esl -= cp1 - esa - 1;
2937 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2940 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2941 /* Yep; check version while we're at it, if it's there. */
2942 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2943 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2944 /* Something other than .DIR[;1]. Bzzt. */
2945 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2946 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2948 set_vaxc_errno(RMS$_DIR);
2952 esa[dirnam.nam$b_esl] = '\0';
2953 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2954 /* They provided at least the name; we added the type, if necessary, */
2955 if (buf) retspec = buf; /* in sys$parse() */
2956 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2957 else retspec = __fileify_retbuf;
2958 strcpy(retspec,esa);
2959 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2960 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2963 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2964 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2966 dirnam.nam$b_esl -= 9;
2968 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2969 if (cp1 == NULL) { /* should never happen */
2970 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2971 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2976 retlen = strlen(esa);
2977 if ((cp1 = strrchr(esa,'.')) != NULL) {
2978 /* There's more than one directory in the path. Just roll back. */
2980 if (buf) retspec = buf;
2981 else if (ts) New(1311,retspec,retlen+7,char);
2982 else retspec = __fileify_retbuf;
2983 strcpy(retspec,esa);
2986 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2987 /* Go back and expand rooted logical name */
2988 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2989 if (!(sys$parse(&dirfab) & 1)) {
2990 dirnam.nam$l_rlf = NULL;
2991 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2993 set_vaxc_errno(dirfab.fab$l_sts);
2996 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2997 if (buf) retspec = buf;
2998 else if (ts) New(1312,retspec,retlen+16,char);
2999 else retspec = __fileify_retbuf;
3000 cp1 = strstr(esa,"][");
3001 if (!cp1) cp1 = strstr(esa,"]<");
3003 memcpy(retspec,esa,dirlen);
3004 if (!strncmp(cp1+2,"000000]",7)) {
3005 retspec[dirlen-1] = '\0';
3006 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3007 if (*cp1 == '.') *cp1 = ']';
3009 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3010 memcpy(cp1+1,"000000]",7);
3014 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3015 retspec[retlen] = '\0';
3016 /* Convert last '.' to ']' */
3017 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3018 if (*cp1 == '.') *cp1 = ']';
3020 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3021 memcpy(cp1+1,"000000]",7);
3025 else { /* This is a top-level dir. Add the MFD to the path. */
3026 if (buf) retspec = buf;
3027 else if (ts) New(1312,retspec,retlen+16,char);
3028 else retspec = __fileify_retbuf;
3031 while (*cp1 != ':') *(cp2++) = *(cp1++);
3032 strcpy(cp2,":[000000]");
3037 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3038 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3039 /* We've set up the string up through the filename. Add the
3040 type and version, and we're done. */
3041 strcat(retspec,".DIR;1");
3043 /* $PARSE may have upcased filespec, so convert output to lower
3044 * case if input contained any lowercase characters. */
3045 if (haslower) __mystrtolower(retspec);
3048 } /* end of do_fileify_dirspec() */
3050 /* External entry points */
3051 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3052 { return do_fileify_dirspec(dir,buf,0); }
3053 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3054 { return do_fileify_dirspec(dir,buf,1); }
3056 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3057 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3059 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3060 unsigned long int retlen;
3061 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3063 if (!dir || !*dir) {
3064 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3067 if (*dir) strcpy(trndir,dir);
3068 else getcwd(trndir,sizeof trndir - 1);
3070 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3071 && my_trnlnm(trndir,trndir,0)) {
3072 STRLEN trnlen = strlen(trndir);
3074 /* Trap simple rooted lnms, and return lnm:[000000] */
3075 if (!strcmp(trndir+trnlen-2,".]")) {
3076 if (buf) retpath = buf;
3077 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3078 else retpath = __pathify_retbuf;
3079 strcpy(retpath,dir);
3080 strcat(retpath,":[000000]");
3086 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3087 if (*dir == '.' && (*(dir+1) == '\0' ||
3088 (*(dir+1) == '.' && *(dir+2) == '\0')))
3089 retlen = 2 + (*(dir+1) != '\0');
3091 if ( !(cp1 = strrchr(dir,'/')) &&
3092 !(cp1 = strrchr(dir,']')) &&
3093 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3094 if ((cp2 = strchr(cp1,'.')) != NULL &&
3095 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3096 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3097 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3098 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3100 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3101 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3102 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3103 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3104 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3105 (ver || *cp3)))))) {
3107 set_vaxc_errno(RMS$_DIR);
3110 retlen = cp2 - dir + 1;
3112 else { /* No file type present. Treat the filename as a directory. */
3113 retlen = strlen(dir) + 1;
3116 if (buf) retpath = buf;
3117 else if (ts) New(1313,retpath,retlen+1,char);
3118 else retpath = __pathify_retbuf;
3119 strncpy(retpath,dir,retlen-1);
3120 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3121 retpath[retlen-1] = '/'; /* with '/', add it. */
3122 retpath[retlen] = '\0';
3124 else retpath[retlen-1] = '\0';
3126 else { /* VMS-style directory spec */
3127 char esa[NAM$C_MAXRSS+1], *cp;
3128 unsigned long int sts, cmplen, haslower;
3129 struct FAB dirfab = cc$rms_fab;
3130 struct NAM savnam, dirnam = cc$rms_nam;
3132 /* If we've got an explicit filename, we can just shuffle the string. */
3133 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3134 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3135 if ((cp2 = strchr(cp1,'.')) != NULL) {
3137 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3138 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3139 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3140 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3141 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3142 (ver || *cp3)))))) {
3144 set_vaxc_errno(RMS$_DIR);
3148 else { /* No file type, so just draw name into directory part */
3149 for (cp2 = cp1; *cp2; cp2++) ;
3152 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3154 /* We've now got a VMS 'path'; fall through */
3156 dirfab.fab$b_fns = strlen(dir);
3157 dirfab.fab$l_fna = dir;
3158 if (dir[dirfab.fab$b_fns-1] == ']' ||
3159 dir[dirfab.fab$b_fns-1] == '>' ||
3160 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3161 if (buf) retpath = buf;
3162 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3163 else retpath = __pathify_retbuf;
3164 strcpy(retpath,dir);
3167 dirfab.fab$l_dna = ".DIR;1";
3168 dirfab.fab$b_dns = 6;
3169 dirfab.fab$l_nam = &dirnam;
3170 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3171 dirnam.nam$l_esa = esa;
3173 for (cp = dir; *cp; cp++)
3174 if (islower(*cp)) { haslower = 1; break; }
3176 if (!(sts = (sys$parse(&dirfab)&1))) {
3177 if (dirfab.fab$l_sts == RMS$_DIR) {
3178 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3179 sts = sys$parse(&dirfab) & 1;
3183 set_vaxc_errno(dirfab.fab$l_sts);
3189 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3190 if (dirfab.fab$l_sts != RMS$_FNF) {
3191 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3192 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3194 set_vaxc_errno(dirfab.fab$l_sts);
3197 dirnam = savnam; /* No; just work with potential name */
3200 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3201 /* Yep; check version while we're at it, if it's there. */
3202 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3203 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3204 /* Something other than .DIR[;1]. Bzzt. */
3205 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3206 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3208 set_vaxc_errno(RMS$_DIR);
3212 /* OK, the type was fine. Now pull any file name into the
3214 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3216 cp1 = strrchr(esa,'>');
3217 *dirnam.nam$l_type = '>';
3220 *(dirnam.nam$l_type + 1) = '\0';
3221 retlen = dirnam.nam$l_type - esa + 2;
3222 if (buf) retpath = buf;
3223 else if (ts) New(1314,retpath,retlen,char);
3224 else retpath = __pathify_retbuf;
3225 strcpy(retpath,esa);
3226 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3227 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3228 /* $PARSE may have upcased filespec, so convert output to lower
3229 * case if input contained any lowercase characters. */
3230 if (haslower) __mystrtolower(retpath);
3234 } /* end of do_pathify_dirspec() */
3236 /* External entry points */
3237 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3238 { return do_pathify_dirspec(dir,buf,0); }
3239 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3240 { return do_pathify_dirspec(dir,buf,1); }
3242 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3243 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3245 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3246 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3247 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3249 if (spec == NULL) return NULL;
3250 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3251 if (buf) rslt = buf;
3253 retlen = strlen(spec);
3254 cp1 = strchr(spec,'[');
3255 if (!cp1) cp1 = strchr(spec,'<');
3257 for (cp1++; *cp1; cp1++) {
3258 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3259 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3260 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3263 New(1315,rslt,retlen+2+2*expand,char);
3265 else rslt = __tounixspec_retbuf;
3266 if (strchr(spec,'/') != NULL) {
3273 dirend = strrchr(spec,']');
3274 if (dirend == NULL) dirend = strrchr(spec,'>');
3275 if (dirend == NULL) dirend = strchr(spec,':');
3276 if (dirend == NULL) {
3280 if (*cp2 != '[' && *cp2 != '<') {
3283 else { /* the VMS spec begins with directories */
3285 if (*cp2 == ']' || *cp2 == '>') {
3286 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3289 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3290 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3291 if (ts) Safefree(rslt);
3296 while (*cp3 != ':' && *cp3) cp3++;
3298 if (strchr(cp3,']') != NULL) break;
3299 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3301 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3302 retlen = devlen + dirlen;
3303 Renew(rslt,retlen+1+2*expand,char);
3309 *(cp1++) = *(cp3++);
3310 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3314 else if ( *cp2 == '.') {
3315 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3316 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3322 for (; cp2 <= dirend; cp2++) {
3325 if (*(cp2+1) == '[') cp2++;
3327 else if (*cp2 == ']' || *cp2 == '>') {
3328 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3330 else if (*cp2 == '.') {
3332 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3333 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3334 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3335 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3336 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3338 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3339 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3343 else if (*cp2 == '-') {
3344 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3345 while (*cp2 == '-') {
3347 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3349 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3350 if (ts) Safefree(rslt); /* filespecs like */
3351 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3355 else *(cp1++) = *cp2;
3357 else *(cp1++) = *cp2;
3359 while (*cp2) *(cp1++) = *(cp2++);
3364 } /* end of do_tounixspec() */
3366 /* External entry points */
3367 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3368 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3370 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3371 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3372 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3373 char *rslt, *dirend;
3374 register char *cp1, *cp2;
3375 unsigned long int infront = 0, hasdir = 1;
3377 if (path == NULL) return NULL;
3378 if (buf) rslt = buf;
3379 else if (ts) New(1316,rslt,strlen(path)+9,char);
3380 else rslt = __tovmsspec_retbuf;
3381 if (strpbrk(path,"]:>") ||
3382 (dirend = strrchr(path,'/')) == NULL) {
3383 if (path[0] == '.') {
3384 if (path[1] == '\0') strcpy(rslt,"[]");
3385 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3386 else strcpy(rslt,path); /* probably garbage */
3388 else strcpy(rslt,path);
3391 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3392 if (!*(dirend+2)) dirend +=2;
3393 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3394 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3399 char trndev[NAM$C_MAXRSS+1];
3403 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3405 if (!buf & ts) Renew(rslt,18,char);
3406 strcpy(rslt,"sys$disk:[000000]");
3409 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3411 islnm = my_trnlnm(rslt,trndev,0);
3412 trnend = islnm ? strlen(trndev) - 1 : 0;
3413 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3414 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3415 /* If the first element of the path is a logical name, determine
3416 * whether it has to be translated so we can add more directories. */
3417 if (!islnm || rooted) {
3420 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3424 if (cp2 != dirend) {
3425 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3426 strcpy(rslt,trndev);
3427 cp1 = rslt + trnend;
3440 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3441 cp2 += 2; /* skip over "./" - it's redundant */
3442 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3444 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3445 *(cp1++) = '-'; /* "../" --> "-" */
3448 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3449 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3450 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3451 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3454 if (cp2 > dirend) cp2 = dirend;
3456 else *(cp1++) = '.';
3458 for (; cp2 < dirend; cp2++) {
3460 if (*(cp2-1) == '/') continue;
3461 if (*(cp1-1) != '.') *(cp1++) = '.';
3464 else if (!infront && *cp2 == '.') {
3465 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3466 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3467 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3468 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3469 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3470 else { /* back up over previous directory name */
3472 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3473 if (*(cp1-1) == '[') {
3474 memcpy(cp1,"000000.",7);
3479 if (cp2 == dirend) break;
3481 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3482 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3483 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3484 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3486 *(cp1++) = '.'; /* Simulate trailing '/' */
3487 cp2 += 2; /* for loop will incr this to == dirend */
3489 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3491 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3494 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3495 if (*cp2 == '.') *(cp1++) = '_';
3496 else *(cp1++) = *cp2;
3500 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3501 if (hasdir) *(cp1++) = ']';
3502 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3503 while (*cp2) *(cp1++) = *(cp2++);
3508 } /* end of do_tovmsspec() */
3510 /* External entry points */
3511 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3512 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3514 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3515 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3516 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3518 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3520 if (path == NULL) return NULL;
3521 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3522 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3523 if (buf) return buf;
3525 vmslen = strlen(vmsified);
3526 New(1317,cp,vmslen+1,char);
3527 memcpy(cp,vmsified,vmslen);
3532 strcpy(__tovmspath_retbuf,vmsified);
3533 return __tovmspath_retbuf;
3536 } /* end of do_tovmspath() */
3538 /* External entry points */
3539 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3540 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3543 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3544 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3545 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3547 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3549 if (path == NULL) return NULL;
3550 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3551 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3552 if (buf) return buf;
3554 unixlen = strlen(unixified);
3555 New(1317,cp,unixlen+1,char);
3556 memcpy(cp,unixified,unixlen);
3561 strcpy(__tounixpath_retbuf,unixified);
3562 return __tounixpath_retbuf;
3565 } /* end of do_tounixpath() */
3567 /* External entry points */
3568 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3569 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3572 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3574 *****************************************************************************
3576 * Copyright (C) 1989-1994 by *
3577 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3579 * Permission is hereby granted for the reproduction of this software, *
3580 * on condition that this copyright notice is included in the reproduction, *
3581 * and that such reproduction is not for purposes of profit or material *
3584 * 27-Aug-1994 Modified for inclusion in perl5 *
3585 * by Charles Bailey bailey@newman.upenn.edu *
3586 *****************************************************************************
3590 * getredirection() is intended to aid in porting C programs
3591 * to VMS (Vax-11 C). The native VMS environment does not support
3592 * '>' and '<' I/O redirection, or command line wild card expansion,
3593 * or a command line pipe mechanism using the '|' AND background
3594 * command execution '&'. All of these capabilities are provided to any
3595 * C program which calls this procedure as the first thing in the
3597 * The piping mechanism will probably work with almost any 'filter' type
3598 * of program. With suitable modification, it may useful for other
3599 * portability problems as well.
3601 * Author: Mark Pizzolato mark@infocomm.com
3605 struct list_item *next;
3609 static void add_item(struct list_item **head,
3610 struct list_item **tail,
3614 static void mp_expand_wild_cards(pTHX_ char *item,
3615 struct list_item **head,
3616 struct list_item **tail,
3619 static int background_process(int argc, char **argv);
3621 static void pipe_and_fork(pTHX_ char **cmargv);
3623 /*{{{ void getredirection(int *ac, char ***av)*/
3625 mp_getredirection(pTHX_ int *ac, char ***av)
3627 * Process vms redirection arg's. Exit if any error is seen.
3628 * If getredirection() processes an argument, it is erased
3629 * from the vector. getredirection() returns a new argc and argv value.
3630 * In the event that a background command is requested (by a trailing "&"),
3631 * this routine creates a background subprocess, and simply exits the program.
3633 * Warning: do not try to simplify the code for vms. The code
3634 * presupposes that getredirection() is called before any data is
3635 * read from stdin or written to stdout.
3637 * Normal usage is as follows:
3643 * getredirection(&argc, &argv);
3647 int argc = *ac; /* Argument Count */
3648 char **argv = *av; /* Argument Vector */
3649 char *ap; /* Argument pointer */
3650 int j; /* argv[] index */
3651 int item_count = 0; /* Count of Items in List */
3652 struct list_item *list_head = 0; /* First Item in List */
3653 struct list_item *list_tail; /* Last Item in List */
3654 char *in = NULL; /* Input File Name */
3655 char *out = NULL; /* Output File Name */
3656 char *outmode = "w"; /* Mode to Open Output File */
3657 char *err = NULL; /* Error File Name */
3658 char *errmode = "w"; /* Mode to Open Error File */
3659 int cmargc = 0; /* Piped Command Arg Count */
3660 char **cmargv = NULL;/* Piped Command Arg Vector */
3663 * First handle the case where the last thing on the line ends with
3664 * a '&'. This indicates the desire for the command to be run in a
3665 * subprocess, so we satisfy that desire.
3668 if (0 == strcmp("&", ap))
3669 exit(background_process(--argc, argv));
3670 if (*ap && '&' == ap[strlen(ap)-1])
3672 ap[strlen(ap)-1] = '\0';
3673 exit(background_process(argc, argv));
3676 * Now we handle the general redirection cases that involve '>', '>>',
3677 * '<', and pipes '|'.
3679 for (j = 0; j < argc; ++j)
3681 if (0 == strcmp("<", argv[j]))
3685 fprintf(stderr,"No input file after < on command line");
3686 exit(LIB$_WRONUMARG);
3691 if ('<' == *(ap = argv[j]))
3696 if (0 == strcmp(">", ap))
3700 fprintf(stderr,"No output file after > on command line");
3701 exit(LIB$_WRONUMARG);
3720 fprintf(stderr,"No output file after > or >> on command line");
3721 exit(LIB$_WRONUMARG);
3725 if (('2' == *ap) && ('>' == ap[1]))
3742 fprintf(stderr,"No output file after 2> or 2>> on command line");
3743 exit(LIB$_WRONUMARG);
3747 if (0 == strcmp("|", argv[j]))
3751 fprintf(stderr,"No command into which to pipe on command line");
3752 exit(LIB$_WRONUMARG);
3754 cmargc = argc-(j+1);
3755 cmargv = &argv[j+1];
3759 if ('|' == *(ap = argv[j]))
3767 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3770 * Allocate and fill in the new argument vector, Some Unix's terminate
3771 * the list with an extra null pointer.
3773 New(1302, argv, item_count+1, char *);
3775 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3776 argv[j] = list_head->value;
3782 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3783 exit(LIB$_INVARGORD);
3785 pipe_and_fork(aTHX_ cmargv);
3788 /* Check for input from a pipe (mailbox) */
3790 if (in == NULL && 1 == isapipe(0))
3792 char mbxname[L_tmpnam];
3794 long int dvi_item = DVI$_DEVBUFSIZ;
3795 $DESCRIPTOR(mbxnam, "");
3796 $DESCRIPTOR(mbxdevnam, "");
3798 /* Input from a pipe, reopen it in binary mode to disable */
3799 /* carriage control processing. */
3801 fgetname(stdin, mbxname);
3802 mbxnam.dsc$a_pointer = mbxname;
3803 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3804 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3805 mbxdevnam.dsc$a_pointer = mbxname;
3806 mbxdevnam.dsc$w_length = sizeof(mbxname);
3807 dvi_item = DVI$_DEVNAM;
3808 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3809 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3812 freopen(mbxname, "rb", stdin);
3815 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3819 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3821 fprintf(stderr,"Can't open input file %s as stdin",in);
3824 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3826 fprintf(stderr,"Can't open output file %s as stdout",out);
3829 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3832 if (strcmp(err,"&1") == 0) {
3833 dup2(fileno(stdout), fileno(stderr));
3834 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3837 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3839 fprintf(stderr,"Can't open error file %s as stderr",err);
3843 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3847 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3850 #ifdef ARGPROC_DEBUG
3851 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3852 for (j = 0; j < *ac; ++j)
3853 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3855 /* Clear errors we may have hit expanding wildcards, so they don't
3856 show up in Perl's $! later */
3857 set_errno(0); set_vaxc_errno(1);
3858 } /* end of getredirection() */
3861 static void add_item(struct list_item **head,
3862 struct list_item **tail,
3868 New(1303,*head,1,struct list_item);
3872 New(1304,(*tail)->next,1,struct list_item);
3873 *tail = (*tail)->next;
3875 (*tail)->value = value;
3879 static void mp_expand_wild_cards(pTHX_ char *item,
3880 struct list_item **head,
3881 struct list_item **tail,
3885 unsigned long int context = 0;
3891 char vmsspec[NAM$C_MAXRSS+1];
3892 $DESCRIPTOR(filespec, "");
3893 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3894 $DESCRIPTOR(resultspec, "");
3895 unsigned long int zero = 0, sts;
3897 for (cp = item; *cp; cp++) {
3898 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3899 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3901 if (!*cp || isspace(*cp))
3903 add_item(head, tail, item, count);
3906 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3907 resultspec.dsc$b_class = DSC$K_CLASS_D;
3908 resultspec.dsc$a_pointer = NULL;
3909 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3910 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3911 if (!isunix || !filespec.dsc$a_pointer)
3912 filespec.dsc$a_pointer = item;
3913 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3915 * Only return version specs, if the caller specified a version
3917 had_version = strchr(item, ';');
3919 * Only return device and directory specs, if the caller specifed either.
3921 had_device = strchr(item, ':');
3922 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3924 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3925 &defaultspec, 0, 0, &zero))))
3930 New(1305,string,resultspec.dsc$w_length+1,char);
3931 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3932 string[resultspec.dsc$w_length] = '\0';
3933 if (NULL == had_version)
3934 *((char *)strrchr(string, ';')) = '\0';
3935 if ((!had_directory) && (had_device == NULL))
3937 if (NULL == (devdir = strrchr(string, ']')))
3938 devdir = strrchr(string, '>');
3939 strcpy(string, devdir + 1);
3942 * Be consistent with what the C RTL has already done to the rest of
3943 * the argv items and lowercase all of these names.
3945 for (c = string; *c; ++c)
3948 if (isunix) trim_unixpath(string,item,1);
3949 add_item(head, tail, string, count);
3952 if (sts != RMS$_NMF)
3954 set_vaxc_errno(sts);
3957 case RMS$_FNF: case RMS$_DNF:
3958 set_errno(ENOENT); break;
3960 set_errno(ENOTDIR); break;
3962 set_errno(ENODEV); break;
3963 case RMS$_FNM: case RMS$_SYN:
3964 set_errno(EINVAL); break;
3966 set_errno(EACCES); break;
3968 _ckvmssts_noperl(sts);
3972 add_item(head, tail, item, count);
3973 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3974 _ckvmssts_noperl(lib$find_file_end(&context));
3977 static int child_st[2];/* Event Flag set when child process completes */
3979 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3981 static unsigned long int exit_handler(int *status)
3985 if (0 == child_st[0])
3987 #ifdef ARGPROC_DEBUG
3988 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3990 fflush(stdout); /* Have to flush pipe for binary data to */
3991 /* terminate properly -- <tp@mccall.com> */
3992 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3993 sys$dassgn(child_chan);
3995 sys$synch(0, child_st);
4000 static void sig_child(int chan)
4002 #ifdef ARGPROC_DEBUG
4003 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4005 if (child_st[0] == 0)
4009 static struct exit_control_block exit_block =
4014 &exit_block.exit_status,
4018 static void pipe_and_fork(pTHX_ char **cmargv)
4021 $DESCRIPTOR(cmddsc, "");
4022 static char mbxname[64];
4023 $DESCRIPTOR(mbxdsc, mbxname);
4025 unsigned long int zero = 0, one = 1;
4027 strcpy(subcmd, cmargv[0]);
4028 for (j = 1; NULL != cmargv[j]; ++j)
4030 strcat(subcmd, " \"");
4031 strcat(subcmd, cmargv[j]);
4032 strcat(subcmd, "\"");
4034 cmddsc.dsc$a_pointer = subcmd;
4035 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
4037 create_mbx(aTHX_ &child_chan,&mbxdsc);
4038 #ifdef ARGPROC_DEBUG
4039 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
4040 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
4042 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
4043 0, &pid, child_st, &zero, sig_child,
4045 #ifdef ARGPROC_DEBUG
4046 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
4048 sys$dclexh(&exit_block);
4049 if (NULL == freopen(mbxname, "wb", stdout))
4051 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
4055 static int background_process(int argc, char **argv)
4057 char command[2048] = "$";
4058 $DESCRIPTOR(value, "");
4059 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4060 static $DESCRIPTOR(null, "NLA0:");
4061 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4063 $DESCRIPTOR(pidstr, "");
4065 unsigned long int flags = 17, one = 1, retsts;
4067 strcat(command, argv[0]);
4070 strcat(command, " \"");
4071 strcat(command, *(++argv));
4072 strcat(command, "\"");
4074 value.dsc$a_pointer = command;
4075 value.dsc$w_length = strlen(value.dsc$a_pointer);
4076 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4077 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4078 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4079 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4082 _ckvmssts_noperl(retsts);
4084 #ifdef ARGPROC_DEBUG
4085 PerlIO_printf(Perl_debug_log, "%s\n", command);
4087 sprintf(pidstring, "%08X", pid);
4088 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4089 pidstr.dsc$a_pointer = pidstring;
4090 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4091 lib$set_symbol(&pidsymbol, &pidstr);
4095 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4098 /* OS-specific initialization at image activation (not thread startup) */
4099 /* Older VAXC header files lack these constants */
4100 #ifndef JPI$_RIGHTS_SIZE
4101 # define JPI$_RIGHTS_SIZE 817
4103 #ifndef KGB$M_SUBSYSTEM
4104 # define KGB$M_SUBSYSTEM 0x8
4107 /*{{{void vms_image_init(int *, char ***)*/
4109 vms_image_init(int *argcp, char ***argvp)
4111 char eqv[LNM$C_NAMLENGTH+1] = "";
4112 unsigned int len, tabct = 8, tabidx = 0;
4113 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4114 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4115 unsigned short int dummy, rlen;
4116 struct dsc$descriptor_s **tabvec;
4117 #if defined(PERL_IMPLICIT_CONTEXT)
4120 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4121 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4122 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4125 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4126 _ckvmssts_noperl(iosb[0]);
4127 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4128 if (iprv[i]) { /* Running image installed with privs? */
4129 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4134 /* Rights identifiers might trigger tainting as well. */
4135 if (!will_taint && (rlen || rsz)) {
4136 while (rlen < rsz) {
4137 /* We didn't get all the identifiers on the first pass. Allocate a
4138 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4139 * were needed to hold all identifiers at time of last call; we'll
4140 * allocate that many unsigned long ints), and go back and get 'em.
4141 * If it gave us less than it wanted to despite ample buffer space,
4142 * something's broken. Is your system missing a system identifier?
4144 if (rsz <= jpilist[1].buflen) {
4145 /* Perl_croak accvios when used this early in startup. */
4146 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4147 rsz, (unsigned long) jpilist[1].buflen,
4148 "Check your rights database for corruption.\n");
4151 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4152 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4153 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4154 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4155 _ckvmssts_noperl(iosb[0]);
4157 mask = jpilist[1].bufadr;
4158 /* Check attribute flags for each identifier (2nd longword); protected
4159 * subsystem identifiers trigger tainting.
4161 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4162 if (mask[i] & KGB$M_SUBSYSTEM) {
4167 if (mask != rlst) Safefree(mask);
4169 /* We need to use this hack to tell Perl it should run with tainting,
4170 * since its tainting flag may be part of the PL_curinterp struct, which
4171 * hasn't been allocated when vms_image_init() is called.
4175 New(1320,newap,*argcp+2,char **);
4176 newap[0] = argvp[0];
4178 Copy(argvp[1],newap[2],*argcp-1,char **);
4179 /* We orphan the old argv, since we don't know where it's come from,
4180 * so we don't know how to free it.
4182 *argcp++; argvp = newap;
4184 else { /* Did user explicitly request tainting? */
4186 char *cp, **av = *argvp;
4187 for (i = 1; i < *argcp; i++) {
4188 if (*av[i] != '-') break;
4189 for (cp = av[i]+1; *cp; cp++) {
4190 if (*cp == 'T') { will_taint = 1; break; }
4191 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4192 strchr("DFIiMmx",*cp)) break;
4194 if (will_taint) break;
4199 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4201 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4202 else if (tabidx >= tabct) {
4204 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4206 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4207 tabvec[tabidx]->dsc$w_length = 0;
4208 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4209 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4210 tabvec[tabidx]->dsc$a_pointer = NULL;
4211 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4213 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4215 getredirection(argcp,argvp);
4216 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4218 # include <reentrancy.h>
4219 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4228 * Trim Unix-style prefix off filespec, so it looks like what a shell
4229 * glob expansion would return (i.e. from specified prefix on, not
4230 * full path). Note that returned filespec is Unix-style, regardless
4231 * of whether input filespec was VMS-style or Unix-style.
4233 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4234 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4235 * vector of options; at present, only bit 0 is used, and if set tells
4236 * trim unixpath to try the current default directory as a prefix when
4237 * presented with a possibly ambiguous ... wildcard.
4239 * Returns !=0 on success, with trimmed filespec replacing contents of
4240 * fspec, and 0 on failure, with contents of fpsec unchanged.
4242 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4244 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4246 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4247 *template, *base, *end, *cp1, *cp2;
4248 register int tmplen, reslen = 0, dirs = 0;
4250 if (!wildspec || !fspec) return 0;
4251 if (strpbrk(wildspec,"]>:") != NULL) {
4252 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4253 else template = unixwild;
4255 else template = wildspec;
4256 if (strpbrk(fspec,"]>:") != NULL) {
4257 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4258 else base = unixified;
4259 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4260 * check to see that final result fits into (isn't longer than) fspec */
4261 reslen = strlen(fspec);
4265 /* No prefix or absolute path on wildcard, so nothing to remove */
4266 if (!*template || *template == '/') {
4267 if (base == fspec) return 1;
4268 tmplen = strlen(unixified);
4269 if (tmplen > reslen) return 0; /* not enough space */
4270 /* Copy unixified resultant, including trailing NUL */
4271 memmove(fspec,unixified,tmplen+1);
4275 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4276 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4277 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4278 for (cp1 = end ;cp1 >= base; cp1--)
4279 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4281 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4285 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4286 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4287 int ells = 1, totells, segdirs, match;
4288 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4289 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4291 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4293 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4294 if (ellipsis == template && opts & 1) {
4295 /* Template begins with an ellipsis. Since we can't tell how many
4296 * directory names at the front of the resultant to keep for an
4297 * arbitrary starting point, we arbitrarily choose the current
4298 * default directory as a starting point. If it's there as a prefix,
4299 * clip it off. If not, fall through and act as if the leading
4300 * ellipsis weren't there (i.e. return shortest possible path that
4301 * could match template).
4303 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4304 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4305 if (_tolower(*cp1) != _tolower(*cp2)) break;
4306 segdirs = dirs - totells; /* Min # of dirs we must have left */
4307 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4308 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4309 memcpy(fspec,cp2+1,end - cp2);
4313 /* First off, back up over constant elements at end of path */
4315 for (front = end ; front >= base; front--)
4316 if (*front == '/' && !dirs--) { front++; break; }
4318 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4319 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4320 if (cp1 != '\0') return 0; /* Path too long. */
4322 *cp2 = '\0'; /* Pick up with memcpy later */
4323 lcfront = lcres + (front - base);
4324 /* Now skip over each ellipsis and try to match the path in front of it. */
4326 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4327 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4328 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4329 if (cp1 < template) break; /* template started with an ellipsis */
4330 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4331 ellipsis = cp1; continue;
4333 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4335 for (segdirs = 0, cp2 = tpl;
4336 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4338 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4339 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4340 if (*cp2 == '/') segdirs++;
4342 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4343 /* Back up at least as many dirs as in template before matching */
4344 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4345 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4346 for (match = 0; cp1 > lcres;) {
4347 resdsc.dsc$a_pointer = cp1;
4348 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4350 if (match == 1) lcfront = cp1;
4352 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4354 if (!match) return 0; /* Can't find prefix ??? */
4355 if (match > 1 && opts & 1) {
4356 /* This ... wildcard could cover more than one set of dirs (i.e.
4357 * a set of similar dir names is repeated). If the template
4358 * contains more than 1 ..., upstream elements could resolve the
4359 * ambiguity, but it's not worth a full backtracking setup here.
4360 * As a quick heuristic, clip off the current default directory
4361 * if it's present to find the trimmed spec, else use the
4362 * shortest string that this ... could cover.
4364 char def[NAM$C_MAXRSS+1], *st;
4366 if (getcwd(def, sizeof def,0) == NULL) return 0;
4367 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4368 if (_tolower(*cp1) != _tolower(*cp2)) break;
4369 segdirs = dirs - totells; /* Min # of dirs we must have left */
4370 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4371 if (*cp1 == '\0' && *cp2 == '/') {
4372 memcpy(fspec,cp2+1,end - cp2);
4375 /* Nope -- stick with lcfront from above and keep going. */
4378 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4383 } /* end of trim_unixpath() */
4388 * VMS readdir() routines.
4389 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4391 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4392 * Minor modifications to original routines.
4395 /* Number of elements in vms_versions array */
4396 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4399 * Open a directory, return a handle for later use.
4401 /*{{{ DIR *opendir(char*name) */
4403 Perl_opendir(pTHX_ char *name)
4406 char dir[NAM$C_MAXRSS+1];
4409 if (do_tovmspath(name,dir,0) == NULL) {
4412 if (flex_stat(dir,&sb) == -1) return NULL;
4413 if (!S_ISDIR(sb.st_mode)) {
4414 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4417 if (!cando_by_name(S_IRUSR,0,dir)) {
4418 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4421 /* Get memory for the handle, and the pattern. */
4423 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4425 /* Fill in the fields; mainly playing with the descriptor. */
4426 (void)sprintf(dd->pattern, "%s*.*",dir);
4429 dd->vms_wantversions = 0;
4430 dd->pat.dsc$a_pointer = dd->pattern;
4431 dd->pat.dsc$w_length = strlen(dd->pattern);
4432 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4433 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4436 } /* end of opendir() */
4440 * Set the flag to indicate we want versions or not.
4442 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4444 vmsreaddirversions(DIR *dd, int flag)
4446 dd->vms_wantversions = flag;
4451 * Free up an opened directory.
4453 /*{{{ void closedir(DIR *dd)*/
4457 (void)lib$find_file_end(&dd->context);
4458 Safefree(dd->pattern);
4459 Safefree((char *)dd);
4464 * Collect all the version numbers for the current file.
4467 collectversions(pTHX_ DIR *dd)
4469 struct dsc$descriptor_s pat;
4470 struct dsc$descriptor_s res;
4472 char *p, *text, buff[sizeof dd->entry.d_name];
4474 unsigned long context, tmpsts;
4476 /* Convenient shorthand. */
4479 /* Add the version wildcard, ignoring the "*.*" put on before */
4480 i = strlen(dd->pattern);
4481 New(1308,text,i + e->d_namlen + 3,char);
4482 (void)strcpy(text, dd->pattern);
4483 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4485 /* Set up the pattern descriptor. */
4486 pat.dsc$a_pointer = text;
4487 pat.dsc$w_length = i + e->d_namlen - 1;
4488 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4489 pat.dsc$b_class = DSC$K_CLASS_S;
4491 /* Set up result descriptor. */
4492 res.dsc$a_pointer = buff;
4493 res.dsc$w_length = sizeof buff - 2;
4494 res.dsc$b_dtype = DSC$K_DTYPE_T;
4495 res.dsc$b_class = DSC$K_CLASS_S;
4497 /* Read files, collecting versions. */
4498 for (context = 0, e->vms_verscount = 0;
4499 e->vms_verscount < VERSIZE(e);
4500 e->vms_verscount++) {
4501 tmpsts = lib$find_file(&pat, &res, &context);
4502 if (tmpsts == RMS$_NMF || context == 0) break;
4504 buff[sizeof buff - 1] = '\0';
4505 if ((p = strchr(buff, ';')))
4506 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4508 e->vms_versions[e->vms_verscount] = -1;
4511 _ckvmssts(lib$find_file_end(&context));
4514 } /* end of collectversions() */
4517 * Read the next entry from the directory.
4519 /*{{{ struct dirent *readdir(DIR *dd)*/
4521 Perl_readdir(pTHX_ DIR *dd)
4523 struct dsc$descriptor_s res;
4524 char *p, buff[sizeof dd->entry.d_name];
4525 unsigned long int tmpsts;
4527 /* Set up result descriptor, and get next file. */
4528 res.dsc$a_pointer = buff;
4529 res.dsc$w_length = sizeof buff - 2;
4530 res.dsc$b_dtype = DSC$K_DTYPE_T;
4531 res.dsc$b_class = DSC$K_CLASS_S;
4532 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4533 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4534 if (!(tmpsts & 1)) {
4535 set_vaxc_errno(tmpsts);
4538 set_errno(EACCES); break;
4540 set_errno(ENODEV); break;
4542 set_errno(ENOTDIR); break;
4543 case RMS$_FNF: case RMS$_DNF:
4544 set_errno(ENOENT); break;
4551 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4552 buff[sizeof buff - 1] = '\0';
4553 for (p = buff; *p; p++) *p = _tolower(*p);
4554 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4557 /* Skip any directory component and just copy the name. */
4558 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4559 else (void)strcpy(dd->entry.d_name, buff);
4561 /* Clobber the version. */
4562 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4564 dd->entry.d_namlen = strlen(dd->entry.d_name);
4565 dd->entry.vms_verscount = 0;
4566 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4569 } /* end of readdir() */
4573 * Return something that can be used in a seekdir later.
4575 /*{{{ long telldir(DIR *dd)*/
4584 * Return to a spot where we used to be. Brute force.
4586 /*{{{ void seekdir(DIR *dd,long count)*/
4588 Perl_seekdir(pTHX_ DIR *dd, long count)
4590 int vms_wantversions;
4592 /* If we haven't done anything yet... */
4596 /* Remember some state, and clear it. */
4597 vms_wantversions = dd->vms_wantversions;
4598 dd->vms_wantversions = 0;
4599 _ckvmssts(lib$find_file_end(&dd->context));
4602 /* The increment is in readdir(). */
4603 for (dd->count = 0; dd->count < count; )
4606 dd->vms_wantversions = vms_wantversions;
4608 } /* end of seekdir() */
4611 /* VMS subprocess management
4613 * my_vfork() - just a vfork(), after setting a flag to record that
4614 * the current script is trying a Unix-style fork/exec.
4616 * vms_do_aexec() and vms_do_exec() are called in response to the
4617 * perl 'exec' function. If this follows a vfork call, then they
4618 * call out the the regular perl routines in doio.c which do an
4619 * execvp (for those who really want to try this under VMS).
4620 * Otherwise, they do exactly what the perl docs say exec should
4621 * do - terminate the current script and invoke a new command
4622 * (See below for notes on command syntax.)
4624 * do_aspawn() and do_spawn() implement the VMS side of the perl
4625 * 'system' function.
4627 * Note on command arguments to perl 'exec' and 'system': When handled
4628 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4629 * are concatenated to form a DCL command string. If the first arg
4630 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4631 * the the command string is handed off to DCL directly. Otherwise,
4632 * the first token of the command is taken as the filespec of an image
4633 * to run. The filespec is expanded using a default type of '.EXE' and
4634 * the process defaults for device, directory, etc., and if found, the resultant
4635 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4636 * the command string as parameters. This is perhaps a bit complicated,
4637 * but I hope it will form a happy medium between what VMS folks expect
4638 * from lib$spawn and what Unix folks expect from exec.
4641 static int vfork_called;
4643 /*{{{int my_vfork()*/
4654 vms_execfree(pTHX) {
4656 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4659 if (VMScmd.dsc$a_pointer) {
4660 Safefree(VMScmd.dsc$a_pointer);
4661 VMScmd.dsc$w_length = 0;
4662 VMScmd.dsc$a_pointer = Nullch;
4667 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4669 char *junk, *tmps = Nullch;
4670 register size_t cmdlen = 0;
4677 tmps = SvPV(really,rlen);
4684 for (idx++; idx <= sp; idx++) {
4686 junk = SvPVx(*idx,rlen);
4687 cmdlen += rlen ? rlen + 1 : 0;
4690 New(401,PL_Cmd,cmdlen+1,char);
4692 if (tmps && *tmps) {
4693 strcpy(PL_Cmd,tmps);
4696 else *PL_Cmd = '\0';
4697 while (++mark <= sp) {
4699 char *s = SvPVx(*mark,n_a);
4701 if (*PL_Cmd) strcat(PL_Cmd," ");
4707 } /* end of setup_argstr() */
4709 #define MAX_DCL_LINE_LENGTH 255
4711 static unsigned long int
4712 setup_cmddsc(pTHX_ char *cmd, int check_img)
4714 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4715 $DESCRIPTOR(defdsc,".EXE");
4716 $DESCRIPTOR(defdsc2,".");
4717 $DESCRIPTOR(resdsc,resspec);
4718 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4719 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4720 register char *s, *rest, *cp, *wordbreak;
4723 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4724 return CLI$_BUFOVF; /* continuation lines currently unsupported */
4726 while (*s && isspace(*s)) s++;
4728 if (*s == '@' || *s == '$') {
4729 vmsspec[0] = *s; rest = s + 1;
4730 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4732 else { cp = vmsspec; rest = s; }
4733 if (*rest == '.' || *rest == '/') {
4736 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4737 rest++, cp2++) *cp2 = *rest;
4739 if (do_tovmsspec(resspec,cp,0)) {
4742 for (cp2 = vmsspec + strlen(vmsspec);
4743 *rest && cp2 - vmsspec < sizeof vmsspec;
4744 rest++, cp2++) *cp2 = *rest;
4749 /* Intuit whether verb (first word of cmd) is a DCL command:
4750 * - if first nonspace char is '@', it's a DCL indirection
4752 * - if verb contains a filespec separator, it's not a DCL command
4753 * - if it doesn't, caller tells us whether to default to a DCL
4754 * command, or to a local image unless told it's DCL (by leading '$')
4756 if (*s == '@') isdcl = 1;
4758 register char *filespec = strpbrk(s,":<[.;");
4759 rest = wordbreak = strpbrk(s," \"\t/");
4760 if (!wordbreak) wordbreak = s + strlen(s);
4761 if (*s == '$') check_img = 0;
4762 if (filespec && (filespec < wordbreak)) isdcl = 0;
4763 else isdcl = !check_img;
4767 imgdsc.dsc$a_pointer = s;
4768 imgdsc.dsc$w_length = wordbreak - s;
4769 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4771 _ckvmssts(lib$find_file_end(&cxt));
4772 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4773 if (!(retsts & 1) && *s == '$') {
4774 _ckvmssts(lib$find_file_end(&cxt));
4775 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4776 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4778 _ckvmssts(lib$find_file_end(&cxt));
4779 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4783 _ckvmssts(lib$find_file_end(&cxt));
4788 while (*s && !isspace(*s)) s++;
4791 /* check that it's really not DCL with no file extension */
4792 fp = fopen(resspec,"r","ctx=bin,shr=get");
4794 char b[4] = {0,0,0,0};
4795 read(fileno(fp),b,4);
4796 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4799 if (check_img && isdcl) return RMS$_FNF;
4801 if (cando_by_name(S_IXUSR,0,resspec)) {
4802 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4804 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4806 strcpy(VMScmd.dsc$a_pointer,"@");
4808 strcat(VMScmd.dsc$a_pointer,resspec);
4809 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4810 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4811 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4813 else retsts = RMS$_PRV;
4816 /* It's either a DCL command or we couldn't find a suitable image */
4817 VMScmd.dsc$w_length = strlen(cmd);
4818 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4819 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4820 if (!(retsts & 1)) {
4821 /* just hand off status values likely to be due to user error */
4822 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4823 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4824 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4825 else { _ckvmssts(retsts); }
4828 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4830 } /* end of setup_cmddsc() */
4833 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4835 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4838 if (vfork_called) { /* this follows a vfork - act Unixish */
4840 if (vfork_called < 0) {
4841 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4844 else return do_aexec(really,mark,sp);
4846 /* no vfork - act VMSish */
4847 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4852 } /* end of vms_do_aexec() */
4855 /* {{{bool vms_do_exec(char *cmd) */
4857 Perl_vms_do_exec(pTHX_ char *cmd)
4860 if (vfork_called) { /* this follows a vfork - act Unixish */
4862 if (vfork_called < 0) {
4863 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4866 else return do_exec(cmd);
4869 { /* no vfork - act VMSish */
4870 unsigned long int retsts;
4873 TAINT_PROPER("exec");
4874 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4875 retsts = lib$do_command(&VMScmd);
4878 case RMS$_FNF: case RMS$_DNF:
4879 set_errno(ENOENT); break;
4881 set_errno(ENOTDIR); break;
4883 set_errno(ENODEV); break;
4885 set_errno(EACCES); break;
4887 set_errno(EINVAL); break;
4888 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4889 set_errno(E2BIG); break;
4890 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4891 _ckvmssts(retsts); /* fall through */
4892 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4895 set_vaxc_errno(retsts);
4896 if (ckWARN(WARN_EXEC)) {
4897 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4898 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4905 } /* end of vms_do_exec() */
4908 unsigned long int Perl_do_spawn(pTHX_ char *);
4910 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4912 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4914 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4917 } /* end of do_aspawn() */
4920 /* {{{unsigned long int do_spawn(char *cmd) */
4922 Perl_do_spawn(pTHX_ char *cmd)
4924 unsigned long int sts, substs, hadcmd = 1;
4927 TAINT_PROPER("spawn");
4928 if (!cmd || !*cmd) {
4930 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4933 sts = setup_cmddsc(aTHX_ cmd,0);
4935 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4937 substs = sts; /* didn't spawn, use command setup failure for return */
4943 case RMS$_FNF: case RMS$_DNF:
4944 set_errno(ENOENT); break;
4946 set_errno(ENOTDIR); break;
4948 set_errno(ENODEV); break;
4950 set_errno(EACCES); break;
4952 set_errno(EINVAL); break;
4953 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4954 set_errno(E2BIG); break;
4955 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4956 _ckvmssts(sts); /* fall through */
4957 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4960 set_vaxc_errno(sts);
4961 if (ckWARN(WARN_EXEC)) {
4962 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4963 hadcmd ? VMScmd.dsc$w_length : 0,
4964 hadcmd ? VMScmd.dsc$a_pointer : "",
4971 } /* end of do_spawn() */
4975 static unsigned int *sockflags, sockflagsize;
4978 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4979 * routines found in some versions of the CRTL can't deal with sockets.
4980 * We don't shim the other file open routines since a socket isn't
4981 * likely to be opened by a name.
4983 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4984 FILE *my_fdopen(int fd, const char *mode)
4986 FILE *fp = fdopen(fd, (char *) mode);
4989 unsigned int fdoff = fd / sizeof(unsigned int);
4990 struct stat sbuf; /* native stat; we don't need flex_stat */
4991 if (!sockflagsize || fdoff > sockflagsize) {
4992 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4993 else New (1324,sockflags,fdoff+2,unsigned int);
4994 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4995 sockflagsize = fdoff + 2;
4997 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4998 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5007 * Clear the corresponding bit when the (possibly) socket stream is closed.
5008 * There still a small hole: we miss an implicit close which might occur
5009 * via freopen(). >> Todo
5011 /*{{{ int my_fclose(FILE *fp)*/
5012 int my_fclose(FILE *fp) {
5014 unsigned int fd = fileno(fp);
5015 unsigned int fdoff = fd / sizeof(unsigned int);
5017 if (sockflagsize && fdoff <= sockflagsize)
5018 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5026 * A simple fwrite replacement which outputs itmsz*nitm chars without
5027 * introducing record boundaries every itmsz chars.
5028 * We are using fputs, which depends on a terminating null. We may
5029 * well be writing binary data, so we need to accommodate not only
5030 * data with nulls sprinkled in the middle but also data with no null
5033 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5035 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5037 register char *cp, *end, *cpd, *data;
5038 register unsigned int fd = fileno(dest);
5039 register unsigned int fdoff = fd / sizeof(unsigned int);
5041 int bufsize = itmsz * nitm + 1;
5043 if (fdoff < sockflagsize &&
5044 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5045 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5049 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5050 memcpy( data, src, itmsz*nitm );
5051 data[itmsz*nitm] = '\0';
5053 end = data + itmsz * nitm;
5054 retval = (int) nitm; /* on success return # items written */
5057 while (cpd <= end) {
5058 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5059 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5061 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5065 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5068 } /* end of my_fwrite() */
5071 /*{{{ int my_flush(FILE *fp)*/
5073 Perl_my_flush(pTHX_ FILE *fp)
5076 if ((res = fflush(fp)) == 0 && fp) {
5077 #ifdef VMS_DO_SOCKETS
5079 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5081 res = fsync(fileno(fp));
5084 * If the flush succeeded but set end-of-file, we need to clear
5085 * the error because our caller may check ferror(). BTW, this
5086 * probably means we just flushed an empty file.
5088 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5095 * Here are replacements for the following Unix routines in the VMS environment:
5096 * getpwuid Get information for a particular UIC or UID
5097 * getpwnam Get information for a named user
5098 * getpwent Get information for each user in the rights database
5099 * setpwent Reset search to the start of the rights database
5100 * endpwent Finish searching for users in the rights database
5102 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5103 * (defined in pwd.h), which contains the following fields:-
5105 * char *pw_name; Username (in lower case)
5106 * char *pw_passwd; Hashed password
5107 * unsigned int pw_uid; UIC
5108 * unsigned int pw_gid; UIC group number
5109 * char *pw_unixdir; Default device/directory (VMS-style)
5110 * char *pw_gecos; Owner name
5111 * char *pw_dir; Default device/directory (Unix-style)
5112 * char *pw_shell; Default CLI name (eg. DCL)
5114 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5116 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5117 * not the UIC member number (eg. what's returned by getuid()),
5118 * getpwuid() can accept either as input (if uid is specified, the caller's
5119 * UIC group is used), though it won't recognise gid=0.
5121 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5122 * information about other users in your group or in other groups, respectively.
5123 * If the required privilege is not available, then these routines fill only
5124 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5127 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5130 /* sizes of various UAF record fields */
5131 #define UAI$S_USERNAME 12
5132 #define UAI$S_IDENT 31
5133 #define UAI$S_OWNER 31
5134 #define UAI$S_DEFDEV 31
5135 #define UAI$S_DEFDIR 63
5136 #define UAI$S_DEFCLI 31
5139 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5140 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5141 (uic).uic$v_group != UIC$K_WILD_GROUP)
5143 static char __empty[]= "";
5144 static struct passwd __passwd_empty=
5145 {(char *) __empty, (char *) __empty, 0, 0,
5146 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5147 static int contxt= 0;
5148 static struct passwd __pwdcache;
5149 static char __pw_namecache[UAI$S_IDENT+1];
5152 * This routine does most of the work extracting the user information.
5154 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5157 unsigned char length;
5158 char pw_gecos[UAI$S_OWNER+1];
5160 static union uicdef uic;
5162 unsigned char length;
5163 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5166 unsigned char length;
5167 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5170 unsigned char length;
5171 char pw_shell[UAI$S_DEFCLI+1];
5173 static char pw_passwd[UAI$S_PWD+1];
5175 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5176 struct dsc$descriptor_s name_desc;
5177 unsigned long int sts;
5179 static struct itmlst_3 itmlst[]= {
5180 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5181 {sizeof(uic), UAI$_UIC, &uic, &luic},
5182 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5183 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5184 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5185 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5186 {0, 0, NULL, NULL}};
5188 name_desc.dsc$w_length= strlen(name);
5189 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5190 name_desc.dsc$b_class= DSC$K_CLASS_S;
5191 name_desc.dsc$a_pointer= (char *) name;
5193 /* Note that sys$getuai returns many fields as counted strings. */
5194 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5195 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5196 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5198 else { _ckvmssts(sts); }
5199 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5201 if ((int) owner.length < lowner) lowner= (int) owner.length;
5202 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5203 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5204 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5205 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5206 owner.pw_gecos[lowner]= '\0';
5207 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5208 defcli.pw_shell[ldefcli]= '\0';
5209 if (valid_uic(uic)) {
5210 pwd->pw_uid= uic.uic$l_uic;
5211 pwd->pw_gid= uic.uic$v_group;
5214 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5215 pwd->pw_passwd= pw_passwd;
5216 pwd->pw_gecos= owner.pw_gecos;
5217 pwd->pw_dir= defdev.pw_dir;
5218 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5219 pwd->pw_shell= defcli.pw_shell;
5220 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5222 ldir= strlen(pwd->pw_unixdir) - 1;
5223 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5226 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5227 __mystrtolower(pwd->pw_unixdir);
5232 * Get information for a named user.
5234 /*{{{struct passwd *getpwnam(char *name)*/
5235 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5237 struct dsc$descriptor_s name_desc;
5239 unsigned long int status, sts;
5241 __pwdcache = __passwd_empty;
5242 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5243 /* We still may be able to determine pw_uid and pw_gid */
5244 name_desc.dsc$w_length= strlen(name);
5245 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5246 name_desc.dsc$b_class= DSC$K_CLASS_S;
5247 name_desc.dsc$a_pointer= (char *) name;
5248 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5249 __pwdcache.pw_uid= uic.uic$l_uic;
5250 __pwdcache.pw_gid= uic.uic$v_group;
5253 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5254 set_vaxc_errno(sts);
5255 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5258 else { _ckvmssts(sts); }
5261 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5262 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5263 __pwdcache.pw_name= __pw_namecache;
5265 } /* end of my_getpwnam() */
5269 * Get information for a particular UIC or UID.
5270 * Called by my_getpwent with uid=-1 to list all users.
5272 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5273 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5275 const $DESCRIPTOR(name_desc,__pw_namecache);
5276 unsigned short lname;
5278 unsigned long int status;
5280 if (uid == (unsigned int) -1) {
5282 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5283 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5284 set_vaxc_errno(status);
5285 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5289 else { _ckvmssts(status); }
5290 } while (!valid_uic (uic));
5294 if (!uic.uic$v_group)
5295 uic.uic$v_group= PerlProc_getgid();
5297 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5298 else status = SS$_IVIDENT;
5299 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5300 status == RMS$_PRV) {
5301 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5304 else { _ckvmssts(status); }
5306 __pw_namecache[lname]= '\0';
5307 __mystrtolower(__pw_namecache);
5309 __pwdcache = __passwd_empty;
5310 __pwdcache.pw_name = __pw_namecache;
5312 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5313 The identifier's value is usually the UIC, but it doesn't have to be,
5314 so if we can, we let fillpasswd update this. */
5315 __pwdcache.pw_uid = uic.uic$l_uic;
5316 __pwdcache.pw_gid = uic.uic$v_group;
5318 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5321 } /* end of my_getpwuid() */
5325 * Get information for next user.
5327 /*{{{struct passwd *my_getpwent()*/
5328 struct passwd *Perl_my_getpwent(pTHX)
5330 return (my_getpwuid((unsigned int) -1));
5335 * Finish searching rights database for users.
5337 /*{{{void my_endpwent()*/
5338 void Perl_my_endpwent(pTHX)
5341 _ckvmssts(sys$finish_rdb(&contxt));
5347 #ifdef HOMEGROWN_POSIX_SIGNALS
5348 /* Signal handling routines, pulled into the core from POSIX.xs.
5350 * We need these for threads, so they've been rolled into the core,
5351 * rather than left in POSIX.xs.
5353 * (DRS, Oct 23, 1997)
5356 /* sigset_t is atomic under VMS, so these routines are easy */
5357 /*{{{int my_sigemptyset(sigset_t *) */
5358 int my_sigemptyset(sigset_t *set) {
5359 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5365 /*{{{int my_sigfillset(sigset_t *)*/
5366 int my_sigfillset(sigset_t *set) {
5368 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5369 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5375 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5376 int my_sigaddset(sigset_t *set, int sig) {
5377 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5378 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5379 *set |= (1 << (sig - 1));
5385 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5386 int my_sigdelset(sigset_t *set, int sig) {
5387 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5388 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5389 *set &= ~(1 << (sig - 1));
5395 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5396 int my_sigismember(sigset_t *set, int sig) {
5397 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5398 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5399 *set & (1 << (sig - 1));
5404 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5405 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5408 /* If set and oset are both null, then things are badly wrong. Bail out. */
5409 if ((oset == NULL) && (set == NULL)) {
5410 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5414 /* If set's null, then we're just handling a fetch. */
5416 tempmask = sigblock(0);
5421 tempmask = sigsetmask(*set);
5424 tempmask = sigblock(*set);
5427 tempmask = sigblock(0);
5428 sigsetmask(*oset & ~tempmask);
5431 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5436 /* Did they pass us an oset? If so, stick our holding mask into it */
5443 #endif /* HOMEGROWN_POSIX_SIGNALS */
5446 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5447 * my_utime(), and flex_stat(), all of which operate on UTC unless
5448 * VMSISH_TIMES is true.
5450 /* method used to handle UTC conversions:
5451 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5453 static int gmtime_emulation_type;
5454 /* number of secs to add to UTC POSIX-style time to get local time */
5455 static long int utc_offset_secs;
5457 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5458 * in vmsish.h. #undef them here so we can call the CRTL routines
5467 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5468 * qualifier with the extern prefix pragma. This provisional
5469 * hack circumvents this prefix pragma problem in previous
5472 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5473 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5474 # pragma __extern_prefix save
5475 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5476 # define gmtime decc$__utctz_gmtime
5477 # define localtime decc$__utctz_localtime
5478 # define time decc$__utc_time
5479 # pragma __extern_prefix restore
5481 struct tm *gmtime(), *localtime();
5487 static time_t toutc_dst(time_t loc) {
5490 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5491 loc -= utc_offset_secs;
5492 if (rsltmp->tm_isdst) loc -= 3600;
5495 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5496 ((gmtime_emulation_type || my_time(NULL)), \
5497 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5498 ((secs) - utc_offset_secs))))
5500 static time_t toloc_dst(time_t utc) {
5503 utc += utc_offset_secs;
5504 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5505 if (rsltmp->tm_isdst) utc += 3600;
5508 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5509 ((gmtime_emulation_type || my_time(NULL)), \
5510 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5511 ((secs) + utc_offset_secs))))
5513 #ifndef RTL_USES_UTC
5516 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5517 DST starts on 1st sun of april at 02:00 std time
5518 ends on last sun of october at 02:00 dst time
5519 see the UCX management command reference, SET CONFIG TIMEZONE
5520 for formatting info.
5522 No, it's not as general as it should be, but then again, NOTHING
5523 will handle UK times in a sensible way.
5528 parse the DST start/end info:
5529 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5533 tz_parse_startend(char *s, struct tm *w, int *past)
5535 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5536 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5541 if (!past) return 0;
5544 if (w->tm_year % 4 == 0) ly = 1;
5545 if (w->tm_year % 100 == 0) ly = 0;
5546 if (w->tm_year+1900 % 400 == 0) ly = 1;
5549 dozjd = isdigit(*s);
5550 if (*s == 'J' || *s == 'j' || dozjd) {
5551 if (!dozjd && !isdigit(*++s)) return 0;
5554 d = d*10 + *s++ - '0';
5556 d = d*10 + *s++ - '0';
5559 if (d == 0) return 0;
5560 if (d > 366) return 0;
5562 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5565 } else if (*s == 'M' || *s == 'm') {
5566 if (!isdigit(*++s)) return 0;
5568 if (isdigit(*s)) m = 10*m + *s++ - '0';
5569 if (*s != '.') return 0;
5570 if (!isdigit(*++s)) return 0;
5572 if (n < 1 || n > 5) return 0;
5573 if (*s != '.') return 0;
5574 if (!isdigit(*++s)) return 0;
5576 if (d > 6) return 0;
5580 if (!isdigit(*++s)) return 0;
5582 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5584 if (!isdigit(*++s)) return 0;
5586 if (isdigit(*s)) min = 10*min + *s++ - '0';
5588 if (!isdigit(*++s)) return 0;
5590 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5600 if (w->tm_yday < d) goto before;
5601 if (w->tm_yday > d) goto after;
5603 if (w->tm_mon+1 < m) goto before;
5604 if (w->tm_mon+1 > m) goto after;
5606 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5607 k = d - j; /* mday of first d */
5609 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5610 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5611 if (w->tm_mday < k) goto before;
5612 if (w->tm_mday > k) goto after;
5615 if (w->tm_hour < hour) goto before;
5616 if (w->tm_hour > hour) goto after;
5617 if (w->tm_min < min) goto before;
5618 if (w->tm_min > min) goto after;
5619 if (w->tm_sec < sec) goto before;
5633 /* parse the offset: (+|-)hh[:mm[:ss]] */
5636 tz_parse_offset(char *s, int *offset)
5638 int hour = 0, min = 0, sec = 0;
5641 if (!offset) return 0;
5643 if (*s == '-') {neg++; s++;}
5645 if (!isdigit(*s)) return 0;
5647 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5648 if (hour > 24) return 0;
5650 if (!isdigit(*++s)) return 0;
5652 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5653 if (min > 59) return 0;
5655 if (!isdigit(*++s)) return 0;
5657 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5658 if (sec > 59) return 0;
5662 *offset = (hour*60+min)*60 + sec;
5663 if (neg) *offset = -*offset;
5668 input time is w, whatever type of time the CRTL localtime() uses.
5669 sets dst, the zone, and the gmtoff (seconds)
5671 caches the value of TZ and UCX$TZ env variables; note that
5672 my_setenv looks for these and sets a flag if they're changed
5675 We have to watch out for the "australian" case (dst starts in
5676 october, ends in april)...flagged by "reverse" and checked by
5677 scanning through the months of the previous year.
5682 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5687 char *dstzone, *tz, *s_start, *s_end;
5688 int std_off, dst_off, isdst;
5689 int y, dststart, dstend;
5690 static char envtz[1025]; /* longer than any logical, symbol, ... */
5691 static char ucxtz[1025];
5692 static char reversed = 0;
5698 reversed = -1; /* flag need to check */
5699 envtz[0] = ucxtz[0] = '\0';
5700 tz = my_getenv("TZ",0);
5701 if (tz) strcpy(envtz, tz);
5702 tz = my_getenv("UCX$TZ",0);
5703 if (tz) strcpy(ucxtz, tz);
5704 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5707 if (!*tz) tz = ucxtz;
5710 while (isalpha(*s)) s++;
5711 s = tz_parse_offset(s, &std_off);
5713 if (!*s) { /* no DST, hurray we're done! */
5719 while (isalpha(*s)) s++;
5720 s2 = tz_parse_offset(s, &dst_off);
5724 dst_off = std_off - 3600;
5727 if (!*s) { /* default dst start/end?? */
5728 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5729 s = strchr(ucxtz,',');
5731 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5733 if (*s != ',') return 0;
5736 when = _toutc(when); /* convert to utc */
5737 when = when - std_off; /* convert to pseudolocal time*/
5739 w2 = localtime(&when);
5742 s = tz_parse_startend(s_start,w2,&dststart);
5744 if (*s != ',') return 0;
5747 when = _toutc(when); /* convert to utc */
5748 when = when - dst_off; /* convert to pseudolocal time*/
5749 w2 = localtime(&when);
5750 if (w2->tm_year != y) { /* spans a year, just check one time */
5751 when += dst_off - std_off;
5752 w2 = localtime(&when);
5755 s = tz_parse_startend(s_end,w2,&dstend);
5758 if (reversed == -1) { /* need to check if start later than end */
5762 if (when < 2*365*86400) {
5763 when += 2*365*86400;
5767 w2 =localtime(&when);
5768 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5770 for (j = 0; j < 12; j++) {
5771 w2 =localtime(&when);
5772 (void) tz_parse_startend(s_start,w2,&ds);
5773 (void) tz_parse_startend(s_end,w2,&de);
5774 if (ds != de) break;
5778 if (de && !ds) reversed = 1;
5781 isdst = dststart && !dstend;
5782 if (reversed) isdst = dststart || !dstend;
5785 if (dst) *dst = isdst;
5786 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5787 if (isdst) tz = dstzone;
5789 while(isalpha(*tz)) *zone++ = *tz++;
5795 #endif /* !RTL_USES_UTC */
5797 /* my_time(), my_localtime(), my_gmtime()
5798 * By default traffic in UTC time values, using CRTL gmtime() or
5799 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5800 * Note: We need to use these functions even when the CRTL has working
5801 * UTC support, since they also handle C<use vmsish qw(times);>
5803 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5804 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5807 /*{{{time_t my_time(time_t *timep)*/
5808 time_t Perl_my_time(pTHX_ time_t *timep)
5813 if (gmtime_emulation_type == 0) {
5815 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5816 /* results of calls to gmtime() and localtime() */
5817 /* for same &base */
5819 gmtime_emulation_type++;
5820 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5821 char off[LNM$C_NAMLENGTH+1];;
5823 gmtime_emulation_type++;
5824 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5825 gmtime_emulation_type++;
5826 utc_offset_secs = 0;
5827 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5829 else { utc_offset_secs = atol(off); }
5831 else { /* We've got a working gmtime() */
5832 struct tm gmt, local;
5835 tm_p = localtime(&base);
5837 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5838 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5839 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5840 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5846 # ifdef RTL_USES_UTC
5847 if (VMSISH_TIME) when = _toloc(when);
5849 if (!VMSISH_TIME) when = _toutc(when);
5852 if (timep != NULL) *timep = when;
5855 } /* end of my_time() */
5859 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5861 Perl_my_gmtime(pTHX_ const time_t *timep)
5867 if (timep == NULL) {
5868 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5871 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5875 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5877 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5878 return gmtime(&when);
5880 /* CRTL localtime() wants local time as input, so does no tz correction */
5881 rsltmp = localtime(&when);
5882 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5885 } /* end of my_gmtime() */
5889 /*{{{struct tm *my_localtime(const time_t *timep)*/
5891 Perl_my_localtime(pTHX_ const time_t *timep)
5893 time_t when, whenutc;
5897 if (timep == NULL) {
5898 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5901 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5902 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5905 # ifdef RTL_USES_UTC
5907 if (VMSISH_TIME) when = _toutc(when);
5909 /* CRTL localtime() wants UTC as input, does tz correction itself */
5910 return localtime(&when);
5912 # else /* !RTL_USES_UTC */
5915 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5916 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5919 #ifndef RTL_USES_UTC
5920 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5921 when = whenutc - offset; /* pseudolocal time*/
5924 /* CRTL localtime() wants local time as input, so does no tz correction */
5925 rsltmp = localtime(&when);
5926 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5930 } /* end of my_localtime() */
5933 /* Reset definitions for later calls */
5934 #define gmtime(t) my_gmtime(t)
5935 #define localtime(t) my_localtime(t)
5936 #define time(t) my_time(t)
5939 /* my_utime - update modification time of a file
5940 * calling sequence is identical to POSIX utime(), but under
5941 * VMS only the modification time is changed; ODS-2 does not
5942 * maintain access times. Restrictions differ from the POSIX
5943 * definition in that the time can be changed as long as the
5944 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5945 * no separate checks are made to insure that the caller is the
5946 * owner of the file or has special privs enabled.
5947 * Code here is based on Joe Meadows' FILE utility.
5950 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5951 * to VMS epoch (01-JAN-1858 00:00:00.00)
5952 * in 100 ns intervals.
5954 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5956 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5957 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5960 long int bintime[2], len = 2, lowbit, unixtime,
5961 secscale = 10000000; /* seconds --> 100 ns intervals */
5962 unsigned long int chan, iosb[2], retsts;
5963 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5964 struct FAB myfab = cc$rms_fab;
5965 struct NAM mynam = cc$rms_nam;
5966 #if defined (__DECC) && defined (__VAX)
5967 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5968 * at least through VMS V6.1, which causes a type-conversion warning.
5970 # pragma message save
5971 # pragma message disable cvtdiftypes
5973 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5974 struct fibdef myfib;
5975 #if defined (__DECC) && defined (__VAX)
5976 /* This should be right after the declaration of myatr, but due
5977 * to a bug in VAX DEC C, this takes effect a statement early.
5979 # pragma message restore
5981 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5982 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5983 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5985 if (file == NULL || *file == '\0') {
5987 set_vaxc_errno(LIB$_INVARG);
5990 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5992 if (utimes != NULL) {
5993 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5994 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5995 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5996 * as input, we force the sign bit to be clear by shifting unixtime right
5997 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5999 lowbit = (utimes->modtime & 1) ? secscale : 0;
6000 unixtime = (long int) utimes->modtime;
6002 /* If input was UTC; convert to local for sys svc */
6003 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6005 unixtime >>= 1; secscale <<= 1;
6006 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6007 if (!(retsts & 1)) {
6009 set_vaxc_errno(retsts);
6012 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6013 if (!(retsts & 1)) {
6015 set_vaxc_errno(retsts);
6020 /* Just get the current time in VMS format directly */
6021 retsts = sys$gettim(bintime);
6022 if (!(retsts & 1)) {
6024 set_vaxc_errno(retsts);
6029 myfab.fab$l_fna = vmsspec;
6030 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6031 myfab.fab$l_nam = &mynam;
6032 mynam.nam$l_esa = esa;
6033 mynam.nam$b_ess = (unsigned char) sizeof esa;
6034 mynam.nam$l_rsa = rsa;
6035 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6037 /* Look for the file to be affected, letting RMS parse the file
6038 * specification for us as well. I have set errno using only
6039 * values documented in the utime() man page for VMS POSIX.
6041 retsts = sys$parse(&myfab,0,0);
6042 if (!(retsts & 1)) {
6043 set_vaxc_errno(retsts);
6044 if (retsts == RMS$_PRV) set_errno(EACCES);
6045 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6046 else set_errno(EVMSERR);
6049 retsts = sys$search(&myfab,0,0);
6050 if (!(retsts & 1)) {
6051 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6052 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6053 set_vaxc_errno(retsts);
6054 if (retsts == RMS$_PRV) set_errno(EACCES);
6055 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6056 else set_errno(EVMSERR);
6060 devdsc.dsc$w_length = mynam.nam$b_dev;
6061 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6063 retsts = sys$assign(&devdsc,&chan,0,0);
6064 if (!(retsts & 1)) {
6065 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6066 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6067 set_vaxc_errno(retsts);
6068 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6069 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6070 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6071 else set_errno(EVMSERR);
6075 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6076 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6078 memset((void *) &myfib, 0, sizeof myfib);
6079 #if defined(__DECC) || defined(__DECCXX)
6080 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6081 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6082 /* This prevents the revision time of the file being reset to the current
6083 * time as a result of our IO$_MODIFY $QIO. */
6084 myfib.fib$l_acctl = FIB$M_NORECORD;
6086 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6087 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6088 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6090 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6091 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6092 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6093 _ckvmssts(sys$dassgn(chan));
6094 if (retsts & 1) retsts = iosb[0];
6095 if (!(retsts & 1)) {
6096 set_vaxc_errno(retsts);
6097 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6098 else set_errno(EVMSERR);
6103 } /* end of my_utime() */
6107 * flex_stat, flex_fstat
6108 * basic stat, but gets it right when asked to stat
6109 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6112 /* encode_dev packs a VMS device name string into an integer to allow
6113 * simple comparisons. This can be used, for example, to check whether two
6114 * files are located on the same device, by comparing their encoded device
6115 * names. Even a string comparison would not do, because stat() reuses the
6116 * device name buffer for each call; so without encode_dev, it would be
6117 * necessary to save the buffer and use strcmp (this would mean a number of
6118 * changes to the standard Perl code, to say nothing of what a Perl script
6121 * The device lock id, if it exists, should be unique (unless perhaps compared
6122 * with lock ids transferred from other nodes). We have a lock id if the disk is
6123 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6124 * device names. Thus we use the lock id in preference, and only if that isn't
6125 * available, do we try to pack the device name into an integer (flagged by
6126 * the sign bit (LOCKID_MASK) being set).
6128 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6129 * name and its encoded form, but it seems very unlikely that we will find
6130 * two files on different disks that share the same encoded device names,
6131 * and even more remote that they will share the same file id (if the test
6132 * is to check for the same file).
6134 * A better method might be to use sys$device_scan on the first call, and to
6135 * search for the device, returning an index into the cached array.
6136 * The number returned would be more intelligable.
6137 * This is probably not worth it, and anyway would take quite a bit longer
6138 * on the first call.
6140 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6141 static mydev_t encode_dev (pTHX_ const char *dev)
6144 unsigned long int f;
6149 if (!dev || !dev[0]) return 0;
6153 struct dsc$descriptor_s dev_desc;
6154 unsigned long int status, lockid, item = DVI$_LOCKID;
6156 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6157 can try that first. */
6158 dev_desc.dsc$w_length = strlen (dev);
6159 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6160 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6161 dev_desc.dsc$a_pointer = (char *) dev;
6162 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6163 if (lockid) return (lockid & ~LOCKID_MASK);
6167 /* Otherwise we try to encode the device name */
6171 for (q = dev + strlen(dev); q--; q >= dev) {
6174 else if (isalpha (toupper (*q)))
6175 c= toupper (*q) - 'A' + (char)10;
6177 continue; /* Skip '$'s */
6179 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6181 enc += f * (unsigned long int) c;
6183 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6185 } /* end of encode_dev() */
6187 static char namecache[NAM$C_MAXRSS+1];
6190 is_null_device(name)
6193 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6194 The underscore prefix, controller letter, and unit number are
6195 independently optional; for our purposes, the colon punctuation
6196 is not. The colon can be trailed by optional directory and/or
6197 filename, but two consecutive colons indicates a nodename rather
6198 than a device. [pr] */
6199 if (*name == '_') ++name;
6200 if (tolower(*name++) != 'n') return 0;
6201 if (tolower(*name++) != 'l') return 0;
6202 if (tolower(*name) == 'a') ++name;
6203 if (*name == '0') ++name;
6204 return (*name++ == ':') && (*name != ':');
6207 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6208 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6209 * subset of the applicable information.
6212 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6214 char fname_phdev[NAM$C_MAXRSS+1];
6215 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6217 char fname[NAM$C_MAXRSS+1];
6218 unsigned long int retsts;
6219 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6220 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6222 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6223 device name on successive calls */
6224 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6225 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6226 namdsc.dsc$a_pointer = fname;
6227 namdsc.dsc$w_length = sizeof fname - 1;
6229 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6230 &namdsc,&namdsc.dsc$w_length,0,0);
6232 fname[namdsc.dsc$w_length] = '\0';
6234 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6235 * but if someone has redefined that logical, Perl gets very lost. Since
6236 * we have the physical device name from the stat buffer, just paste it on.
6238 strcpy( fname_phdev, statbufp->st_devnam );
6239 strcat( fname_phdev, strrchr(fname, ':') );
6241 return cando_by_name(bit,effective,fname_phdev);
6243 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6244 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6248 return FALSE; /* Should never get to here */
6250 } /* end of cando() */
6254 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6256 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6258 static char usrname[L_cuserid];
6259 static struct dsc$descriptor_s usrdsc =
6260 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6261 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6262 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6263 unsigned short int retlen;
6264 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6265 union prvdef curprv;
6266 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6267 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6268 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6271 if (!fname || !*fname) return FALSE;
6272 /* Make sure we expand logical names, since sys$check_access doesn't */
6273 if (!strpbrk(fname,"/]>:")) {
6274 strcpy(fileified,fname);
6275 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6278 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6279 retlen = namdsc.dsc$w_length = strlen(vmsname);
6280 namdsc.dsc$a_pointer = vmsname;
6281 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6282 vmsname[retlen-1] == ':') {
6283 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6284 namdsc.dsc$w_length = strlen(fileified);
6285 namdsc.dsc$a_pointer = fileified;
6288 if (!usrdsc.dsc$w_length) {
6290 usrdsc.dsc$w_length = strlen(usrname);
6294 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6295 access = ARM$M_EXECUTE; break;
6296 case S_IRUSR: case S_IRGRP: case S_IROTH:
6297 access = ARM$M_READ; break;
6298 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6299 access = ARM$M_WRITE; break;
6300 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6301 access = ARM$M_DELETE; break;
6306 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6307 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6308 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6309 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6310 set_vaxc_errno(retsts);
6311 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6312 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6313 else set_errno(ENOENT);
6316 if (retsts == SS$_NORMAL) {
6317 if (!privused) return TRUE;
6318 /* We can get access, but only by using privs. Do we have the
6319 necessary privs currently enabled? */
6320 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6321 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6322 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6323 !curprv.prv$v_bypass) return FALSE;
6324 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6325 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6326 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6329 if (retsts == SS$_ACCONFLICT) {
6334 return FALSE; /* Should never get here */
6336 } /* end of cando_by_name() */
6340 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6342 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6344 if (!fstat(fd,(stat_t *) statbufp)) {
6345 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6346 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6347 # ifdef RTL_USES_UTC
6350 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6351 statbufp->st_atime = _toloc(statbufp->st_atime);
6352 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6357 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6361 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6362 statbufp->st_atime = _toutc(statbufp->st_atime);
6363 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6370 } /* end of flex_fstat() */
6373 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6375 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6377 char fileified[NAM$C_MAXRSS+1];
6378 char temp_fspec[NAM$C_MAXRSS+300];
6381 strcpy(temp_fspec, fspec);
6382 if (statbufp == (Stat_t *) &PL_statcache)
6383 do_tovmsspec(temp_fspec,namecache,0);
6384 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6385 memset(statbufp,0,sizeof *statbufp);
6386 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6387 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6388 statbufp->st_uid = 0x00010001;
6389 statbufp->st_gid = 0x0001;
6390 time((time_t *)&statbufp->st_mtime);
6391 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6395 /* Try for a directory name first. If fspec contains a filename without
6396 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6397 * and sea:[wine.dark]water. exist, we prefer the directory here.
6398 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6399 * not sea:[wine.dark]., if the latter exists. If the intended target is
6400 * the file with null type, specify this by calling flex_stat() with
6401 * a '.' at the end of fspec.
6403 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6404 retval = stat(fileified,(stat_t *) statbufp);
6405 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6406 strcpy(namecache,fileified);
6408 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6410 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6411 # ifdef RTL_USES_UTC
6414 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6415 statbufp->st_atime = _toloc(statbufp->st_atime);
6416 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6421 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6425 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6426 statbufp->st_atime = _toutc(statbufp->st_atime);
6427 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6433 } /* end of flex_stat() */
6437 /*{{{char *my_getlogin()*/
6438 /* VMS cuserid == Unix getlogin, except calling sequence */
6442 static char user[L_cuserid];
6443 return cuserid(user);
6448 /* rmscopy - copy a file using VMS RMS routines
6450 * Copies contents and attributes of spec_in to spec_out, except owner
6451 * and protection information. Name and type of spec_in are used as
6452 * defaults for spec_out. The third parameter specifies whether rmscopy()
6453 * should try to propagate timestamps from the input file to the output file.
6454 * If it is less than 0, no timestamps are preserved. If it is 0, then
6455 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6456 * propagated to the output file at creation iff the output file specification
6457 * did not contain an explicit name or type, and the revision date is always
6458 * updated at the end of the copy operation. If it is greater than 0, then
6459 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6460 * other than the revision date should be propagated, and bit 1 indicates
6461 * that the revision date should be propagated.
6463 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6465 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6466 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6467 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6468 * as part of the Perl standard distribution under the terms of the
6469 * GNU General Public License or the Perl Artistic License. Copies
6470 * of each may be found in the Perl standard distribution.
6472 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6474 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6476 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6477 rsa[NAM$C_MAXRSS], ubf[32256];
6478 unsigned long int i, sts, sts2;
6479 struct FAB fab_in, fab_out;
6480 struct RAB rab_in, rab_out;
6482 struct XABDAT xabdat;
6483 struct XABFHC xabfhc;
6484 struct XABRDT xabrdt;
6485 struct XABSUM xabsum;
6487 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6488 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6489 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6493 fab_in = cc$rms_fab;
6494 fab_in.fab$l_fna = vmsin;
6495 fab_in.fab$b_fns = strlen(vmsin);
6496 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6497 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6498 fab_in.fab$l_fop = FAB$M_SQO;
6499 fab_in.fab$l_nam = &nam;
6500 fab_in.fab$l_xab = (void *) &xabdat;
6503 nam.nam$l_rsa = rsa;
6504 nam.nam$b_rss = sizeof(rsa);
6505 nam.nam$l_esa = esa;
6506 nam.nam$b_ess = sizeof (esa);
6507 nam.nam$b_esl = nam.nam$b_rsl = 0;
6509 xabdat = cc$rms_xabdat; /* To get creation date */
6510 xabdat.xab$l_nxt = (void *) &xabfhc;
6512 xabfhc = cc$rms_xabfhc; /* To get record length */
6513 xabfhc.xab$l_nxt = (void *) &xabsum;
6515 xabsum = cc$rms_xabsum; /* To get key and area information */
6517 if (!((sts = sys$open(&fab_in)) & 1)) {
6518 set_vaxc_errno(sts);
6520 case RMS$_FNF: case RMS$_DNF:
6521 set_errno(ENOENT); break;
6523 set_errno(ENOTDIR); break;
6525 set_errno(ENODEV); break;
6527 set_errno(EINVAL); break;
6529 set_errno(EACCES); break;
6537 fab_out.fab$w_ifi = 0;
6538 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6539 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6540 fab_out.fab$l_fop = FAB$M_SQO;
6541 fab_out.fab$l_fna = vmsout;
6542 fab_out.fab$b_fns = strlen(vmsout);
6543 fab_out.fab$l_dna = nam.nam$l_name;
6544 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6546 if (preserve_dates == 0) { /* Act like DCL COPY */
6547 nam.nam$b_nop = NAM$M_SYNCHK;
6548 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6549 if (!((sts = sys$parse(&fab_out)) & 1)) {
6550 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6551 set_vaxc_errno(sts);
6554 fab_out.fab$l_xab = (void *) &xabdat;
6555 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6557 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6558 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6559 preserve_dates =0; /* bitmask from this point forward */
6561 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6562 if (!((sts = sys$create(&fab_out)) & 1)) {
6563 set_vaxc_errno(sts);
6566 set_errno(ENOENT); break;
6568 set_errno(ENOTDIR); break;
6570 set_errno(ENODEV); break;
6572 set_errno(EINVAL); break;
6574 set_errno(EACCES); break;
6580 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6581 if (preserve_dates & 2) {
6582 /* sys$close() will process xabrdt, not xabdat */
6583 xabrdt = cc$rms_xabrdt;
6585 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6587 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6588 * is unsigned long[2], while DECC & VAXC use a struct */
6589 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6591 fab_out.fab$l_xab = (void *) &xabrdt;
6594 rab_in = cc$rms_rab;
6595 rab_in.rab$l_fab = &fab_in;
6596 rab_in.rab$l_rop = RAB$M_BIO;
6597 rab_in.rab$l_ubf = ubf;
6598 rab_in.rab$w_usz = sizeof ubf;
6599 if (!((sts = sys$connect(&rab_in)) & 1)) {
6600 sys$close(&fab_in); sys$close(&fab_out);
6601 set_errno(EVMSERR); set_vaxc_errno(sts);
6605 rab_out = cc$rms_rab;
6606 rab_out.rab$l_fab = &fab_out;
6607 rab_out.rab$l_rbf = ubf;
6608 if (!((sts = sys$connect(&rab_out)) & 1)) {
6609 sys$close(&fab_in); sys$close(&fab_out);
6610 set_errno(EVMSERR); set_vaxc_errno(sts);
6614 while ((sts = sys$read(&rab_in))) { /* always true */
6615 if (sts == RMS$_EOF) break;
6616 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6617 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6618 sys$close(&fab_in); sys$close(&fab_out);
6619 set_errno(EVMSERR); set_vaxc_errno(sts);
6624 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6625 sys$close(&fab_in); sys$close(&fab_out);
6626 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6628 set_errno(EVMSERR); set_vaxc_errno(sts);
6634 } /* end of rmscopy() */
6638 /*** The following glue provides 'hooks' to make some of the routines
6639 * from this file available from Perl. These routines are sufficiently
6640 * basic, and are required sufficiently early in the build process,
6641 * that's it's nice to have them available to miniperl as well as the
6642 * full Perl, so they're set up here instead of in an extension. The
6643 * Perl code which handles importation of these names into a given
6644 * package lives in [.VMS]Filespec.pm in @INC.
6648 rmsexpand_fromperl(pTHX_ CV *cv)
6651 char *fspec, *defspec = NULL, *rslt;
6654 if (!items || items > 2)
6655 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6656 fspec = SvPV(ST(0),n_a);
6657 if (!fspec || !*fspec) XSRETURN_UNDEF;
6658 if (items == 2) defspec = SvPV(ST(1),n_a);
6660 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6661 ST(0) = sv_newmortal();
6662 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6667 vmsify_fromperl(pTHX_ CV *cv)
6673 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6674 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6675 ST(0) = sv_newmortal();
6676 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6681 unixify_fromperl(pTHX_ CV *cv)
6687 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6688 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6689 ST(0) = sv_newmortal();
6690 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6695 fileify_fromperl(pTHX_ CV *cv)
6701 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6702 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6703 ST(0) = sv_newmortal();
6704 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6709 pathify_fromperl(pTHX_ CV *cv)
6715 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6716 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6717 ST(0) = sv_newmortal();
6718 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6723 vmspath_fromperl(pTHX_ CV *cv)
6729 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6730 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6731 ST(0) = sv_newmortal();
6732 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6737 unixpath_fromperl(pTHX_ CV *cv)
6743 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6744 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6745 ST(0) = sv_newmortal();
6746 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6751 candelete_fromperl(pTHX_ CV *cv)
6754 char fspec[NAM$C_MAXRSS+1], *fsp;
6759 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6761 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6762 if (SvTYPE(mysv) == SVt_PVGV) {
6763 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6764 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6771 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6772 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6778 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6783 rmscopy_fromperl(pTHX_ CV *cv)
6786 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6788 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6789 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6790 unsigned long int sts;
6795 if (items < 2 || items > 3)
6796 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6798 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6799 if (SvTYPE(mysv) == SVt_PVGV) {
6800 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6801 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6808 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6809 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6814 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6815 if (SvTYPE(mysv) == SVt_PVGV) {
6816 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6817 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6824 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6825 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6830 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6832 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6838 mod2fname(pTHX_ CV *cv)
6841 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6842 workbuff[NAM$C_MAXRSS*1 + 1];
6843 int total_namelen = 3, counter, num_entries;
6844 /* ODS-5 ups this, but we want to be consistent, so... */
6845 int max_name_len = 39;
6846 AV *in_array = (AV *)SvRV(ST(0));
6848 num_entries = av_len(in_array);
6850 /* All the names start with PL_. */
6851 strcpy(ultimate_name, "PL_");
6853 /* Clean up our working buffer */
6854 Zero(work_name, sizeof(work_name), char);
6856 /* Run through the entries and build up a working name */
6857 for(counter = 0; counter <= num_entries; counter++) {
6858 /* If it's not the first name then tack on a __ */
6860 strcat(work_name, "__");
6862 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6866 /* Check to see if we actually have to bother...*/
6867 if (strlen(work_name) + 3 <= max_name_len) {
6868 strcat(ultimate_name, work_name);
6870 /* It's too darned big, so we need to go strip. We use the same */
6871 /* algorithm as xsubpp does. First, strip out doubled __ */
6872 char *source, *dest, last;
6875 for (source = work_name; *source; source++) {
6876 if (last == *source && last == '_') {
6882 /* Go put it back */
6883 strcpy(work_name, workbuff);
6884 /* Is it still too big? */
6885 if (strlen(work_name) + 3 > max_name_len) {
6886 /* Strip duplicate letters */
6889 for (source = work_name; *source; source++) {
6890 if (last == toupper(*source)) {
6894 last = toupper(*source);
6896 strcpy(work_name, workbuff);
6899 /* Is it *still* too big? */
6900 if (strlen(work_name) + 3 > max_name_len) {
6901 /* Too bad, we truncate */
6902 work_name[max_name_len - 2] = 0;
6904 strcat(ultimate_name, work_name);
6907 /* Okay, return it */
6908 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6916 char* file = __FILE__;
6917 char temp_buff[512];
6918 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6919 no_translate_barewords = TRUE;
6921 no_translate_barewords = FALSE;
6924 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6925 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6926 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6927 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6928 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6929 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6930 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6931 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6932 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6933 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6935 store_pipelocs(aTHX);