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;
427 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
428 unsigned short int chan;
429 #ifndef CLI$M_TRUSTED
430 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
432 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
433 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
435 bool have_sym = FALSE, have_lnm = FALSE;
436 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
437 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
438 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
439 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
440 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
441 #if defined(PERL_IMPLICIT_CONTEXT)
444 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
445 static perl_mutex primenv_mutex;
446 MUTEX_INIT(&primenv_mutex);
449 #if defined(PERL_IMPLICIT_CONTEXT)
450 /* We jump through these hoops because we can be called at */
451 /* platform-specific initialization time, which is before anything is */
452 /* set up--we can't even do a plain dTHX since that relies on the */
453 /* interpreter structure to be initialized */
454 #if defined(USE_5005THREADS)
456 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
462 aTHX = PERL_GET_INTERP;
469 if (primed || !PL_envgv) return;
470 MUTEX_LOCK(&primenv_mutex);
471 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
472 envhv = GvHVn(PL_envgv);
473 /* Perform a dummy fetch as an lval to insure that the hash table is
474 * set up. Otherwise, the hv_store() will turn into a nullop. */
475 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
477 for (i = 0; env_tables[i]; i++) {
478 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
479 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
480 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
482 if (have_sym || have_lnm) {
483 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
484 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
485 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
486 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
489 for (i--; i >= 0; i--) {
490 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
493 for (j = 0; environ[j]; j++) {
494 if (!(start = strchr(environ[j],'='))) {
495 if (ckWARN(WARN_INTERNAL))
496 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
500 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
506 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
507 !str$case_blind_compare(&tmpdsc,&clisym)) {
508 strcpy(cmd,"Show Symbol/Global *");
509 cmddsc.dsc$w_length = 20;
510 if (env_tables[i]->dsc$w_length == 12 &&
511 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
512 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
513 flags = defflags | CLI$M_NOLOGNAM;
516 strcpy(cmd,"Show Logical *");
517 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
518 strcat(cmd," /Table=");
519 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
520 cmddsc.dsc$w_length = strlen(cmd);
522 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
523 flags = defflags | CLI$M_NOCLISYM;
526 /* Create a new subprocess to execute each command, to exclude the
527 * remote possibility that someone could subvert a mbx or file used
528 * to write multiple commands to a single subprocess.
531 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
532 0,&riseandshine,0,0,&clidsc,&clitabdsc);
533 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
534 defflags &= ~CLI$M_TRUSTED;
535 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
537 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
538 if (seenhv) SvREFCNT_dec(seenhv);
541 char *cp1, *cp2, *key;
542 unsigned long int sts, iosb[2], retlen, keylen;
545 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
546 if (sts & 1) sts = iosb[0] & 0xffff;
547 if (sts == SS$_ENDOFFILE) {
549 while (substs == 0) { sys$hiber(); wakect++;}
550 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
555 retlen = iosb[0] >> 16;
556 if (!retlen) continue; /* blank line */
558 if (iosb[1] != subpid) {
560 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
564 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
565 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
567 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
568 if (*cp1 == '(' || /* Logical name table name */
569 *cp1 == '=' /* Next eqv of searchlist */) continue;
570 if (*cp1 == '"') cp1++;
571 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
572 key = cp1; keylen = cp2 - cp1;
573 if (keylen && hv_exists(seenhv,key,keylen)) continue;
574 while (*cp2 && *cp2 != '=') cp2++;
575 while (*cp2 && *cp2 == '=') cp2++;
576 while (*cp2 && *cp2 == ' ') cp2++;
577 if (*cp2 == '"') { /* String translation; may embed "" */
578 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
579 cp2++; cp1--; /* Skip "" surrounding translation */
581 else { /* Numeric translation */
582 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
583 cp1--; /* stop on last non-space char */
585 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
586 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
589 PERL_HASH(hash,key,keylen);
590 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
591 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
593 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
594 /* get the PPFs for this process, not the subprocess */
595 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
596 char eqv[LNM$C_NAMLENGTH+1];
598 for (i = 0; ppfs[i]; i++) {
599 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
600 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
605 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
606 if (buf) Safefree(buf);
607 if (seenhv) SvREFCNT_dec(seenhv);
608 MUTEX_UNLOCK(&primenv_mutex);
611 } /* end of prime_env_iter */
615 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
616 /* Define or delete an element in the same "environment" as
617 * vmstrnenv(). If an element is to be deleted, it's removed from
618 * the first place it's found. If it's to be set, it's set in the
619 * place designated by the first element of the table vector.
620 * Like setenv() returns 0 for success, non-zero on error.
623 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
625 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
626 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
627 unsigned long int retsts, usermode = PSL$C_USER;
628 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
629 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
630 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
631 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
632 $DESCRIPTOR(local,"_LOCAL");
634 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
635 *cp2 = _toupper(*cp1);
636 if (cp1 - lnm > LNM$C_NAMLENGTH) {
637 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
641 lnmdsc.dsc$w_length = cp1 - lnm;
642 if (!tabvec || !*tabvec) tabvec = env_tables;
644 if (!eqv) { /* we're deleting n element */
645 for (curtab = 0; tabvec[curtab]; curtab++) {
646 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
648 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
649 if ((cp1 = strchr(environ[i],'=')) &&
650 !strncmp(environ[i],lnm,cp1 - environ[i])) {
652 return setenv(lnm,"",1) ? vaxc$errno : 0;
655 ivenv = 1; retsts = SS$_NOLOGNAM;
657 if (ckWARN(WARN_INTERNAL))
658 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
659 ivenv = 1; retsts = SS$_NOSUCHPGM;
665 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
666 !str$case_blind_compare(&tmpdsc,&clisym)) {
667 unsigned int symtype;
668 if (tabvec[curtab]->dsc$w_length == 12 &&
669 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
670 !str$case_blind_compare(&tmpdsc,&local))
671 symtype = LIB$K_CLI_LOCAL_SYM;
672 else symtype = LIB$K_CLI_GLOBAL_SYM;
673 retsts = lib$delete_symbol(&lnmdsc,&symtype);
674 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
675 if (retsts == LIB$_NOSUCHSYM) continue;
679 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
680 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
681 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
682 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
683 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
687 else { /* we're defining a value */
688 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
690 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
692 if (ckWARN(WARN_INTERNAL))
693 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
694 retsts = SS$_NOSUCHPGM;
698 eqvdsc.dsc$a_pointer = eqv;
699 eqvdsc.dsc$w_length = strlen(eqv);
700 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
701 !str$case_blind_compare(&tmpdsc,&clisym)) {
702 unsigned int symtype;
703 if (tabvec[0]->dsc$w_length == 12 &&
704 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
705 !str$case_blind_compare(&tmpdsc,&local))
706 symtype = LIB$K_CLI_LOCAL_SYM;
707 else symtype = LIB$K_CLI_GLOBAL_SYM;
708 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
711 if (!*eqv) eqvdsc.dsc$w_length = 1;
712 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
713 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
714 if (ckWARN(WARN_MISC)) {
715 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
718 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
724 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
725 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
726 set_errno(EVMSERR); break;
727 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
728 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
729 set_errno(EINVAL); break;
736 set_vaxc_errno(retsts);
737 return (int) retsts || 44; /* retsts should never be 0, but just in case */
740 /* We reset error values on success because Perl does an hv_fetch()
741 * before each hv_store(), and if the thing we're setting didn't
742 * previously exist, we've got a leftover error message. (Of course,
743 * this fails in the face of
744 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
745 * in that the error reported in $! isn't spurious,
746 * but it's right more often than not.)
748 set_errno(0); set_vaxc_errno(retsts);
752 } /* end of vmssetenv() */
755 /*{{{ void my_setenv(char *lnm, char *eqv)*/
756 /* This has to be a function since there's a prototype for it in proto.h */
758 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
761 int len = strlen(lnm);
765 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
766 if (!strcmp(uplnm,"DEFAULT")) {
767 if (eqv && *eqv) chdir(eqv);
772 if (len == 6 || len == 2) {
775 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
777 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
778 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
782 (void) vmssetenv(lnm,eqv,NULL);
786 /*{{{static void vmssetuserlnm(char *name, char *eqv);
788 * sets a user-mode logical in the process logical name table
789 * used for redirection of sys$error
792 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
794 $DESCRIPTOR(d_tab, "LNM$PROCESS");
795 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
796 unsigned long int iss, attr = LNM$M_CONFINE;
797 unsigned char acmode = PSL$C_USER;
798 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
800 d_name.dsc$a_pointer = name;
801 d_name.dsc$w_length = strlen(name);
803 lnmlst[0].buflen = strlen(eqv);
804 lnmlst[0].bufadr = eqv;
806 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
807 if (!(iss&1)) lib$signal(iss);
812 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
813 /* my_crypt - VMS password hashing
814 * my_crypt() provides an interface compatible with the Unix crypt()
815 * C library function, and uses sys$hash_password() to perform VMS
816 * password hashing. The quadword hashed password value is returned
817 * as a NUL-terminated 8 character string. my_crypt() does not change
818 * the case of its string arguments; in order to match the behavior
819 * of LOGINOUT et al., alphabetic characters in both arguments must
820 * be upcased by the caller.
823 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
825 # ifndef UAI$C_PREFERRED_ALGORITHM
826 # define UAI$C_PREFERRED_ALGORITHM 127
828 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
829 unsigned short int salt = 0;
830 unsigned long int sts;
832 unsigned short int dsc$w_length;
833 unsigned char dsc$b_type;
834 unsigned char dsc$b_class;
835 const char * dsc$a_pointer;
836 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
837 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
838 struct itmlst_3 uailst[3] = {
839 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
840 { sizeof salt, UAI$_SALT, &salt, 0},
841 { 0, 0, NULL, NULL}};
844 usrdsc.dsc$w_length = strlen(usrname);
845 usrdsc.dsc$a_pointer = usrname;
846 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
848 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
852 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
858 if (sts != RMS$_RNF) return NULL;
861 txtdsc.dsc$w_length = strlen(textpasswd);
862 txtdsc.dsc$a_pointer = textpasswd;
863 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
864 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
867 return (char *) hash;
869 } /* end of my_crypt() */
873 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
874 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
875 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
877 /*{{{int do_rmdir(char *name)*/
879 Perl_do_rmdir(pTHX_ char *name)
881 char dirfile[NAM$C_MAXRSS+1];
885 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
886 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
887 else retval = kill_file(dirfile);
890 } /* end of do_rmdir */
894 * Delete any file to which user has control access, regardless of whether
895 * delete access is explicitly allowed.
896 * Limitations: User must have write access to parent directory.
897 * Does not block signals or ASTs; if interrupted in midstream
898 * may leave file with an altered ACL.
901 /*{{{int kill_file(char *name)*/
903 Perl_kill_file(pTHX_ char *name)
905 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
906 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
907 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
908 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
910 unsigned char myace$b_length;
911 unsigned char myace$b_type;
912 unsigned short int myace$w_flags;
913 unsigned long int myace$l_access;
914 unsigned long int myace$l_ident;
915 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
916 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
917 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
919 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
920 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
921 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
922 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
923 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
924 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
926 /* Expand the input spec using RMS, since the CRTL remove() and
927 * system services won't do this by themselves, so we may miss
928 * a file "hiding" behind a logical name or search list. */
929 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
930 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
931 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
932 /* If not, can changing protections help? */
933 if (vaxc$errno != RMS$_PRV) return -1;
935 /* No, so we get our own UIC to use as a rights identifier,
936 * and the insert an ACE at the head of the ACL which allows us
937 * to delete the file.
939 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
940 fildsc.dsc$w_length = strlen(rspec);
941 fildsc.dsc$a_pointer = rspec;
943 newace.myace$l_ident = oldace.myace$l_ident;
944 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
946 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
947 set_errno(ENOENT); break;
949 set_errno(ENOTDIR); break;
951 set_errno(ENODEV); break;
952 case RMS$_SYN: case SS$_INVFILFOROP:
953 set_errno(EINVAL); break;
955 set_errno(EACCES); break;
959 set_vaxc_errno(aclsts);
962 /* Grab any existing ACEs with this identifier in case we fail */
963 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
964 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
965 || fndsts == SS$_NOMOREACE ) {
966 /* Add the new ACE . . . */
967 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
969 if ((rmsts = remove(name))) {
970 /* We blew it - dir with files in it, no write priv for
971 * parent directory, etc. Put things back the way they were. */
972 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
975 addlst[0].bufadr = &oldace;
976 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
983 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
984 /* We just deleted it, so of course it's not there. Some versions of
985 * VMS seem to return success on the unlock operation anyhow (after all
986 * the unlock is successful), but others don't.
988 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
989 if (aclsts & 1) aclsts = fndsts;
992 set_vaxc_errno(aclsts);
998 } /* end of kill_file() */
1002 /*{{{int my_mkdir(char *,Mode_t)*/
1004 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1006 STRLEN dirlen = strlen(dir);
1008 /* zero length string sometimes gives ACCVIO */
1009 if (dirlen == 0) return -1;
1011 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1012 * null file name/type. However, it's commonplace under Unix,
1013 * so we'll allow it for a gain in portability.
1015 if (dir[dirlen-1] == '/') {
1016 char *newdir = savepvn(dir,dirlen-1);
1017 int ret = mkdir(newdir,mode);
1021 else return mkdir(dir,mode);
1022 } /* end of my_mkdir */
1025 /*{{{int my_chdir(char *)*/
1027 Perl_my_chdir(pTHX_ char *dir)
1029 STRLEN dirlen = strlen(dir);
1031 /* zero length string sometimes gives ACCVIO */
1032 if (dirlen == 0) return -1;
1034 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1036 * null file name/type. However, it's commonplace under Unix,
1037 * so we'll allow it for a gain in portability.
1039 if (dir[dirlen-1] == '/') {
1040 char *newdir = savepvn(dir,dirlen-1);
1041 int ret = chdir(newdir);
1045 else return chdir(dir);
1046 } /* end of my_chdir */
1050 /*{{{FILE *my_tmpfile()*/
1057 if ((fp = tmpfile())) return fp;
1059 New(1323,cp,L_tmpnam+24,char);
1060 strcpy(cp,"Sys$Scratch:");
1061 tmpnam(cp+strlen(cp));
1062 strcat(cp,".Perltmp");
1063 fp = fopen(cp,"w+","fop=dlt");
1070 #ifndef HOMEGROWN_POSIX_SIGNALS
1072 * The C RTL's sigaction fails to check for invalid signal numbers so we
1073 * help it out a bit. The docs are correct, but the actual routine doesn't
1074 * do what the docs say it will.
1076 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1078 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1079 struct sigaction* oact)
1081 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1082 SETERRNO(EINVAL, SS$_INVARG);
1085 return sigaction(sig, act, oact);
1090 /* default piping mailbox size */
1091 #define PERL_BUFSIZ 512
1095 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1097 unsigned long int mbxbufsiz;
1098 static unsigned long int syssize = 0;
1099 unsigned long int dviitm = DVI$_DEVNAM;
1100 char csize[LNM$C_NAMLENGTH+1];
1103 unsigned long syiitm = SYI$_MAXBUF;
1105 * Get the SYSGEN parameter MAXBUF
1107 * If the logical 'PERL_MBX_SIZE' is defined
1108 * use the value of the logical instead of PERL_BUFSIZ, but
1109 * keep the size between 128 and MAXBUF.
1112 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1115 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1116 mbxbufsiz = atoi(csize);
1118 mbxbufsiz = PERL_BUFSIZ;
1120 if (mbxbufsiz < 128) mbxbufsiz = 128;
1121 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1123 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1125 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1126 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1128 } /* end of create_mbx() */
1131 /*{{{ my_popen and my_pclose*/
1133 typedef struct _iosb IOSB;
1134 typedef struct _iosb* pIOSB;
1135 typedef struct _pipe Pipe;
1136 typedef struct _pipe* pPipe;
1137 typedef struct pipe_details Info;
1138 typedef struct pipe_details* pInfo;
1139 typedef struct _srqp RQE;
1140 typedef struct _srqp* pRQE;
1141 typedef struct _tochildbuf CBuf;
1142 typedef struct _tochildbuf* pCBuf;
1145 unsigned short status;
1146 unsigned short count;
1147 unsigned long dvispec;
1150 #pragma member_alignment save
1151 #pragma nomember_alignment quadword
1152 struct _srqp { /* VMS self-relative queue entry */
1153 unsigned long qptr[2];
1155 #pragma member_alignment restore
1156 static RQE RQE_ZERO = {0,0};
1158 struct _tochildbuf {
1161 unsigned short size;
1169 unsigned short chan_in;
1170 unsigned short chan_out;
1172 unsigned int bufsize;
1184 #if defined(PERL_IMPLICIT_CONTEXT)
1185 void *thx; /* Either a thread or an interpreter */
1186 /* pointer, depending on how we're built */
1194 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1195 int pid; /* PID of subprocess */
1196 int mode; /* == 'r' if pipe open for reading */
1197 int done; /* subprocess has completed */
1198 int closing; /* my_pclose is closing this pipe */
1199 unsigned long completion; /* termination status of subprocess */
1200 pPipe in; /* pipe in to sub */
1201 pPipe out; /* pipe out of sub */
1202 pPipe err; /* pipe of sub's sys$error */
1203 int in_done; /* true when in pipe finished */
1208 struct exit_control_block
1210 struct exit_control_block *flink;
1211 unsigned long int (*exit_routine)();
1212 unsigned long int arg_count;
1213 unsigned long int *status_address;
1214 unsigned long int exit_status;
1217 #define RETRY_DELAY "0 ::0.20"
1218 #define MAX_RETRY 50
1220 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1221 static unsigned long mypid;
1222 static unsigned long delaytime[2];
1224 static pInfo open_pipes = NULL;
1225 static $DESCRIPTOR(nl_desc, "NL:");
1228 static unsigned long int
1229 pipe_exit_routine(pTHX)
1232 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1233 int sts, did_stuff, need_eof;
1236 first we try sending an EOF...ignore if doesn't work, make sure we
1244 _ckvmssts(sys$setast(0));
1245 if (info->in && !info->in->shut_on_empty) {
1246 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1250 _ckvmssts(sys$setast(1));
1253 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1258 _ckvmssts(sys$setast(0));
1259 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1260 sts = sys$forcex(&info->pid,0,&abort);
1261 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1264 _ckvmssts(sys$setast(1));
1267 if (did_stuff) sleep(1); /* wait for them to respond */
1271 _ckvmssts(sys$setast(0));
1272 if (!info->done) { /* We tried to be nice . . . */
1273 sts = sys$delprc(&info->pid,0);
1274 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1276 _ckvmssts(sys$setast(1));
1281 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1282 else if (!(sts & 1)) retsts = sts;
1287 static struct exit_control_block pipe_exitblock =
1288 {(struct exit_control_block *) 0,
1289 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1291 static void pipe_mbxtofd_ast(pPipe p);
1292 static void pipe_tochild1_ast(pPipe p);
1293 static void pipe_tochild2_ast(pPipe p);
1296 popen_completion_ast(pInfo info)
1298 pInfo i = open_pipes;
1302 if (i == info) break;
1305 if (!i) return; /* unlinked, probably freed too */
1307 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1311 Writing to subprocess ...
1312 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1314 chan_out may be waiting for "done" flag, or hung waiting
1315 for i/o completion to child...cancel the i/o. This will
1316 put it into "snarf mode" (done but no EOF yet) that discards
1319 Output from subprocess (stdout, stderr) needs to be flushed and
1320 shut down. We try sending an EOF, but if the mbx is full the pipe
1321 routine should still catch the "shut_on_empty" flag, telling it to
1322 use immediate-style reads so that "mbx empty" -> EOF.
1326 if (info->in && !info->in_done) { /* only for mode=w */
1327 if (info->in->shut_on_empty && info->in->need_wake) {
1328 info->in->need_wake = FALSE;
1329 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1331 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1335 if (info->out && !info->out_done) { /* were we also piping output? */
1336 info->out->shut_on_empty = TRUE;
1337 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1338 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1339 _ckvmssts_noperl(iss);
1342 if (info->err && !info->err_done) { /* we were piping stderr */
1343 info->err->shut_on_empty = TRUE;
1344 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1345 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1346 _ckvmssts_noperl(iss);
1348 _ckvmssts_noperl(sys$setef(pipe_ef));
1352 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1353 static void vms_execfree(pTHX);
1356 we actually differ from vmstrnenv since we use this to
1357 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1358 are pointing to the same thing
1361 static unsigned short
1362 popen_translate(pTHX_ char *logical, char *result)
1365 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1366 $DESCRIPTOR(d_log,"");
1368 unsigned short length;
1369 unsigned short code;
1371 unsigned short *retlenaddr;
1373 unsigned short l, ifi;
1375 d_log.dsc$a_pointer = logical;
1376 d_log.dsc$w_length = strlen(logical);
1378 itmlst[0].code = LNM$_STRING;
1379 itmlst[0].length = 255;
1380 itmlst[0].buffer_addr = result;
1381 itmlst[0].retlenaddr = &l;
1384 itmlst[1].length = 0;
1385 itmlst[1].buffer_addr = 0;
1386 itmlst[1].retlenaddr = 0;
1388 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1389 if (iss == SS$_NOLOGNAM) {
1393 if (!(iss&1)) lib$signal(iss);
1396 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1397 strip it off and return the ifi, if any
1400 if (result[0] == 0x1b && result[1] == 0x00) {
1401 memcpy(&ifi,result+2,2);
1402 strcpy(result,result+4);
1404 return ifi; /* this is the RMS internal file id */
1407 #define MAX_DCL_SYMBOL 255
1408 static void pipe_infromchild_ast(pPipe p);
1411 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1412 inside an AST routine without worrying about reentrancy and which Perl
1413 memory allocator is being used.
1415 We read data and queue up the buffers, then spit them out one at a
1416 time to the output mailbox when the output mailbox is ready for one.
1419 #define INITIAL_TOCHILDQUEUE 2
1422 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1426 char mbx1[64], mbx2[64];
1427 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1428 DSC$K_CLASS_S, mbx1},
1429 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1430 DSC$K_CLASS_S, mbx2};
1431 unsigned int dviitm = DVI$_DEVBUFSIZ;
1434 New(1368, p, 1, Pipe);
1436 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1437 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1438 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1441 p->shut_on_empty = FALSE;
1442 p->need_wake = FALSE;
1445 p->iosb.status = SS$_NORMAL;
1446 p->iosb2.status = SS$_NORMAL;
1452 #ifdef PERL_IMPLICIT_CONTEXT
1456 n = sizeof(CBuf) + p->bufsize;
1458 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1459 _ckvmssts(lib$get_vm(&n, &b));
1460 b->buf = (char *) b + sizeof(CBuf);
1461 _ckvmssts(lib$insqhi(b, &p->free));
1464 pipe_tochild2_ast(p);
1465 pipe_tochild1_ast(p);
1471 /* reads the MBX Perl is writing, and queues */
1474 pipe_tochild1_ast(pPipe p)
1477 int iss = p->iosb.status;
1478 int eof = (iss == SS$_ENDOFFILE);
1479 #ifdef PERL_IMPLICIT_CONTEXT
1485 p->shut_on_empty = TRUE;
1487 _ckvmssts(sys$dassgn(p->chan_in));
1493 b->size = p->iosb.count;
1494 _ckvmssts(lib$insqhi(b, &p->wait));
1496 p->need_wake = FALSE;
1497 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1500 p->retry = 1; /* initial call */
1503 if (eof) { /* flush the free queue, return when done */
1504 int n = sizeof(CBuf) + p->bufsize;
1506 iss = lib$remqti(&p->free, &b);
1507 if (iss == LIB$_QUEWASEMP) return;
1509 _ckvmssts(lib$free_vm(&n, &b));
1513 iss = lib$remqti(&p->free, &b);
1514 if (iss == LIB$_QUEWASEMP) {
1515 int n = sizeof(CBuf) + p->bufsize;
1516 _ckvmssts(lib$get_vm(&n, &b));
1517 b->buf = (char *) b + sizeof(CBuf);
1523 iss = sys$qio(0,p->chan_in,
1524 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1526 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1527 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1532 /* writes queued buffers to output, waits for each to complete before
1536 pipe_tochild2_ast(pPipe p)
1539 int iss = p->iosb2.status;
1540 int n = sizeof(CBuf) + p->bufsize;
1541 int done = (p->info && p->info->done) ||
1542 iss == SS$_CANCEL || iss == SS$_ABORT;
1543 #if defined(PERL_IMPLICIT_CONTEXT)
1548 if (p->type) { /* type=1 has old buffer, dispose */
1549 if (p->shut_on_empty) {
1550 _ckvmssts(lib$free_vm(&n, &b));
1552 _ckvmssts(lib$insqhi(b, &p->free));
1557 iss = lib$remqti(&p->wait, &b);
1558 if (iss == LIB$_QUEWASEMP) {
1559 if (p->shut_on_empty) {
1561 _ckvmssts(sys$dassgn(p->chan_out));
1562 *p->pipe_done = TRUE;
1563 _ckvmssts(sys$setef(pipe_ef));
1565 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1566 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1570 p->need_wake = TRUE;
1580 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1581 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1583 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1584 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1593 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1596 char mbx1[64], mbx2[64];
1597 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1598 DSC$K_CLASS_S, mbx1},
1599 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1600 DSC$K_CLASS_S, mbx2};
1601 unsigned int dviitm = DVI$_DEVBUFSIZ;
1603 New(1367, p, 1, Pipe);
1604 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1605 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1607 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1608 New(1367, p->buf, p->bufsize, char);
1609 p->shut_on_empty = FALSE;
1612 p->iosb.status = SS$_NORMAL;
1613 #if defined(PERL_IMPLICIT_CONTEXT)
1616 pipe_infromchild_ast(p);
1624 pipe_infromchild_ast(pPipe p)
1626 int iss = p->iosb.status;
1627 int eof = (iss == SS$_ENDOFFILE);
1628 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1629 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1630 #if defined(PERL_IMPLICIT_CONTEXT)
1634 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1635 _ckvmssts(sys$dassgn(p->chan_out));
1640 input shutdown if EOF from self (done or shut_on_empty)
1641 output shutdown if closing flag set (my_pclose)
1642 send data/eof from child or eof from self
1643 otherwise, re-read (snarf of data from child)
1648 if (myeof && p->chan_in) { /* input shutdown */
1649 _ckvmssts(sys$dassgn(p->chan_in));
1654 if (myeof || kideof) { /* pass EOF to parent */
1655 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1656 pipe_infromchild_ast, p,
1659 } else if (eof) { /* eat EOF --- fall through to read*/
1661 } else { /* transmit data */
1662 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1663 pipe_infromchild_ast,p,
1664 p->buf, p->iosb.count, 0, 0, 0, 0));
1670 /* everything shut? flag as done */
1672 if (!p->chan_in && !p->chan_out) {
1673 *p->pipe_done = TRUE;
1674 _ckvmssts(sys$setef(pipe_ef));
1678 /* write completed (or read, if snarfing from child)
1679 if still have input active,
1680 queue read...immediate mode if shut_on_empty so we get EOF if empty
1682 check if Perl reading, generate EOFs as needed
1688 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1689 pipe_infromchild_ast,p,
1690 p->buf, p->bufsize, 0, 0, 0, 0);
1691 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1693 } else { /* send EOFs for extra reads */
1694 p->iosb.status = SS$_ENDOFFILE;
1695 p->iosb.dvispec = 0;
1696 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1698 pipe_infromchild_ast, p, 0, 0, 0, 0));
1704 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1708 unsigned long dviitm = DVI$_DEVBUFSIZ;
1710 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1711 DSC$K_CLASS_S, mbx};
1713 /* things like terminals and mbx's don't need this filter */
1714 if (fd && fstat(fd,&s) == 0) {
1715 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1716 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1717 DSC$K_CLASS_S, s.st_dev};
1719 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1720 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1721 strcpy(out, s.st_dev);
1726 New(1366, p, 1, Pipe);
1727 p->fd_out = dup(fd);
1728 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1729 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1730 New(1366, p->buf, p->bufsize+1, char);
1731 p->shut_on_empty = FALSE;
1736 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1737 pipe_mbxtofd_ast, p,
1738 p->buf, p->bufsize, 0, 0, 0, 0));
1744 pipe_mbxtofd_ast(pPipe p)
1746 int iss = p->iosb.status;
1747 int done = p->info->done;
1749 int eof = (iss == SS$_ENDOFFILE);
1750 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1751 int err = !(iss&1) && !eof;
1752 #if defined(PERL_IMPLICIT_CONTEXT)
1756 if (done && myeof) { /* end piping */
1758 sys$dassgn(p->chan_in);
1759 *p->pipe_done = TRUE;
1760 _ckvmssts(sys$setef(pipe_ef));
1764 if (!err && !eof) { /* good data to send to file */
1765 p->buf[p->iosb.count] = '\n';
1766 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1769 if (p->retry < MAX_RETRY) {
1770 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1780 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1781 pipe_mbxtofd_ast, p,
1782 p->buf, p->bufsize, 0, 0, 0, 0);
1783 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1788 typedef struct _pipeloc PLOC;
1789 typedef struct _pipeloc* pPLOC;
1793 char dir[NAM$C_MAXRSS+1];
1795 static pPLOC head_PLOC = 0;
1798 free_pipelocs(pTHX_ void *head)
1811 store_pipelocs(pTHX)
1815 AV *av = GvAVn(PL_incgv);
1820 char temp[NAM$C_MAXRSS+1];
1823 /* the . directory from @INC comes last */
1826 p->next = head_PLOC;
1828 strcpy(p->dir,"./");
1830 /* get the directory from $^X */
1832 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1833 strcpy(temp, PL_origargv[0]);
1834 x = strrchr(temp,']');
1837 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1839 p->next = head_PLOC;
1841 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1842 p->dir[NAM$C_MAXRSS] = '\0';
1846 /* reverse order of @INC entries, skip "." since entered above */
1848 for (i = 0; i <= AvFILL(av); i++) {
1849 dirsv = *av_fetch(av,i,TRUE);
1851 if (SvROK(dirsv)) continue;
1852 dir = SvPVx(dirsv,n_a);
1853 if (strcmp(dir,".") == 0) continue;
1854 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1858 p->next = head_PLOC;
1860 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1861 p->dir[NAM$C_MAXRSS] = '\0';
1864 /* most likely spot (ARCHLIB) put first in the list */
1867 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1869 p->next = head_PLOC;
1871 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1872 p->dir[NAM$C_MAXRSS] = '\0';
1875 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1882 static int vmspipe_file_status = 0;
1883 static char vmspipe_file[NAM$C_MAXRSS+1];
1885 /* already found? Check and use ... need read+execute permission */
1887 if (vmspipe_file_status == 1) {
1888 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1889 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1890 return vmspipe_file;
1892 vmspipe_file_status = 0;
1895 /* scan through stored @INC, $^X */
1897 if (vmspipe_file_status == 0) {
1898 char file[NAM$C_MAXRSS+1];
1899 pPLOC p = head_PLOC;
1902 strcpy(file, p->dir);
1903 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1904 file[NAM$C_MAXRSS] = '\0';
1907 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1909 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1910 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1911 vmspipe_file_status = 1;
1912 return vmspipe_file;
1915 vmspipe_file_status = -1; /* failed, use tempfiles */
1922 vmspipe_tempfile(pTHX)
1924 char file[NAM$C_MAXRSS+1];
1926 static int index = 0;
1929 /* create a tempfile */
1931 /* we can't go from W, shr=get to R, shr=get without
1932 an intermediate vulnerable state, so don't bother trying...
1934 and lib$spawn doesn't shr=put, so have to close the write
1936 So... match up the creation date/time and the FID to
1937 make sure we're dealing with the same file
1942 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1943 fp = fopen(file,"w");
1945 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1946 fp = fopen(file,"w");
1948 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1949 fp = fopen(file,"w");
1952 if (!fp) return 0; /* we're hosed */
1954 fprintf(fp,"$! 'f$verify(0)\n");
1955 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1956 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1957 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1958 fprintf(fp,"$ perl_on = \"set noon\"\n");
1959 fprintf(fp,"$ perl_exit = \"exit\"\n");
1960 fprintf(fp,"$ perl_del = \"delete\"\n");
1961 fprintf(fp,"$ pif = \"if\"\n");
1962 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1963 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1964 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
1965 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1966 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1967 fprintf(fp,"$! --- get rid of global symbols\n");
1968 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1969 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1970 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1971 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1972 fprintf(fp,"$ perl_on\n");
1973 fprintf(fp,"$ 'cmd\n");
1974 fprintf(fp,"$ perl_status = $STATUS\n");
1975 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1976 fprintf(fp,"$ perl_exit 'perl_status'\n");
1979 fgetname(fp, file, 1);
1980 fstat(fileno(fp), &s0);
1983 fp = fopen(file,"r","shr=get");
1985 fstat(fileno(fp), &s1);
1987 if (s0.st_ino[0] != s1.st_ino[0] ||
1988 s0.st_ino[1] != s1.st_ino[1] ||
1989 s0.st_ino[2] != s1.st_ino[2] ||
1990 s0.st_ctime != s1.st_ctime ) {
2001 safe_popen(pTHX_ char *cmd, char *mode)
2003 static int handler_set_up = FALSE;
2004 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2005 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2006 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2007 char in[512], out[512], err[512], mbx[512];
2009 char tfilebuf[NAM$C_MAXRSS+1];
2011 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2012 DSC$K_CLASS_S, symbol};
2013 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2016 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2017 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2018 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2019 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2021 /* once-per-program initialization...
2022 note that the SETAST calls and the dual test of pipe_ef
2023 makes sure that only the FIRST thread through here does
2024 the initialization...all other threads wait until it's
2027 Yeah, uglier than a pthread call, it's got all the stuff inline
2028 rather than in a separate routine.
2032 _ckvmssts(sys$setast(0));
2034 unsigned long int pidcode = JPI$_PID;
2035 $DESCRIPTOR(d_delay, RETRY_DELAY);
2036 _ckvmssts(lib$get_ef(&pipe_ef));
2037 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2038 _ckvmssts(sys$bintim(&d_delay, delaytime));
2040 if (!handler_set_up) {
2041 _ckvmssts(sys$dclexh(&pipe_exitblock));
2042 handler_set_up = TRUE;
2044 _ckvmssts(sys$setast(1));
2047 /* see if we can find a VMSPIPE.COM */
2050 vmspipe = find_vmspipe(aTHX);
2052 strcpy(tfilebuf+1,vmspipe);
2053 } else { /* uh, oh...we're in tempfile hell */
2054 tpipe = vmspipe_tempfile(aTHX);
2055 if (!tpipe) { /* a fish popular in Boston */
2056 if (ckWARN(WARN_PIPE)) {
2057 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2061 fgetname(tpipe,tfilebuf+1,1);
2063 vmspipedsc.dsc$a_pointer = tfilebuf;
2064 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2066 sts = setup_cmddsc(aTHX_ cmd,0);
2069 case RMS$_FNF: case RMS$_DNF:
2070 set_errno(ENOENT); break;
2072 set_errno(ENOTDIR); break;
2074 set_errno(ENODEV); break;
2076 set_errno(EACCES); break;
2078 set_errno(EINVAL); break;
2079 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2080 set_errno(E2BIG); break;
2081 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2082 _ckvmssts(sts); /* fall through */
2083 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2086 set_vaxc_errno(sts);
2087 if (ckWARN(WARN_PIPE)) {
2088 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2092 New(1301,info,1,Info);
2096 info->completion = 0;
2097 info->closing = FALSE;
2101 info->in_done = TRUE;
2102 info->out_done = TRUE;
2103 info->err_done = TRUE;
2104 in[0] = out[0] = err[0] = '\0';
2106 if (*mode == 'r') { /* piping from subroutine */
2108 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2110 info->out->pipe_done = &info->out_done;
2111 info->out_done = FALSE;
2112 info->out->info = info;
2114 info->fp = PerlIO_open(mbx, mode);
2115 if (!info->fp && info->out) {
2116 sys$cancel(info->out->chan_out);
2118 while (!info->out_done) {
2120 _ckvmssts(sys$setast(0));
2121 done = info->out_done;
2122 if (!done) _ckvmssts(sys$clref(pipe_ef));
2123 _ckvmssts(sys$setast(1));
2124 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2127 if (info->out->buf) Safefree(info->out->buf);
2128 Safefree(info->out);
2133 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2135 info->err->pipe_done = &info->err_done;
2136 info->err_done = FALSE;
2137 info->err->info = info;
2140 } else { /* piping to subroutine , mode=w*/
2142 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2143 info->fp = PerlIO_open(mbx, mode);
2145 info->in->pipe_done = &info->in_done;
2146 info->in_done = FALSE;
2147 info->in->info = info;
2151 if (!info->fp && info->in) {
2153 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2154 0, 0, 0, 0, 0, 0, 0, 0));
2156 while (!info->in_done) {
2158 _ckvmssts(sys$setast(0));
2159 done = info->in_done;
2160 if (!done) _ckvmssts(sys$clref(pipe_ef));
2161 _ckvmssts(sys$setast(1));
2162 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2165 if (info->in->buf) Safefree(info->in->buf);
2172 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2174 info->out->pipe_done = &info->out_done;
2175 info->out_done = FALSE;
2176 info->out->info = info;
2179 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2181 info->err->pipe_done = &info->err_done;
2182 info->err_done = FALSE;
2183 info->err->info = info;
2187 symbol[MAX_DCL_SYMBOL] = '\0';
2189 strncpy(symbol, in, MAX_DCL_SYMBOL);
2190 d_symbol.dsc$w_length = strlen(symbol);
2191 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2193 strncpy(symbol, err, MAX_DCL_SYMBOL);
2194 d_symbol.dsc$w_length = strlen(symbol);
2195 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2197 strncpy(symbol, out, MAX_DCL_SYMBOL);
2198 d_symbol.dsc$w_length = strlen(symbol);
2199 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2201 p = VMScmd.dsc$a_pointer;
2202 while (*p && *p != '\n') p++;
2203 *p = '\0'; /* truncate on \n */
2204 p = VMScmd.dsc$a_pointer;
2205 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2206 if (*p == '$') p++; /* remove leading $ */
2207 while (*p == ' ' || *p == '\t') p++;
2208 strncpy(symbol, p, MAX_DCL_SYMBOL);
2209 d_symbol.dsc$w_length = strlen(symbol);
2210 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2212 _ckvmssts(sys$setast(0));
2213 info->next=open_pipes; /* prepend to list */
2215 _ckvmssts(sys$setast(1));
2216 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2217 0, &info->pid, &info->completion,
2218 0, popen_completion_ast,info,0,0,0));
2220 /* if we were using a tempfile, close it now */
2222 if (tpipe) fclose(tpipe);
2224 /* once the subprocess is spawned, its copied the symbols and
2225 we can get rid of ours */
2227 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2228 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2229 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2230 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2233 PL_forkprocess = info->pid;
2235 } /* end of safe_popen */
2238 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2240 Perl_my_popen(pTHX_ char *cmd, char *mode)
2243 TAINT_PROPER("popen");
2244 PERL_FLUSHALL_FOR_CHILD;
2245 return safe_popen(aTHX_ cmd,mode);
2250 /*{{{ I32 my_pclose(PerlIO *fp)*/
2251 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2253 pInfo info, last = NULL;
2254 unsigned long int retsts;
2257 for (info = open_pipes; info != NULL; last = info, info = info->next)
2258 if (info->fp == fp) break;
2260 if (info == NULL) { /* no such pipe open */
2261 set_errno(ECHILD); /* quoth POSIX */
2262 set_vaxc_errno(SS$_NONEXPR);
2266 /* If we were writing to a subprocess, insure that someone reading from
2267 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2268 * produce an EOF record in the mailbox.
2270 * well, at least sometimes it *does*, so we have to watch out for
2271 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2274 PerlIO_flush(info->fp); /* first, flush data */
2276 _ckvmssts(sys$setast(0));
2277 info->closing = TRUE;
2278 done = info->done && info->in_done && info->out_done && info->err_done;
2279 /* hanging on write to Perl's input? cancel it */
2280 if (info->mode == 'r' && info->out && !info->out_done) {
2281 if (info->out->chan_out) {
2282 _ckvmssts(sys$cancel(info->out->chan_out));
2283 if (!info->out->chan_in) { /* EOF generation, need AST */
2284 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2288 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2289 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2291 _ckvmssts(sys$setast(1));
2292 PerlIO_close(info->fp);
2295 we have to wait until subprocess completes, but ALSO wait until all
2296 the i/o completes...otherwise we'll be freeing the "info" structure
2297 that the i/o ASTs could still be using...
2301 _ckvmssts(sys$setast(0));
2302 done = info->done && info->in_done && info->out_done && info->err_done;
2303 if (!done) _ckvmssts(sys$clref(pipe_ef));
2304 _ckvmssts(sys$setast(1));
2305 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2307 retsts = info->completion;
2309 /* remove from list of open pipes */
2310 _ckvmssts(sys$setast(0));
2311 if (last) last->next = info->next;
2312 else open_pipes = info->next;
2313 _ckvmssts(sys$setast(1));
2315 /* free buffers and structures */
2318 if (info->in->buf) Safefree(info->in->buf);
2322 if (info->out->buf) Safefree(info->out->buf);
2323 Safefree(info->out);
2326 if (info->err->buf) Safefree(info->err->buf);
2327 Safefree(info->err);
2333 } /* end of my_pclose() */
2335 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2336 /* Roll our own prototype because we want this regardless of whether
2337 * _VMS_WAIT is defined.
2339 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2341 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2342 created with popen(); otherwise partially emulate waitpid() unless
2343 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2344 Also check processes not considered by the CRTL waitpid().
2346 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2348 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2354 if (statusp) *statusp = 0;
2356 for (info = open_pipes; info != NULL; info = info->next)
2357 if (info->pid == pid) break;
2359 if (info != NULL) { /* we know about this child */
2360 while (!info->done) {
2361 _ckvmssts(sys$setast(0));
2363 if (!done) _ckvmssts(sys$clref(pipe_ef));
2364 _ckvmssts(sys$setast(1));
2365 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2368 if (statusp) *statusp = info->completion;
2372 else { /* this child is not one of our own pipe children */
2374 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2376 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2377 * in 7.2 did we get a version that fills in the VMS completion
2378 * status as Perl has always tried to do.
2381 sts = __vms_waitpid( pid, statusp, flags );
2383 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2386 /* If the real waitpid tells us the child does not exist, we
2387 * fall through here to implement waiting for a child that
2388 * was created by some means other than exec() (say, spawned
2389 * from DCL) or to wait for a process that is not a subprocess
2390 * of the current process.
2393 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2395 $DESCRIPTOR(intdsc,"0 00:00:01");
2396 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2397 unsigned long int pidcode = JPI$_PID, mypid;
2398 unsigned long int interval[2];
2399 int termination_mbu = 0;
2400 unsigned short qio_iosb[4];
2401 unsigned int jpi_iosb[2];
2402 struct itmlst_3 jpilist[3] = {
2403 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2404 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2407 char trmmbx[NAM$C_DVI+1];
2408 $DESCRIPTOR(trmmbxdsc,trmmbx);
2409 struct accdef trmmsg;
2410 unsigned short int mbxchan;
2413 /* Sorry folks, we don't presently implement rooting around for
2414 the first child we can find, and we definitely don't want to
2415 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2421 /* Get the owner of the child so I can warn if it's not mine, plus
2422 * get the termination mailbox. If the process doesn't exist or I
2423 * don't have the privs to look at it, I can go home early.
2425 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2426 if (sts & 1) sts = jpi_iosb[0];
2438 set_vaxc_errno(sts);
2442 if (ckWARN(WARN_EXEC)) {
2443 /* remind folks they are asking for non-standard waitpid behavior */
2444 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2445 if (ownerpid != mypid)
2446 Perl_warner(aTHX_ WARN_EXEC,
2447 "waitpid: process %x is not a child of process %x",
2451 /* It's possible to have a mailbox unit number but no actual mailbox; we
2452 * check for this by assigning a channel to it, which we need anyway.
2454 if (termination_mbu != 0) {
2455 sprintf(trmmbx, "MBA%d:", termination_mbu);
2456 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2457 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2458 if (sts == SS$_NOSUCHDEV) {
2459 termination_mbu = 0; /* set up to take "no mailbox" case */
2464 /* If the process doesn't have a termination mailbox, then simply check
2465 * on it once a second until it's not there anymore.
2467 if (termination_mbu == 0) {
2468 _ckvmssts(sys$bintim(&intdsc,interval));
2469 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2470 _ckvmssts(sys$schdwk(0,0,interval,0));
2471 _ckvmssts(sys$hiber());
2473 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2476 /* If we do have a termination mailbox, post reads to it until we get a
2477 * termination message, discarding messages of the wrong type or for other
2478 * processes. If there is a place to put the final status, then do so.
2482 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2483 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2484 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2485 if (sts & 1) sts = qio_iosb[0];
2488 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2489 && trmmsg.acc$l_pid == pid ) {
2491 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2492 sts = sys$dassgn(mbxchan);
2496 } /* termination_mbu ? */
2501 } /* else one of our own pipe children */
2503 } /* end of waitpid() */
2508 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2510 my_gconvert(double val, int ndig, int trail, char *buf)
2512 static char __gcvtbuf[DBL_DIG+1];
2515 loc = buf ? buf : __gcvtbuf;
2517 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2519 sprintf(loc,"%.*g",ndig,val);
2525 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2526 return gcvt(val,ndig,loc);
2529 loc[0] = '0'; loc[1] = '\0';
2537 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2538 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2539 * to expand file specification. Allows for a single default file
2540 * specification and a simple mask of options. If outbuf is non-NULL,
2541 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2542 * the resultant file specification is placed. If outbuf is NULL, the
2543 * resultant file specification is placed into a static buffer.
2544 * The third argument, if non-NULL, is taken to be a default file
2545 * specification string. The fourth argument is unused at present.
2546 * rmesexpand() returns the address of the resultant string if
2547 * successful, and NULL on error.
2549 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2552 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2554 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2555 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2556 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2557 struct FAB myfab = cc$rms_fab;
2558 struct NAM mynam = cc$rms_nam;
2560 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2562 if (!filespec || !*filespec) {
2563 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2567 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2568 else outbuf = __rmsexpand_retbuf;
2570 if ((isunix = (strchr(filespec,'/') != NULL))) {
2571 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2572 filespec = vmsfspec;
2575 myfab.fab$l_fna = filespec;
2576 myfab.fab$b_fns = strlen(filespec);
2577 myfab.fab$l_nam = &mynam;
2579 if (defspec && *defspec) {
2580 if (strchr(defspec,'/') != NULL) {
2581 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2584 myfab.fab$l_dna = defspec;
2585 myfab.fab$b_dns = strlen(defspec);
2588 mynam.nam$l_esa = esa;
2589 mynam.nam$b_ess = sizeof esa;
2590 mynam.nam$l_rsa = outbuf;
2591 mynam.nam$b_rss = NAM$C_MAXRSS;
2593 retsts = sys$parse(&myfab,0,0);
2594 if (!(retsts & 1)) {
2595 mynam.nam$b_nop |= NAM$M_SYNCHK;
2596 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2597 retsts = sys$parse(&myfab,0,0);
2598 if (retsts & 1) goto expanded;
2600 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2601 (void) sys$parse(&myfab,0,0); /* Free search context */
2602 if (out) Safefree(out);
2603 set_vaxc_errno(retsts);
2604 if (retsts == RMS$_PRV) set_errno(EACCES);
2605 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2606 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2607 else set_errno(EVMSERR);
2610 retsts = sys$search(&myfab,0,0);
2611 if (!(retsts & 1) && retsts != RMS$_FNF) {
2612 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2613 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2614 if (out) Safefree(out);
2615 set_vaxc_errno(retsts);
2616 if (retsts == RMS$_PRV) set_errno(EACCES);
2617 else set_errno(EVMSERR);
2621 /* If the input filespec contained any lowercase characters,
2622 * downcase the result for compatibility with Unix-minded code. */
2624 for (out = myfab.fab$l_fna; *out; out++)
2625 if (islower(*out)) { haslower = 1; break; }
2626 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2627 else { out = esa; speclen = mynam.nam$b_esl; }
2628 /* Trim off null fields added by $PARSE
2629 * If type > 1 char, must have been specified in original or default spec
2630 * (not true for version; $SEARCH may have added version of existing file).
2632 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2633 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2634 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2635 if (trimver || trimtype) {
2636 if (defspec && *defspec) {
2637 char defesa[NAM$C_MAXRSS];
2638 struct FAB deffab = cc$rms_fab;
2639 struct NAM defnam = cc$rms_nam;
2641 deffab.fab$l_nam = &defnam;
2642 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2643 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2644 defnam.nam$b_nop = NAM$M_SYNCHK;
2645 if (sys$parse(&deffab,0,0) & 1) {
2646 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2647 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2650 if (trimver) speclen = mynam.nam$l_ver - out;
2652 /* If we didn't already trim version, copy down */
2653 if (speclen > mynam.nam$l_ver - out)
2654 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2655 speclen - (mynam.nam$l_ver - out));
2656 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2659 /* If we just had a directory spec on input, $PARSE "helpfully"
2660 * adds an empty name and type for us */
2661 if (mynam.nam$l_name == mynam.nam$l_type &&
2662 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2663 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2664 speclen = mynam.nam$l_name - out;
2665 out[speclen] = '\0';
2666 if (haslower) __mystrtolower(out);
2668 /* Have we been working with an expanded, but not resultant, spec? */
2669 /* Also, convert back to Unix syntax if necessary. */
2670 if (!mynam.nam$b_rsl) {
2672 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2674 else strcpy(outbuf,esa);
2677 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2678 strcpy(outbuf,tmpfspec);
2680 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2681 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2682 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2686 /* External entry points */
2687 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2688 { return do_rmsexpand(spec,buf,0,def,opt); }
2689 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2690 { return do_rmsexpand(spec,buf,1,def,opt); }
2694 ** The following routines are provided to make life easier when
2695 ** converting among VMS-style and Unix-style directory specifications.
2696 ** All will take input specifications in either VMS or Unix syntax. On
2697 ** failure, all return NULL. If successful, the routines listed below
2698 ** return a pointer to a buffer containing the appropriately
2699 ** reformatted spec (and, therefore, subsequent calls to that routine
2700 ** will clobber the result), while the routines of the same names with
2701 ** a _ts suffix appended will return a pointer to a mallocd string
2702 ** containing the appropriately reformatted spec.
2703 ** In all cases, only explicit syntax is altered; no check is made that
2704 ** the resulting string is valid or that the directory in question
2707 ** fileify_dirspec() - convert a directory spec into the name of the
2708 ** directory file (i.e. what you can stat() to see if it's a dir).
2709 ** The style (VMS or Unix) of the result is the same as the style
2710 ** of the parameter passed in.
2711 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2712 ** what you prepend to a filename to indicate what directory it's in).
2713 ** The style (VMS or Unix) of the result is the same as the style
2714 ** of the parameter passed in.
2715 ** tounixpath() - convert a directory spec into a Unix-style path.
2716 ** tovmspath() - convert a directory spec into a VMS-style path.
2717 ** tounixspec() - convert any file spec into a Unix-style file spec.
2718 ** tovmsspec() - convert any file spec into a VMS-style spec.
2720 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2721 ** Permission is given to distribute this code as part of the Perl
2722 ** standard distribution under the terms of the GNU General Public
2723 ** License or the Perl Artistic License. Copies of each may be
2724 ** found in the Perl standard distribution.
2727 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2728 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2730 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2731 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2732 char *retspec, *cp1, *cp2, *lastdir;
2733 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2735 if (!dir || !*dir) {
2736 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2738 dirlen = strlen(dir);
2739 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2740 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2741 strcpy(trndir,"/sys$disk/000000");
2745 if (dirlen > NAM$C_MAXRSS) {
2746 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2748 if (!strpbrk(dir+1,"/]>:")) {
2749 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2750 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2752 dirlen = strlen(dir);
2755 strncpy(trndir,dir,dirlen);
2756 trndir[dirlen] = '\0';
2759 /* If we were handed a rooted logical name or spec, treat it like a
2760 * simple directory, so that
2761 * $ Define myroot dev:[dir.]
2762 * ... do_fileify_dirspec("myroot",buf,1) ...
2763 * does something useful.
2765 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2766 dir[--dirlen] = '\0';
2767 dir[dirlen-1] = ']';
2769 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2770 dir[--dirlen] = '\0';
2771 dir[dirlen-1] = '>';
2774 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2775 /* If we've got an explicit filename, we can just shuffle the string. */
2776 if (*(cp1+1)) hasfilename = 1;
2777 /* Similarly, we can just back up a level if we've got multiple levels
2778 of explicit directories in a VMS spec which ends with directories. */
2780 for (cp2 = cp1; cp2 > dir; cp2--) {
2782 *cp2 = *cp1; *cp1 = '\0';
2786 if (*cp2 == '[' || *cp2 == '<') break;
2791 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2792 if (dir[0] == '.') {
2793 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2794 return do_fileify_dirspec("[]",buf,ts);
2795 else if (dir[1] == '.' &&
2796 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2797 return do_fileify_dirspec("[-]",buf,ts);
2799 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2800 dirlen -= 1; /* to last element */
2801 lastdir = strrchr(dir,'/');
2803 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2804 /* If we have "/." or "/..", VMSify it and let the VMS code
2805 * below expand it, rather than repeating the code to handle
2806 * relative components of a filespec here */
2808 if (*(cp1+2) == '.') cp1++;
2809 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2810 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2811 if (strchr(vmsdir,'/') != NULL) {
2812 /* If do_tovmsspec() returned it, it must have VMS syntax
2813 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2814 * the time to check this here only so we avoid a recursion
2815 * loop; otherwise, gigo.
2817 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2819 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2820 return do_tounixspec(trndir,buf,ts);
2823 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2824 lastdir = strrchr(dir,'/');
2826 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2827 /* Ditto for specs that end in an MFD -- let the VMS code
2828 * figure out whether it's a real device or a rooted logical. */
2829 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2830 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2831 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2832 return do_tounixspec(trndir,buf,ts);
2835 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2836 !(lastdir = cp1 = strrchr(dir,']')) &&
2837 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2838 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2840 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2841 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2842 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2843 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2844 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2845 (ver || *cp3)))))) {
2847 set_vaxc_errno(RMS$_DIR);
2853 /* If we lead off with a device or rooted logical, add the MFD
2854 if we're specifying a top-level directory. */
2855 if (lastdir && *dir == '/') {
2857 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2864 retlen = dirlen + (addmfd ? 13 : 6);
2865 if (buf) retspec = buf;
2866 else if (ts) New(1309,retspec,retlen+1,char);
2867 else retspec = __fileify_retbuf;
2869 dirlen = lastdir - dir;
2870 memcpy(retspec,dir,dirlen);
2871 strcpy(&retspec[dirlen],"/000000");
2872 strcpy(&retspec[dirlen+7],lastdir);
2875 memcpy(retspec,dir,dirlen);
2876 retspec[dirlen] = '\0';
2878 /* We've picked up everything up to the directory file name.
2879 Now just add the type and version, and we're set. */
2880 strcat(retspec,".dir;1");
2883 else { /* VMS-style directory spec */
2884 char esa[NAM$C_MAXRSS+1], term, *cp;
2885 unsigned long int sts, cmplen, haslower = 0;
2886 struct FAB dirfab = cc$rms_fab;
2887 struct NAM savnam, dirnam = cc$rms_nam;
2889 dirfab.fab$b_fns = strlen(dir);
2890 dirfab.fab$l_fna = dir;
2891 dirfab.fab$l_nam = &dirnam;
2892 dirfab.fab$l_dna = ".DIR;1";
2893 dirfab.fab$b_dns = 6;
2894 dirnam.nam$b_ess = NAM$C_MAXRSS;
2895 dirnam.nam$l_esa = esa;
2897 for (cp = dir; *cp; cp++)
2898 if (islower(*cp)) { haslower = 1; break; }
2899 if (!((sts = sys$parse(&dirfab))&1)) {
2900 if (dirfab.fab$l_sts == RMS$_DIR) {
2901 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2902 sts = sys$parse(&dirfab) & 1;
2906 set_vaxc_errno(dirfab.fab$l_sts);
2912 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2913 /* Yes; fake the fnb bits so we'll check type below */
2914 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2916 else { /* No; just work with potential name */
2917 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2919 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2920 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2921 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2926 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2927 cp1 = strchr(esa,']');
2928 if (!cp1) cp1 = strchr(esa,'>');
2929 if (cp1) { /* Should always be true */
2930 dirnam.nam$b_esl -= cp1 - esa - 1;
2931 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2934 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2935 /* Yep; check version while we're at it, if it's there. */
2936 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2937 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2938 /* Something other than .DIR[;1]. Bzzt. */
2939 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2940 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2942 set_vaxc_errno(RMS$_DIR);
2946 esa[dirnam.nam$b_esl] = '\0';
2947 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2948 /* They provided at least the name; we added the type, if necessary, */
2949 if (buf) retspec = buf; /* in sys$parse() */
2950 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2951 else retspec = __fileify_retbuf;
2952 strcpy(retspec,esa);
2953 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2954 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2957 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2958 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2960 dirnam.nam$b_esl -= 9;
2962 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2963 if (cp1 == NULL) { /* should never happen */
2964 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2965 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2970 retlen = strlen(esa);
2971 if ((cp1 = strrchr(esa,'.')) != NULL) {
2972 /* There's more than one directory in the path. Just roll back. */
2974 if (buf) retspec = buf;
2975 else if (ts) New(1311,retspec,retlen+7,char);
2976 else retspec = __fileify_retbuf;
2977 strcpy(retspec,esa);
2980 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2981 /* Go back and expand rooted logical name */
2982 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2983 if (!(sys$parse(&dirfab) & 1)) {
2984 dirnam.nam$l_rlf = NULL;
2985 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2987 set_vaxc_errno(dirfab.fab$l_sts);
2990 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2991 if (buf) retspec = buf;
2992 else if (ts) New(1312,retspec,retlen+16,char);
2993 else retspec = __fileify_retbuf;
2994 cp1 = strstr(esa,"][");
2995 if (!cp1) cp1 = strstr(esa,"]<");
2997 memcpy(retspec,esa,dirlen);
2998 if (!strncmp(cp1+2,"000000]",7)) {
2999 retspec[dirlen-1] = '\0';
3000 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3001 if (*cp1 == '.') *cp1 = ']';
3003 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3004 memcpy(cp1+1,"000000]",7);
3008 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3009 retspec[retlen] = '\0';
3010 /* Convert last '.' to ']' */
3011 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3012 if (*cp1 == '.') *cp1 = ']';
3014 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3015 memcpy(cp1+1,"000000]",7);
3019 else { /* This is a top-level dir. Add the MFD to the path. */
3020 if (buf) retspec = buf;
3021 else if (ts) New(1312,retspec,retlen+16,char);
3022 else retspec = __fileify_retbuf;
3025 while (*cp1 != ':') *(cp2++) = *(cp1++);
3026 strcpy(cp2,":[000000]");
3031 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3032 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3033 /* We've set up the string up through the filename. Add the
3034 type and version, and we're done. */
3035 strcat(retspec,".DIR;1");
3037 /* $PARSE may have upcased filespec, so convert output to lower
3038 * case if input contained any lowercase characters. */
3039 if (haslower) __mystrtolower(retspec);
3042 } /* end of do_fileify_dirspec() */
3044 /* External entry points */
3045 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3046 { return do_fileify_dirspec(dir,buf,0); }
3047 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3048 { return do_fileify_dirspec(dir,buf,1); }
3050 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3051 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3053 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3054 unsigned long int retlen;
3055 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3057 if (!dir || !*dir) {
3058 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3061 if (*dir) strcpy(trndir,dir);
3062 else getcwd(trndir,sizeof trndir - 1);
3064 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3065 && my_trnlnm(trndir,trndir,0)) {
3066 STRLEN trnlen = strlen(trndir);
3068 /* Trap simple rooted lnms, and return lnm:[000000] */
3069 if (!strcmp(trndir+trnlen-2,".]")) {
3070 if (buf) retpath = buf;
3071 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3072 else retpath = __pathify_retbuf;
3073 strcpy(retpath,dir);
3074 strcat(retpath,":[000000]");
3080 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3081 if (*dir == '.' && (*(dir+1) == '\0' ||
3082 (*(dir+1) == '.' && *(dir+2) == '\0')))
3083 retlen = 2 + (*(dir+1) != '\0');
3085 if ( !(cp1 = strrchr(dir,'/')) &&
3086 !(cp1 = strrchr(dir,']')) &&
3087 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3088 if ((cp2 = strchr(cp1,'.')) != NULL &&
3089 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3090 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3091 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3092 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3094 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3095 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3096 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3097 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3098 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3099 (ver || *cp3)))))) {
3101 set_vaxc_errno(RMS$_DIR);
3104 retlen = cp2 - dir + 1;
3106 else { /* No file type present. Treat the filename as a directory. */
3107 retlen = strlen(dir) + 1;
3110 if (buf) retpath = buf;
3111 else if (ts) New(1313,retpath,retlen+1,char);
3112 else retpath = __pathify_retbuf;
3113 strncpy(retpath,dir,retlen-1);
3114 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3115 retpath[retlen-1] = '/'; /* with '/', add it. */
3116 retpath[retlen] = '\0';
3118 else retpath[retlen-1] = '\0';
3120 else { /* VMS-style directory spec */
3121 char esa[NAM$C_MAXRSS+1], *cp;
3122 unsigned long int sts, cmplen, haslower;
3123 struct FAB dirfab = cc$rms_fab;
3124 struct NAM savnam, dirnam = cc$rms_nam;
3126 /* If we've got an explicit filename, we can just shuffle the string. */
3127 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3128 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3129 if ((cp2 = strchr(cp1,'.')) != NULL) {
3131 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3132 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3133 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3134 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3135 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3136 (ver || *cp3)))))) {
3138 set_vaxc_errno(RMS$_DIR);
3142 else { /* No file type, so just draw name into directory part */
3143 for (cp2 = cp1; *cp2; cp2++) ;
3146 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3148 /* We've now got a VMS 'path'; fall through */
3150 dirfab.fab$b_fns = strlen(dir);
3151 dirfab.fab$l_fna = dir;
3152 if (dir[dirfab.fab$b_fns-1] == ']' ||
3153 dir[dirfab.fab$b_fns-1] == '>' ||
3154 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3155 if (buf) retpath = buf;
3156 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3157 else retpath = __pathify_retbuf;
3158 strcpy(retpath,dir);
3161 dirfab.fab$l_dna = ".DIR;1";
3162 dirfab.fab$b_dns = 6;
3163 dirfab.fab$l_nam = &dirnam;
3164 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3165 dirnam.nam$l_esa = esa;
3167 for (cp = dir; *cp; cp++)
3168 if (islower(*cp)) { haslower = 1; break; }
3170 if (!(sts = (sys$parse(&dirfab)&1))) {
3171 if (dirfab.fab$l_sts == RMS$_DIR) {
3172 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3173 sts = sys$parse(&dirfab) & 1;
3177 set_vaxc_errno(dirfab.fab$l_sts);
3183 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3184 if (dirfab.fab$l_sts != RMS$_FNF) {
3185 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3186 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3188 set_vaxc_errno(dirfab.fab$l_sts);
3191 dirnam = savnam; /* No; just work with potential name */
3194 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3195 /* Yep; check version while we're at it, if it's there. */
3196 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3197 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3198 /* Something other than .DIR[;1]. Bzzt. */
3199 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3200 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3202 set_vaxc_errno(RMS$_DIR);
3206 /* OK, the type was fine. Now pull any file name into the
3208 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3210 cp1 = strrchr(esa,'>');
3211 *dirnam.nam$l_type = '>';
3214 *(dirnam.nam$l_type + 1) = '\0';
3215 retlen = dirnam.nam$l_type - esa + 2;
3216 if (buf) retpath = buf;
3217 else if (ts) New(1314,retpath,retlen,char);
3218 else retpath = __pathify_retbuf;
3219 strcpy(retpath,esa);
3220 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3221 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3222 /* $PARSE may have upcased filespec, so convert output to lower
3223 * case if input contained any lowercase characters. */
3224 if (haslower) __mystrtolower(retpath);
3228 } /* end of do_pathify_dirspec() */
3230 /* External entry points */
3231 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3232 { return do_pathify_dirspec(dir,buf,0); }
3233 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3234 { return do_pathify_dirspec(dir,buf,1); }
3236 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3237 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3239 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3240 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3241 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3243 if (spec == NULL) return NULL;
3244 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3245 if (buf) rslt = buf;
3247 retlen = strlen(spec);
3248 cp1 = strchr(spec,'[');
3249 if (!cp1) cp1 = strchr(spec,'<');
3251 for (cp1++; *cp1; cp1++) {
3252 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3253 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3254 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3257 New(1315,rslt,retlen+2+2*expand,char);
3259 else rslt = __tounixspec_retbuf;
3260 if (strchr(spec,'/') != NULL) {
3267 dirend = strrchr(spec,']');
3268 if (dirend == NULL) dirend = strrchr(spec,'>');
3269 if (dirend == NULL) dirend = strchr(spec,':');
3270 if (dirend == NULL) {
3274 if (*cp2 != '[' && *cp2 != '<') {
3277 else { /* the VMS spec begins with directories */
3279 if (*cp2 == ']' || *cp2 == '>') {
3280 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3283 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3284 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3285 if (ts) Safefree(rslt);
3290 while (*cp3 != ':' && *cp3) cp3++;
3292 if (strchr(cp3,']') != NULL) break;
3293 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3295 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3296 retlen = devlen + dirlen;
3297 Renew(rslt,retlen+1+2*expand,char);
3303 *(cp1++) = *(cp3++);
3304 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3308 else if ( *cp2 == '.') {
3309 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3310 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3316 for (; cp2 <= dirend; cp2++) {
3319 if (*(cp2+1) == '[') cp2++;
3321 else if (*cp2 == ']' || *cp2 == '>') {
3322 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3324 else if (*cp2 == '.') {
3326 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3327 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3328 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3329 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3330 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3332 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3333 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3337 else if (*cp2 == '-') {
3338 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3339 while (*cp2 == '-') {
3341 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3343 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3344 if (ts) Safefree(rslt); /* filespecs like */
3345 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3349 else *(cp1++) = *cp2;
3351 else *(cp1++) = *cp2;
3353 while (*cp2) *(cp1++) = *(cp2++);
3358 } /* end of do_tounixspec() */
3360 /* External entry points */
3361 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3362 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3364 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3365 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3366 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3367 char *rslt, *dirend;
3368 register char *cp1, *cp2;
3369 unsigned long int infront = 0, hasdir = 1;
3371 if (path == NULL) return NULL;
3372 if (buf) rslt = buf;
3373 else if (ts) New(1316,rslt,strlen(path)+9,char);
3374 else rslt = __tovmsspec_retbuf;
3375 if (strpbrk(path,"]:>") ||
3376 (dirend = strrchr(path,'/')) == NULL) {
3377 if (path[0] == '.') {
3378 if (path[1] == '\0') strcpy(rslt,"[]");
3379 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3380 else strcpy(rslt,path); /* probably garbage */
3382 else strcpy(rslt,path);
3385 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3386 if (!*(dirend+2)) dirend +=2;
3387 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3388 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3393 char trndev[NAM$C_MAXRSS+1];
3397 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3399 if (!buf & ts) Renew(rslt,18,char);
3400 strcpy(rslt,"sys$disk:[000000]");
3403 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3405 islnm = my_trnlnm(rslt,trndev,0);
3406 trnend = islnm ? strlen(trndev) - 1 : 0;
3407 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3408 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3409 /* If the first element of the path is a logical name, determine
3410 * whether it has to be translated so we can add more directories. */
3411 if (!islnm || rooted) {
3414 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3418 if (cp2 != dirend) {
3419 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3420 strcpy(rslt,trndev);
3421 cp1 = rslt + trnend;
3434 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3435 cp2 += 2; /* skip over "./" - it's redundant */
3436 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3438 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3439 *(cp1++) = '-'; /* "../" --> "-" */
3442 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3443 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3444 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3445 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3448 if (cp2 > dirend) cp2 = dirend;
3450 else *(cp1++) = '.';
3452 for (; cp2 < dirend; cp2++) {
3454 if (*(cp2-1) == '/') continue;
3455 if (*(cp1-1) != '.') *(cp1++) = '.';
3458 else if (!infront && *cp2 == '.') {
3459 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3460 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3461 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3462 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3463 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3464 else { /* back up over previous directory name */
3466 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3467 if (*(cp1-1) == '[') {
3468 memcpy(cp1,"000000.",7);
3473 if (cp2 == dirend) break;
3475 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3476 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3477 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3478 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3480 *(cp1++) = '.'; /* Simulate trailing '/' */
3481 cp2 += 2; /* for loop will incr this to == dirend */
3483 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3485 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3488 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3489 if (*cp2 == '.') *(cp1++) = '_';
3490 else *(cp1++) = *cp2;
3494 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3495 if (hasdir) *(cp1++) = ']';
3496 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3497 while (*cp2) *(cp1++) = *(cp2++);
3502 } /* end of do_tovmsspec() */
3504 /* External entry points */
3505 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3506 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3508 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3509 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3510 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3512 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3514 if (path == NULL) return NULL;
3515 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3516 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3517 if (buf) return buf;
3519 vmslen = strlen(vmsified);
3520 New(1317,cp,vmslen+1,char);
3521 memcpy(cp,vmsified,vmslen);
3526 strcpy(__tovmspath_retbuf,vmsified);
3527 return __tovmspath_retbuf;
3530 } /* end of do_tovmspath() */
3532 /* External entry points */
3533 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3534 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3537 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3538 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3539 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3541 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3543 if (path == NULL) return NULL;
3544 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3545 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3546 if (buf) return buf;
3548 unixlen = strlen(unixified);
3549 New(1317,cp,unixlen+1,char);
3550 memcpy(cp,unixified,unixlen);
3555 strcpy(__tounixpath_retbuf,unixified);
3556 return __tounixpath_retbuf;
3559 } /* end of do_tounixpath() */
3561 /* External entry points */
3562 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3563 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3566 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3568 *****************************************************************************
3570 * Copyright (C) 1989-1994 by *
3571 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3573 * Permission is hereby granted for the reproduction of this software, *
3574 * on condition that this copyright notice is included in the reproduction, *
3575 * and that such reproduction is not for purposes of profit or material *
3578 * 27-Aug-1994 Modified for inclusion in perl5 *
3579 * by Charles Bailey bailey@newman.upenn.edu *
3580 *****************************************************************************
3584 * getredirection() is intended to aid in porting C programs
3585 * to VMS (Vax-11 C). The native VMS environment does not support
3586 * '>' and '<' I/O redirection, or command line wild card expansion,
3587 * or a command line pipe mechanism using the '|' AND background
3588 * command execution '&'. All of these capabilities are provided to any
3589 * C program which calls this procedure as the first thing in the
3591 * The piping mechanism will probably work with almost any 'filter' type
3592 * of program. With suitable modification, it may useful for other
3593 * portability problems as well.
3595 * Author: Mark Pizzolato mark@infocomm.com
3599 struct list_item *next;
3603 static void add_item(struct list_item **head,
3604 struct list_item **tail,
3608 static void mp_expand_wild_cards(pTHX_ char *item,
3609 struct list_item **head,
3610 struct list_item **tail,
3613 static int background_process(int argc, char **argv);
3615 static void pipe_and_fork(pTHX_ char **cmargv);
3617 /*{{{ void getredirection(int *ac, char ***av)*/
3619 mp_getredirection(pTHX_ int *ac, char ***av)
3621 * Process vms redirection arg's. Exit if any error is seen.
3622 * If getredirection() processes an argument, it is erased
3623 * from the vector. getredirection() returns a new argc and argv value.
3624 * In the event that a background command is requested (by a trailing "&"),
3625 * this routine creates a background subprocess, and simply exits the program.
3627 * Warning: do not try to simplify the code for vms. The code
3628 * presupposes that getredirection() is called before any data is
3629 * read from stdin or written to stdout.
3631 * Normal usage is as follows:
3637 * getredirection(&argc, &argv);
3641 int argc = *ac; /* Argument Count */
3642 char **argv = *av; /* Argument Vector */
3643 char *ap; /* Argument pointer */
3644 int j; /* argv[] index */
3645 int item_count = 0; /* Count of Items in List */
3646 struct list_item *list_head = 0; /* First Item in List */
3647 struct list_item *list_tail; /* Last Item in List */
3648 char *in = NULL; /* Input File Name */
3649 char *out = NULL; /* Output File Name */
3650 char *outmode = "w"; /* Mode to Open Output File */
3651 char *err = NULL; /* Error File Name */
3652 char *errmode = "w"; /* Mode to Open Error File */
3653 int cmargc = 0; /* Piped Command Arg Count */
3654 char **cmargv = NULL;/* Piped Command Arg Vector */
3657 * First handle the case where the last thing on the line ends with
3658 * a '&'. This indicates the desire for the command to be run in a
3659 * subprocess, so we satisfy that desire.
3662 if (0 == strcmp("&", ap))
3663 exit(background_process(--argc, argv));
3664 if (*ap && '&' == ap[strlen(ap)-1])
3666 ap[strlen(ap)-1] = '\0';
3667 exit(background_process(argc, argv));
3670 * Now we handle the general redirection cases that involve '>', '>>',
3671 * '<', and pipes '|'.
3673 for (j = 0; j < argc; ++j)
3675 if (0 == strcmp("<", argv[j]))
3679 fprintf(stderr,"No input file after < on command line");
3680 exit(LIB$_WRONUMARG);
3685 if ('<' == *(ap = argv[j]))
3690 if (0 == strcmp(">", ap))
3694 fprintf(stderr,"No output file after > on command line");
3695 exit(LIB$_WRONUMARG);
3714 fprintf(stderr,"No output file after > or >> on command line");
3715 exit(LIB$_WRONUMARG);
3719 if (('2' == *ap) && ('>' == ap[1]))
3736 fprintf(stderr,"No output file after 2> or 2>> on command line");
3737 exit(LIB$_WRONUMARG);
3741 if (0 == strcmp("|", argv[j]))
3745 fprintf(stderr,"No command into which to pipe on command line");
3746 exit(LIB$_WRONUMARG);
3748 cmargc = argc-(j+1);
3749 cmargv = &argv[j+1];
3753 if ('|' == *(ap = argv[j]))
3761 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3764 * Allocate and fill in the new argument vector, Some Unix's terminate
3765 * the list with an extra null pointer.
3767 New(1302, argv, item_count+1, char *);
3769 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3770 argv[j] = list_head->value;
3776 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3777 exit(LIB$_INVARGORD);
3779 pipe_and_fork(aTHX_ cmargv);
3782 /* Check for input from a pipe (mailbox) */
3784 if (in == NULL && 1 == isapipe(0))
3786 char mbxname[L_tmpnam];
3788 long int dvi_item = DVI$_DEVBUFSIZ;
3789 $DESCRIPTOR(mbxnam, "");
3790 $DESCRIPTOR(mbxdevnam, "");
3792 /* Input from a pipe, reopen it in binary mode to disable */
3793 /* carriage control processing. */
3795 fgetname(stdin, mbxname);
3796 mbxnam.dsc$a_pointer = mbxname;
3797 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3798 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3799 mbxdevnam.dsc$a_pointer = mbxname;
3800 mbxdevnam.dsc$w_length = sizeof(mbxname);
3801 dvi_item = DVI$_DEVNAM;
3802 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3803 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3806 freopen(mbxname, "rb", stdin);
3809 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3813 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3815 fprintf(stderr,"Can't open input file %s as stdin",in);
3818 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3820 fprintf(stderr,"Can't open output file %s as stdout",out);
3823 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3826 if (strcmp(err,"&1") == 0) {
3827 dup2(fileno(stdout), fileno(stderr));
3828 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3831 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3833 fprintf(stderr,"Can't open error file %s as stderr",err);
3837 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3841 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3844 #ifdef ARGPROC_DEBUG
3845 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3846 for (j = 0; j < *ac; ++j)
3847 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3849 /* Clear errors we may have hit expanding wildcards, so they don't
3850 show up in Perl's $! later */
3851 set_errno(0); set_vaxc_errno(1);
3852 } /* end of getredirection() */
3855 static void add_item(struct list_item **head,
3856 struct list_item **tail,
3862 New(1303,*head,1,struct list_item);
3866 New(1304,(*tail)->next,1,struct list_item);
3867 *tail = (*tail)->next;
3869 (*tail)->value = value;
3873 static void mp_expand_wild_cards(pTHX_ char *item,
3874 struct list_item **head,
3875 struct list_item **tail,
3879 unsigned long int context = 0;
3885 char vmsspec[NAM$C_MAXRSS+1];
3886 $DESCRIPTOR(filespec, "");
3887 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3888 $DESCRIPTOR(resultspec, "");
3889 unsigned long int zero = 0, sts;
3891 for (cp = item; *cp; cp++) {
3892 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3893 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3895 if (!*cp || isspace(*cp))
3897 add_item(head, tail, item, count);
3900 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3901 resultspec.dsc$b_class = DSC$K_CLASS_D;
3902 resultspec.dsc$a_pointer = NULL;
3903 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3904 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3905 if (!isunix || !filespec.dsc$a_pointer)
3906 filespec.dsc$a_pointer = item;
3907 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3909 * Only return version specs, if the caller specified a version
3911 had_version = strchr(item, ';');
3913 * Only return device and directory specs, if the caller specifed either.
3915 had_device = strchr(item, ':');
3916 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3918 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3919 &defaultspec, 0, 0, &zero))))
3924 New(1305,string,resultspec.dsc$w_length+1,char);
3925 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3926 string[resultspec.dsc$w_length] = '\0';
3927 if (NULL == had_version)
3928 *((char *)strrchr(string, ';')) = '\0';
3929 if ((!had_directory) && (had_device == NULL))
3931 if (NULL == (devdir = strrchr(string, ']')))
3932 devdir = strrchr(string, '>');
3933 strcpy(string, devdir + 1);
3936 * Be consistent with what the C RTL has already done to the rest of
3937 * the argv items and lowercase all of these names.
3939 for (c = string; *c; ++c)
3942 if (isunix) trim_unixpath(string,item,1);
3943 add_item(head, tail, string, count);
3946 if (sts != RMS$_NMF)
3948 set_vaxc_errno(sts);
3951 case RMS$_FNF: case RMS$_DNF:
3952 set_errno(ENOENT); break;
3954 set_errno(ENOTDIR); break;
3956 set_errno(ENODEV); break;
3957 case RMS$_FNM: case RMS$_SYN:
3958 set_errno(EINVAL); break;
3960 set_errno(EACCES); break;
3962 _ckvmssts_noperl(sts);
3966 add_item(head, tail, item, count);
3967 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3968 _ckvmssts_noperl(lib$find_file_end(&context));
3971 static int child_st[2];/* Event Flag set when child process completes */
3973 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3975 static unsigned long int exit_handler(int *status)
3979 if (0 == child_st[0])
3981 #ifdef ARGPROC_DEBUG
3982 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3984 fflush(stdout); /* Have to flush pipe for binary data to */
3985 /* terminate properly -- <tp@mccall.com> */
3986 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3987 sys$dassgn(child_chan);
3989 sys$synch(0, child_st);
3994 static void sig_child(int chan)
3996 #ifdef ARGPROC_DEBUG
3997 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3999 if (child_st[0] == 0)
4003 static struct exit_control_block exit_block =
4008 &exit_block.exit_status,
4012 static void pipe_and_fork(pTHX_ char **cmargv)
4015 $DESCRIPTOR(cmddsc, "");
4016 static char mbxname[64];
4017 $DESCRIPTOR(mbxdsc, mbxname);
4019 unsigned long int zero = 0, one = 1;
4021 strcpy(subcmd, cmargv[0]);
4022 for (j = 1; NULL != cmargv[j]; ++j)
4024 strcat(subcmd, " \"");
4025 strcat(subcmd, cmargv[j]);
4026 strcat(subcmd, "\"");
4028 cmddsc.dsc$a_pointer = subcmd;
4029 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
4031 create_mbx(aTHX_ &child_chan,&mbxdsc);
4032 #ifdef ARGPROC_DEBUG
4033 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
4034 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
4036 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
4037 0, &pid, child_st, &zero, sig_child,
4039 #ifdef ARGPROC_DEBUG
4040 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
4042 sys$dclexh(&exit_block);
4043 if (NULL == freopen(mbxname, "wb", stdout))
4045 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
4049 static int background_process(int argc, char **argv)
4051 char command[2048] = "$";
4052 $DESCRIPTOR(value, "");
4053 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4054 static $DESCRIPTOR(null, "NLA0:");
4055 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4057 $DESCRIPTOR(pidstr, "");
4059 unsigned long int flags = 17, one = 1, retsts;
4061 strcat(command, argv[0]);
4064 strcat(command, " \"");
4065 strcat(command, *(++argv));
4066 strcat(command, "\"");
4068 value.dsc$a_pointer = command;
4069 value.dsc$w_length = strlen(value.dsc$a_pointer);
4070 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4071 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4072 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4073 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4076 _ckvmssts_noperl(retsts);
4078 #ifdef ARGPROC_DEBUG
4079 PerlIO_printf(Perl_debug_log, "%s\n", command);
4081 sprintf(pidstring, "%08X", pid);
4082 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4083 pidstr.dsc$a_pointer = pidstring;
4084 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4085 lib$set_symbol(&pidsymbol, &pidstr);
4089 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4092 /* OS-specific initialization at image activation (not thread startup) */
4093 /* Older VAXC header files lack these constants */
4094 #ifndef JPI$_RIGHTS_SIZE
4095 # define JPI$_RIGHTS_SIZE 817
4097 #ifndef KGB$M_SUBSYSTEM
4098 # define KGB$M_SUBSYSTEM 0x8
4101 /*{{{void vms_image_init(int *, char ***)*/
4103 vms_image_init(int *argcp, char ***argvp)
4105 char eqv[LNM$C_NAMLENGTH+1] = "";
4106 unsigned int len, tabct = 8, tabidx = 0;
4107 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4108 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4109 unsigned short int dummy, rlen;
4110 struct dsc$descriptor_s **tabvec;
4111 #if defined(PERL_IMPLICIT_CONTEXT)
4114 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4115 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4116 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4119 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4120 _ckvmssts_noperl(iosb[0]);
4121 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4122 if (iprv[i]) { /* Running image installed with privs? */
4123 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4128 /* Rights identifiers might trigger tainting as well. */
4129 if (!will_taint && (rlen || rsz)) {
4130 while (rlen < rsz) {
4131 /* We didn't get all the identifiers on the first pass. Allocate a
4132 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4133 * were needed to hold all identifiers at time of last call; we'll
4134 * allocate that many unsigned long ints), and go back and get 'em.
4135 * If it gave us less than it wanted to despite ample buffer space,
4136 * something's broken. Is your system missing a system identifier?
4138 if (rsz <= jpilist[1].buflen) {
4139 /* Perl_croak accvios when used this early in startup. */
4140 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4141 rsz, (unsigned long) jpilist[1].buflen,
4142 "Check your rights database for corruption.\n");
4145 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4146 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4147 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4148 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4149 _ckvmssts_noperl(iosb[0]);
4151 mask = jpilist[1].bufadr;
4152 /* Check attribute flags for each identifier (2nd longword); protected
4153 * subsystem identifiers trigger tainting.
4155 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4156 if (mask[i] & KGB$M_SUBSYSTEM) {
4161 if (mask != rlst) Safefree(mask);
4163 /* We need to use this hack to tell Perl it should run with tainting,
4164 * since its tainting flag may be part of the PL_curinterp struct, which
4165 * hasn't been allocated when vms_image_init() is called.
4169 New(1320,newap,*argcp+2,char **);
4170 newap[0] = argvp[0];
4172 Copy(argvp[1],newap[2],*argcp-1,char **);
4173 /* We orphan the old argv, since we don't know where it's come from,
4174 * so we don't know how to free it.
4176 *argcp++; argvp = newap;
4178 else { /* Did user explicitly request tainting? */
4180 char *cp, **av = *argvp;
4181 for (i = 1; i < *argcp; i++) {
4182 if (*av[i] != '-') break;
4183 for (cp = av[i]+1; *cp; cp++) {
4184 if (*cp == 'T') { will_taint = 1; break; }
4185 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4186 strchr("DFIiMmx",*cp)) break;
4188 if (will_taint) break;
4193 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4195 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4196 else if (tabidx >= tabct) {
4198 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4200 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4201 tabvec[tabidx]->dsc$w_length = 0;
4202 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4203 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4204 tabvec[tabidx]->dsc$a_pointer = NULL;
4205 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4207 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4209 getredirection(argcp,argvp);
4210 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4212 # include <reentrancy.h>
4213 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4222 * Trim Unix-style prefix off filespec, so it looks like what a shell
4223 * glob expansion would return (i.e. from specified prefix on, not
4224 * full path). Note that returned filespec is Unix-style, regardless
4225 * of whether input filespec was VMS-style or Unix-style.
4227 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4228 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4229 * vector of options; at present, only bit 0 is used, and if set tells
4230 * trim unixpath to try the current default directory as a prefix when
4231 * presented with a possibly ambiguous ... wildcard.
4233 * Returns !=0 on success, with trimmed filespec replacing contents of
4234 * fspec, and 0 on failure, with contents of fpsec unchanged.
4236 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4238 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4240 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4241 *template, *base, *end, *cp1, *cp2;
4242 register int tmplen, reslen = 0, dirs = 0;
4244 if (!wildspec || !fspec) return 0;
4245 if (strpbrk(wildspec,"]>:") != NULL) {
4246 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4247 else template = unixwild;
4249 else template = wildspec;
4250 if (strpbrk(fspec,"]>:") != NULL) {
4251 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4252 else base = unixified;
4253 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4254 * check to see that final result fits into (isn't longer than) fspec */
4255 reslen = strlen(fspec);
4259 /* No prefix or absolute path on wildcard, so nothing to remove */
4260 if (!*template || *template == '/') {
4261 if (base == fspec) return 1;
4262 tmplen = strlen(unixified);
4263 if (tmplen > reslen) return 0; /* not enough space */
4264 /* Copy unixified resultant, including trailing NUL */
4265 memmove(fspec,unixified,tmplen+1);
4269 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4270 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4271 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4272 for (cp1 = end ;cp1 >= base; cp1--)
4273 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4275 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4279 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4280 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4281 int ells = 1, totells, segdirs, match;
4282 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4283 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4285 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4287 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4288 if (ellipsis == template && opts & 1) {
4289 /* Template begins with an ellipsis. Since we can't tell how many
4290 * directory names at the front of the resultant to keep for an
4291 * arbitrary starting point, we arbitrarily choose the current
4292 * default directory as a starting point. If it's there as a prefix,
4293 * clip it off. If not, fall through and act as if the leading
4294 * ellipsis weren't there (i.e. return shortest possible path that
4295 * could match template).
4297 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4298 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4299 if (_tolower(*cp1) != _tolower(*cp2)) break;
4300 segdirs = dirs - totells; /* Min # of dirs we must have left */
4301 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4302 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4303 memcpy(fspec,cp2+1,end - cp2);
4307 /* First off, back up over constant elements at end of path */
4309 for (front = end ; front >= base; front--)
4310 if (*front == '/' && !dirs--) { front++; break; }
4312 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4313 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4314 if (cp1 != '\0') return 0; /* Path too long. */
4316 *cp2 = '\0'; /* Pick up with memcpy later */
4317 lcfront = lcres + (front - base);
4318 /* Now skip over each ellipsis and try to match the path in front of it. */
4320 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4321 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4322 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4323 if (cp1 < template) break; /* template started with an ellipsis */
4324 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4325 ellipsis = cp1; continue;
4327 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4329 for (segdirs = 0, cp2 = tpl;
4330 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4332 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4333 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4334 if (*cp2 == '/') segdirs++;
4336 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4337 /* Back up at least as many dirs as in template before matching */
4338 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4339 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4340 for (match = 0; cp1 > lcres;) {
4341 resdsc.dsc$a_pointer = cp1;
4342 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4344 if (match == 1) lcfront = cp1;
4346 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4348 if (!match) return 0; /* Can't find prefix ??? */
4349 if (match > 1 && opts & 1) {
4350 /* This ... wildcard could cover more than one set of dirs (i.e.
4351 * a set of similar dir names is repeated). If the template
4352 * contains more than 1 ..., upstream elements could resolve the
4353 * ambiguity, but it's not worth a full backtracking setup here.
4354 * As a quick heuristic, clip off the current default directory
4355 * if it's present to find the trimmed spec, else use the
4356 * shortest string that this ... could cover.
4358 char def[NAM$C_MAXRSS+1], *st;
4360 if (getcwd(def, sizeof def,0) == NULL) return 0;
4361 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4362 if (_tolower(*cp1) != _tolower(*cp2)) break;
4363 segdirs = dirs - totells; /* Min # of dirs we must have left */
4364 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4365 if (*cp1 == '\0' && *cp2 == '/') {
4366 memcpy(fspec,cp2+1,end - cp2);
4369 /* Nope -- stick with lcfront from above and keep going. */
4372 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4377 } /* end of trim_unixpath() */
4382 * VMS readdir() routines.
4383 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4385 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4386 * Minor modifications to original routines.
4389 /* Number of elements in vms_versions array */
4390 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4393 * Open a directory, return a handle for later use.
4395 /*{{{ DIR *opendir(char*name) */
4397 Perl_opendir(pTHX_ char *name)
4400 char dir[NAM$C_MAXRSS+1];
4403 if (do_tovmspath(name,dir,0) == NULL) {
4406 if (flex_stat(dir,&sb) == -1) return NULL;
4407 if (!S_ISDIR(sb.st_mode)) {
4408 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4411 if (!cando_by_name(S_IRUSR,0,dir)) {
4412 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4415 /* Get memory for the handle, and the pattern. */
4417 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4419 /* Fill in the fields; mainly playing with the descriptor. */
4420 (void)sprintf(dd->pattern, "%s*.*",dir);
4423 dd->vms_wantversions = 0;
4424 dd->pat.dsc$a_pointer = dd->pattern;
4425 dd->pat.dsc$w_length = strlen(dd->pattern);
4426 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4427 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4430 } /* end of opendir() */
4434 * Set the flag to indicate we want versions or not.
4436 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4438 vmsreaddirversions(DIR *dd, int flag)
4440 dd->vms_wantversions = flag;
4445 * Free up an opened directory.
4447 /*{{{ void closedir(DIR *dd)*/
4451 (void)lib$find_file_end(&dd->context);
4452 Safefree(dd->pattern);
4453 Safefree((char *)dd);
4458 * Collect all the version numbers for the current file.
4461 collectversions(pTHX_ DIR *dd)
4463 struct dsc$descriptor_s pat;
4464 struct dsc$descriptor_s res;
4466 char *p, *text, buff[sizeof dd->entry.d_name];
4468 unsigned long context, tmpsts;
4470 /* Convenient shorthand. */
4473 /* Add the version wildcard, ignoring the "*.*" put on before */
4474 i = strlen(dd->pattern);
4475 New(1308,text,i + e->d_namlen + 3,char);
4476 (void)strcpy(text, dd->pattern);
4477 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4479 /* Set up the pattern descriptor. */
4480 pat.dsc$a_pointer = text;
4481 pat.dsc$w_length = i + e->d_namlen - 1;
4482 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4483 pat.dsc$b_class = DSC$K_CLASS_S;
4485 /* Set up result descriptor. */
4486 res.dsc$a_pointer = buff;
4487 res.dsc$w_length = sizeof buff - 2;
4488 res.dsc$b_dtype = DSC$K_DTYPE_T;
4489 res.dsc$b_class = DSC$K_CLASS_S;
4491 /* Read files, collecting versions. */
4492 for (context = 0, e->vms_verscount = 0;
4493 e->vms_verscount < VERSIZE(e);
4494 e->vms_verscount++) {
4495 tmpsts = lib$find_file(&pat, &res, &context);
4496 if (tmpsts == RMS$_NMF || context == 0) break;
4498 buff[sizeof buff - 1] = '\0';
4499 if ((p = strchr(buff, ';')))
4500 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4502 e->vms_versions[e->vms_verscount] = -1;
4505 _ckvmssts(lib$find_file_end(&context));
4508 } /* end of collectversions() */
4511 * Read the next entry from the directory.
4513 /*{{{ struct dirent *readdir(DIR *dd)*/
4515 Perl_readdir(pTHX_ DIR *dd)
4517 struct dsc$descriptor_s res;
4518 char *p, buff[sizeof dd->entry.d_name];
4519 unsigned long int tmpsts;
4521 /* Set up result descriptor, and get next file. */
4522 res.dsc$a_pointer = buff;
4523 res.dsc$w_length = sizeof buff - 2;
4524 res.dsc$b_dtype = DSC$K_DTYPE_T;
4525 res.dsc$b_class = DSC$K_CLASS_S;
4526 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4527 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4528 if (!(tmpsts & 1)) {
4529 set_vaxc_errno(tmpsts);
4532 set_errno(EACCES); break;
4534 set_errno(ENODEV); break;
4536 set_errno(ENOTDIR); break;
4537 case RMS$_FNF: case RMS$_DNF:
4538 set_errno(ENOENT); break;
4545 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4546 buff[sizeof buff - 1] = '\0';
4547 for (p = buff; *p; p++) *p = _tolower(*p);
4548 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4551 /* Skip any directory component and just copy the name. */
4552 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4553 else (void)strcpy(dd->entry.d_name, buff);
4555 /* Clobber the version. */
4556 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4558 dd->entry.d_namlen = strlen(dd->entry.d_name);
4559 dd->entry.vms_verscount = 0;
4560 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4563 } /* end of readdir() */
4567 * Return something that can be used in a seekdir later.
4569 /*{{{ long telldir(DIR *dd)*/
4578 * Return to a spot where we used to be. Brute force.
4580 /*{{{ void seekdir(DIR *dd,long count)*/
4582 Perl_seekdir(pTHX_ DIR *dd, long count)
4584 int vms_wantversions;
4586 /* If we haven't done anything yet... */
4590 /* Remember some state, and clear it. */
4591 vms_wantversions = dd->vms_wantversions;
4592 dd->vms_wantversions = 0;
4593 _ckvmssts(lib$find_file_end(&dd->context));
4596 /* The increment is in readdir(). */
4597 for (dd->count = 0; dd->count < count; )
4600 dd->vms_wantversions = vms_wantversions;
4602 } /* end of seekdir() */
4605 /* VMS subprocess management
4607 * my_vfork() - just a vfork(), after setting a flag to record that
4608 * the current script is trying a Unix-style fork/exec.
4610 * vms_do_aexec() and vms_do_exec() are called in response to the
4611 * perl 'exec' function. If this follows a vfork call, then they
4612 * call out the the regular perl routines in doio.c which do an
4613 * execvp (for those who really want to try this under VMS).
4614 * Otherwise, they do exactly what the perl docs say exec should
4615 * do - terminate the current script and invoke a new command
4616 * (See below for notes on command syntax.)
4618 * do_aspawn() and do_spawn() implement the VMS side of the perl
4619 * 'system' function.
4621 * Note on command arguments to perl 'exec' and 'system': When handled
4622 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4623 * are concatenated to form a DCL command string. If the first arg
4624 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4625 * the the command string is handed off to DCL directly. Otherwise,
4626 * the first token of the command is taken as the filespec of an image
4627 * to run. The filespec is expanded using a default type of '.EXE' and
4628 * the process defaults for device, directory, etc., and if found, the resultant
4629 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4630 * the command string as parameters. This is perhaps a bit complicated,
4631 * but I hope it will form a happy medium between what VMS folks expect
4632 * from lib$spawn and what Unix folks expect from exec.
4635 static int vfork_called;
4637 /*{{{int my_vfork()*/
4648 vms_execfree(pTHX) {
4650 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4653 if (VMScmd.dsc$a_pointer) {
4654 Safefree(VMScmd.dsc$a_pointer);
4655 VMScmd.dsc$w_length = 0;
4656 VMScmd.dsc$a_pointer = Nullch;
4661 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4663 char *junk, *tmps = Nullch;
4664 register size_t cmdlen = 0;
4671 tmps = SvPV(really,rlen);
4678 for (idx++; idx <= sp; idx++) {
4680 junk = SvPVx(*idx,rlen);
4681 cmdlen += rlen ? rlen + 1 : 0;
4684 New(401,PL_Cmd,cmdlen+1,char);
4686 if (tmps && *tmps) {
4687 strcpy(PL_Cmd,tmps);
4690 else *PL_Cmd = '\0';
4691 while (++mark <= sp) {
4693 char *s = SvPVx(*mark,n_a);
4695 if (*PL_Cmd) strcat(PL_Cmd," ");
4701 } /* end of setup_argstr() */
4703 #define MAX_DCL_LINE_LENGTH 255
4705 static unsigned long int
4706 setup_cmddsc(pTHX_ char *cmd, int check_img)
4708 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4709 $DESCRIPTOR(defdsc,".EXE");
4710 $DESCRIPTOR(defdsc2,".");
4711 $DESCRIPTOR(resdsc,resspec);
4712 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4713 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4714 register char *s, *rest, *cp, *wordbreak;
4717 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4718 return CLI$_BUFOVF; /* continuation lines currently unsupported */
4720 while (*s && isspace(*s)) s++;
4722 if (*s == '@' || *s == '$') {
4723 vmsspec[0] = *s; rest = s + 1;
4724 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4726 else { cp = vmsspec; rest = s; }
4727 if (*rest == '.' || *rest == '/') {
4730 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4731 rest++, cp2++) *cp2 = *rest;
4733 if (do_tovmsspec(resspec,cp,0)) {
4736 for (cp2 = vmsspec + strlen(vmsspec);
4737 *rest && cp2 - vmsspec < sizeof vmsspec;
4738 rest++, cp2++) *cp2 = *rest;
4743 /* Intuit whether verb (first word of cmd) is a DCL command:
4744 * - if first nonspace char is '@', it's a DCL indirection
4746 * - if verb contains a filespec separator, it's not a DCL command
4747 * - if it doesn't, caller tells us whether to default to a DCL
4748 * command, or to a local image unless told it's DCL (by leading '$')
4750 if (*s == '@') isdcl = 1;
4752 register char *filespec = strpbrk(s,":<[.;");
4753 rest = wordbreak = strpbrk(s," \"\t/");
4754 if (!wordbreak) wordbreak = s + strlen(s);
4755 if (*s == '$') check_img = 0;
4756 if (filespec && (filespec < wordbreak)) isdcl = 0;
4757 else isdcl = !check_img;
4761 imgdsc.dsc$a_pointer = s;
4762 imgdsc.dsc$w_length = wordbreak - s;
4763 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4765 _ckvmssts(lib$find_file_end(&cxt));
4766 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4767 if (!(retsts & 1) && *s == '$') {
4768 _ckvmssts(lib$find_file_end(&cxt));
4769 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4770 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4772 _ckvmssts(lib$find_file_end(&cxt));
4773 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4777 _ckvmssts(lib$find_file_end(&cxt));
4782 while (*s && !isspace(*s)) s++;
4785 /* check that it's really not DCL with no file extension */
4786 fp = fopen(resspec,"r","ctx=bin,shr=get");
4788 char b[4] = {0,0,0,0};
4789 read(fileno(fp),b,4);
4790 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4793 if (check_img && isdcl) return RMS$_FNF;
4795 if (cando_by_name(S_IXUSR,0,resspec)) {
4796 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4798 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4800 strcpy(VMScmd.dsc$a_pointer,"@");
4802 strcat(VMScmd.dsc$a_pointer,resspec);
4803 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4804 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4805 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4807 else retsts = RMS$_PRV;
4810 /* It's either a DCL command or we couldn't find a suitable image */
4811 VMScmd.dsc$w_length = strlen(cmd);
4812 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4813 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4814 if (!(retsts & 1)) {
4815 /* just hand off status values likely to be due to user error */
4816 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4817 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4818 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4819 else { _ckvmssts(retsts); }
4822 return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4824 } /* end of setup_cmddsc() */
4827 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4829 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4832 if (vfork_called) { /* this follows a vfork - act Unixish */
4834 if (vfork_called < 0) {
4835 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4838 else return do_aexec(really,mark,sp);
4840 /* no vfork - act VMSish */
4841 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4846 } /* end of vms_do_aexec() */
4849 /* {{{bool vms_do_exec(char *cmd) */
4851 Perl_vms_do_exec(pTHX_ char *cmd)
4854 if (vfork_called) { /* this follows a vfork - act Unixish */
4856 if (vfork_called < 0) {
4857 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4860 else return do_exec(cmd);
4863 { /* no vfork - act VMSish */
4864 unsigned long int retsts;
4867 TAINT_PROPER("exec");
4868 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4869 retsts = lib$do_command(&VMScmd);
4872 case RMS$_FNF: case RMS$_DNF:
4873 set_errno(ENOENT); break;
4875 set_errno(ENOTDIR); break;
4877 set_errno(ENODEV); break;
4879 set_errno(EACCES); break;
4881 set_errno(EINVAL); break;
4882 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4883 set_errno(E2BIG); break;
4884 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4885 _ckvmssts(retsts); /* fall through */
4886 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4889 set_vaxc_errno(retsts);
4890 if (ckWARN(WARN_EXEC)) {
4891 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4892 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4899 } /* end of vms_do_exec() */
4902 unsigned long int Perl_do_spawn(pTHX_ char *);
4904 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4906 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4908 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4911 } /* end of do_aspawn() */
4914 /* {{{unsigned long int do_spawn(char *cmd) */
4916 Perl_do_spawn(pTHX_ char *cmd)
4918 unsigned long int sts, substs, hadcmd = 1;
4921 TAINT_PROPER("spawn");
4922 if (!cmd || !*cmd) {
4924 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4927 sts = setup_cmddsc(aTHX_ cmd,0);
4929 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4931 substs = sts; /* didn't spawn, use command setup failure for return */
4937 case RMS$_FNF: case RMS$_DNF:
4938 set_errno(ENOENT); break;
4940 set_errno(ENOTDIR); break;
4942 set_errno(ENODEV); break;
4944 set_errno(EACCES); break;
4946 set_errno(EINVAL); break;
4947 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4948 set_errno(E2BIG); break;
4949 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4950 _ckvmssts(sts); /* fall through */
4951 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4954 set_vaxc_errno(sts);
4955 if (ckWARN(WARN_EXEC)) {
4956 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4957 hadcmd ? VMScmd.dsc$w_length : 0,
4958 hadcmd ? VMScmd.dsc$a_pointer : "",
4965 } /* end of do_spawn() */
4969 static unsigned int *sockflags, sockflagsize;
4972 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4973 * routines found in some versions of the CRTL can't deal with sockets.
4974 * We don't shim the other file open routines since a socket isn't
4975 * likely to be opened by a name.
4977 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4978 FILE *my_fdopen(int fd, const char *mode)
4980 FILE *fp = fdopen(fd, (char *) mode);
4983 unsigned int fdoff = fd / sizeof(unsigned int);
4984 struct stat sbuf; /* native stat; we don't need flex_stat */
4985 if (!sockflagsize || fdoff > sockflagsize) {
4986 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4987 else New (1324,sockflags,fdoff+2,unsigned int);
4988 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4989 sockflagsize = fdoff + 2;
4991 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4992 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5001 * Clear the corresponding bit when the (possibly) socket stream is closed.
5002 * There still a small hole: we miss an implicit close which might occur
5003 * via freopen(). >> Todo
5005 /*{{{ int my_fclose(FILE *fp)*/
5006 int my_fclose(FILE *fp) {
5008 unsigned int fd = fileno(fp);
5009 unsigned int fdoff = fd / sizeof(unsigned int);
5011 if (sockflagsize && fdoff <= sockflagsize)
5012 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5020 * A simple fwrite replacement which outputs itmsz*nitm chars without
5021 * introducing record boundaries every itmsz chars.
5022 * We are using fputs, which depends on a terminating null. We may
5023 * well be writing binary data, so we need to accommodate not only
5024 * data with nulls sprinkled in the middle but also data with no null
5027 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5029 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5031 register char *cp, *end, *cpd, *data;
5032 register unsigned int fd = fileno(dest);
5033 register unsigned int fdoff = fd / sizeof(unsigned int);
5035 int bufsize = itmsz * nitm + 1;
5037 if (fdoff < sockflagsize &&
5038 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5039 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5043 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5044 memcpy( data, src, itmsz*nitm );
5045 data[itmsz*nitm] = '\0';
5047 end = data + itmsz * nitm;
5048 retval = (int) nitm; /* on success return # items written */
5051 while (cpd <= end) {
5052 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5053 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5055 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5059 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5062 } /* end of my_fwrite() */
5065 /*{{{ int my_flush(FILE *fp)*/
5067 Perl_my_flush(pTHX_ FILE *fp)
5070 if ((res = fflush(fp)) == 0 && fp) {
5071 #ifdef VMS_DO_SOCKETS
5073 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5075 res = fsync(fileno(fp));
5078 * If the flush succeeded but set end-of-file, we need to clear
5079 * the error because our caller may check ferror(). BTW, this
5080 * probably means we just flushed an empty file.
5082 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5089 * Here are replacements for the following Unix routines in the VMS environment:
5090 * getpwuid Get information for a particular UIC or UID
5091 * getpwnam Get information for a named user
5092 * getpwent Get information for each user in the rights database
5093 * setpwent Reset search to the start of the rights database
5094 * endpwent Finish searching for users in the rights database
5096 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5097 * (defined in pwd.h), which contains the following fields:-
5099 * char *pw_name; Username (in lower case)
5100 * char *pw_passwd; Hashed password
5101 * unsigned int pw_uid; UIC
5102 * unsigned int pw_gid; UIC group number
5103 * char *pw_unixdir; Default device/directory (VMS-style)
5104 * char *pw_gecos; Owner name
5105 * char *pw_dir; Default device/directory (Unix-style)
5106 * char *pw_shell; Default CLI name (eg. DCL)
5108 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5110 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5111 * not the UIC member number (eg. what's returned by getuid()),
5112 * getpwuid() can accept either as input (if uid is specified, the caller's
5113 * UIC group is used), though it won't recognise gid=0.
5115 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5116 * information about other users in your group or in other groups, respectively.
5117 * If the required privilege is not available, then these routines fill only
5118 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5121 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5124 /* sizes of various UAF record fields */
5125 #define UAI$S_USERNAME 12
5126 #define UAI$S_IDENT 31
5127 #define UAI$S_OWNER 31
5128 #define UAI$S_DEFDEV 31
5129 #define UAI$S_DEFDIR 63
5130 #define UAI$S_DEFCLI 31
5133 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5134 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5135 (uic).uic$v_group != UIC$K_WILD_GROUP)
5137 static char __empty[]= "";
5138 static struct passwd __passwd_empty=
5139 {(char *) __empty, (char *) __empty, 0, 0,
5140 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5141 static int contxt= 0;
5142 static struct passwd __pwdcache;
5143 static char __pw_namecache[UAI$S_IDENT+1];
5146 * This routine does most of the work extracting the user information.
5148 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5151 unsigned char length;
5152 char pw_gecos[UAI$S_OWNER+1];
5154 static union uicdef uic;
5156 unsigned char length;
5157 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5160 unsigned char length;
5161 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5164 unsigned char length;
5165 char pw_shell[UAI$S_DEFCLI+1];
5167 static char pw_passwd[UAI$S_PWD+1];
5169 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5170 struct dsc$descriptor_s name_desc;
5171 unsigned long int sts;
5173 static struct itmlst_3 itmlst[]= {
5174 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5175 {sizeof(uic), UAI$_UIC, &uic, &luic},
5176 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5177 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5178 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5179 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5180 {0, 0, NULL, NULL}};
5182 name_desc.dsc$w_length= strlen(name);
5183 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5184 name_desc.dsc$b_class= DSC$K_CLASS_S;
5185 name_desc.dsc$a_pointer= (char *) name;
5187 /* Note that sys$getuai returns many fields as counted strings. */
5188 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5189 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5190 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5192 else { _ckvmssts(sts); }
5193 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5195 if ((int) owner.length < lowner) lowner= (int) owner.length;
5196 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5197 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5198 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5199 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5200 owner.pw_gecos[lowner]= '\0';
5201 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5202 defcli.pw_shell[ldefcli]= '\0';
5203 if (valid_uic(uic)) {
5204 pwd->pw_uid= uic.uic$l_uic;
5205 pwd->pw_gid= uic.uic$v_group;
5208 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5209 pwd->pw_passwd= pw_passwd;
5210 pwd->pw_gecos= owner.pw_gecos;
5211 pwd->pw_dir= defdev.pw_dir;
5212 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5213 pwd->pw_shell= defcli.pw_shell;
5214 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5216 ldir= strlen(pwd->pw_unixdir) - 1;
5217 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5220 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5221 __mystrtolower(pwd->pw_unixdir);
5226 * Get information for a named user.
5228 /*{{{struct passwd *getpwnam(char *name)*/
5229 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5231 struct dsc$descriptor_s name_desc;
5233 unsigned long int status, sts;
5235 __pwdcache = __passwd_empty;
5236 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5237 /* We still may be able to determine pw_uid and pw_gid */
5238 name_desc.dsc$w_length= strlen(name);
5239 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5240 name_desc.dsc$b_class= DSC$K_CLASS_S;
5241 name_desc.dsc$a_pointer= (char *) name;
5242 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5243 __pwdcache.pw_uid= uic.uic$l_uic;
5244 __pwdcache.pw_gid= uic.uic$v_group;
5247 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5248 set_vaxc_errno(sts);
5249 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5252 else { _ckvmssts(sts); }
5255 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5256 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5257 __pwdcache.pw_name= __pw_namecache;
5259 } /* end of my_getpwnam() */
5263 * Get information for a particular UIC or UID.
5264 * Called by my_getpwent with uid=-1 to list all users.
5266 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5267 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5269 const $DESCRIPTOR(name_desc,__pw_namecache);
5270 unsigned short lname;
5272 unsigned long int status;
5274 if (uid == (unsigned int) -1) {
5276 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5277 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5278 set_vaxc_errno(status);
5279 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5283 else { _ckvmssts(status); }
5284 } while (!valid_uic (uic));
5288 if (!uic.uic$v_group)
5289 uic.uic$v_group= PerlProc_getgid();
5291 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5292 else status = SS$_IVIDENT;
5293 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5294 status == RMS$_PRV) {
5295 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5298 else { _ckvmssts(status); }
5300 __pw_namecache[lname]= '\0';
5301 __mystrtolower(__pw_namecache);
5303 __pwdcache = __passwd_empty;
5304 __pwdcache.pw_name = __pw_namecache;
5306 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5307 The identifier's value is usually the UIC, but it doesn't have to be,
5308 so if we can, we let fillpasswd update this. */
5309 __pwdcache.pw_uid = uic.uic$l_uic;
5310 __pwdcache.pw_gid = uic.uic$v_group;
5312 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5315 } /* end of my_getpwuid() */
5319 * Get information for next user.
5321 /*{{{struct passwd *my_getpwent()*/
5322 struct passwd *Perl_my_getpwent(pTHX)
5324 return (my_getpwuid((unsigned int) -1));
5329 * Finish searching rights database for users.
5331 /*{{{void my_endpwent()*/
5332 void Perl_my_endpwent(pTHX)
5335 _ckvmssts(sys$finish_rdb(&contxt));
5341 #ifdef HOMEGROWN_POSIX_SIGNALS
5342 /* Signal handling routines, pulled into the core from POSIX.xs.
5344 * We need these for threads, so they've been rolled into the core,
5345 * rather than left in POSIX.xs.
5347 * (DRS, Oct 23, 1997)
5350 /* sigset_t is atomic under VMS, so these routines are easy */
5351 /*{{{int my_sigemptyset(sigset_t *) */
5352 int my_sigemptyset(sigset_t *set) {
5353 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5359 /*{{{int my_sigfillset(sigset_t *)*/
5360 int my_sigfillset(sigset_t *set) {
5362 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5363 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5369 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5370 int my_sigaddset(sigset_t *set, int sig) {
5371 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5372 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5373 *set |= (1 << (sig - 1));
5379 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5380 int my_sigdelset(sigset_t *set, int sig) {
5381 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5382 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5383 *set &= ~(1 << (sig - 1));
5389 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5390 int my_sigismember(sigset_t *set, int sig) {
5391 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5392 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5393 *set & (1 << (sig - 1));
5398 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5399 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5402 /* If set and oset are both null, then things are badly wrong. Bail out. */
5403 if ((oset == NULL) && (set == NULL)) {
5404 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5408 /* If set's null, then we're just handling a fetch. */
5410 tempmask = sigblock(0);
5415 tempmask = sigsetmask(*set);
5418 tempmask = sigblock(*set);
5421 tempmask = sigblock(0);
5422 sigsetmask(*oset & ~tempmask);
5425 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5430 /* Did they pass us an oset? If so, stick our holding mask into it */
5437 #endif /* HOMEGROWN_POSIX_SIGNALS */
5440 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5441 * my_utime(), and flex_stat(), all of which operate on UTC unless
5442 * VMSISH_TIMES is true.
5444 /* method used to handle UTC conversions:
5445 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5447 static int gmtime_emulation_type;
5448 /* number of secs to add to UTC POSIX-style time to get local time */
5449 static long int utc_offset_secs;
5451 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5452 * in vmsish.h. #undef them here so we can call the CRTL routines
5461 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5462 * qualifier with the extern prefix pragma. This provisional
5463 * hack circumvents this prefix pragma problem in previous
5466 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5467 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5468 # pragma __extern_prefix save
5469 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5470 # define gmtime decc$__utctz_gmtime
5471 # define localtime decc$__utctz_localtime
5472 # define time decc$__utc_time
5473 # pragma __extern_prefix restore
5475 struct tm *gmtime(), *localtime();
5481 static time_t toutc_dst(time_t loc) {
5484 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5485 loc -= utc_offset_secs;
5486 if (rsltmp->tm_isdst) loc -= 3600;
5489 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5490 ((gmtime_emulation_type || my_time(NULL)), \
5491 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5492 ((secs) - utc_offset_secs))))
5494 static time_t toloc_dst(time_t utc) {
5497 utc += utc_offset_secs;
5498 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5499 if (rsltmp->tm_isdst) utc += 3600;
5502 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5503 ((gmtime_emulation_type || my_time(NULL)), \
5504 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5505 ((secs) + utc_offset_secs))))
5507 #ifndef RTL_USES_UTC
5510 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5511 DST starts on 1st sun of april at 02:00 std time
5512 ends on last sun of october at 02:00 dst time
5513 see the UCX management command reference, SET CONFIG TIMEZONE
5514 for formatting info.
5516 No, it's not as general as it should be, but then again, NOTHING
5517 will handle UK times in a sensible way.
5522 parse the DST start/end info:
5523 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5527 tz_parse_startend(char *s, struct tm *w, int *past)
5529 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5530 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5535 if (!past) return 0;
5538 if (w->tm_year % 4 == 0) ly = 1;
5539 if (w->tm_year % 100 == 0) ly = 0;
5540 if (w->tm_year+1900 % 400 == 0) ly = 1;
5543 dozjd = isdigit(*s);
5544 if (*s == 'J' || *s == 'j' || dozjd) {
5545 if (!dozjd && !isdigit(*++s)) return 0;
5548 d = d*10 + *s++ - '0';
5550 d = d*10 + *s++ - '0';
5553 if (d == 0) return 0;
5554 if (d > 366) return 0;
5556 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5559 } else if (*s == 'M' || *s == 'm') {
5560 if (!isdigit(*++s)) return 0;
5562 if (isdigit(*s)) m = 10*m + *s++ - '0';
5563 if (*s != '.') return 0;
5564 if (!isdigit(*++s)) return 0;
5566 if (n < 1 || n > 5) return 0;
5567 if (*s != '.') return 0;
5568 if (!isdigit(*++s)) return 0;
5570 if (d > 6) return 0;
5574 if (!isdigit(*++s)) return 0;
5576 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5578 if (!isdigit(*++s)) return 0;
5580 if (isdigit(*s)) min = 10*min + *s++ - '0';
5582 if (!isdigit(*++s)) return 0;
5584 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5594 if (w->tm_yday < d) goto before;
5595 if (w->tm_yday > d) goto after;
5597 if (w->tm_mon+1 < m) goto before;
5598 if (w->tm_mon+1 > m) goto after;
5600 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5601 k = d - j; /* mday of first d */
5603 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5604 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5605 if (w->tm_mday < k) goto before;
5606 if (w->tm_mday > k) goto after;
5609 if (w->tm_hour < hour) goto before;
5610 if (w->tm_hour > hour) goto after;
5611 if (w->tm_min < min) goto before;
5612 if (w->tm_min > min) goto after;
5613 if (w->tm_sec < sec) goto before;
5627 /* parse the offset: (+|-)hh[:mm[:ss]] */
5630 tz_parse_offset(char *s, int *offset)
5632 int hour = 0, min = 0, sec = 0;
5635 if (!offset) return 0;
5637 if (*s == '-') {neg++; s++;}
5639 if (!isdigit(*s)) return 0;
5641 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5642 if (hour > 24) return 0;
5644 if (!isdigit(*++s)) return 0;
5646 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5647 if (min > 59) return 0;
5649 if (!isdigit(*++s)) return 0;
5651 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5652 if (sec > 59) return 0;
5656 *offset = (hour*60+min)*60 + sec;
5657 if (neg) *offset = -*offset;
5662 input time is w, whatever type of time the CRTL localtime() uses.
5663 sets dst, the zone, and the gmtoff (seconds)
5665 caches the value of TZ and UCX$TZ env variables; note that
5666 my_setenv looks for these and sets a flag if they're changed
5669 We have to watch out for the "australian" case (dst starts in
5670 october, ends in april)...flagged by "reverse" and checked by
5671 scanning through the months of the previous year.
5676 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5681 char *dstzone, *tz, *s_start, *s_end;
5682 int std_off, dst_off, isdst;
5683 int y, dststart, dstend;
5684 static char envtz[1025]; /* longer than any logical, symbol, ... */
5685 static char ucxtz[1025];
5686 static char reversed = 0;
5692 reversed = -1; /* flag need to check */
5693 envtz[0] = ucxtz[0] = '\0';
5694 tz = my_getenv("TZ",0);
5695 if (tz) strcpy(envtz, tz);
5696 tz = my_getenv("UCX$TZ",0);
5697 if (tz) strcpy(ucxtz, tz);
5698 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5701 if (!*tz) tz = ucxtz;
5704 while (isalpha(*s)) s++;
5705 s = tz_parse_offset(s, &std_off);
5707 if (!*s) { /* no DST, hurray we're done! */
5713 while (isalpha(*s)) s++;
5714 s2 = tz_parse_offset(s, &dst_off);
5718 dst_off = std_off - 3600;
5721 if (!*s) { /* default dst start/end?? */
5722 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5723 s = strchr(ucxtz,',');
5725 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5727 if (*s != ',') return 0;
5730 when = _toutc(when); /* convert to utc */
5731 when = when - std_off; /* convert to pseudolocal time*/
5733 w2 = localtime(&when);
5736 s = tz_parse_startend(s_start,w2,&dststart);
5738 if (*s != ',') return 0;
5741 when = _toutc(when); /* convert to utc */
5742 when = when - dst_off; /* convert to pseudolocal time*/
5743 w2 = localtime(&when);
5744 if (w2->tm_year != y) { /* spans a year, just check one time */
5745 when += dst_off - std_off;
5746 w2 = localtime(&when);
5749 s = tz_parse_startend(s_end,w2,&dstend);
5752 if (reversed == -1) { /* need to check if start later than end */
5756 if (when < 2*365*86400) {
5757 when += 2*365*86400;
5761 w2 =localtime(&when);
5762 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5764 for (j = 0; j < 12; j++) {
5765 w2 =localtime(&when);
5766 (void) tz_parse_startend(s_start,w2,&ds);
5767 (void) tz_parse_startend(s_end,w2,&de);
5768 if (ds != de) break;
5772 if (de && !ds) reversed = 1;
5775 isdst = dststart && !dstend;
5776 if (reversed) isdst = dststart || !dstend;
5779 if (dst) *dst = isdst;
5780 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5781 if (isdst) tz = dstzone;
5783 while(isalpha(*tz)) *zone++ = *tz++;
5789 #endif /* !RTL_USES_UTC */
5791 /* my_time(), my_localtime(), my_gmtime()
5792 * By default traffic in UTC time values, using CRTL gmtime() or
5793 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5794 * Note: We need to use these functions even when the CRTL has working
5795 * UTC support, since they also handle C<use vmsish qw(times);>
5797 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5798 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5801 /*{{{time_t my_time(time_t *timep)*/
5802 time_t Perl_my_time(pTHX_ time_t *timep)
5807 if (gmtime_emulation_type == 0) {
5809 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5810 /* results of calls to gmtime() and localtime() */
5811 /* for same &base */
5813 gmtime_emulation_type++;
5814 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5815 char off[LNM$C_NAMLENGTH+1];;
5817 gmtime_emulation_type++;
5818 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5819 gmtime_emulation_type++;
5820 utc_offset_secs = 0;
5821 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5823 else { utc_offset_secs = atol(off); }
5825 else { /* We've got a working gmtime() */
5826 struct tm gmt, local;
5829 tm_p = localtime(&base);
5831 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5832 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5833 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5834 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5840 # ifdef RTL_USES_UTC
5841 if (VMSISH_TIME) when = _toloc(when);
5843 if (!VMSISH_TIME) when = _toutc(when);
5846 if (timep != NULL) *timep = when;
5849 } /* end of my_time() */
5853 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5855 Perl_my_gmtime(pTHX_ const time_t *timep)
5861 if (timep == NULL) {
5862 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5865 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5869 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5871 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5872 return gmtime(&when);
5874 /* CRTL localtime() wants local time as input, so does no tz correction */
5875 rsltmp = localtime(&when);
5876 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5879 } /* end of my_gmtime() */
5883 /*{{{struct tm *my_localtime(const time_t *timep)*/
5885 Perl_my_localtime(pTHX_ const time_t *timep)
5887 time_t when, whenutc;
5891 if (timep == NULL) {
5892 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5895 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5896 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5899 # ifdef RTL_USES_UTC
5901 if (VMSISH_TIME) when = _toutc(when);
5903 /* CRTL localtime() wants UTC as input, does tz correction itself */
5904 return localtime(&when);
5906 # else /* !RTL_USES_UTC */
5909 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5910 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5913 #ifndef RTL_USES_UTC
5914 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5915 when = whenutc - offset; /* pseudolocal time*/
5918 /* CRTL localtime() wants local time as input, so does no tz correction */
5919 rsltmp = localtime(&when);
5920 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5924 } /* end of my_localtime() */
5927 /* Reset definitions for later calls */
5928 #define gmtime(t) my_gmtime(t)
5929 #define localtime(t) my_localtime(t)
5930 #define time(t) my_time(t)
5933 /* my_utime - update modification time of a file
5934 * calling sequence is identical to POSIX utime(), but under
5935 * VMS only the modification time is changed; ODS-2 does not
5936 * maintain access times. Restrictions differ from the POSIX
5937 * definition in that the time can be changed as long as the
5938 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5939 * no separate checks are made to insure that the caller is the
5940 * owner of the file or has special privs enabled.
5941 * Code here is based on Joe Meadows' FILE utility.
5944 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5945 * to VMS epoch (01-JAN-1858 00:00:00.00)
5946 * in 100 ns intervals.
5948 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5950 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5951 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5954 long int bintime[2], len = 2, lowbit, unixtime,
5955 secscale = 10000000; /* seconds --> 100 ns intervals */
5956 unsigned long int chan, iosb[2], retsts;
5957 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5958 struct FAB myfab = cc$rms_fab;
5959 struct NAM mynam = cc$rms_nam;
5960 #if defined (__DECC) && defined (__VAX)
5961 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5962 * at least through VMS V6.1, which causes a type-conversion warning.
5964 # pragma message save
5965 # pragma message disable cvtdiftypes
5967 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5968 struct fibdef myfib;
5969 #if defined (__DECC) && defined (__VAX)
5970 /* This should be right after the declaration of myatr, but due
5971 * to a bug in VAX DEC C, this takes effect a statement early.
5973 # pragma message restore
5975 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5976 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5977 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5979 if (file == NULL || *file == '\0') {
5981 set_vaxc_errno(LIB$_INVARG);
5984 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5986 if (utimes != NULL) {
5987 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5988 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5989 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5990 * as input, we force the sign bit to be clear by shifting unixtime right
5991 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5993 lowbit = (utimes->modtime & 1) ? secscale : 0;
5994 unixtime = (long int) utimes->modtime;
5996 /* If input was UTC; convert to local for sys svc */
5997 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5999 unixtime >>= 1; secscale <<= 1;
6000 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6001 if (!(retsts & 1)) {
6003 set_vaxc_errno(retsts);
6006 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6007 if (!(retsts & 1)) {
6009 set_vaxc_errno(retsts);
6014 /* Just get the current time in VMS format directly */
6015 retsts = sys$gettim(bintime);
6016 if (!(retsts & 1)) {
6018 set_vaxc_errno(retsts);
6023 myfab.fab$l_fna = vmsspec;
6024 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6025 myfab.fab$l_nam = &mynam;
6026 mynam.nam$l_esa = esa;
6027 mynam.nam$b_ess = (unsigned char) sizeof esa;
6028 mynam.nam$l_rsa = rsa;
6029 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6031 /* Look for the file to be affected, letting RMS parse the file
6032 * specification for us as well. I have set errno using only
6033 * values documented in the utime() man page for VMS POSIX.
6035 retsts = sys$parse(&myfab,0,0);
6036 if (!(retsts & 1)) {
6037 set_vaxc_errno(retsts);
6038 if (retsts == RMS$_PRV) set_errno(EACCES);
6039 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6040 else set_errno(EVMSERR);
6043 retsts = sys$search(&myfab,0,0);
6044 if (!(retsts & 1)) {
6045 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6046 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6047 set_vaxc_errno(retsts);
6048 if (retsts == RMS$_PRV) set_errno(EACCES);
6049 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6050 else set_errno(EVMSERR);
6054 devdsc.dsc$w_length = mynam.nam$b_dev;
6055 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6057 retsts = sys$assign(&devdsc,&chan,0,0);
6058 if (!(retsts & 1)) {
6059 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6060 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6061 set_vaxc_errno(retsts);
6062 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6063 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6064 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6065 else set_errno(EVMSERR);
6069 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6070 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6072 memset((void *) &myfib, 0, sizeof myfib);
6073 #if defined(__DECC) || defined(__DECCXX)
6074 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6075 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6076 /* This prevents the revision time of the file being reset to the current
6077 * time as a result of our IO$_MODIFY $QIO. */
6078 myfib.fib$l_acctl = FIB$M_NORECORD;
6080 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6081 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6082 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6084 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6085 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6086 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6087 _ckvmssts(sys$dassgn(chan));
6088 if (retsts & 1) retsts = iosb[0];
6089 if (!(retsts & 1)) {
6090 set_vaxc_errno(retsts);
6091 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6092 else set_errno(EVMSERR);
6097 } /* end of my_utime() */
6101 * flex_stat, flex_fstat
6102 * basic stat, but gets it right when asked to stat
6103 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6106 /* encode_dev packs a VMS device name string into an integer to allow
6107 * simple comparisons. This can be used, for example, to check whether two
6108 * files are located on the same device, by comparing their encoded device
6109 * names. Even a string comparison would not do, because stat() reuses the
6110 * device name buffer for each call; so without encode_dev, it would be
6111 * necessary to save the buffer and use strcmp (this would mean a number of
6112 * changes to the standard Perl code, to say nothing of what a Perl script
6115 * The device lock id, if it exists, should be unique (unless perhaps compared
6116 * with lock ids transferred from other nodes). We have a lock id if the disk is
6117 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6118 * device names. Thus we use the lock id in preference, and only if that isn't
6119 * available, do we try to pack the device name into an integer (flagged by
6120 * the sign bit (LOCKID_MASK) being set).
6122 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6123 * name and its encoded form, but it seems very unlikely that we will find
6124 * two files on different disks that share the same encoded device names,
6125 * and even more remote that they will share the same file id (if the test
6126 * is to check for the same file).
6128 * A better method might be to use sys$device_scan on the first call, and to
6129 * search for the device, returning an index into the cached array.
6130 * The number returned would be more intelligable.
6131 * This is probably not worth it, and anyway would take quite a bit longer
6132 * on the first call.
6134 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6135 static mydev_t encode_dev (pTHX_ const char *dev)
6138 unsigned long int f;
6143 if (!dev || !dev[0]) return 0;
6147 struct dsc$descriptor_s dev_desc;
6148 unsigned long int status, lockid, item = DVI$_LOCKID;
6150 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6151 can try that first. */
6152 dev_desc.dsc$w_length = strlen (dev);
6153 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6154 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6155 dev_desc.dsc$a_pointer = (char *) dev;
6156 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6157 if (lockid) return (lockid & ~LOCKID_MASK);
6161 /* Otherwise we try to encode the device name */
6165 for (q = dev + strlen(dev); q--; q >= dev) {
6168 else if (isalpha (toupper (*q)))
6169 c= toupper (*q) - 'A' + (char)10;
6171 continue; /* Skip '$'s */
6173 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6175 enc += f * (unsigned long int) c;
6177 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6179 } /* end of encode_dev() */
6181 static char namecache[NAM$C_MAXRSS+1];
6184 is_null_device(name)
6187 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6188 The underscore prefix, controller letter, and unit number are
6189 independently optional; for our purposes, the colon punctuation
6190 is not. The colon can be trailed by optional directory and/or
6191 filename, but two consecutive colons indicates a nodename rather
6192 than a device. [pr] */
6193 if (*name == '_') ++name;
6194 if (tolower(*name++) != 'n') return 0;
6195 if (tolower(*name++) != 'l') return 0;
6196 if (tolower(*name) == 'a') ++name;
6197 if (*name == '0') ++name;
6198 return (*name++ == ':') && (*name != ':');
6201 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6202 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6203 * subset of the applicable information.
6206 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6208 char fname_phdev[NAM$C_MAXRSS+1];
6209 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6211 char fname[NAM$C_MAXRSS+1];
6212 unsigned long int retsts;
6213 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6214 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6216 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6217 device name on successive calls */
6218 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6219 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6220 namdsc.dsc$a_pointer = fname;
6221 namdsc.dsc$w_length = sizeof fname - 1;
6223 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6224 &namdsc,&namdsc.dsc$w_length,0,0);
6226 fname[namdsc.dsc$w_length] = '\0';
6228 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6229 * but if someone has redefined that logical, Perl gets very lost. Since
6230 * we have the physical device name from the stat buffer, just paste it on.
6232 strcpy( fname_phdev, statbufp->st_devnam );
6233 strcat( fname_phdev, strrchr(fname, ':') );
6235 return cando_by_name(bit,effective,fname_phdev);
6237 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6238 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6242 return FALSE; /* Should never get to here */
6244 } /* end of cando() */
6248 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6250 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6252 static char usrname[L_cuserid];
6253 static struct dsc$descriptor_s usrdsc =
6254 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6255 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6256 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6257 unsigned short int retlen;
6258 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6259 union prvdef curprv;
6260 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6261 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6262 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6265 if (!fname || !*fname) return FALSE;
6266 /* Make sure we expand logical names, since sys$check_access doesn't */
6267 if (!strpbrk(fname,"/]>:")) {
6268 strcpy(fileified,fname);
6269 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6272 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6273 retlen = namdsc.dsc$w_length = strlen(vmsname);
6274 namdsc.dsc$a_pointer = vmsname;
6275 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6276 vmsname[retlen-1] == ':') {
6277 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6278 namdsc.dsc$w_length = strlen(fileified);
6279 namdsc.dsc$a_pointer = fileified;
6282 if (!usrdsc.dsc$w_length) {
6284 usrdsc.dsc$w_length = strlen(usrname);
6288 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6289 access = ARM$M_EXECUTE; break;
6290 case S_IRUSR: case S_IRGRP: case S_IROTH:
6291 access = ARM$M_READ; break;
6292 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6293 access = ARM$M_WRITE; break;
6294 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6295 access = ARM$M_DELETE; break;
6300 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6301 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6302 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6303 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6304 set_vaxc_errno(retsts);
6305 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6306 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6307 else set_errno(ENOENT);
6310 if (retsts == SS$_NORMAL) {
6311 if (!privused) return TRUE;
6312 /* We can get access, but only by using privs. Do we have the
6313 necessary privs currently enabled? */
6314 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6315 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6316 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6317 !curprv.prv$v_bypass) return FALSE;
6318 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6319 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6320 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6323 if (retsts == SS$_ACCONFLICT) {
6328 return FALSE; /* Should never get here */
6330 } /* end of cando_by_name() */
6334 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6336 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6338 if (!fstat(fd,(stat_t *) statbufp)) {
6339 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6340 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6341 # ifdef RTL_USES_UTC
6344 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6345 statbufp->st_atime = _toloc(statbufp->st_atime);
6346 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6351 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6355 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6356 statbufp->st_atime = _toutc(statbufp->st_atime);
6357 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6364 } /* end of flex_fstat() */
6367 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6369 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6371 char fileified[NAM$C_MAXRSS+1];
6372 char temp_fspec[NAM$C_MAXRSS+300];
6375 strcpy(temp_fspec, fspec);
6376 if (statbufp == (Stat_t *) &PL_statcache)
6377 do_tovmsspec(temp_fspec,namecache,0);
6378 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6379 memset(statbufp,0,sizeof *statbufp);
6380 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6381 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6382 statbufp->st_uid = 0x00010001;
6383 statbufp->st_gid = 0x0001;
6384 time((time_t *)&statbufp->st_mtime);
6385 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6389 /* Try for a directory name first. If fspec contains a filename without
6390 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6391 * and sea:[wine.dark]water. exist, we prefer the directory here.
6392 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6393 * not sea:[wine.dark]., if the latter exists. If the intended target is
6394 * the file with null type, specify this by calling flex_stat() with
6395 * a '.' at the end of fspec.
6397 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6398 retval = stat(fileified,(stat_t *) statbufp);
6399 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6400 strcpy(namecache,fileified);
6402 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6404 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6405 # ifdef RTL_USES_UTC
6408 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6409 statbufp->st_atime = _toloc(statbufp->st_atime);
6410 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6415 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6419 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6420 statbufp->st_atime = _toutc(statbufp->st_atime);
6421 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6427 } /* end of flex_stat() */
6431 /*{{{char *my_getlogin()*/
6432 /* VMS cuserid == Unix getlogin, except calling sequence */
6436 static char user[L_cuserid];
6437 return cuserid(user);
6442 /* rmscopy - copy a file using VMS RMS routines
6444 * Copies contents and attributes of spec_in to spec_out, except owner
6445 * and protection information. Name and type of spec_in are used as
6446 * defaults for spec_out. The third parameter specifies whether rmscopy()
6447 * should try to propagate timestamps from the input file to the output file.
6448 * If it is less than 0, no timestamps are preserved. If it is 0, then
6449 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6450 * propagated to the output file at creation iff the output file specification
6451 * did not contain an explicit name or type, and the revision date is always
6452 * updated at the end of the copy operation. If it is greater than 0, then
6453 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6454 * other than the revision date should be propagated, and bit 1 indicates
6455 * that the revision date should be propagated.
6457 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6459 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6460 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6461 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6462 * as part of the Perl standard distribution under the terms of the
6463 * GNU General Public License or the Perl Artistic License. Copies
6464 * of each may be found in the Perl standard distribution.
6466 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6468 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6470 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6471 rsa[NAM$C_MAXRSS], ubf[32256];
6472 unsigned long int i, sts, sts2;
6473 struct FAB fab_in, fab_out;
6474 struct RAB rab_in, rab_out;
6476 struct XABDAT xabdat;
6477 struct XABFHC xabfhc;
6478 struct XABRDT xabrdt;
6479 struct XABSUM xabsum;
6481 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6482 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6483 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6487 fab_in = cc$rms_fab;
6488 fab_in.fab$l_fna = vmsin;
6489 fab_in.fab$b_fns = strlen(vmsin);
6490 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6491 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6492 fab_in.fab$l_fop = FAB$M_SQO;
6493 fab_in.fab$l_nam = &nam;
6494 fab_in.fab$l_xab = (void *) &xabdat;
6497 nam.nam$l_rsa = rsa;
6498 nam.nam$b_rss = sizeof(rsa);
6499 nam.nam$l_esa = esa;
6500 nam.nam$b_ess = sizeof (esa);
6501 nam.nam$b_esl = nam.nam$b_rsl = 0;
6503 xabdat = cc$rms_xabdat; /* To get creation date */
6504 xabdat.xab$l_nxt = (void *) &xabfhc;
6506 xabfhc = cc$rms_xabfhc; /* To get record length */
6507 xabfhc.xab$l_nxt = (void *) &xabsum;
6509 xabsum = cc$rms_xabsum; /* To get key and area information */
6511 if (!((sts = sys$open(&fab_in)) & 1)) {
6512 set_vaxc_errno(sts);
6514 case RMS$_FNF: case RMS$_DNF:
6515 set_errno(ENOENT); break;
6517 set_errno(ENOTDIR); break;
6519 set_errno(ENODEV); break;
6521 set_errno(EINVAL); break;
6523 set_errno(EACCES); break;
6531 fab_out.fab$w_ifi = 0;
6532 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6533 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6534 fab_out.fab$l_fop = FAB$M_SQO;
6535 fab_out.fab$l_fna = vmsout;
6536 fab_out.fab$b_fns = strlen(vmsout);
6537 fab_out.fab$l_dna = nam.nam$l_name;
6538 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6540 if (preserve_dates == 0) { /* Act like DCL COPY */
6541 nam.nam$b_nop = NAM$M_SYNCHK;
6542 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6543 if (!((sts = sys$parse(&fab_out)) & 1)) {
6544 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6545 set_vaxc_errno(sts);
6548 fab_out.fab$l_xab = (void *) &xabdat;
6549 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6551 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6552 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6553 preserve_dates =0; /* bitmask from this point forward */
6555 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6556 if (!((sts = sys$create(&fab_out)) & 1)) {
6557 set_vaxc_errno(sts);
6560 set_errno(ENOENT); break;
6562 set_errno(ENOTDIR); break;
6564 set_errno(ENODEV); break;
6566 set_errno(EINVAL); break;
6568 set_errno(EACCES); break;
6574 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6575 if (preserve_dates & 2) {
6576 /* sys$close() will process xabrdt, not xabdat */
6577 xabrdt = cc$rms_xabrdt;
6579 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6581 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6582 * is unsigned long[2], while DECC & VAXC use a struct */
6583 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6585 fab_out.fab$l_xab = (void *) &xabrdt;
6588 rab_in = cc$rms_rab;
6589 rab_in.rab$l_fab = &fab_in;
6590 rab_in.rab$l_rop = RAB$M_BIO;
6591 rab_in.rab$l_ubf = ubf;
6592 rab_in.rab$w_usz = sizeof ubf;
6593 if (!((sts = sys$connect(&rab_in)) & 1)) {
6594 sys$close(&fab_in); sys$close(&fab_out);
6595 set_errno(EVMSERR); set_vaxc_errno(sts);
6599 rab_out = cc$rms_rab;
6600 rab_out.rab$l_fab = &fab_out;
6601 rab_out.rab$l_rbf = ubf;
6602 if (!((sts = sys$connect(&rab_out)) & 1)) {
6603 sys$close(&fab_in); sys$close(&fab_out);
6604 set_errno(EVMSERR); set_vaxc_errno(sts);
6608 while ((sts = sys$read(&rab_in))) { /* always true */
6609 if (sts == RMS$_EOF) break;
6610 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6611 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6612 sys$close(&fab_in); sys$close(&fab_out);
6613 set_errno(EVMSERR); set_vaxc_errno(sts);
6618 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6619 sys$close(&fab_in); sys$close(&fab_out);
6620 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6622 set_errno(EVMSERR); set_vaxc_errno(sts);
6628 } /* end of rmscopy() */
6632 /*** The following glue provides 'hooks' to make some of the routines
6633 * from this file available from Perl. These routines are sufficiently
6634 * basic, and are required sufficiently early in the build process,
6635 * that's it's nice to have them available to miniperl as well as the
6636 * full Perl, so they're set up here instead of in an extension. The
6637 * Perl code which handles importation of these names into a given
6638 * package lives in [.VMS]Filespec.pm in @INC.
6642 rmsexpand_fromperl(pTHX_ CV *cv)
6645 char *fspec, *defspec = NULL, *rslt;
6648 if (!items || items > 2)
6649 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6650 fspec = SvPV(ST(0),n_a);
6651 if (!fspec || !*fspec) XSRETURN_UNDEF;
6652 if (items == 2) defspec = SvPV(ST(1),n_a);
6654 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6655 ST(0) = sv_newmortal();
6656 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6661 vmsify_fromperl(pTHX_ CV *cv)
6667 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6668 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6669 ST(0) = sv_newmortal();
6670 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6675 unixify_fromperl(pTHX_ CV *cv)
6681 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6682 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6683 ST(0) = sv_newmortal();
6684 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6689 fileify_fromperl(pTHX_ CV *cv)
6695 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6696 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6697 ST(0) = sv_newmortal();
6698 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6703 pathify_fromperl(pTHX_ CV *cv)
6709 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6710 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6711 ST(0) = sv_newmortal();
6712 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6717 vmspath_fromperl(pTHX_ CV *cv)
6723 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6724 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6725 ST(0) = sv_newmortal();
6726 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6731 unixpath_fromperl(pTHX_ CV *cv)
6737 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6738 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6739 ST(0) = sv_newmortal();
6740 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6745 candelete_fromperl(pTHX_ CV *cv)
6748 char fspec[NAM$C_MAXRSS+1], *fsp;
6753 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6755 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6756 if (SvTYPE(mysv) == SVt_PVGV) {
6757 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6758 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6765 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6766 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6772 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6777 rmscopy_fromperl(pTHX_ CV *cv)
6780 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6782 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6783 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6784 unsigned long int sts;
6789 if (items < 2 || items > 3)
6790 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6792 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6793 if (SvTYPE(mysv) == SVt_PVGV) {
6794 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6795 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6802 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6803 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6808 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6809 if (SvTYPE(mysv) == SVt_PVGV) {
6810 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6811 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6818 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6819 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6824 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6826 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6832 mod2fname(pTHX_ CV *cv)
6835 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6836 workbuff[NAM$C_MAXRSS*1 + 1];
6837 int total_namelen = 3, counter, num_entries;
6838 /* ODS-5 ups this, but we want to be consistent, so... */
6839 int max_name_len = 39;
6840 AV *in_array = (AV *)SvRV(ST(0));
6842 num_entries = av_len(in_array);
6844 /* All the names start with PL_. */
6845 strcpy(ultimate_name, "PL_");
6847 /* Clean up our working buffer */
6848 Zero(work_name, sizeof(work_name), char);
6850 /* Run through the entries and build up a working name */
6851 for(counter = 0; counter <= num_entries; counter++) {
6852 /* If it's not the first name then tack on a __ */
6854 strcat(work_name, "__");
6856 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6860 /* Check to see if we actually have to bother...*/
6861 if (strlen(work_name) + 3 <= max_name_len) {
6862 strcat(ultimate_name, work_name);
6864 /* It's too darned big, so we need to go strip. We use the same */
6865 /* algorithm as xsubpp does. First, strip out doubled __ */
6866 char *source, *dest, last;
6869 for (source = work_name; *source; source++) {
6870 if (last == *source && last == '_') {
6876 /* Go put it back */
6877 strcpy(work_name, workbuff);
6878 /* Is it still too big? */
6879 if (strlen(work_name) + 3 > max_name_len) {
6880 /* Strip duplicate letters */
6883 for (source = work_name; *source; source++) {
6884 if (last == toupper(*source)) {
6888 last = toupper(*source);
6890 strcpy(work_name, workbuff);
6893 /* Is it *still* too big? */
6894 if (strlen(work_name) + 3 > max_name_len) {
6895 /* Too bad, we truncate */
6896 work_name[max_name_len - 2] = 0;
6898 strcat(ultimate_name, work_name);
6901 /* Okay, return it */
6902 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6910 char* file = __FILE__;
6911 char temp_buff[512];
6912 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6913 no_translate_barewords = TRUE;
6915 no_translate_barewords = FALSE;
6918 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6919 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6920 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6921 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6922 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6923 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6924 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6925 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6926 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6927 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6929 store_pipelocs(aTHX);