3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
41 #include <str$routines.h>
46 /* Older versions of ssdef.h don't have these */
47 #ifndef SS$_INVFILFOROP
48 # define SS$_INVFILFOROP 3930
50 #ifndef SS$_NOSUCHOBJECT
51 # define SS$_NOSUCHOBJECT 2696
54 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
55 #define PERLIO_NOT_STDIO 0
57 /* Don't replace system definitions of vfork, getenv, and stat,
58 * code below needs to get to the underlying CRTL routines. */
59 #define DONT_MASK_RTL_CALLS
63 /* Anticipating future expansion in lexical warnings . . . */
65 # define WARN_INTERNAL WARN_MISC
68 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
69 # define RTL_USES_UTC 1
73 /* gcc's header files don't #define direct access macros
74 * corresponding to VAXC's variant structs */
76 # define uic$v_format uic$r_uic_form.uic$v_format
77 # define uic$v_group uic$r_uic_form.uic$v_group
78 # define uic$v_member uic$r_uic_form.uic$v_member
79 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
80 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
81 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
82 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
85 #if defined(NEED_AN_H_ERRNO)
90 unsigned short int buflen;
91 unsigned short int itmcode;
93 unsigned short int *retlen;
96 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
97 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
98 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
99 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
100 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
101 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
102 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
103 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
104 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
106 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
107 #define PERL_LNM_MAX_ALLOWED_INDEX 127
109 #define MAX_DCL_LINE_LENGTH 255
111 static char *__mystrtolower(char *str)
113 if (str) for (; *str; ++str) *str= tolower(*str);
117 static struct dsc$descriptor_s fildevdsc =
118 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
119 static struct dsc$descriptor_s crtlenvdsc =
120 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
121 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
122 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
123 static struct dsc$descriptor_s **env_tables = defenv;
124 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
126 /* True if we shouldn't treat barewords as logicals during directory */
128 static int no_translate_barewords;
131 static int tz_updated = 1;
134 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
136 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
137 struct dsc$descriptor_s **tabvec, unsigned long int flags)
139 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
140 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
141 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
142 unsigned char acmode;
143 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
144 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
145 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
146 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
148 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
149 #if defined(PERL_IMPLICIT_CONTEXT)
151 # if defined(USE_5005THREADS)
152 /* We jump through these hoops because we can be called at */
153 /* platform-specific initialization time, which is before anything is */
154 /* set up--we can't even do a plain dTHX since that relies on the */
155 /* interpreter structure to be initialized */
157 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
163 aTHX = PERL_GET_INTERP;
171 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
172 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
174 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
175 *cp2 = _toupper(*cp1);
176 if (cp1 - lnm > LNM$C_NAMLENGTH) {
177 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
181 lnmdsc.dsc$w_length = cp1 - lnm;
182 lnmdsc.dsc$a_pointer = uplnm;
183 uplnm[lnmdsc.dsc$w_length] = '\0';
184 secure = flags & PERL__TRNENV_SECURE;
185 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
186 if (!tabvec || !*tabvec) tabvec = env_tables;
188 for (curtab = 0; tabvec[curtab]; curtab++) {
189 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
190 if (!ivenv && !secure) {
195 Perl_warn(aTHX_ "Can't read CRTL environ\n");
198 retsts = SS$_NOLOGNAM;
199 for (i = 0; environ[i]; i++) {
200 if ((eq = strchr(environ[i],'=')) &&
201 !strncmp(environ[i],uplnm,eq - environ[i])) {
203 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
204 if (!eqvlen) continue;
209 if (retsts != SS$_NOLOGNAM) break;
212 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
213 !str$case_blind_compare(&tmpdsc,&clisym)) {
214 if (!ivsym && !secure) {
215 unsigned short int deflen = LNM$C_NAMLENGTH;
216 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
217 /* dynamic dsc to accomodate possible long value */
218 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
219 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
222 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
224 /* Special hack--we might be called before the interpreter's */
225 /* fully initialized, in which case either thr or PL_curcop */
226 /* might be bogus. We have to check, since ckWARN needs them */
227 /* both to be valid if running threaded */
228 #if defined(USE_5005THREADS)
229 if (thr && PL_curcop) {
231 if (ckWARN(WARN_MISC)) {
232 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
234 #if defined(USE_5005THREADS)
236 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
241 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
243 _ckvmssts(lib$sfree1_dd(&eqvdsc));
244 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
245 if (retsts == LIB$_NOSUCHSYM) continue;
250 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
251 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
252 if (retsts == SS$_NOLOGNAM) continue;
253 /* PPFs have a prefix */
256 *((int *)uplnm) == *((int *)"SYS$") &&
258 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
259 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
260 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
261 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
262 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
263 memcpy(eqv,eqv+4,eqvlen-4);
269 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
270 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
271 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
272 retsts == SS$_NOLOGNAM) {
273 set_errno(EINVAL); set_vaxc_errno(retsts);
275 else _ckvmssts(retsts);
277 } /* end of vmstrnenv */
280 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
281 /* Define as a function so we can access statics. */
282 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
284 return vmstrnenv(lnm,eqv,idx,fildev,
285 #ifdef SECURE_INTERNAL_GETENV
286 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
295 * Note: Uses Perl temp to store result so char * can be returned to
296 * caller; this pointer will be invalidated at next Perl statement
298 * We define this as a function rather than a macro in terms of my_getenv_len()
299 * so that it'll work when PL_curinterp is undefined (and we therefore can't
302 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
304 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
306 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
307 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
308 unsigned long int idx = 0;
309 int trnsuccess, success, secure, saverr, savvmserr;
312 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
313 /* Set up a temporary buffer for the return value; Perl will
314 * clean it up at the next statement transition */
315 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
316 if (!tmpsv) return NULL;
319 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
320 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
321 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
322 getcwd(eqv,LNM$C_NAMLENGTH);
326 if ((cp2 = strchr(lnm,';')) != NULL) {
328 uplnm[cp2-lnm] = '\0';
329 idx = strtoul(cp2+1,NULL,0);
332 /* Impose security constraints only if tainting */
334 /* Impose security constraints only if tainting */
335 secure = PL_curinterp ? PL_tainting : will_taint;
336 saverr = errno; savvmserr = vaxc$errno;
339 success = vmstrnenv(lnm,eqv,idx,
340 secure ? fildev : NULL,
341 #ifdef SECURE_INTERNAL_GETENV
342 secure ? PERL__TRNENV_SECURE : 0
347 /* Discard NOLOGNAM on internal calls since we're often looking
348 * for an optional name, and this "error" often shows up as the
349 * (bogus) exit status for a die() call later on. */
350 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
351 return success ? eqv : Nullch;
354 } /* end of my_getenv() */
358 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
360 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
362 char *buf, *cp1, *cp2;
363 unsigned long idx = 0;
364 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
365 int secure, saverr, savvmserr;
368 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
369 /* Set up a temporary buffer for the return value; Perl will
370 * clean it up at the next statement transition */
371 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
372 if (!tmpsv) return NULL;
375 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
376 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
377 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
378 getcwd(buf,LNM$C_NAMLENGTH);
383 if ((cp2 = strchr(lnm,';')) != NULL) {
386 idx = strtoul(cp2+1,NULL,0);
390 /* Impose security constraints only if tainting */
391 secure = PL_curinterp ? PL_tainting : will_taint;
392 saverr = errno; savvmserr = vaxc$errno;
395 *len = vmstrnenv(lnm,buf,idx,
396 secure ? fildev : NULL,
397 #ifdef SECURE_INTERNAL_GETENV
398 secure ? PERL__TRNENV_SECURE : 0
403 /* Discard NOLOGNAM on internal calls since we're often looking
404 * for an optional name, and this "error" often shows up as the
405 * (bogus) exit status for a die() call later on. */
406 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
407 return *len ? buf : Nullch;
410 } /* end of my_getenv_len() */
413 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
415 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
417 /*{{{ void prime_env_iter() */
420 /* Fill the %ENV associative array with all logical names we can
421 * find, in preparation for iterating over it.
424 static int primed = 0;
425 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 sv = newSVpv(start,0);
502 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
507 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
508 !str$case_blind_compare(&tmpdsc,&clisym)) {
509 strcpy(cmd,"Show Symbol/Global *");
510 cmddsc.dsc$w_length = 20;
511 if (env_tables[i]->dsc$w_length == 12 &&
512 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
513 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
514 flags = defflags | CLI$M_NOLOGNAM;
517 strcpy(cmd,"Show Logical *");
518 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
519 strcat(cmd," /Table=");
520 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
521 cmddsc.dsc$w_length = strlen(cmd);
523 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
524 flags = defflags | CLI$M_NOCLISYM;
527 /* Create a new subprocess to execute each command, to exclude the
528 * remote possibility that someone could subvert a mbx or file used
529 * to write multiple commands to a single subprocess.
532 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
533 0,&riseandshine,0,0,&clidsc,&clitabdsc);
534 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
535 defflags &= ~CLI$M_TRUSTED;
536 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
538 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
539 if (seenhv) SvREFCNT_dec(seenhv);
542 char *cp1, *cp2, *key;
543 unsigned long int sts, iosb[2], retlen, keylen;
546 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
547 if (sts & 1) sts = iosb[0] & 0xffff;
548 if (sts == SS$_ENDOFFILE) {
550 while (substs == 0) { sys$hiber(); wakect++;}
551 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
556 retlen = iosb[0] >> 16;
557 if (!retlen) continue; /* blank line */
559 if (iosb[1] != subpid) {
561 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
565 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
566 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
568 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
569 if (*cp1 == '(' || /* Logical name table name */
570 *cp1 == '=' /* Next eqv of searchlist */) continue;
571 if (*cp1 == '"') cp1++;
572 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
573 key = cp1; keylen = cp2 - cp1;
574 if (keylen && hv_exists(seenhv,key,keylen)) continue;
575 while (*cp2 && *cp2 != '=') cp2++;
576 while (*cp2 && *cp2 == '=') cp2++;
577 while (*cp2 && *cp2 == ' ') cp2++;
578 if (*cp2 == '"') { /* String translation; may embed "" */
579 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
580 cp2++; cp1--; /* Skip "" surrounding translation */
582 else { /* Numeric translation */
583 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
584 cp1--; /* stop on last non-space char */
586 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
587 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
590 PERL_HASH(hash,key,keylen);
591 sv = newSVpvn(cp2,cp1 - cp2 + 1);
593 hv_store(envhv,key,keylen,sv,hash);
594 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
596 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
597 /* get the PPFs for this process, not the subprocess */
598 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
599 char eqv[LNM$C_NAMLENGTH+1];
601 for (i = 0; ppfs[i]; i++) {
602 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
603 sv = newSVpv(eqv,trnlen);
605 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
610 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
611 if (buf) Safefree(buf);
612 if (seenhv) SvREFCNT_dec(seenhv);
613 MUTEX_UNLOCK(&primenv_mutex);
616 } /* end of prime_env_iter */
620 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
621 /* Define or delete an element in the same "environment" as
622 * vmstrnenv(). If an element is to be deleted, it's removed from
623 * the first place it's found. If it's to be set, it's set in the
624 * place designated by the first element of the table vector.
625 * Like setenv() returns 0 for success, non-zero on error.
628 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
630 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
631 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
632 unsigned long int retsts, usermode = PSL$C_USER;
633 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
634 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
635 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
636 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
637 $DESCRIPTOR(local,"_LOCAL");
639 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
640 *cp2 = _toupper(*cp1);
641 if (cp1 - lnm > LNM$C_NAMLENGTH) {
642 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
646 lnmdsc.dsc$w_length = cp1 - lnm;
647 if (!tabvec || !*tabvec) tabvec = env_tables;
649 if (!eqv) { /* we're deleting n element */
650 for (curtab = 0; tabvec[curtab]; curtab++) {
651 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
653 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
654 if ((cp1 = strchr(environ[i],'=')) &&
655 !strncmp(environ[i],lnm,cp1 - environ[i])) {
657 return setenv(lnm,"",1) ? vaxc$errno : 0;
660 ivenv = 1; retsts = SS$_NOLOGNAM;
662 if (ckWARN(WARN_INTERNAL))
663 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
664 ivenv = 1; retsts = SS$_NOSUCHPGM;
670 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
671 !str$case_blind_compare(&tmpdsc,&clisym)) {
672 unsigned int symtype;
673 if (tabvec[curtab]->dsc$w_length == 12 &&
674 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
675 !str$case_blind_compare(&tmpdsc,&local))
676 symtype = LIB$K_CLI_LOCAL_SYM;
677 else symtype = LIB$K_CLI_GLOBAL_SYM;
678 retsts = lib$delete_symbol(&lnmdsc,&symtype);
679 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
680 if (retsts == LIB$_NOSUCHSYM) continue;
684 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
685 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
686 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
687 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
688 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
692 else { /* we're defining a value */
693 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
695 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
697 if (ckWARN(WARN_INTERNAL))
698 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
699 retsts = SS$_NOSUCHPGM;
703 eqvdsc.dsc$a_pointer = eqv;
704 eqvdsc.dsc$w_length = strlen(eqv);
705 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
706 !str$case_blind_compare(&tmpdsc,&clisym)) {
707 unsigned int symtype;
708 if (tabvec[0]->dsc$w_length == 12 &&
709 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
710 !str$case_blind_compare(&tmpdsc,&local))
711 symtype = LIB$K_CLI_LOCAL_SYM;
712 else symtype = LIB$K_CLI_GLOBAL_SYM;
713 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
716 if (!*eqv) eqvdsc.dsc$w_length = 1;
717 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
718 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
719 if (ckWARN(WARN_MISC)) {
720 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
723 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
729 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
730 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
731 set_errno(EVMSERR); break;
732 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
733 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
734 set_errno(EINVAL); break;
741 set_vaxc_errno(retsts);
742 return (int) retsts || 44; /* retsts should never be 0, but just in case */
745 /* We reset error values on success because Perl does an hv_fetch()
746 * before each hv_store(), and if the thing we're setting didn't
747 * previously exist, we've got a leftover error message. (Of course,
748 * this fails in the face of
749 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
750 * in that the error reported in $! isn't spurious,
751 * but it's right more often than not.)
753 set_errno(0); set_vaxc_errno(retsts);
757 } /* end of vmssetenv() */
760 /*{{{ void my_setenv(char *lnm, char *eqv)*/
761 /* This has to be a function since there's a prototype for it in proto.h */
763 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
766 int len = strlen(lnm);
770 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
771 if (!strcmp(uplnm,"DEFAULT")) {
772 if (eqv && *eqv) chdir(eqv);
777 if (len == 6 || len == 2) {
780 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
782 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
783 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
787 (void) vmssetenv(lnm,eqv,NULL);
791 /*{{{static void vmssetuserlnm(char *name, char *eqv);
793 * sets a user-mode logical in the process logical name table
794 * used for redirection of sys$error
797 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
799 $DESCRIPTOR(d_tab, "LNM$PROCESS");
800 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
801 unsigned long int iss, attr = LNM$M_CONFINE;
802 unsigned char acmode = PSL$C_USER;
803 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
805 d_name.dsc$a_pointer = name;
806 d_name.dsc$w_length = strlen(name);
808 lnmlst[0].buflen = strlen(eqv);
809 lnmlst[0].bufadr = eqv;
811 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
812 if (!(iss&1)) lib$signal(iss);
817 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
818 /* my_crypt - VMS password hashing
819 * my_crypt() provides an interface compatible with the Unix crypt()
820 * C library function, and uses sys$hash_password() to perform VMS
821 * password hashing. The quadword hashed password value is returned
822 * as a NUL-terminated 8 character string. my_crypt() does not change
823 * the case of its string arguments; in order to match the behavior
824 * of LOGINOUT et al., alphabetic characters in both arguments must
825 * be upcased by the caller.
828 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
830 # ifndef UAI$C_PREFERRED_ALGORITHM
831 # define UAI$C_PREFERRED_ALGORITHM 127
833 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
834 unsigned short int salt = 0;
835 unsigned long int sts;
837 unsigned short int dsc$w_length;
838 unsigned char dsc$b_type;
839 unsigned char dsc$b_class;
840 const char * dsc$a_pointer;
841 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
842 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
843 struct itmlst_3 uailst[3] = {
844 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
845 { sizeof salt, UAI$_SALT, &salt, 0},
846 { 0, 0, NULL, NULL}};
849 usrdsc.dsc$w_length = strlen(usrname);
850 usrdsc.dsc$a_pointer = usrname;
851 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
853 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
857 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
863 if (sts != RMS$_RNF) return NULL;
866 txtdsc.dsc$w_length = strlen(textpasswd);
867 txtdsc.dsc$a_pointer = textpasswd;
868 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
869 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
872 return (char *) hash;
874 } /* end of my_crypt() */
878 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
879 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
880 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
882 /*{{{int do_rmdir(char *name)*/
884 Perl_do_rmdir(pTHX_ char *name)
886 char dirfile[NAM$C_MAXRSS+1];
890 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
891 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
892 else retval = kill_file(dirfile);
895 } /* end of do_rmdir */
899 * Delete any file to which user has control access, regardless of whether
900 * delete access is explicitly allowed.
901 * Limitations: User must have write access to parent directory.
902 * Does not block signals or ASTs; if interrupted in midstream
903 * may leave file with an altered ACL.
906 /*{{{int kill_file(char *name)*/
908 Perl_kill_file(pTHX_ char *name)
910 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
911 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
912 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
913 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
915 unsigned char myace$b_length;
916 unsigned char myace$b_type;
917 unsigned short int myace$w_flags;
918 unsigned long int myace$l_access;
919 unsigned long int myace$l_ident;
920 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
921 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
922 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
924 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
925 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
926 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
927 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
928 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
929 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
931 /* Expand the input spec using RMS, since the CRTL remove() and
932 * system services won't do this by themselves, so we may miss
933 * a file "hiding" behind a logical name or search list. */
934 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
935 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
936 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
937 /* If not, can changing protections help? */
938 if (vaxc$errno != RMS$_PRV) return -1;
940 /* No, so we get our own UIC to use as a rights identifier,
941 * and the insert an ACE at the head of the ACL which allows us
942 * to delete the file.
944 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
945 fildsc.dsc$w_length = strlen(rspec);
946 fildsc.dsc$a_pointer = rspec;
948 newace.myace$l_ident = oldace.myace$l_ident;
949 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
951 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
952 set_errno(ENOENT); break;
954 set_errno(ENOTDIR); break;
956 set_errno(ENODEV); break;
957 case RMS$_SYN: case SS$_INVFILFOROP:
958 set_errno(EINVAL); break;
960 set_errno(EACCES); break;
964 set_vaxc_errno(aclsts);
967 /* Grab any existing ACEs with this identifier in case we fail */
968 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
969 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
970 || fndsts == SS$_NOMOREACE ) {
971 /* Add the new ACE . . . */
972 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
974 if ((rmsts = remove(name))) {
975 /* We blew it - dir with files in it, no write priv for
976 * parent directory, etc. Put things back the way they were. */
977 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
980 addlst[0].bufadr = &oldace;
981 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
988 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
989 /* We just deleted it, so of course it's not there. Some versions of
990 * VMS seem to return success on the unlock operation anyhow (after all
991 * the unlock is successful), but others don't.
993 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
994 if (aclsts & 1) aclsts = fndsts;
997 set_vaxc_errno(aclsts);
1003 } /* end of kill_file() */
1007 /*{{{int my_mkdir(char *,Mode_t)*/
1009 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1011 STRLEN dirlen = strlen(dir);
1013 /* zero length string sometimes gives ACCVIO */
1014 if (dirlen == 0) return -1;
1016 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1017 * null file name/type. However, it's commonplace under Unix,
1018 * so we'll allow it for a gain in portability.
1020 if (dir[dirlen-1] == '/') {
1021 char *newdir = savepvn(dir,dirlen-1);
1022 int ret = mkdir(newdir,mode);
1026 else return mkdir(dir,mode);
1027 } /* end of my_mkdir */
1030 /*{{{int my_chdir(char *)*/
1032 Perl_my_chdir(pTHX_ char *dir)
1034 STRLEN dirlen = strlen(dir);
1036 /* zero length string sometimes gives ACCVIO */
1037 if (dirlen == 0) return -1;
1039 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1041 * null file name/type. However, it's commonplace under Unix,
1042 * so we'll allow it for a gain in portability.
1044 if (dir[dirlen-1] == '/') {
1045 char *newdir = savepvn(dir,dirlen-1);
1046 int ret = chdir(newdir);
1050 else return chdir(dir);
1051 } /* end of my_chdir */
1055 /*{{{FILE *my_tmpfile()*/
1062 if ((fp = tmpfile())) return fp;
1064 New(1323,cp,L_tmpnam+24,char);
1065 strcpy(cp,"Sys$Scratch:");
1066 tmpnam(cp+strlen(cp));
1067 strcat(cp,".Perltmp");
1068 fp = fopen(cp,"w+","fop=dlt");
1075 #ifndef HOMEGROWN_POSIX_SIGNALS
1077 * The C RTL's sigaction fails to check for invalid signal numbers so we
1078 * help it out a bit. The docs are correct, but the actual routine doesn't
1079 * do what the docs say it will.
1081 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1083 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1084 struct sigaction* oact)
1086 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1087 SETERRNO(EINVAL, SS$_INVARG);
1090 return sigaction(sig, act, oact);
1095 /* default piping mailbox size */
1096 #define PERL_BUFSIZ 512
1100 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1102 unsigned long int mbxbufsiz;
1103 static unsigned long int syssize = 0;
1104 unsigned long int dviitm = DVI$_DEVNAM;
1105 char csize[LNM$C_NAMLENGTH+1];
1108 unsigned long syiitm = SYI$_MAXBUF;
1110 * Get the SYSGEN parameter MAXBUF
1112 * If the logical 'PERL_MBX_SIZE' is defined
1113 * use the value of the logical instead of PERL_BUFSIZ, but
1114 * keep the size between 128 and MAXBUF.
1117 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1120 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1121 mbxbufsiz = atoi(csize);
1123 mbxbufsiz = PERL_BUFSIZ;
1125 if (mbxbufsiz < 128) mbxbufsiz = 128;
1126 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1128 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1130 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1131 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1133 } /* end of create_mbx() */
1136 /*{{{ my_popen and my_pclose*/
1138 typedef struct _iosb IOSB;
1139 typedef struct _iosb* pIOSB;
1140 typedef struct _pipe Pipe;
1141 typedef struct _pipe* pPipe;
1142 typedef struct pipe_details Info;
1143 typedef struct pipe_details* pInfo;
1144 typedef struct _srqp RQE;
1145 typedef struct _srqp* pRQE;
1146 typedef struct _tochildbuf CBuf;
1147 typedef struct _tochildbuf* pCBuf;
1150 unsigned short status;
1151 unsigned short count;
1152 unsigned long dvispec;
1155 #pragma member_alignment save
1156 #pragma nomember_alignment quadword
1157 struct _srqp { /* VMS self-relative queue entry */
1158 unsigned long qptr[2];
1160 #pragma member_alignment restore
1161 static RQE RQE_ZERO = {0,0};
1163 struct _tochildbuf {
1166 unsigned short size;
1174 unsigned short chan_in;
1175 unsigned short chan_out;
1177 unsigned int bufsize;
1189 #if defined(PERL_IMPLICIT_CONTEXT)
1190 void *thx; /* Either a thread or an interpreter */
1191 /* pointer, depending on how we're built */
1199 PerlIO *fp; /* file pointer to pipe mailbox */
1200 int useFILE; /* using stdio, not perlio */
1201 int pid; /* PID of subprocess */
1202 int mode; /* == 'r' if pipe open for reading */
1203 int done; /* subprocess has completed */
1204 int waiting; /* waiting for completion/closure */
1205 int closing; /* my_pclose is closing this pipe */
1206 unsigned long completion; /* termination status of subprocess */
1207 pPipe in; /* pipe in to sub */
1208 pPipe out; /* pipe out of sub */
1209 pPipe err; /* pipe of sub's sys$error */
1210 int in_done; /* true when in pipe finished */
1215 struct exit_control_block
1217 struct exit_control_block *flink;
1218 unsigned long int (*exit_routine)();
1219 unsigned long int arg_count;
1220 unsigned long int *status_address;
1221 unsigned long int exit_status;
1224 #define RETRY_DELAY "0 ::0.20"
1225 #define MAX_RETRY 50
1227 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1228 static unsigned long mypid;
1229 static unsigned long delaytime[2];
1231 static pInfo open_pipes = NULL;
1232 static $DESCRIPTOR(nl_desc, "NL:");
1234 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1238 static unsigned long int
1239 pipe_exit_routine(pTHX)
1242 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1243 int sts, did_stuff, need_eof, j;
1246 flush any pending i/o
1252 PerlIO_flush(info->fp); /* first, flush data */
1254 fflush((FILE *)info->fp);
1260 next we try sending an EOF...ignore if doesn't work, make sure we
1268 _ckvmssts(sys$setast(0));
1269 if (info->in && !info->in->shut_on_empty) {
1270 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1275 _ckvmssts(sys$setast(1));
1279 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1281 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1286 _ckvmssts(sys$setast(0));
1287 if (info->waiting && info->done)
1289 nwait += info->waiting;
1290 _ckvmssts(sys$setast(1));
1300 _ckvmssts(sys$setast(0));
1301 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1302 sts = sys$forcex(&info->pid,0,&abort);
1303 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1306 _ckvmssts(sys$setast(1));
1310 /* again, wait for effect */
1312 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1317 _ckvmssts(sys$setast(0));
1318 if (info->waiting && info->done)
1320 nwait += info->waiting;
1321 _ckvmssts(sys$setast(1));
1330 _ckvmssts(sys$setast(0));
1331 if (!info->done) { /* We tried to be nice . . . */
1332 sts = sys$delprc(&info->pid,0);
1333 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1335 _ckvmssts(sys$setast(1));
1340 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1341 else if (!(sts & 1)) retsts = sts;
1346 static struct exit_control_block pipe_exitblock =
1347 {(struct exit_control_block *) 0,
1348 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1350 static void pipe_mbxtofd_ast(pPipe p);
1351 static void pipe_tochild1_ast(pPipe p);
1352 static void pipe_tochild2_ast(pPipe p);
1355 popen_completion_ast(pInfo info)
1357 pInfo i = open_pipes;
1361 if (i == info) break;
1364 if (!i) return; /* unlinked, probably freed too */
1366 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1370 Writing to subprocess ...
1371 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1373 chan_out may be waiting for "done" flag, or hung waiting
1374 for i/o completion to child...cancel the i/o. This will
1375 put it into "snarf mode" (done but no EOF yet) that discards
1378 Output from subprocess (stdout, stderr) needs to be flushed and
1379 shut down. We try sending an EOF, but if the mbx is full the pipe
1380 routine should still catch the "shut_on_empty" flag, telling it to
1381 use immediate-style reads so that "mbx empty" -> EOF.
1385 if (info->in && !info->in_done) { /* only for mode=w */
1386 if (info->in->shut_on_empty && info->in->need_wake) {
1387 info->in->need_wake = FALSE;
1388 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1390 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1394 if (info->out && !info->out_done) { /* were we also piping output? */
1395 info->out->shut_on_empty = TRUE;
1396 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1397 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1398 _ckvmssts_noperl(iss);
1401 if (info->err && !info->err_done) { /* we were piping stderr */
1402 info->err->shut_on_empty = TRUE;
1403 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1404 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1405 _ckvmssts_noperl(iss);
1407 _ckvmssts_noperl(sys$setef(pipe_ef));
1411 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
1412 static void vms_execfree(pTHX);
1415 we actually differ from vmstrnenv since we use this to
1416 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1417 are pointing to the same thing
1420 static unsigned short
1421 popen_translate(pTHX_ char *logical, char *result)
1424 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1425 $DESCRIPTOR(d_log,"");
1427 unsigned short length;
1428 unsigned short code;
1430 unsigned short *retlenaddr;
1432 unsigned short l, ifi;
1434 d_log.dsc$a_pointer = logical;
1435 d_log.dsc$w_length = strlen(logical);
1437 itmlst[0].code = LNM$_STRING;
1438 itmlst[0].length = 255;
1439 itmlst[0].buffer_addr = result;
1440 itmlst[0].retlenaddr = &l;
1443 itmlst[1].length = 0;
1444 itmlst[1].buffer_addr = 0;
1445 itmlst[1].retlenaddr = 0;
1447 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1448 if (iss == SS$_NOLOGNAM) {
1452 if (!(iss&1)) lib$signal(iss);
1455 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1456 strip it off and return the ifi, if any
1459 if (result[0] == 0x1b && result[1] == 0x00) {
1460 memcpy(&ifi,result+2,2);
1461 strcpy(result,result+4);
1463 return ifi; /* this is the RMS internal file id */
1466 #define MAX_DCL_SYMBOL 255
1467 static void pipe_infromchild_ast(pPipe p);
1470 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1471 inside an AST routine without worrying about reentrancy and which Perl
1472 memory allocator is being used.
1474 We read data and queue up the buffers, then spit them out one at a
1475 time to the output mailbox when the output mailbox is ready for one.
1478 #define INITIAL_TOCHILDQUEUE 2
1481 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1485 char mbx1[64], mbx2[64];
1486 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1487 DSC$K_CLASS_S, mbx1},
1488 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1489 DSC$K_CLASS_S, mbx2};
1490 unsigned int dviitm = DVI$_DEVBUFSIZ;
1493 New(1368, p, 1, Pipe);
1495 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1496 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1497 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1500 p->shut_on_empty = FALSE;
1501 p->need_wake = FALSE;
1504 p->iosb.status = SS$_NORMAL;
1505 p->iosb2.status = SS$_NORMAL;
1511 #ifdef PERL_IMPLICIT_CONTEXT
1515 n = sizeof(CBuf) + p->bufsize;
1517 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1518 _ckvmssts(lib$get_vm(&n, &b));
1519 b->buf = (char *) b + sizeof(CBuf);
1520 _ckvmssts(lib$insqhi(b, &p->free));
1523 pipe_tochild2_ast(p);
1524 pipe_tochild1_ast(p);
1530 /* reads the MBX Perl is writing, and queues */
1533 pipe_tochild1_ast(pPipe p)
1536 int iss = p->iosb.status;
1537 int eof = (iss == SS$_ENDOFFILE);
1538 #ifdef PERL_IMPLICIT_CONTEXT
1544 p->shut_on_empty = TRUE;
1546 _ckvmssts(sys$dassgn(p->chan_in));
1552 b->size = p->iosb.count;
1553 _ckvmssts(lib$insqhi(b, &p->wait));
1555 p->need_wake = FALSE;
1556 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1559 p->retry = 1; /* initial call */
1562 if (eof) { /* flush the free queue, return when done */
1563 int n = sizeof(CBuf) + p->bufsize;
1565 iss = lib$remqti(&p->free, &b);
1566 if (iss == LIB$_QUEWASEMP) return;
1568 _ckvmssts(lib$free_vm(&n, &b));
1572 iss = lib$remqti(&p->free, &b);
1573 if (iss == LIB$_QUEWASEMP) {
1574 int n = sizeof(CBuf) + p->bufsize;
1575 _ckvmssts(lib$get_vm(&n, &b));
1576 b->buf = (char *) b + sizeof(CBuf);
1582 iss = sys$qio(0,p->chan_in,
1583 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1585 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1586 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1591 /* writes queued buffers to output, waits for each to complete before
1595 pipe_tochild2_ast(pPipe p)
1598 int iss = p->iosb2.status;
1599 int n = sizeof(CBuf) + p->bufsize;
1600 int done = (p->info && p->info->done) ||
1601 iss == SS$_CANCEL || iss == SS$_ABORT;
1602 #if defined(PERL_IMPLICIT_CONTEXT)
1607 if (p->type) { /* type=1 has old buffer, dispose */
1608 if (p->shut_on_empty) {
1609 _ckvmssts(lib$free_vm(&n, &b));
1611 _ckvmssts(lib$insqhi(b, &p->free));
1616 iss = lib$remqti(&p->wait, &b);
1617 if (iss == LIB$_QUEWASEMP) {
1618 if (p->shut_on_empty) {
1620 _ckvmssts(sys$dassgn(p->chan_out));
1621 *p->pipe_done = TRUE;
1622 _ckvmssts(sys$setef(pipe_ef));
1624 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1625 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1629 p->need_wake = TRUE;
1639 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1640 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1642 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1643 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1652 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1655 char mbx1[64], mbx2[64];
1656 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1657 DSC$K_CLASS_S, mbx1},
1658 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1659 DSC$K_CLASS_S, mbx2};
1660 unsigned int dviitm = DVI$_DEVBUFSIZ;
1662 New(1367, p, 1, Pipe);
1663 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1664 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1666 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1667 New(1367, p->buf, p->bufsize, char);
1668 p->shut_on_empty = FALSE;
1671 p->iosb.status = SS$_NORMAL;
1672 #if defined(PERL_IMPLICIT_CONTEXT)
1675 pipe_infromchild_ast(p);
1683 pipe_infromchild_ast(pPipe p)
1685 int iss = p->iosb.status;
1686 int eof = (iss == SS$_ENDOFFILE);
1687 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1688 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1689 #if defined(PERL_IMPLICIT_CONTEXT)
1693 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1694 _ckvmssts(sys$dassgn(p->chan_out));
1699 input shutdown if EOF from self (done or shut_on_empty)
1700 output shutdown if closing flag set (my_pclose)
1701 send data/eof from child or eof from self
1702 otherwise, re-read (snarf of data from child)
1707 if (myeof && p->chan_in) { /* input shutdown */
1708 _ckvmssts(sys$dassgn(p->chan_in));
1713 if (myeof || kideof) { /* pass EOF to parent */
1714 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1715 pipe_infromchild_ast, p,
1718 } else if (eof) { /* eat EOF --- fall through to read*/
1720 } else { /* transmit data */
1721 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1722 pipe_infromchild_ast,p,
1723 p->buf, p->iosb.count, 0, 0, 0, 0));
1729 /* everything shut? flag as done */
1731 if (!p->chan_in && !p->chan_out) {
1732 *p->pipe_done = TRUE;
1733 _ckvmssts(sys$setef(pipe_ef));
1737 /* write completed (or read, if snarfing from child)
1738 if still have input active,
1739 queue read...immediate mode if shut_on_empty so we get EOF if empty
1741 check if Perl reading, generate EOFs as needed
1747 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1748 pipe_infromchild_ast,p,
1749 p->buf, p->bufsize, 0, 0, 0, 0);
1750 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1752 } else { /* send EOFs for extra reads */
1753 p->iosb.status = SS$_ENDOFFILE;
1754 p->iosb.dvispec = 0;
1755 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1757 pipe_infromchild_ast, p, 0, 0, 0, 0));
1763 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1767 unsigned long dviitm = DVI$_DEVBUFSIZ;
1769 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1770 DSC$K_CLASS_S, mbx};
1772 /* things like terminals and mbx's don't need this filter */
1773 if (fd && fstat(fd,&s) == 0) {
1774 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1775 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1776 DSC$K_CLASS_S, s.st_dev};
1778 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1779 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1780 strcpy(out, s.st_dev);
1785 New(1366, p, 1, Pipe);
1786 p->fd_out = dup(fd);
1787 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1788 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1789 New(1366, p->buf, p->bufsize+1, char);
1790 p->shut_on_empty = FALSE;
1795 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1796 pipe_mbxtofd_ast, p,
1797 p->buf, p->bufsize, 0, 0, 0, 0));
1803 pipe_mbxtofd_ast(pPipe p)
1805 int iss = p->iosb.status;
1806 int done = p->info->done;
1808 int eof = (iss == SS$_ENDOFFILE);
1809 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1810 int err = !(iss&1) && !eof;
1811 #if defined(PERL_IMPLICIT_CONTEXT)
1815 if (done && myeof) { /* end piping */
1817 sys$dassgn(p->chan_in);
1818 *p->pipe_done = TRUE;
1819 _ckvmssts(sys$setef(pipe_ef));
1823 if (!err && !eof) { /* good data to send to file */
1824 p->buf[p->iosb.count] = '\n';
1825 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1828 if (p->retry < MAX_RETRY) {
1829 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1839 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1840 pipe_mbxtofd_ast, p,
1841 p->buf, p->bufsize, 0, 0, 0, 0);
1842 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1847 typedef struct _pipeloc PLOC;
1848 typedef struct _pipeloc* pPLOC;
1852 char dir[NAM$C_MAXRSS+1];
1854 static pPLOC head_PLOC = 0;
1857 free_pipelocs(pTHX_ void *head)
1860 pPLOC *pHead = (pPLOC *)head;
1872 store_pipelocs(pTHX)
1881 char temp[NAM$C_MAXRSS+1];
1885 free_pipelocs(&head_PLOC);
1887 /* the . directory from @INC comes last */
1890 p->next = head_PLOC;
1892 strcpy(p->dir,"./");
1894 /* get the directory from $^X */
1896 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1897 strcpy(temp, PL_origargv[0]);
1898 x = strrchr(temp,']');
1901 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1903 p->next = head_PLOC;
1905 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1906 p->dir[NAM$C_MAXRSS] = '\0';
1910 /* reverse order of @INC entries, skip "." since entered above */
1912 if (PL_incgv) av = GvAVn(PL_incgv);
1914 for (i = 0; av && i <= AvFILL(av); i++) {
1915 dirsv = *av_fetch(av,i,TRUE);
1917 if (SvROK(dirsv)) continue;
1918 dir = SvPVx(dirsv,n_a);
1919 if (strcmp(dir,".") == 0) continue;
1920 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1924 p->next = head_PLOC;
1926 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1927 p->dir[NAM$C_MAXRSS] = '\0';
1930 /* most likely spot (ARCHLIB) put first in the list */
1933 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1935 p->next = head_PLOC;
1937 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1938 p->dir[NAM$C_MAXRSS] = '\0';
1941 Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
1948 static int vmspipe_file_status = 0;
1949 static char vmspipe_file[NAM$C_MAXRSS+1];
1951 /* already found? Check and use ... need read+execute permission */
1953 if (vmspipe_file_status == 1) {
1954 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1955 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1956 return vmspipe_file;
1958 vmspipe_file_status = 0;
1961 /* scan through stored @INC, $^X */
1963 if (vmspipe_file_status == 0) {
1964 char file[NAM$C_MAXRSS+1];
1965 pPLOC p = head_PLOC;
1968 strcpy(file, p->dir);
1969 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1970 file[NAM$C_MAXRSS] = '\0';
1973 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1975 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1976 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1977 vmspipe_file_status = 1;
1978 return vmspipe_file;
1981 vmspipe_file_status = -1; /* failed, use tempfiles */
1988 vmspipe_tempfile(pTHX)
1990 char file[NAM$C_MAXRSS+1];
1992 static int index = 0;
1995 /* create a tempfile */
1997 /* we can't go from W, shr=get to R, shr=get without
1998 an intermediate vulnerable state, so don't bother trying...
2000 and lib$spawn doesn't shr=put, so have to close the write
2002 So... match up the creation date/time and the FID to
2003 make sure we're dealing with the same file
2008 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2009 fp = fopen(file,"w");
2011 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2012 fp = fopen(file,"w");
2014 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2015 fp = fopen(file,"w");
2018 if (!fp) return 0; /* we're hosed */
2020 fprintf(fp,"$! 'f$verify(0)\n");
2021 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2022 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2023 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2024 fprintf(fp,"$ perl_on = \"set noon\"\n");
2025 fprintf(fp,"$ perl_exit = \"exit\"\n");
2026 fprintf(fp,"$ perl_del = \"delete\"\n");
2027 fprintf(fp,"$ pif = \"if\"\n");
2028 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2029 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2030 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2031 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2032 fprintf(fp,"$ cmd = perl_popen_cmd\n");
2033 fprintf(fp,"$! --- get rid of global symbols\n");
2034 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2035 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2036 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2037 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
2038 fprintf(fp,"$ perl_on\n");
2039 fprintf(fp,"$ 'cmd\n");
2040 fprintf(fp,"$ perl_status = $STATUS\n");
2041 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2042 fprintf(fp,"$ perl_exit 'perl_status'\n");
2045 fgetname(fp, file, 1);
2046 fstat(fileno(fp), &s0);
2049 fp = fopen(file,"r","shr=get");
2051 fstat(fileno(fp), &s1);
2053 if (s0.st_ino[0] != s1.st_ino[0] ||
2054 s0.st_ino[1] != s1.st_ino[1] ||
2055 s0.st_ino[2] != s1.st_ino[2] ||
2056 s0.st_ctime != s1.st_ctime ) {
2067 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2069 static int handler_set_up = FALSE;
2070 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2071 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2073 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2074 char in[512], out[512], err[512], mbx[512];
2076 char tfilebuf[NAM$C_MAXRSS+1];
2078 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2079 DSC$K_CLASS_S, symbol};
2080 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2083 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2084 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2085 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2086 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2088 /* once-per-program initialization...
2089 note that the SETAST calls and the dual test of pipe_ef
2090 makes sure that only the FIRST thread through here does
2091 the initialization...all other threads wait until it's
2094 Yeah, uglier than a pthread call, it's got all the stuff inline
2095 rather than in a separate routine.
2099 _ckvmssts(sys$setast(0));
2101 unsigned long int pidcode = JPI$_PID;
2102 $DESCRIPTOR(d_delay, RETRY_DELAY);
2103 _ckvmssts(lib$get_ef(&pipe_ef));
2104 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2105 _ckvmssts(sys$bintim(&d_delay, delaytime));
2107 if (!handler_set_up) {
2108 _ckvmssts(sys$dclexh(&pipe_exitblock));
2109 handler_set_up = TRUE;
2111 _ckvmssts(sys$setast(1));
2114 /* see if we can find a VMSPIPE.COM */
2117 vmspipe = find_vmspipe(aTHX);
2119 strcpy(tfilebuf+1,vmspipe);
2120 } else { /* uh, oh...we're in tempfile hell */
2121 tpipe = vmspipe_tempfile(aTHX);
2122 if (!tpipe) { /* a fish popular in Boston */
2123 if (ckWARN(WARN_PIPE)) {
2124 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2128 fgetname(tpipe,tfilebuf+1,1);
2130 vmspipedsc.dsc$a_pointer = tfilebuf;
2131 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2133 sts = setup_cmddsc(aTHX_ cmd,0,0);
2136 case RMS$_FNF: case RMS$_DNF:
2137 set_errno(ENOENT); break;
2139 set_errno(ENOTDIR); break;
2141 set_errno(ENODEV); break;
2143 set_errno(EACCES); break;
2145 set_errno(EINVAL); break;
2146 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2147 set_errno(E2BIG); break;
2148 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2149 _ckvmssts(sts); /* fall through */
2150 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2153 set_vaxc_errno(sts);
2154 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2155 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2160 New(1301,info,1,Info);
2162 strcpy(mode,in_mode);
2165 info->completion = 0;
2166 info->closing = FALSE;
2173 info->in_done = TRUE;
2174 info->out_done = TRUE;
2175 info->err_done = TRUE;
2176 in[0] = out[0] = err[0] = '\0';
2178 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2182 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2187 if (*mode == 'r') { /* piping from subroutine */
2189 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2191 info->out->pipe_done = &info->out_done;
2192 info->out_done = FALSE;
2193 info->out->info = info;
2195 if (!info->useFILE) {
2196 info->fp = PerlIO_open(mbx, mode);
2198 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2199 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2202 if (!info->fp && info->out) {
2203 sys$cancel(info->out->chan_out);
2205 while (!info->out_done) {
2207 _ckvmssts(sys$setast(0));
2208 done = info->out_done;
2209 if (!done) _ckvmssts(sys$clref(pipe_ef));
2210 _ckvmssts(sys$setast(1));
2211 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2214 if (info->out->buf) Safefree(info->out->buf);
2215 Safefree(info->out);
2221 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2223 info->err->pipe_done = &info->err_done;
2224 info->err_done = FALSE;
2225 info->err->info = info;
2228 } else if (*mode == 'w') { /* piping to subroutine */
2230 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2232 info->out->pipe_done = &info->out_done;
2233 info->out_done = FALSE;
2234 info->out->info = info;
2237 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2239 info->err->pipe_done = &info->err_done;
2240 info->err_done = FALSE;
2241 info->err->info = info;
2244 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2245 if (!info->useFILE) {
2246 info->fp = PerlIO_open(mbx, mode);
2248 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2249 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2253 info->in->pipe_done = &info->in_done;
2254 info->in_done = FALSE;
2255 info->in->info = info;
2259 if (!info->fp && info->in) {
2261 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2262 0, 0, 0, 0, 0, 0, 0, 0));
2264 while (!info->in_done) {
2266 _ckvmssts(sys$setast(0));
2267 done = info->in_done;
2268 if (!done) _ckvmssts(sys$clref(pipe_ef));
2269 _ckvmssts(sys$setast(1));
2270 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2273 if (info->in->buf) Safefree(info->in->buf);
2281 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2282 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2284 info->out->pipe_done = &info->out_done;
2285 info->out_done = FALSE;
2286 info->out->info = info;
2289 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2291 info->err->pipe_done = &info->err_done;
2292 info->err_done = FALSE;
2293 info->err->info = info;
2297 symbol[MAX_DCL_SYMBOL] = '\0';
2299 strncpy(symbol, in, MAX_DCL_SYMBOL);
2300 d_symbol.dsc$w_length = strlen(symbol);
2301 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2303 strncpy(symbol, err, MAX_DCL_SYMBOL);
2304 d_symbol.dsc$w_length = strlen(symbol);
2305 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2307 strncpy(symbol, out, MAX_DCL_SYMBOL);
2308 d_symbol.dsc$w_length = strlen(symbol);
2309 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2311 p = VMSCMD.dsc$a_pointer;
2312 while (*p && *p != '\n') p++;
2313 *p = '\0'; /* truncate on \n */
2314 p = VMSCMD.dsc$a_pointer;
2315 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2316 if (*p == '$') p++; /* remove leading $ */
2317 while (*p == ' ' || *p == '\t') p++;
2318 strncpy(symbol, p, MAX_DCL_SYMBOL);
2319 d_symbol.dsc$w_length = strlen(symbol);
2320 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2322 _ckvmssts(sys$setast(0));
2323 info->next=open_pipes; /* prepend to list */
2325 _ckvmssts(sys$setast(1));
2326 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2327 0, &info->pid, &info->completion,
2328 0, popen_completion_ast,info,0,0,0));
2330 /* if we were using a tempfile, close it now */
2332 if (tpipe) fclose(tpipe);
2334 /* once the subprocess is spawned, it has copied the symbols and
2335 we can get rid of ours */
2337 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2338 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2339 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2340 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2343 PL_forkprocess = info->pid;
2347 _ckvmssts(sys$setast(0));
2349 if (!done) _ckvmssts(sys$clref(pipe_ef));
2350 _ckvmssts(sys$setast(1));
2351 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2353 *psts = info->completion;
2354 my_pclose(info->fp);
2359 } /* end of safe_popen */
2362 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2364 Perl_my_popen(pTHX_ char *cmd, char *mode)
2368 TAINT_PROPER("popen");
2369 PERL_FLUSHALL_FOR_CHILD;
2370 return safe_popen(aTHX_ cmd,mode,&sts);
2375 /*{{{ I32 my_pclose(PerlIO *fp)*/
2376 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2378 pInfo info, last = NULL;
2379 unsigned long int retsts;
2382 for (info = open_pipes; info != NULL; last = info, info = info->next)
2383 if (info->fp == fp) break;
2385 if (info == NULL) { /* no such pipe open */
2386 set_errno(ECHILD); /* quoth POSIX */
2387 set_vaxc_errno(SS$_NONEXPR);
2391 /* If we were writing to a subprocess, insure that someone reading from
2392 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2393 * produce an EOF record in the mailbox.
2395 * well, at least sometimes it *does*, so we have to watch out for
2396 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2400 PerlIO_flush(info->fp); /* first, flush data */
2402 fflush((FILE *)info->fp);
2405 _ckvmssts(sys$setast(0));
2406 info->closing = TRUE;
2407 done = info->done && info->in_done && info->out_done && info->err_done;
2408 /* hanging on write to Perl's input? cancel it */
2409 if (info->mode == 'r' && info->out && !info->out_done) {
2410 if (info->out->chan_out) {
2411 _ckvmssts(sys$cancel(info->out->chan_out));
2412 if (!info->out->chan_in) { /* EOF generation, need AST */
2413 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2417 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2418 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2420 _ckvmssts(sys$setast(1));
2423 PerlIO_close(info->fp);
2425 fclose((FILE *)info->fp);
2428 we have to wait until subprocess completes, but ALSO wait until all
2429 the i/o completes...otherwise we'll be freeing the "info" structure
2430 that the i/o ASTs could still be using...
2434 _ckvmssts(sys$setast(0));
2435 done = info->done && info->in_done && info->out_done && info->err_done;
2436 if (!done) _ckvmssts(sys$clref(pipe_ef));
2437 _ckvmssts(sys$setast(1));
2438 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2440 retsts = info->completion;
2442 /* remove from list of open pipes */
2443 _ckvmssts(sys$setast(0));
2444 if (last) last->next = info->next;
2445 else open_pipes = info->next;
2446 _ckvmssts(sys$setast(1));
2448 /* free buffers and structures */
2451 if (info->in->buf) Safefree(info->in->buf);
2455 if (info->out->buf) Safefree(info->out->buf);
2456 Safefree(info->out);
2459 if (info->err->buf) Safefree(info->err->buf);
2460 Safefree(info->err);
2466 } /* end of my_pclose() */
2468 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2469 /* Roll our own prototype because we want this regardless of whether
2470 * _VMS_WAIT is defined.
2472 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2474 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2475 created with popen(); otherwise partially emulate waitpid() unless
2476 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2477 Also check processes not considered by the CRTL waitpid().
2479 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2481 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2487 if (statusp) *statusp = 0;
2489 for (info = open_pipes; info != NULL; info = info->next)
2490 if (info->pid == pid) break;
2492 if (info != NULL) { /* we know about this child */
2493 while (!info->done) {
2494 _ckvmssts(sys$setast(0));
2496 if (!done) _ckvmssts(sys$clref(pipe_ef));
2497 _ckvmssts(sys$setast(1));
2498 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2501 if (statusp) *statusp = info->completion;
2505 else { /* this child is not one of our own pipe children */
2507 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2509 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2510 * in 7.2 did we get a version that fills in the VMS completion
2511 * status as Perl has always tried to do.
2514 sts = __vms_waitpid( pid, statusp, flags );
2516 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2519 /* If the real waitpid tells us the child does not exist, we
2520 * fall through here to implement waiting for a child that
2521 * was created by some means other than exec() (say, spawned
2522 * from DCL) or to wait for a process that is not a subprocess
2523 * of the current process.
2526 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2528 $DESCRIPTOR(intdsc,"0 00:00:01");
2529 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2530 unsigned long int pidcode = JPI$_PID, mypid;
2531 unsigned long int interval[2];
2532 int termination_mbu = 0;
2533 unsigned short qio_iosb[4];
2534 unsigned int jpi_iosb[2];
2535 struct itmlst_3 jpilist[3] = {
2536 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2537 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2540 char trmmbx[NAM$C_DVI+1];
2541 $DESCRIPTOR(trmmbxdsc,trmmbx);
2542 struct accdef trmmsg;
2543 unsigned short int mbxchan;
2546 /* Sorry folks, we don't presently implement rooting around for
2547 the first child we can find, and we definitely don't want to
2548 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2554 /* Get the owner of the child so I can warn if it's not mine, plus
2555 * get the termination mailbox. If the process doesn't exist or I
2556 * don't have the privs to look at it, I can go home early.
2558 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2559 if (sts & 1) sts = jpi_iosb[0];
2571 set_vaxc_errno(sts);
2575 if (ckWARN(WARN_EXEC)) {
2576 /* remind folks they are asking for non-standard waitpid behavior */
2577 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2578 if (ownerpid != mypid)
2579 Perl_warner(aTHX_ WARN_EXEC,
2580 "waitpid: process %x is not a child of process %x",
2584 /* It's possible to have a mailbox unit number but no actual mailbox; we
2585 * check for this by assigning a channel to it, which we need anyway.
2587 if (termination_mbu != 0) {
2588 sprintf(trmmbx, "MBA%d:", termination_mbu);
2589 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2590 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2591 if (sts == SS$_NOSUCHDEV) {
2592 termination_mbu = 0; /* set up to take "no mailbox" case */
2597 /* If the process doesn't have a termination mailbox, then simply check
2598 * on it once a second until it's not there anymore.
2600 if (termination_mbu == 0) {
2601 _ckvmssts(sys$bintim(&intdsc,interval));
2602 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2603 _ckvmssts(sys$schdwk(0,0,interval,0));
2604 _ckvmssts(sys$hiber());
2606 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2609 /* If we do have a termination mailbox, post reads to it until we get a
2610 * termination message, discarding messages of the wrong type or for other
2611 * processes. If there is a place to put the final status, then do so.
2615 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2616 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2617 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2618 if (sts & 1) sts = qio_iosb[0];
2621 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2622 && trmmsg.acc$l_pid == pid ) {
2624 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2625 sts = sys$dassgn(mbxchan);
2629 } /* termination_mbu ? */
2634 } /* else one of our own pipe children */
2636 } /* end of waitpid() */
2641 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2643 my_gconvert(double val, int ndig, int trail, char *buf)
2645 static char __gcvtbuf[DBL_DIG+1];
2648 loc = buf ? buf : __gcvtbuf;
2650 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2652 sprintf(loc,"%.*g",ndig,val);
2658 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2659 return gcvt(val,ndig,loc);
2662 loc[0] = '0'; loc[1] = '\0';
2670 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2671 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2672 * to expand file specification. Allows for a single default file
2673 * specification and a simple mask of options. If outbuf is non-NULL,
2674 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2675 * the resultant file specification is placed. If outbuf is NULL, the
2676 * resultant file specification is placed into a static buffer.
2677 * The third argument, if non-NULL, is taken to be a default file
2678 * specification string. The fourth argument is unused at present.
2679 * rmesexpand() returns the address of the resultant string if
2680 * successful, and NULL on error.
2682 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2685 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2687 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2688 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2689 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2690 struct FAB myfab = cc$rms_fab;
2691 struct NAM mynam = cc$rms_nam;
2693 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2695 if (!filespec || !*filespec) {
2696 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2700 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2701 else outbuf = __rmsexpand_retbuf;
2703 if ((isunix = (strchr(filespec,'/') != NULL))) {
2704 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2705 filespec = vmsfspec;
2708 myfab.fab$l_fna = filespec;
2709 myfab.fab$b_fns = strlen(filespec);
2710 myfab.fab$l_nam = &mynam;
2712 if (defspec && *defspec) {
2713 if (strchr(defspec,'/') != NULL) {
2714 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2717 myfab.fab$l_dna = defspec;
2718 myfab.fab$b_dns = strlen(defspec);
2721 mynam.nam$l_esa = esa;
2722 mynam.nam$b_ess = sizeof esa;
2723 mynam.nam$l_rsa = outbuf;
2724 mynam.nam$b_rss = NAM$C_MAXRSS;
2726 retsts = sys$parse(&myfab,0,0);
2727 if (!(retsts & 1)) {
2728 mynam.nam$b_nop |= NAM$M_SYNCHK;
2729 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2730 retsts = sys$parse(&myfab,0,0);
2731 if (retsts & 1) goto expanded;
2733 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2734 (void) sys$parse(&myfab,0,0); /* Free search context */
2735 if (out) Safefree(out);
2736 set_vaxc_errno(retsts);
2737 if (retsts == RMS$_PRV) set_errno(EACCES);
2738 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2739 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2740 else set_errno(EVMSERR);
2743 retsts = sys$search(&myfab,0,0);
2744 if (!(retsts & 1) && retsts != RMS$_FNF) {
2745 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2746 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2747 if (out) Safefree(out);
2748 set_vaxc_errno(retsts);
2749 if (retsts == RMS$_PRV) set_errno(EACCES);
2750 else set_errno(EVMSERR);
2754 /* If the input filespec contained any lowercase characters,
2755 * downcase the result for compatibility with Unix-minded code. */
2757 for (out = myfab.fab$l_fna; *out; out++)
2758 if (islower(*out)) { haslower = 1; break; }
2759 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2760 else { out = esa; speclen = mynam.nam$b_esl; }
2761 /* Trim off null fields added by $PARSE
2762 * If type > 1 char, must have been specified in original or default spec
2763 * (not true for version; $SEARCH may have added version of existing file).
2765 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2766 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2767 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2768 if (trimver || trimtype) {
2769 if (defspec && *defspec) {
2770 char defesa[NAM$C_MAXRSS];
2771 struct FAB deffab = cc$rms_fab;
2772 struct NAM defnam = cc$rms_nam;
2774 deffab.fab$l_nam = &defnam;
2775 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2776 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2777 defnam.nam$b_nop = NAM$M_SYNCHK;
2778 if (sys$parse(&deffab,0,0) & 1) {
2779 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2780 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2783 if (trimver) speclen = mynam.nam$l_ver - out;
2785 /* If we didn't already trim version, copy down */
2786 if (speclen > mynam.nam$l_ver - out)
2787 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2788 speclen - (mynam.nam$l_ver - out));
2789 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2792 /* If we just had a directory spec on input, $PARSE "helpfully"
2793 * adds an empty name and type for us */
2794 if (mynam.nam$l_name == mynam.nam$l_type &&
2795 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2796 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2797 speclen = mynam.nam$l_name - out;
2798 out[speclen] = '\0';
2799 if (haslower) __mystrtolower(out);
2801 /* Have we been working with an expanded, but not resultant, spec? */
2802 /* Also, convert back to Unix syntax if necessary. */
2803 if (!mynam.nam$b_rsl) {
2805 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2807 else strcpy(outbuf,esa);
2810 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2811 strcpy(outbuf,tmpfspec);
2813 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2814 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2815 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2819 /* External entry points */
2820 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2821 { return do_rmsexpand(spec,buf,0,def,opt); }
2822 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2823 { return do_rmsexpand(spec,buf,1,def,opt); }
2827 ** The following routines are provided to make life easier when
2828 ** converting among VMS-style and Unix-style directory specifications.
2829 ** All will take input specifications in either VMS or Unix syntax. On
2830 ** failure, all return NULL. If successful, the routines listed below
2831 ** return a pointer to a buffer containing the appropriately
2832 ** reformatted spec (and, therefore, subsequent calls to that routine
2833 ** will clobber the result), while the routines of the same names with
2834 ** a _ts suffix appended will return a pointer to a mallocd string
2835 ** containing the appropriately reformatted spec.
2836 ** In all cases, only explicit syntax is altered; no check is made that
2837 ** the resulting string is valid or that the directory in question
2840 ** fileify_dirspec() - convert a directory spec into the name of the
2841 ** directory file (i.e. what you can stat() to see if it's a dir).
2842 ** The style (VMS or Unix) of the result is the same as the style
2843 ** of the parameter passed in.
2844 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2845 ** what you prepend to a filename to indicate what directory it's in).
2846 ** The style (VMS or Unix) of the result is the same as the style
2847 ** of the parameter passed in.
2848 ** tounixpath() - convert a directory spec into a Unix-style path.
2849 ** tovmspath() - convert a directory spec into a VMS-style path.
2850 ** tounixspec() - convert any file spec into a Unix-style file spec.
2851 ** tovmsspec() - convert any file spec into a VMS-style spec.
2853 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2854 ** Permission is given to distribute this code as part of the Perl
2855 ** standard distribution under the terms of the GNU General Public
2856 ** License or the Perl Artistic License. Copies of each may be
2857 ** found in the Perl standard distribution.
2860 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2861 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2863 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2864 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2865 char *retspec, *cp1, *cp2, *lastdir;
2866 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2868 if (!dir || !*dir) {
2869 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2871 dirlen = strlen(dir);
2872 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2873 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2874 strcpy(trndir,"/sys$disk/000000");
2878 if (dirlen > NAM$C_MAXRSS) {
2879 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2881 if (!strpbrk(dir+1,"/]>:")) {
2882 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2883 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2885 dirlen = strlen(dir);
2888 strncpy(trndir,dir,dirlen);
2889 trndir[dirlen] = '\0';
2892 /* If we were handed a rooted logical name or spec, treat it like a
2893 * simple directory, so that
2894 * $ Define myroot dev:[dir.]
2895 * ... do_fileify_dirspec("myroot",buf,1) ...
2896 * does something useful.
2898 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2899 dir[--dirlen] = '\0';
2900 dir[dirlen-1] = ']';
2902 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
2903 dir[--dirlen] = '\0';
2904 dir[dirlen-1] = '>';
2907 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2908 /* If we've got an explicit filename, we can just shuffle the string. */
2909 if (*(cp1+1)) hasfilename = 1;
2910 /* Similarly, we can just back up a level if we've got multiple levels
2911 of explicit directories in a VMS spec which ends with directories. */
2913 for (cp2 = cp1; cp2 > dir; cp2--) {
2915 *cp2 = *cp1; *cp1 = '\0';
2919 if (*cp2 == '[' || *cp2 == '<') break;
2924 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2925 if (dir[0] == '.') {
2926 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2927 return do_fileify_dirspec("[]",buf,ts);
2928 else if (dir[1] == '.' &&
2929 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2930 return do_fileify_dirspec("[-]",buf,ts);
2932 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2933 dirlen -= 1; /* to last element */
2934 lastdir = strrchr(dir,'/');
2936 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2937 /* If we have "/." or "/..", VMSify it and let the VMS code
2938 * below expand it, rather than repeating the code to handle
2939 * relative components of a filespec here */
2941 if (*(cp1+2) == '.') cp1++;
2942 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2943 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2944 if (strchr(vmsdir,'/') != NULL) {
2945 /* If do_tovmsspec() returned it, it must have VMS syntax
2946 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2947 * the time to check this here only so we avoid a recursion
2948 * loop; otherwise, gigo.
2950 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2952 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2953 return do_tounixspec(trndir,buf,ts);
2956 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2957 lastdir = strrchr(dir,'/');
2959 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2960 /* Ditto for specs that end in an MFD -- let the VMS code
2961 * figure out whether it's a real device or a rooted logical. */
2962 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2963 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2964 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2965 return do_tounixspec(trndir,buf,ts);
2968 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2969 !(lastdir = cp1 = strrchr(dir,']')) &&
2970 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2971 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2973 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2974 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2975 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2976 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2977 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2978 (ver || *cp3)))))) {
2980 set_vaxc_errno(RMS$_DIR);
2986 /* If we lead off with a device or rooted logical, add the MFD
2987 if we're specifying a top-level directory. */
2988 if (lastdir && *dir == '/') {
2990 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2997 retlen = dirlen + (addmfd ? 13 : 6);
2998 if (buf) retspec = buf;
2999 else if (ts) New(1309,retspec,retlen+1,char);
3000 else retspec = __fileify_retbuf;
3002 dirlen = lastdir - dir;
3003 memcpy(retspec,dir,dirlen);
3004 strcpy(&retspec[dirlen],"/000000");
3005 strcpy(&retspec[dirlen+7],lastdir);
3008 memcpy(retspec,dir,dirlen);
3009 retspec[dirlen] = '\0';
3011 /* We've picked up everything up to the directory file name.
3012 Now just add the type and version, and we're set. */
3013 strcat(retspec,".dir;1");
3016 else { /* VMS-style directory spec */
3017 char esa[NAM$C_MAXRSS+1], term, *cp;
3018 unsigned long int sts, cmplen, haslower = 0;
3019 struct FAB dirfab = cc$rms_fab;
3020 struct NAM savnam, dirnam = cc$rms_nam;
3022 dirfab.fab$b_fns = strlen(dir);
3023 dirfab.fab$l_fna = dir;
3024 dirfab.fab$l_nam = &dirnam;
3025 dirfab.fab$l_dna = ".DIR;1";
3026 dirfab.fab$b_dns = 6;
3027 dirnam.nam$b_ess = NAM$C_MAXRSS;
3028 dirnam.nam$l_esa = esa;
3030 for (cp = dir; *cp; cp++)
3031 if (islower(*cp)) { haslower = 1; break; }
3032 if (!((sts = sys$parse(&dirfab))&1)) {
3033 if (dirfab.fab$l_sts == RMS$_DIR) {
3034 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3035 sts = sys$parse(&dirfab) & 1;
3039 set_vaxc_errno(dirfab.fab$l_sts);
3045 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3046 /* Yes; fake the fnb bits so we'll check type below */
3047 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3049 else { /* No; just work with potential name */
3050 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3052 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3053 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3054 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3059 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3060 cp1 = strchr(esa,']');
3061 if (!cp1) cp1 = strchr(esa,'>');
3062 if (cp1) { /* Should always be true */
3063 dirnam.nam$b_esl -= cp1 - esa - 1;
3064 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3067 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3068 /* Yep; check version while we're at it, if it's there. */
3069 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3070 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3071 /* Something other than .DIR[;1]. Bzzt. */
3072 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3073 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3075 set_vaxc_errno(RMS$_DIR);
3079 esa[dirnam.nam$b_esl] = '\0';
3080 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3081 /* They provided at least the name; we added the type, if necessary, */
3082 if (buf) retspec = buf; /* in sys$parse() */
3083 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3084 else retspec = __fileify_retbuf;
3085 strcpy(retspec,esa);
3086 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3087 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3090 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3091 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3093 dirnam.nam$b_esl -= 9;
3095 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3096 if (cp1 == NULL) { /* should never happen */
3097 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3098 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3103 retlen = strlen(esa);
3104 if ((cp1 = strrchr(esa,'.')) != NULL) {
3105 /* There's more than one directory in the path. Just roll back. */
3107 if (buf) retspec = buf;
3108 else if (ts) New(1311,retspec,retlen+7,char);
3109 else retspec = __fileify_retbuf;
3110 strcpy(retspec,esa);
3113 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3114 /* Go back and expand rooted logical name */
3115 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3116 if (!(sys$parse(&dirfab) & 1)) {
3117 dirnam.nam$l_rlf = NULL;
3118 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3120 set_vaxc_errno(dirfab.fab$l_sts);
3123 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3124 if (buf) retspec = buf;
3125 else if (ts) New(1312,retspec,retlen+16,char);
3126 else retspec = __fileify_retbuf;
3127 cp1 = strstr(esa,"][");
3128 if (!cp1) cp1 = strstr(esa,"]<");
3130 memcpy(retspec,esa,dirlen);
3131 if (!strncmp(cp1+2,"000000]",7)) {
3132 retspec[dirlen-1] = '\0';
3133 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3134 if (*cp1 == '.') *cp1 = ']';
3136 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3137 memcpy(cp1+1,"000000]",7);
3141 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3142 retspec[retlen] = '\0';
3143 /* Convert last '.' to ']' */
3144 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3145 if (*cp1 == '.') *cp1 = ']';
3147 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3148 memcpy(cp1+1,"000000]",7);
3152 else { /* This is a top-level dir. Add the MFD to the path. */
3153 if (buf) retspec = buf;
3154 else if (ts) New(1312,retspec,retlen+16,char);
3155 else retspec = __fileify_retbuf;
3158 while (*cp1 != ':') *(cp2++) = *(cp1++);
3159 strcpy(cp2,":[000000]");
3164 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3165 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3166 /* We've set up the string up through the filename. Add the
3167 type and version, and we're done. */
3168 strcat(retspec,".DIR;1");
3170 /* $PARSE may have upcased filespec, so convert output to lower
3171 * case if input contained any lowercase characters. */
3172 if (haslower) __mystrtolower(retspec);
3175 } /* end of do_fileify_dirspec() */
3177 /* External entry points */
3178 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3179 { return do_fileify_dirspec(dir,buf,0); }
3180 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3181 { return do_fileify_dirspec(dir,buf,1); }
3183 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3184 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3186 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3187 unsigned long int retlen;
3188 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3190 if (!dir || !*dir) {
3191 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3194 if (*dir) strcpy(trndir,dir);
3195 else getcwd(trndir,sizeof trndir - 1);
3197 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3198 && my_trnlnm(trndir,trndir,0)) {
3199 STRLEN trnlen = strlen(trndir);
3201 /* Trap simple rooted lnms, and return lnm:[000000] */
3202 if (!strcmp(trndir+trnlen-2,".]")) {
3203 if (buf) retpath = buf;
3204 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3205 else retpath = __pathify_retbuf;
3206 strcpy(retpath,dir);
3207 strcat(retpath,":[000000]");
3213 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3214 if (*dir == '.' && (*(dir+1) == '\0' ||
3215 (*(dir+1) == '.' && *(dir+2) == '\0')))
3216 retlen = 2 + (*(dir+1) != '\0');
3218 if ( !(cp1 = strrchr(dir,'/')) &&
3219 !(cp1 = strrchr(dir,']')) &&
3220 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3221 if ((cp2 = strchr(cp1,'.')) != NULL &&
3222 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3223 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3224 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3225 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3227 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3228 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3229 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3230 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3231 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3232 (ver || *cp3)))))) {
3234 set_vaxc_errno(RMS$_DIR);
3237 retlen = cp2 - dir + 1;
3239 else { /* No file type present. Treat the filename as a directory. */
3240 retlen = strlen(dir) + 1;
3243 if (buf) retpath = buf;
3244 else if (ts) New(1313,retpath,retlen+1,char);
3245 else retpath = __pathify_retbuf;
3246 strncpy(retpath,dir,retlen-1);
3247 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3248 retpath[retlen-1] = '/'; /* with '/', add it. */
3249 retpath[retlen] = '\0';
3251 else retpath[retlen-1] = '\0';
3253 else { /* VMS-style directory spec */
3254 char esa[NAM$C_MAXRSS+1], *cp;
3255 unsigned long int sts, cmplen, haslower;
3256 struct FAB dirfab = cc$rms_fab;
3257 struct NAM savnam, dirnam = cc$rms_nam;
3259 /* If we've got an explicit filename, we can just shuffle the string. */
3260 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3261 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3262 if ((cp2 = strchr(cp1,'.')) != NULL) {
3264 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3265 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3266 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3267 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3268 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3269 (ver || *cp3)))))) {
3271 set_vaxc_errno(RMS$_DIR);
3275 else { /* No file type, so just draw name into directory part */
3276 for (cp2 = cp1; *cp2; cp2++) ;
3279 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3281 /* We've now got a VMS 'path'; fall through */
3283 dirfab.fab$b_fns = strlen(dir);
3284 dirfab.fab$l_fna = dir;
3285 if (dir[dirfab.fab$b_fns-1] == ']' ||
3286 dir[dirfab.fab$b_fns-1] == '>' ||
3287 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3288 if (buf) retpath = buf;
3289 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3290 else retpath = __pathify_retbuf;
3291 strcpy(retpath,dir);
3294 dirfab.fab$l_dna = ".DIR;1";
3295 dirfab.fab$b_dns = 6;
3296 dirfab.fab$l_nam = &dirnam;
3297 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3298 dirnam.nam$l_esa = esa;
3300 for (cp = dir; *cp; cp++)
3301 if (islower(*cp)) { haslower = 1; break; }
3303 if (!(sts = (sys$parse(&dirfab)&1))) {
3304 if (dirfab.fab$l_sts == RMS$_DIR) {
3305 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3306 sts = sys$parse(&dirfab) & 1;
3310 set_vaxc_errno(dirfab.fab$l_sts);
3316 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3317 if (dirfab.fab$l_sts != RMS$_FNF) {
3318 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3319 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3321 set_vaxc_errno(dirfab.fab$l_sts);
3324 dirnam = savnam; /* No; just work with potential name */
3327 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3328 /* Yep; check version while we're at it, if it's there. */
3329 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3330 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3331 /* Something other than .DIR[;1]. Bzzt. */
3332 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3333 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3335 set_vaxc_errno(RMS$_DIR);
3339 /* OK, the type was fine. Now pull any file name into the
3341 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3343 cp1 = strrchr(esa,'>');
3344 *dirnam.nam$l_type = '>';
3347 *(dirnam.nam$l_type + 1) = '\0';
3348 retlen = dirnam.nam$l_type - esa + 2;
3349 if (buf) retpath = buf;
3350 else if (ts) New(1314,retpath,retlen,char);
3351 else retpath = __pathify_retbuf;
3352 strcpy(retpath,esa);
3353 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3354 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3355 /* $PARSE may have upcased filespec, so convert output to lower
3356 * case if input contained any lowercase characters. */
3357 if (haslower) __mystrtolower(retpath);
3361 } /* end of do_pathify_dirspec() */
3363 /* External entry points */
3364 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3365 { return do_pathify_dirspec(dir,buf,0); }
3366 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3367 { return do_pathify_dirspec(dir,buf,1); }
3369 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3370 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3372 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3373 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3374 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3376 if (spec == NULL) return NULL;
3377 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3378 if (buf) rslt = buf;
3380 retlen = strlen(spec);
3381 cp1 = strchr(spec,'[');
3382 if (!cp1) cp1 = strchr(spec,'<');
3384 for (cp1++; *cp1; cp1++) {
3385 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3386 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3387 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3390 New(1315,rslt,retlen+2+2*expand,char);
3392 else rslt = __tounixspec_retbuf;
3393 if (strchr(spec,'/') != NULL) {
3400 dirend = strrchr(spec,']');
3401 if (dirend == NULL) dirend = strrchr(spec,'>');
3402 if (dirend == NULL) dirend = strchr(spec,':');
3403 if (dirend == NULL) {
3407 if (*cp2 != '[' && *cp2 != '<') {
3410 else { /* the VMS spec begins with directories */
3412 if (*cp2 == ']' || *cp2 == '>') {
3413 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3416 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3417 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3418 if (ts) Safefree(rslt);
3423 while (*cp3 != ':' && *cp3) cp3++;
3425 if (strchr(cp3,']') != NULL) break;
3426 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3428 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3429 retlen = devlen + dirlen;
3430 Renew(rslt,retlen+1+2*expand,char);
3436 *(cp1++) = *(cp3++);
3437 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3441 else if ( *cp2 == '.') {
3442 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3443 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3449 for (; cp2 <= dirend; cp2++) {
3452 if (*(cp2+1) == '[') cp2++;
3454 else if (*cp2 == ']' || *cp2 == '>') {
3455 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3457 else if (*cp2 == '.') {
3459 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3460 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3461 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3462 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3463 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3465 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3466 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3470 else if (*cp2 == '-') {
3471 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3472 while (*cp2 == '-') {
3474 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3476 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3477 if (ts) Safefree(rslt); /* filespecs like */
3478 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3482 else *(cp1++) = *cp2;
3484 else *(cp1++) = *cp2;
3486 while (*cp2) *(cp1++) = *(cp2++);
3491 } /* end of do_tounixspec() */
3493 /* External entry points */
3494 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3495 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3497 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3498 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3499 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3500 char *rslt, *dirend;
3501 register char *cp1, *cp2;
3502 unsigned long int infront = 0, hasdir = 1;
3504 if (path == NULL) return NULL;
3505 if (buf) rslt = buf;
3506 else if (ts) New(1316,rslt,strlen(path)+9,char);
3507 else rslt = __tovmsspec_retbuf;
3508 if (strpbrk(path,"]:>") ||
3509 (dirend = strrchr(path,'/')) == NULL) {
3510 if (path[0] == '.') {
3511 if (path[1] == '\0') strcpy(rslt,"[]");
3512 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3513 else strcpy(rslt,path); /* probably garbage */
3515 else strcpy(rslt,path);
3518 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3519 if (!*(dirend+2)) dirend +=2;
3520 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3521 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3526 char trndev[NAM$C_MAXRSS+1];
3530 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3532 if (!buf & ts) Renew(rslt,18,char);
3533 strcpy(rslt,"sys$disk:[000000]");
3536 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3538 islnm = my_trnlnm(rslt,trndev,0);
3539 trnend = islnm ? strlen(trndev) - 1 : 0;
3540 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3541 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3542 /* If the first element of the path is a logical name, determine
3543 * whether it has to be translated so we can add more directories. */
3544 if (!islnm || rooted) {
3547 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3551 if (cp2 != dirend) {
3552 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3553 strcpy(rslt,trndev);
3554 cp1 = rslt + trnend;
3567 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3568 cp2 += 2; /* skip over "./" - it's redundant */
3569 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3571 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3572 *(cp1++) = '-'; /* "../" --> "-" */
3575 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3576 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3577 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3578 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3581 if (cp2 > dirend) cp2 = dirend;
3583 else *(cp1++) = '.';
3585 for (; cp2 < dirend; cp2++) {
3587 if (*(cp2-1) == '/') continue;
3588 if (*(cp1-1) != '.') *(cp1++) = '.';
3591 else if (!infront && *cp2 == '.') {
3592 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3593 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3594 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3595 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3596 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3597 else { /* back up over previous directory name */
3599 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3600 if (*(cp1-1) == '[') {
3601 memcpy(cp1,"000000.",7);
3606 if (cp2 == dirend) break;
3608 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3609 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3610 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3611 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3613 *(cp1++) = '.'; /* Simulate trailing '/' */
3614 cp2 += 2; /* for loop will incr this to == dirend */
3616 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3618 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3621 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3622 if (*cp2 == '.') *(cp1++) = '_';
3623 else *(cp1++) = *cp2;
3627 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3628 if (hasdir) *(cp1++) = ']';
3629 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3630 while (*cp2) *(cp1++) = *(cp2++);
3635 } /* end of do_tovmsspec() */
3637 /* External entry points */
3638 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3639 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3641 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3642 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3643 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3645 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3647 if (path == NULL) return NULL;
3648 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3649 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3650 if (buf) return buf;
3652 vmslen = strlen(vmsified);
3653 New(1317,cp,vmslen+1,char);
3654 memcpy(cp,vmsified,vmslen);
3659 strcpy(__tovmspath_retbuf,vmsified);
3660 return __tovmspath_retbuf;
3663 } /* end of do_tovmspath() */
3665 /* External entry points */
3666 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3667 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3670 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3671 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3672 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3674 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3676 if (path == NULL) return NULL;
3677 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3678 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3679 if (buf) return buf;
3681 unixlen = strlen(unixified);
3682 New(1317,cp,unixlen+1,char);
3683 memcpy(cp,unixified,unixlen);
3688 strcpy(__tounixpath_retbuf,unixified);
3689 return __tounixpath_retbuf;
3692 } /* end of do_tounixpath() */
3694 /* External entry points */
3695 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3696 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3699 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3701 *****************************************************************************
3703 * Copyright (C) 1989-1994 by *
3704 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3706 * Permission is hereby granted for the reproduction of this software, *
3707 * on condition that this copyright notice is included in the reproduction, *
3708 * and that such reproduction is not for purposes of profit or material *
3711 * 27-Aug-1994 Modified for inclusion in perl5 *
3712 * by Charles Bailey bailey@newman.upenn.edu *
3713 *****************************************************************************
3717 * getredirection() is intended to aid in porting C programs
3718 * to VMS (Vax-11 C). The native VMS environment does not support
3719 * '>' and '<' I/O redirection, or command line wild card expansion,
3720 * or a command line pipe mechanism using the '|' AND background
3721 * command execution '&'. All of these capabilities are provided to any
3722 * C program which calls this procedure as the first thing in the
3724 * The piping mechanism will probably work with almost any 'filter' type
3725 * of program. With suitable modification, it may useful for other
3726 * portability problems as well.
3728 * Author: Mark Pizzolato mark@infocomm.com
3732 struct list_item *next;
3736 static void add_item(struct list_item **head,
3737 struct list_item **tail,
3741 static void mp_expand_wild_cards(pTHX_ char *item,
3742 struct list_item **head,
3743 struct list_item **tail,
3746 static int background_process(int argc, char **argv);
3748 static void pipe_and_fork(pTHX_ char **cmargv);
3750 /*{{{ void getredirection(int *ac, char ***av)*/
3752 mp_getredirection(pTHX_ int *ac, char ***av)
3754 * Process vms redirection arg's. Exit if any error is seen.
3755 * If getredirection() processes an argument, it is erased
3756 * from the vector. getredirection() returns a new argc and argv value.
3757 * In the event that a background command is requested (by a trailing "&"),
3758 * this routine creates a background subprocess, and simply exits the program.
3760 * Warning: do not try to simplify the code for vms. The code
3761 * presupposes that getredirection() is called before any data is
3762 * read from stdin or written to stdout.
3764 * Normal usage is as follows:
3770 * getredirection(&argc, &argv);
3774 int argc = *ac; /* Argument Count */
3775 char **argv = *av; /* Argument Vector */
3776 char *ap; /* Argument pointer */
3777 int j; /* argv[] index */
3778 int item_count = 0; /* Count of Items in List */
3779 struct list_item *list_head = 0; /* First Item in List */
3780 struct list_item *list_tail; /* Last Item in List */
3781 char *in = NULL; /* Input File Name */
3782 char *out = NULL; /* Output File Name */
3783 char *outmode = "w"; /* Mode to Open Output File */
3784 char *err = NULL; /* Error File Name */
3785 char *errmode = "w"; /* Mode to Open Error File */
3786 int cmargc = 0; /* Piped Command Arg Count */
3787 char **cmargv = NULL;/* Piped Command Arg Vector */
3790 * First handle the case where the last thing on the line ends with
3791 * a '&'. This indicates the desire for the command to be run in a
3792 * subprocess, so we satisfy that desire.
3795 if (0 == strcmp("&", ap))
3796 exit(background_process(--argc, argv));
3797 if (*ap && '&' == ap[strlen(ap)-1])
3799 ap[strlen(ap)-1] = '\0';
3800 exit(background_process(argc, argv));
3803 * Now we handle the general redirection cases that involve '>', '>>',
3804 * '<', and pipes '|'.
3806 for (j = 0; j < argc; ++j)
3808 if (0 == strcmp("<", argv[j]))
3812 fprintf(stderr,"No input file after < on command line");
3813 exit(LIB$_WRONUMARG);
3818 if ('<' == *(ap = argv[j]))
3823 if (0 == strcmp(">", ap))
3827 fprintf(stderr,"No output file after > on command line");
3828 exit(LIB$_WRONUMARG);
3847 fprintf(stderr,"No output file after > or >> on command line");
3848 exit(LIB$_WRONUMARG);
3852 if (('2' == *ap) && ('>' == ap[1]))
3869 fprintf(stderr,"No output file after 2> or 2>> on command line");
3870 exit(LIB$_WRONUMARG);
3874 if (0 == strcmp("|", argv[j]))
3878 fprintf(stderr,"No command into which to pipe on command line");
3879 exit(LIB$_WRONUMARG);
3881 cmargc = argc-(j+1);
3882 cmargv = &argv[j+1];
3886 if ('|' == *(ap = argv[j]))
3894 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3897 * Allocate and fill in the new argument vector, Some Unix's terminate
3898 * the list with an extra null pointer.
3900 New(1302, argv, item_count+1, char *);
3902 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3903 argv[j] = list_head->value;
3909 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3910 exit(LIB$_INVARGORD);
3912 pipe_and_fork(aTHX_ cmargv);
3915 /* Check for input from a pipe (mailbox) */
3917 if (in == NULL && 1 == isapipe(0))
3919 char mbxname[L_tmpnam];
3921 long int dvi_item = DVI$_DEVBUFSIZ;
3922 $DESCRIPTOR(mbxnam, "");
3923 $DESCRIPTOR(mbxdevnam, "");
3925 /* Input from a pipe, reopen it in binary mode to disable */
3926 /* carriage control processing. */
3928 fgetname(stdin, mbxname);
3929 mbxnam.dsc$a_pointer = mbxname;
3930 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3931 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3932 mbxdevnam.dsc$a_pointer = mbxname;
3933 mbxdevnam.dsc$w_length = sizeof(mbxname);
3934 dvi_item = DVI$_DEVNAM;
3935 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3936 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3939 freopen(mbxname, "rb", stdin);
3942 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3946 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3948 fprintf(stderr,"Can't open input file %s as stdin",in);
3951 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3953 fprintf(stderr,"Can't open output file %s as stdout",out);
3956 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3959 if (strcmp(err,"&1") == 0) {
3960 dup2(fileno(stdout), fileno(stderr));
3961 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3964 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3966 fprintf(stderr,"Can't open error file %s as stderr",err);
3970 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3974 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3977 #ifdef ARGPROC_DEBUG
3978 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3979 for (j = 0; j < *ac; ++j)
3980 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3982 /* Clear errors we may have hit expanding wildcards, so they don't
3983 show up in Perl's $! later */
3984 set_errno(0); set_vaxc_errno(1);
3985 } /* end of getredirection() */
3988 static void add_item(struct list_item **head,
3989 struct list_item **tail,
3995 New(1303,*head,1,struct list_item);
3999 New(1304,(*tail)->next,1,struct list_item);
4000 *tail = (*tail)->next;
4002 (*tail)->value = value;
4006 static void mp_expand_wild_cards(pTHX_ char *item,
4007 struct list_item **head,
4008 struct list_item **tail,
4012 unsigned long int context = 0;
4018 char vmsspec[NAM$C_MAXRSS+1];
4019 $DESCRIPTOR(filespec, "");
4020 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4021 $DESCRIPTOR(resultspec, "");
4022 unsigned long int zero = 0, sts;
4024 for (cp = item; *cp; cp++) {
4025 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4026 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4028 if (!*cp || isspace(*cp))
4030 add_item(head, tail, item, count);
4033 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4034 resultspec.dsc$b_class = DSC$K_CLASS_D;
4035 resultspec.dsc$a_pointer = NULL;
4036 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4037 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4038 if (!isunix || !filespec.dsc$a_pointer)
4039 filespec.dsc$a_pointer = item;
4040 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4042 * Only return version specs, if the caller specified a version
4044 had_version = strchr(item, ';');
4046 * Only return device and directory specs, if the caller specifed either.
4048 had_device = strchr(item, ':');
4049 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4051 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4052 &defaultspec, 0, 0, &zero))))
4057 New(1305,string,resultspec.dsc$w_length+1,char);
4058 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4059 string[resultspec.dsc$w_length] = '\0';
4060 if (NULL == had_version)
4061 *((char *)strrchr(string, ';')) = '\0';
4062 if ((!had_directory) && (had_device == NULL))
4064 if (NULL == (devdir = strrchr(string, ']')))
4065 devdir = strrchr(string, '>');
4066 strcpy(string, devdir + 1);
4069 * Be consistent with what the C RTL has already done to the rest of
4070 * the argv items and lowercase all of these names.
4072 for (c = string; *c; ++c)
4075 if (isunix) trim_unixpath(string,item,1);
4076 add_item(head, tail, string, count);
4079 if (sts != RMS$_NMF)
4081 set_vaxc_errno(sts);
4084 case RMS$_FNF: case RMS$_DNF:
4085 set_errno(ENOENT); break;
4087 set_errno(ENOTDIR); break;
4089 set_errno(ENODEV); break;
4090 case RMS$_FNM: case RMS$_SYN:
4091 set_errno(EINVAL); break;
4093 set_errno(EACCES); break;
4095 _ckvmssts_noperl(sts);
4099 add_item(head, tail, item, count);
4100 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4101 _ckvmssts_noperl(lib$find_file_end(&context));
4104 static int child_st[2];/* Event Flag set when child process completes */
4106 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4108 static unsigned long int exit_handler(int *status)
4112 if (0 == child_st[0])
4114 #ifdef ARGPROC_DEBUG
4115 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4117 fflush(stdout); /* Have to flush pipe for binary data to */
4118 /* terminate properly -- <tp@mccall.com> */
4119 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4120 sys$dassgn(child_chan);
4122 sys$synch(0, child_st);
4127 static void sig_child(int chan)
4129 #ifdef ARGPROC_DEBUG
4130 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4132 if (child_st[0] == 0)
4136 static struct exit_control_block exit_block =
4141 &exit_block.exit_status,
4146 pipe_and_fork(pTHX_ char **cmargv)
4149 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4150 int sts, j, l, ismcr, quote, tquote = 0;
4152 sts = setup_cmddsc(cmargv[0],0,"e);
4157 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4158 && toupper(*(q+2)) == 'R' && !*(q+3);
4160 while (q && l < MAX_DCL_LINE_LENGTH) {
4162 if (j > 0 && quote) {
4168 if (ismcr && j > 1) quote = 1;
4169 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4172 if (quote || tquote) {
4178 if ((quote||tquote) && *q == '"') {
4188 store_pipelocs(); /* gets redone later */
4189 fp = safe_popen(subcmd,"wbF",&sts);
4191 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4195 static int background_process(int argc, char **argv)
4197 char command[2048] = "$";
4198 $DESCRIPTOR(value, "");
4199 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4200 static $DESCRIPTOR(null, "NLA0:");
4201 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4203 $DESCRIPTOR(pidstr, "");
4205 unsigned long int flags = 17, one = 1, retsts;
4207 strcat(command, argv[0]);
4210 strcat(command, " \"");
4211 strcat(command, *(++argv));
4212 strcat(command, "\"");
4214 value.dsc$a_pointer = command;
4215 value.dsc$w_length = strlen(value.dsc$a_pointer);
4216 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4217 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4218 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4219 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4222 _ckvmssts_noperl(retsts);
4224 #ifdef ARGPROC_DEBUG
4225 PerlIO_printf(Perl_debug_log, "%s\n", command);
4227 sprintf(pidstring, "%08X", pid);
4228 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4229 pidstr.dsc$a_pointer = pidstring;
4230 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4231 lib$set_symbol(&pidsymbol, &pidstr);
4235 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4238 /* OS-specific initialization at image activation (not thread startup) */
4239 /* Older VAXC header files lack these constants */
4240 #ifndef JPI$_RIGHTS_SIZE
4241 # define JPI$_RIGHTS_SIZE 817
4243 #ifndef KGB$M_SUBSYSTEM
4244 # define KGB$M_SUBSYSTEM 0x8
4247 /*{{{void vms_image_init(int *, char ***)*/
4249 vms_image_init(int *argcp, char ***argvp)
4251 char eqv[LNM$C_NAMLENGTH+1] = "";
4252 unsigned int len, tabct = 8, tabidx = 0;
4253 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4254 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4255 unsigned short int dummy, rlen;
4256 struct dsc$descriptor_s **tabvec;
4257 #if defined(PERL_IMPLICIT_CONTEXT)
4260 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4261 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4262 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4265 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4266 _ckvmssts_noperl(iosb[0]);
4267 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4268 if (iprv[i]) { /* Running image installed with privs? */
4269 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4274 /* Rights identifiers might trigger tainting as well. */
4275 if (!will_taint && (rlen || rsz)) {
4276 while (rlen < rsz) {
4277 /* We didn't get all the identifiers on the first pass. Allocate a
4278 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4279 * were needed to hold all identifiers at time of last call; we'll
4280 * allocate that many unsigned long ints), and go back and get 'em.
4281 * If it gave us less than it wanted to despite ample buffer space,
4282 * something's broken. Is your system missing a system identifier?
4284 if (rsz <= jpilist[1].buflen) {
4285 /* Perl_croak accvios when used this early in startup. */
4286 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4287 rsz, (unsigned long) jpilist[1].buflen,
4288 "Check your rights database for corruption.\n");
4291 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4292 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4293 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4294 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4295 _ckvmssts_noperl(iosb[0]);
4297 mask = jpilist[1].bufadr;
4298 /* Check attribute flags for each identifier (2nd longword); protected
4299 * subsystem identifiers trigger tainting.
4301 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4302 if (mask[i] & KGB$M_SUBSYSTEM) {
4307 if (mask != rlst) Safefree(mask);
4309 /* We need to use this hack to tell Perl it should run with tainting,
4310 * since its tainting flag may be part of the PL_curinterp struct, which
4311 * hasn't been allocated when vms_image_init() is called.
4315 New(1320,newap,*argcp+2,char **);
4316 newap[0] = argvp[0];
4318 Copy(argvp[1],newap[2],*argcp-1,char **);
4319 /* We orphan the old argv, since we don't know where it's come from,
4320 * so we don't know how to free it.
4322 *argcp++; argvp = newap;
4324 else { /* Did user explicitly request tainting? */
4326 char *cp, **av = *argvp;
4327 for (i = 1; i < *argcp; i++) {
4328 if (*av[i] != '-') break;
4329 for (cp = av[i]+1; *cp; cp++) {
4330 if (*cp == 'T') { will_taint = 1; break; }
4331 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4332 strchr("DFIiMmx",*cp)) break;
4334 if (will_taint) break;
4339 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4341 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4342 else if (tabidx >= tabct) {
4344 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4346 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4347 tabvec[tabidx]->dsc$w_length = 0;
4348 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4349 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4350 tabvec[tabidx]->dsc$a_pointer = NULL;
4351 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4353 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4355 getredirection(argcp,argvp);
4356 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4358 # include <reentrancy.h>
4359 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4368 * Trim Unix-style prefix off filespec, so it looks like what a shell
4369 * glob expansion would return (i.e. from specified prefix on, not
4370 * full path). Note that returned filespec is Unix-style, regardless
4371 * of whether input filespec was VMS-style or Unix-style.
4373 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4374 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4375 * vector of options; at present, only bit 0 is used, and if set tells
4376 * trim unixpath to try the current default directory as a prefix when
4377 * presented with a possibly ambiguous ... wildcard.
4379 * Returns !=0 on success, with trimmed filespec replacing contents of
4380 * fspec, and 0 on failure, with contents of fpsec unchanged.
4382 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4384 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4386 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4387 *template, *base, *end, *cp1, *cp2;
4388 register int tmplen, reslen = 0, dirs = 0;
4390 if (!wildspec || !fspec) return 0;
4391 if (strpbrk(wildspec,"]>:") != NULL) {
4392 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4393 else template = unixwild;
4395 else template = wildspec;
4396 if (strpbrk(fspec,"]>:") != NULL) {
4397 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4398 else base = unixified;
4399 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4400 * check to see that final result fits into (isn't longer than) fspec */
4401 reslen = strlen(fspec);
4405 /* No prefix or absolute path on wildcard, so nothing to remove */
4406 if (!*template || *template == '/') {
4407 if (base == fspec) return 1;
4408 tmplen = strlen(unixified);
4409 if (tmplen > reslen) return 0; /* not enough space */
4410 /* Copy unixified resultant, including trailing NUL */
4411 memmove(fspec,unixified,tmplen+1);
4415 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4416 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4417 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4418 for (cp1 = end ;cp1 >= base; cp1--)
4419 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4421 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4425 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4426 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4427 int ells = 1, totells, segdirs, match;
4428 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4429 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4431 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4433 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4434 if (ellipsis == template && opts & 1) {
4435 /* Template begins with an ellipsis. Since we can't tell how many
4436 * directory names at the front of the resultant to keep for an
4437 * arbitrary starting point, we arbitrarily choose the current
4438 * default directory as a starting point. If it's there as a prefix,
4439 * clip it off. If not, fall through and act as if the leading
4440 * ellipsis weren't there (i.e. return shortest possible path that
4441 * could match template).
4443 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4444 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4445 if (_tolower(*cp1) != _tolower(*cp2)) break;
4446 segdirs = dirs - totells; /* Min # of dirs we must have left */
4447 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4448 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4449 memcpy(fspec,cp2+1,end - cp2);
4453 /* First off, back up over constant elements at end of path */
4455 for (front = end ; front >= base; front--)
4456 if (*front == '/' && !dirs--) { front++; break; }
4458 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4459 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4460 if (cp1 != '\0') return 0; /* Path too long. */
4462 *cp2 = '\0'; /* Pick up with memcpy later */
4463 lcfront = lcres + (front - base);
4464 /* Now skip over each ellipsis and try to match the path in front of it. */
4466 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4467 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4468 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4469 if (cp1 < template) break; /* template started with an ellipsis */
4470 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4471 ellipsis = cp1; continue;
4473 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4475 for (segdirs = 0, cp2 = tpl;
4476 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4478 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4479 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4480 if (*cp2 == '/') segdirs++;
4482 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4483 /* Back up at least as many dirs as in template before matching */
4484 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4485 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4486 for (match = 0; cp1 > lcres;) {
4487 resdsc.dsc$a_pointer = cp1;
4488 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4490 if (match == 1) lcfront = cp1;
4492 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4494 if (!match) return 0; /* Can't find prefix ??? */
4495 if (match > 1 && opts & 1) {
4496 /* This ... wildcard could cover more than one set of dirs (i.e.
4497 * a set of similar dir names is repeated). If the template
4498 * contains more than 1 ..., upstream elements could resolve the
4499 * ambiguity, but it's not worth a full backtracking setup here.
4500 * As a quick heuristic, clip off the current default directory
4501 * if it's present to find the trimmed spec, else use the
4502 * shortest string that this ... could cover.
4504 char def[NAM$C_MAXRSS+1], *st;
4506 if (getcwd(def, sizeof def,0) == NULL) return 0;
4507 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4508 if (_tolower(*cp1) != _tolower(*cp2)) break;
4509 segdirs = dirs - totells; /* Min # of dirs we must have left */
4510 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4511 if (*cp1 == '\0' && *cp2 == '/') {
4512 memcpy(fspec,cp2+1,end - cp2);
4515 /* Nope -- stick with lcfront from above and keep going. */
4518 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4523 } /* end of trim_unixpath() */
4528 * VMS readdir() routines.
4529 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4531 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4532 * Minor modifications to original routines.
4535 /* Number of elements in vms_versions array */
4536 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4539 * Open a directory, return a handle for later use.
4541 /*{{{ DIR *opendir(char*name) */
4543 Perl_opendir(pTHX_ char *name)
4546 char dir[NAM$C_MAXRSS+1];
4549 if (do_tovmspath(name,dir,0) == NULL) {
4552 if (flex_stat(dir,&sb) == -1) return NULL;
4553 if (!S_ISDIR(sb.st_mode)) {
4554 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4557 if (!cando_by_name(S_IRUSR,0,dir)) {
4558 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4561 /* Get memory for the handle, and the pattern. */
4563 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4565 /* Fill in the fields; mainly playing with the descriptor. */
4566 (void)sprintf(dd->pattern, "%s*.*",dir);
4569 dd->vms_wantversions = 0;
4570 dd->pat.dsc$a_pointer = dd->pattern;
4571 dd->pat.dsc$w_length = strlen(dd->pattern);
4572 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4573 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4576 } /* end of opendir() */
4580 * Set the flag to indicate we want versions or not.
4582 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4584 vmsreaddirversions(DIR *dd, int flag)
4586 dd->vms_wantversions = flag;
4591 * Free up an opened directory.
4593 /*{{{ void closedir(DIR *dd)*/
4597 (void)lib$find_file_end(&dd->context);
4598 Safefree(dd->pattern);
4599 Safefree((char *)dd);
4604 * Collect all the version numbers for the current file.
4607 collectversions(pTHX_ DIR *dd)
4609 struct dsc$descriptor_s pat;
4610 struct dsc$descriptor_s res;
4612 char *p, *text, buff[sizeof dd->entry.d_name];
4614 unsigned long context, tmpsts;
4616 /* Convenient shorthand. */
4619 /* Add the version wildcard, ignoring the "*.*" put on before */
4620 i = strlen(dd->pattern);
4621 New(1308,text,i + e->d_namlen + 3,char);
4622 (void)strcpy(text, dd->pattern);
4623 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4625 /* Set up the pattern descriptor. */
4626 pat.dsc$a_pointer = text;
4627 pat.dsc$w_length = i + e->d_namlen - 1;
4628 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4629 pat.dsc$b_class = DSC$K_CLASS_S;
4631 /* Set up result descriptor. */
4632 res.dsc$a_pointer = buff;
4633 res.dsc$w_length = sizeof buff - 2;
4634 res.dsc$b_dtype = DSC$K_DTYPE_T;
4635 res.dsc$b_class = DSC$K_CLASS_S;
4637 /* Read files, collecting versions. */
4638 for (context = 0, e->vms_verscount = 0;
4639 e->vms_verscount < VERSIZE(e);
4640 e->vms_verscount++) {
4641 tmpsts = lib$find_file(&pat, &res, &context);
4642 if (tmpsts == RMS$_NMF || context == 0) break;
4644 buff[sizeof buff - 1] = '\0';
4645 if ((p = strchr(buff, ';')))
4646 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4648 e->vms_versions[e->vms_verscount] = -1;
4651 _ckvmssts(lib$find_file_end(&context));
4654 } /* end of collectversions() */
4657 * Read the next entry from the directory.
4659 /*{{{ struct dirent *readdir(DIR *dd)*/
4661 Perl_readdir(pTHX_ DIR *dd)
4663 struct dsc$descriptor_s res;
4664 char *p, buff[sizeof dd->entry.d_name];
4665 unsigned long int tmpsts;
4667 /* Set up result descriptor, and get next file. */
4668 res.dsc$a_pointer = buff;
4669 res.dsc$w_length = sizeof buff - 2;
4670 res.dsc$b_dtype = DSC$K_DTYPE_T;
4671 res.dsc$b_class = DSC$K_CLASS_S;
4672 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4673 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4674 if (!(tmpsts & 1)) {
4675 set_vaxc_errno(tmpsts);
4678 set_errno(EACCES); break;
4680 set_errno(ENODEV); break;
4682 set_errno(ENOTDIR); break;
4683 case RMS$_FNF: case RMS$_DNF:
4684 set_errno(ENOENT); break;
4691 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4692 buff[sizeof buff - 1] = '\0';
4693 for (p = buff; *p; p++) *p = _tolower(*p);
4694 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4697 /* Skip any directory component and just copy the name. */
4698 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4699 else (void)strcpy(dd->entry.d_name, buff);
4701 /* Clobber the version. */
4702 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4704 dd->entry.d_namlen = strlen(dd->entry.d_name);
4705 dd->entry.vms_verscount = 0;
4706 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4709 } /* end of readdir() */
4713 * Return something that can be used in a seekdir later.
4715 /*{{{ long telldir(DIR *dd)*/
4724 * Return to a spot where we used to be. Brute force.
4726 /*{{{ void seekdir(DIR *dd,long count)*/
4728 Perl_seekdir(pTHX_ DIR *dd, long count)
4730 int vms_wantversions;
4732 /* If we haven't done anything yet... */
4736 /* Remember some state, and clear it. */
4737 vms_wantversions = dd->vms_wantversions;
4738 dd->vms_wantversions = 0;
4739 _ckvmssts(lib$find_file_end(&dd->context));
4742 /* The increment is in readdir(). */
4743 for (dd->count = 0; dd->count < count; )
4746 dd->vms_wantversions = vms_wantversions;
4748 } /* end of seekdir() */
4751 /* VMS subprocess management
4753 * my_vfork() - just a vfork(), after setting a flag to record that
4754 * the current script is trying a Unix-style fork/exec.
4756 * vms_do_aexec() and vms_do_exec() are called in response to the
4757 * perl 'exec' function. If this follows a vfork call, then they
4758 * call out the the regular perl routines in doio.c which do an
4759 * execvp (for those who really want to try this under VMS).
4760 * Otherwise, they do exactly what the perl docs say exec should
4761 * do - terminate the current script and invoke a new command
4762 * (See below for notes on command syntax.)
4764 * do_aspawn() and do_spawn() implement the VMS side of the perl
4765 * 'system' function.
4767 * Note on command arguments to perl 'exec' and 'system': When handled
4768 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4769 * are concatenated to form a DCL command string. If the first arg
4770 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4771 * the the command string is handed off to DCL directly. Otherwise,
4772 * the first token of the command is taken as the filespec of an image
4773 * to run. The filespec is expanded using a default type of '.EXE' and
4774 * the process defaults for device, directory, etc., and if found, the resultant
4775 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4776 * the command string as parameters. This is perhaps a bit complicated,
4777 * but I hope it will form a happy medium between what VMS folks expect
4778 * from lib$spawn and what Unix folks expect from exec.
4781 static int vfork_called;
4783 /*{{{int my_vfork()*/
4794 vms_execfree(pTHX) {
4796 if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
4799 if (VMSCMD.dsc$a_pointer) {
4800 Safefree(VMSCMD.dsc$a_pointer);
4801 VMSCMD.dsc$w_length = 0;
4802 VMSCMD.dsc$a_pointer = Nullch;
4807 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4809 char *junk, *tmps = Nullch;
4810 register size_t cmdlen = 0;
4817 tmps = SvPV(really,rlen);
4824 for (idx++; idx <= sp; idx++) {
4826 junk = SvPVx(*idx,rlen);
4827 cmdlen += rlen ? rlen + 1 : 0;
4830 New(401,PL_Cmd,cmdlen+1,char);
4832 if (tmps && *tmps) {
4833 strcpy(PL_Cmd,tmps);
4836 else *PL_Cmd = '\0';
4837 while (++mark <= sp) {
4839 char *s = SvPVx(*mark,n_a);
4841 if (*PL_Cmd) strcat(PL_Cmd," ");
4847 } /* end of setup_argstr() */
4850 static unsigned long int
4851 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
4853 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4854 $DESCRIPTOR(defdsc,".EXE");
4855 $DESCRIPTOR(defdsc2,".");
4856 $DESCRIPTOR(resdsc,resspec);
4857 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4858 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4859 register char *s, *rest, *cp, *wordbreak;
4862 if (suggest_quote) *suggest_quote = 0;
4864 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
4865 return CLI$_BUFOVF; /* continuation lines currently unsupported */
4867 while (*s && isspace(*s)) s++;
4869 if (*s == '@' || *s == '$') {
4870 vmsspec[0] = *s; rest = s + 1;
4871 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4873 else { cp = vmsspec; rest = s; }
4874 if (*rest == '.' || *rest == '/') {
4877 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4878 rest++, cp2++) *cp2 = *rest;
4880 if (do_tovmsspec(resspec,cp,0)) {
4883 for (cp2 = vmsspec + strlen(vmsspec);
4884 *rest && cp2 - vmsspec < sizeof vmsspec;
4885 rest++, cp2++) *cp2 = *rest;
4890 /* Intuit whether verb (first word of cmd) is a DCL command:
4891 * - if first nonspace char is '@', it's a DCL indirection
4893 * - if verb contains a filespec separator, it's not a DCL command
4894 * - if it doesn't, caller tells us whether to default to a DCL
4895 * command, or to a local image unless told it's DCL (by leading '$')
4899 if (suggest_quote) *suggest_quote = 1;
4901 register char *filespec = strpbrk(s,":<[.;");
4902 rest = wordbreak = strpbrk(s," \"\t/");
4903 if (!wordbreak) wordbreak = s + strlen(s);
4904 if (*s == '$') check_img = 0;
4905 if (filespec && (filespec < wordbreak)) isdcl = 0;
4906 else isdcl = !check_img;
4910 imgdsc.dsc$a_pointer = s;
4911 imgdsc.dsc$w_length = wordbreak - s;
4912 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4914 _ckvmssts(lib$find_file_end(&cxt));
4915 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4916 if (!(retsts & 1) && *s == '$') {
4917 _ckvmssts(lib$find_file_end(&cxt));
4918 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4919 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4921 _ckvmssts(lib$find_file_end(&cxt));
4922 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4926 _ckvmssts(lib$find_file_end(&cxt));
4931 while (*s && !isspace(*s)) s++;
4934 /* check that it's really not DCL with no file extension */
4935 fp = fopen(resspec,"r","ctx=bin,shr=get");
4937 char b[4] = {0,0,0,0};
4938 read(fileno(fp),b,4);
4939 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4942 if (check_img && isdcl) return RMS$_FNF;
4944 if (cando_by_name(S_IXUSR,0,resspec)) {
4945 New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4947 strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
4948 if (suggest_quote) *suggest_quote = 1;
4950 strcpy(VMSCMD.dsc$a_pointer,"@");
4951 if (suggest_quote) *suggest_quote = 1;
4953 strcat(VMSCMD.dsc$a_pointer,resspec);
4954 if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
4955 VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
4956 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4958 else retsts = RMS$_PRV;
4961 /* It's either a DCL command or we couldn't find a suitable image */
4962 VMSCMD.dsc$w_length = strlen(cmd);
4963 if (cmd == PL_Cmd) {
4964 VMSCMD.dsc$a_pointer = PL_Cmd;
4965 if (suggest_quote) *suggest_quote = 1;
4967 else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
4969 /* check if it's a symbol (for quoting purposes) */
4970 if (suggest_quote && !*suggest_quote) {
4972 char equiv[LNM$C_NAMLENGTH];
4973 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4974 eqvdsc.dsc$a_pointer = equiv;
4976 iss = lib$get_symbol(&VMSCMD,&eqvdsc);
4977 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
4979 if (!(retsts & 1)) {
4980 /* just hand off status values likely to be due to user error */
4981 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4982 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4983 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4984 else { _ckvmssts(retsts); }
4987 return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
4989 } /* end of setup_cmddsc() */
4992 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4994 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4997 if (vfork_called) { /* this follows a vfork - act Unixish */
4999 if (vfork_called < 0) {
5000 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5003 else return do_aexec(really,mark,sp);
5005 /* no vfork - act VMSish */
5006 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5011 } /* end of vms_do_aexec() */
5014 /* {{{bool vms_do_exec(char *cmd) */
5016 Perl_vms_do_exec(pTHX_ char *cmd)
5019 if (vfork_called) { /* this follows a vfork - act Unixish */
5021 if (vfork_called < 0) {
5022 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5025 else return do_exec(cmd);
5028 { /* no vfork - act VMSish */
5029 unsigned long int retsts;
5032 TAINT_PROPER("exec");
5033 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
5034 retsts = lib$do_command(&VMSCMD);
5037 case RMS$_FNF: case RMS$_DNF:
5038 set_errno(ENOENT); break;
5040 set_errno(ENOTDIR); break;
5042 set_errno(ENODEV); break;
5044 set_errno(EACCES); break;
5046 set_errno(EINVAL); break;
5047 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5048 set_errno(E2BIG); break;
5049 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5050 _ckvmssts(retsts); /* fall through */
5051 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5054 set_vaxc_errno(retsts);
5055 if (ckWARN(WARN_EXEC)) {
5056 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
5057 VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
5064 } /* end of vms_do_exec() */
5067 unsigned long int Perl_do_spawn(pTHX_ char *);
5069 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5071 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5073 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5076 } /* end of do_aspawn() */
5079 /* {{{unsigned long int do_spawn(char *cmd) */
5081 Perl_do_spawn(pTHX_ char *cmd)
5083 unsigned long int sts, substs, hadcmd = 1;
5086 TAINT_PROPER("spawn");
5087 if (!cmd || !*cmd) {
5089 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5092 (void) safe_popen(cmd, "nW", (int *)&sts);
5098 case RMS$_FNF: case RMS$_DNF:
5099 set_errno(ENOENT); break;
5101 set_errno(ENOTDIR); break;
5103 set_errno(ENODEV); break;
5105 set_errno(EACCES); break;
5107 set_errno(EINVAL); break;
5108 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5109 set_errno(E2BIG); break;
5110 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5111 _ckvmssts(sts); /* fall through */
5112 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5115 set_vaxc_errno(sts);
5116 if (ckWARN(WARN_EXEC)) {
5117 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
5125 } /* end of do_spawn() */
5129 static unsigned int *sockflags, sockflagsize;
5132 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5133 * routines found in some versions of the CRTL can't deal with sockets.
5134 * We don't shim the other file open routines since a socket isn't
5135 * likely to be opened by a name.
5137 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5138 FILE *my_fdopen(int fd, const char *mode)
5140 FILE *fp = fdopen(fd, (char *) mode);
5143 unsigned int fdoff = fd / sizeof(unsigned int);
5144 struct stat sbuf; /* native stat; we don't need flex_stat */
5145 if (!sockflagsize || fdoff > sockflagsize) {
5146 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5147 else New (1324,sockflags,fdoff+2,unsigned int);
5148 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5149 sockflagsize = fdoff + 2;
5151 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5152 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5161 * Clear the corresponding bit when the (possibly) socket stream is closed.
5162 * There still a small hole: we miss an implicit close which might occur
5163 * via freopen(). >> Todo
5165 /*{{{ int my_fclose(FILE *fp)*/
5166 int my_fclose(FILE *fp) {
5168 unsigned int fd = fileno(fp);
5169 unsigned int fdoff = fd / sizeof(unsigned int);
5171 if (sockflagsize && fdoff <= sockflagsize)
5172 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5180 * A simple fwrite replacement which outputs itmsz*nitm chars without
5181 * introducing record boundaries every itmsz chars.
5182 * We are using fputs, which depends on a terminating null. We may
5183 * well be writing binary data, so we need to accommodate not only
5184 * data with nulls sprinkled in the middle but also data with no null
5187 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5189 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5191 register char *cp, *end, *cpd, *data;
5192 register unsigned int fd = fileno(dest);
5193 register unsigned int fdoff = fd / sizeof(unsigned int);
5195 int bufsize = itmsz * nitm + 1;
5197 if (fdoff < sockflagsize &&
5198 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5199 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5203 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5204 memcpy( data, src, itmsz*nitm );
5205 data[itmsz*nitm] = '\0';
5207 end = data + itmsz * nitm;
5208 retval = (int) nitm; /* on success return # items written */
5211 while (cpd <= end) {
5212 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5213 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5215 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5219 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5222 } /* end of my_fwrite() */
5225 /*{{{ int my_flush(FILE *fp)*/
5227 Perl_my_flush(pTHX_ FILE *fp)
5230 if ((res = fflush(fp)) == 0 && fp) {
5231 #ifdef VMS_DO_SOCKETS
5233 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5235 res = fsync(fileno(fp));
5238 * If the flush succeeded but set end-of-file, we need to clear
5239 * the error because our caller may check ferror(). BTW, this
5240 * probably means we just flushed an empty file.
5242 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5249 * Here are replacements for the following Unix routines in the VMS environment:
5250 * getpwuid Get information for a particular UIC or UID
5251 * getpwnam Get information for a named user
5252 * getpwent Get information for each user in the rights database
5253 * setpwent Reset search to the start of the rights database
5254 * endpwent Finish searching for users in the rights database
5256 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5257 * (defined in pwd.h), which contains the following fields:-
5259 * char *pw_name; Username (in lower case)
5260 * char *pw_passwd; Hashed password
5261 * unsigned int pw_uid; UIC
5262 * unsigned int pw_gid; UIC group number
5263 * char *pw_unixdir; Default device/directory (VMS-style)
5264 * char *pw_gecos; Owner name
5265 * char *pw_dir; Default device/directory (Unix-style)
5266 * char *pw_shell; Default CLI name (eg. DCL)
5268 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5270 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5271 * not the UIC member number (eg. what's returned by getuid()),
5272 * getpwuid() can accept either as input (if uid is specified, the caller's
5273 * UIC group is used), though it won't recognise gid=0.
5275 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5276 * information about other users in your group or in other groups, respectively.
5277 * If the required privilege is not available, then these routines fill only
5278 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5281 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5284 /* sizes of various UAF record fields */
5285 #define UAI$S_USERNAME 12
5286 #define UAI$S_IDENT 31
5287 #define UAI$S_OWNER 31
5288 #define UAI$S_DEFDEV 31
5289 #define UAI$S_DEFDIR 63
5290 #define UAI$S_DEFCLI 31
5293 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5294 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5295 (uic).uic$v_group != UIC$K_WILD_GROUP)
5297 static char __empty[]= "";
5298 static struct passwd __passwd_empty=
5299 {(char *) __empty, (char *) __empty, 0, 0,
5300 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5301 static int contxt= 0;
5302 static struct passwd __pwdcache;
5303 static char __pw_namecache[UAI$S_IDENT+1];
5306 * This routine does most of the work extracting the user information.
5308 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5311 unsigned char length;
5312 char pw_gecos[UAI$S_OWNER+1];
5314 static union uicdef uic;
5316 unsigned char length;
5317 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5320 unsigned char length;
5321 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5324 unsigned char length;
5325 char pw_shell[UAI$S_DEFCLI+1];
5327 static char pw_passwd[UAI$S_PWD+1];
5329 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5330 struct dsc$descriptor_s name_desc;
5331 unsigned long int sts;
5333 static struct itmlst_3 itmlst[]= {
5334 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5335 {sizeof(uic), UAI$_UIC, &uic, &luic},
5336 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5337 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5338 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5339 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5340 {0, 0, NULL, NULL}};
5342 name_desc.dsc$w_length= strlen(name);
5343 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5344 name_desc.dsc$b_class= DSC$K_CLASS_S;
5345 name_desc.dsc$a_pointer= (char *) name;
5347 /* Note that sys$getuai returns many fields as counted strings. */
5348 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5349 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5350 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5352 else { _ckvmssts(sts); }
5353 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5355 if ((int) owner.length < lowner) lowner= (int) owner.length;
5356 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5357 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5358 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5359 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5360 owner.pw_gecos[lowner]= '\0';
5361 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5362 defcli.pw_shell[ldefcli]= '\0';
5363 if (valid_uic(uic)) {
5364 pwd->pw_uid= uic.uic$l_uic;
5365 pwd->pw_gid= uic.uic$v_group;
5368 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5369 pwd->pw_passwd= pw_passwd;
5370 pwd->pw_gecos= owner.pw_gecos;
5371 pwd->pw_dir= defdev.pw_dir;
5372 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5373 pwd->pw_shell= defcli.pw_shell;
5374 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5376 ldir= strlen(pwd->pw_unixdir) - 1;
5377 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5380 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5381 __mystrtolower(pwd->pw_unixdir);
5386 * Get information for a named user.
5388 /*{{{struct passwd *getpwnam(char *name)*/
5389 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5391 struct dsc$descriptor_s name_desc;
5393 unsigned long int status, sts;
5395 __pwdcache = __passwd_empty;
5396 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5397 /* We still may be able to determine pw_uid and pw_gid */
5398 name_desc.dsc$w_length= strlen(name);
5399 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5400 name_desc.dsc$b_class= DSC$K_CLASS_S;
5401 name_desc.dsc$a_pointer= (char *) name;
5402 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5403 __pwdcache.pw_uid= uic.uic$l_uic;
5404 __pwdcache.pw_gid= uic.uic$v_group;
5407 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5408 set_vaxc_errno(sts);
5409 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5412 else { _ckvmssts(sts); }
5415 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5416 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5417 __pwdcache.pw_name= __pw_namecache;
5419 } /* end of my_getpwnam() */
5423 * Get information for a particular UIC or UID.
5424 * Called by my_getpwent with uid=-1 to list all users.
5426 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5427 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5429 const $DESCRIPTOR(name_desc,__pw_namecache);
5430 unsigned short lname;
5432 unsigned long int status;
5434 if (uid == (unsigned int) -1) {
5436 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5437 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5438 set_vaxc_errno(status);
5439 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5443 else { _ckvmssts(status); }
5444 } while (!valid_uic (uic));
5448 if (!uic.uic$v_group)
5449 uic.uic$v_group= PerlProc_getgid();
5451 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5452 else status = SS$_IVIDENT;
5453 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5454 status == RMS$_PRV) {
5455 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5458 else { _ckvmssts(status); }
5460 __pw_namecache[lname]= '\0';
5461 __mystrtolower(__pw_namecache);
5463 __pwdcache = __passwd_empty;
5464 __pwdcache.pw_name = __pw_namecache;
5466 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5467 The identifier's value is usually the UIC, but it doesn't have to be,
5468 so if we can, we let fillpasswd update this. */
5469 __pwdcache.pw_uid = uic.uic$l_uic;
5470 __pwdcache.pw_gid = uic.uic$v_group;
5472 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5475 } /* end of my_getpwuid() */
5479 * Get information for next user.
5481 /*{{{struct passwd *my_getpwent()*/
5482 struct passwd *Perl_my_getpwent(pTHX)
5484 return (my_getpwuid((unsigned int) -1));
5489 * Finish searching rights database for users.
5491 /*{{{void my_endpwent()*/
5492 void Perl_my_endpwent(pTHX)
5495 _ckvmssts(sys$finish_rdb(&contxt));
5501 #ifdef HOMEGROWN_POSIX_SIGNALS
5502 /* Signal handling routines, pulled into the core from POSIX.xs.
5504 * We need these for threads, so they've been rolled into the core,
5505 * rather than left in POSIX.xs.
5507 * (DRS, Oct 23, 1997)
5510 /* sigset_t is atomic under VMS, so these routines are easy */
5511 /*{{{int my_sigemptyset(sigset_t *) */
5512 int my_sigemptyset(sigset_t *set) {
5513 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5519 /*{{{int my_sigfillset(sigset_t *)*/
5520 int my_sigfillset(sigset_t *set) {
5522 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5523 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5529 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5530 int my_sigaddset(sigset_t *set, int sig) {
5531 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5532 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5533 *set |= (1 << (sig - 1));
5539 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5540 int my_sigdelset(sigset_t *set, int sig) {
5541 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5542 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5543 *set &= ~(1 << (sig - 1));
5549 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5550 int my_sigismember(sigset_t *set, int sig) {
5551 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5552 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5553 *set & (1 << (sig - 1));
5558 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5559 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5562 /* If set and oset are both null, then things are badly wrong. Bail out. */
5563 if ((oset == NULL) && (set == NULL)) {
5564 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5568 /* If set's null, then we're just handling a fetch. */
5570 tempmask = sigblock(0);
5575 tempmask = sigsetmask(*set);
5578 tempmask = sigblock(*set);
5581 tempmask = sigblock(0);
5582 sigsetmask(*oset & ~tempmask);
5585 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5590 /* Did they pass us an oset? If so, stick our holding mask into it */
5597 #endif /* HOMEGROWN_POSIX_SIGNALS */
5600 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5601 * my_utime(), and flex_stat(), all of which operate on UTC unless
5602 * VMSISH_TIMES is true.
5604 /* method used to handle UTC conversions:
5605 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5607 static int gmtime_emulation_type;
5608 /* number of secs to add to UTC POSIX-style time to get local time */
5609 static long int utc_offset_secs;
5611 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5612 * in vmsish.h. #undef them here so we can call the CRTL routines
5621 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5622 * qualifier with the extern prefix pragma. This provisional
5623 * hack circumvents this prefix pragma problem in previous
5626 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5627 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5628 # pragma __extern_prefix save
5629 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5630 # define gmtime decc$__utctz_gmtime
5631 # define localtime decc$__utctz_localtime
5632 # define time decc$__utc_time
5633 # pragma __extern_prefix restore
5635 struct tm *gmtime(), *localtime();
5641 static time_t toutc_dst(time_t loc) {
5644 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5645 loc -= utc_offset_secs;
5646 if (rsltmp->tm_isdst) loc -= 3600;
5649 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5650 ((gmtime_emulation_type || my_time(NULL)), \
5651 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5652 ((secs) - utc_offset_secs))))
5654 static time_t toloc_dst(time_t utc) {
5657 utc += utc_offset_secs;
5658 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5659 if (rsltmp->tm_isdst) utc += 3600;
5662 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5663 ((gmtime_emulation_type || my_time(NULL)), \
5664 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5665 ((secs) + utc_offset_secs))))
5667 #ifndef RTL_USES_UTC
5670 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5671 DST starts on 1st sun of april at 02:00 std time
5672 ends on last sun of october at 02:00 dst time
5673 see the UCX management command reference, SET CONFIG TIMEZONE
5674 for formatting info.
5676 No, it's not as general as it should be, but then again, NOTHING
5677 will handle UK times in a sensible way.
5682 parse the DST start/end info:
5683 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5687 tz_parse_startend(char *s, struct tm *w, int *past)
5689 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5690 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5695 if (!past) return 0;
5698 if (w->tm_year % 4 == 0) ly = 1;
5699 if (w->tm_year % 100 == 0) ly = 0;
5700 if (w->tm_year+1900 % 400 == 0) ly = 1;
5703 dozjd = isdigit(*s);
5704 if (*s == 'J' || *s == 'j' || dozjd) {
5705 if (!dozjd && !isdigit(*++s)) return 0;
5708 d = d*10 + *s++ - '0';
5710 d = d*10 + *s++ - '0';
5713 if (d == 0) return 0;
5714 if (d > 366) return 0;
5716 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5719 } else if (*s == 'M' || *s == 'm') {
5720 if (!isdigit(*++s)) return 0;
5722 if (isdigit(*s)) m = 10*m + *s++ - '0';
5723 if (*s != '.') return 0;
5724 if (!isdigit(*++s)) return 0;
5726 if (n < 1 || n > 5) return 0;
5727 if (*s != '.') return 0;
5728 if (!isdigit(*++s)) return 0;
5730 if (d > 6) return 0;
5734 if (!isdigit(*++s)) return 0;
5736 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5738 if (!isdigit(*++s)) return 0;
5740 if (isdigit(*s)) min = 10*min + *s++ - '0';
5742 if (!isdigit(*++s)) return 0;
5744 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5754 if (w->tm_yday < d) goto before;
5755 if (w->tm_yday > d) goto after;
5757 if (w->tm_mon+1 < m) goto before;
5758 if (w->tm_mon+1 > m) goto after;
5760 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5761 k = d - j; /* mday of first d */
5763 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5764 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5765 if (w->tm_mday < k) goto before;
5766 if (w->tm_mday > k) goto after;
5769 if (w->tm_hour < hour) goto before;
5770 if (w->tm_hour > hour) goto after;
5771 if (w->tm_min < min) goto before;
5772 if (w->tm_min > min) goto after;
5773 if (w->tm_sec < sec) goto before;
5787 /* parse the offset: (+|-)hh[:mm[:ss]] */
5790 tz_parse_offset(char *s, int *offset)
5792 int hour = 0, min = 0, sec = 0;
5795 if (!offset) return 0;
5797 if (*s == '-') {neg++; s++;}
5799 if (!isdigit(*s)) return 0;
5801 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5802 if (hour > 24) return 0;
5804 if (!isdigit(*++s)) return 0;
5806 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5807 if (min > 59) return 0;
5809 if (!isdigit(*++s)) return 0;
5811 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5812 if (sec > 59) return 0;
5816 *offset = (hour*60+min)*60 + sec;
5817 if (neg) *offset = -*offset;
5822 input time is w, whatever type of time the CRTL localtime() uses.
5823 sets dst, the zone, and the gmtoff (seconds)
5825 caches the value of TZ and UCX$TZ env variables; note that
5826 my_setenv looks for these and sets a flag if they're changed
5829 We have to watch out for the "australian" case (dst starts in
5830 october, ends in april)...flagged by "reverse" and checked by
5831 scanning through the months of the previous year.
5836 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5841 char *dstzone, *tz, *s_start, *s_end;
5842 int std_off, dst_off, isdst;
5843 int y, dststart, dstend;
5844 static char envtz[1025]; /* longer than any logical, symbol, ... */
5845 static char ucxtz[1025];
5846 static char reversed = 0;
5852 reversed = -1; /* flag need to check */
5853 envtz[0] = ucxtz[0] = '\0';
5854 tz = my_getenv("TZ",0);
5855 if (tz) strcpy(envtz, tz);
5856 tz = my_getenv("UCX$TZ",0);
5857 if (tz) strcpy(ucxtz, tz);
5858 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5861 if (!*tz) tz = ucxtz;
5864 while (isalpha(*s)) s++;
5865 s = tz_parse_offset(s, &std_off);
5867 if (!*s) { /* no DST, hurray we're done! */
5873 while (isalpha(*s)) s++;
5874 s2 = tz_parse_offset(s, &dst_off);
5878 dst_off = std_off - 3600;
5881 if (!*s) { /* default dst start/end?? */
5882 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5883 s = strchr(ucxtz,',');
5885 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5887 if (*s != ',') return 0;
5890 when = _toutc(when); /* convert to utc */
5891 when = when - std_off; /* convert to pseudolocal time*/
5893 w2 = localtime(&when);
5896 s = tz_parse_startend(s_start,w2,&dststart);
5898 if (*s != ',') return 0;
5901 when = _toutc(when); /* convert to utc */
5902 when = when - dst_off; /* convert to pseudolocal time*/
5903 w2 = localtime(&when);
5904 if (w2->tm_year != y) { /* spans a year, just check one time */
5905 when += dst_off - std_off;
5906 w2 = localtime(&when);
5909 s = tz_parse_startend(s_end,w2,&dstend);
5912 if (reversed == -1) { /* need to check if start later than end */
5916 if (when < 2*365*86400) {
5917 when += 2*365*86400;
5921 w2 =localtime(&when);
5922 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5924 for (j = 0; j < 12; j++) {
5925 w2 =localtime(&when);
5926 (void) tz_parse_startend(s_start,w2,&ds);
5927 (void) tz_parse_startend(s_end,w2,&de);
5928 if (ds != de) break;
5932 if (de && !ds) reversed = 1;
5935 isdst = dststart && !dstend;
5936 if (reversed) isdst = dststart || !dstend;
5939 if (dst) *dst = isdst;
5940 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5941 if (isdst) tz = dstzone;
5943 while(isalpha(*tz)) *zone++ = *tz++;
5949 #endif /* !RTL_USES_UTC */
5951 /* my_time(), my_localtime(), my_gmtime()
5952 * By default traffic in UTC time values, using CRTL gmtime() or
5953 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5954 * Note: We need to use these functions even when the CRTL has working
5955 * UTC support, since they also handle C<use vmsish qw(times);>
5957 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5958 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5961 /*{{{time_t my_time(time_t *timep)*/
5962 time_t Perl_my_time(pTHX_ time_t *timep)
5967 if (gmtime_emulation_type == 0) {
5969 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5970 /* results of calls to gmtime() and localtime() */
5971 /* for same &base */
5973 gmtime_emulation_type++;
5974 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5975 char off[LNM$C_NAMLENGTH+1];;
5977 gmtime_emulation_type++;
5978 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5979 gmtime_emulation_type++;
5980 utc_offset_secs = 0;
5981 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5983 else { utc_offset_secs = atol(off); }
5985 else { /* We've got a working gmtime() */
5986 struct tm gmt, local;
5989 tm_p = localtime(&base);
5991 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5992 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5993 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5994 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6000 # ifdef RTL_USES_UTC
6001 if (VMSISH_TIME) when = _toloc(when);
6003 if (!VMSISH_TIME) when = _toutc(when);
6006 if (timep != NULL) *timep = when;
6009 } /* end of my_time() */
6013 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6015 Perl_my_gmtime(pTHX_ const time_t *timep)
6021 if (timep == NULL) {
6022 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6025 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6029 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6031 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6032 return gmtime(&when);
6034 /* CRTL localtime() wants local time as input, so does no tz correction */
6035 rsltmp = localtime(&when);
6036 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6039 } /* end of my_gmtime() */
6043 /*{{{struct tm *my_localtime(const time_t *timep)*/
6045 Perl_my_localtime(pTHX_ const time_t *timep)
6047 time_t when, whenutc;
6051 if (timep == NULL) {
6052 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6055 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6056 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6059 # ifdef RTL_USES_UTC
6061 if (VMSISH_TIME) when = _toutc(when);
6063 /* CRTL localtime() wants UTC as input, does tz correction itself */
6064 return localtime(&when);
6066 # else /* !RTL_USES_UTC */
6069 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6070 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6073 #ifndef RTL_USES_UTC
6074 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6075 when = whenutc - offset; /* pseudolocal time*/
6078 /* CRTL localtime() wants local time as input, so does no tz correction */
6079 rsltmp = localtime(&when);
6080 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6084 } /* end of my_localtime() */
6087 /* Reset definitions for later calls */
6088 #define gmtime(t) my_gmtime(t)
6089 #define localtime(t) my_localtime(t)
6090 #define time(t) my_time(t)
6093 /* my_utime - update modification time of a file
6094 * calling sequence is identical to POSIX utime(), but under
6095 * VMS only the modification time is changed; ODS-2 does not
6096 * maintain access times. Restrictions differ from the POSIX
6097 * definition in that the time can be changed as long as the
6098 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6099 * no separate checks are made to insure that the caller is the
6100 * owner of the file or has special privs enabled.
6101 * Code here is based on Joe Meadows' FILE utility.
6104 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6105 * to VMS epoch (01-JAN-1858 00:00:00.00)
6106 * in 100 ns intervals.
6108 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6110 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6111 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6114 long int bintime[2], len = 2, lowbit, unixtime,
6115 secscale = 10000000; /* seconds --> 100 ns intervals */
6116 unsigned long int chan, iosb[2], retsts;
6117 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6118 struct FAB myfab = cc$rms_fab;
6119 struct NAM mynam = cc$rms_nam;
6120 #if defined (__DECC) && defined (__VAX)
6121 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6122 * at least through VMS V6.1, which causes a type-conversion warning.
6124 # pragma message save
6125 # pragma message disable cvtdiftypes
6127 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6128 struct fibdef myfib;
6129 #if defined (__DECC) && defined (__VAX)
6130 /* This should be right after the declaration of myatr, but due
6131 * to a bug in VAX DEC C, this takes effect a statement early.
6133 # pragma message restore
6135 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6136 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6137 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6139 if (file == NULL || *file == '\0') {
6141 set_vaxc_errno(LIB$_INVARG);
6144 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6146 if (utimes != NULL) {
6147 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6148 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6149 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6150 * as input, we force the sign bit to be clear by shifting unixtime right
6151 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6153 lowbit = (utimes->modtime & 1) ? secscale : 0;
6154 unixtime = (long int) utimes->modtime;
6156 /* If input was UTC; convert to local for sys svc */
6157 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6159 unixtime >>= 1; secscale <<= 1;
6160 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6161 if (!(retsts & 1)) {
6163 set_vaxc_errno(retsts);
6166 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6167 if (!(retsts & 1)) {
6169 set_vaxc_errno(retsts);
6174 /* Just get the current time in VMS format directly */
6175 retsts = sys$gettim(bintime);
6176 if (!(retsts & 1)) {
6178 set_vaxc_errno(retsts);
6183 myfab.fab$l_fna = vmsspec;
6184 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6185 myfab.fab$l_nam = &mynam;
6186 mynam.nam$l_esa = esa;
6187 mynam.nam$b_ess = (unsigned char) sizeof esa;
6188 mynam.nam$l_rsa = rsa;
6189 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6191 /* Look for the file to be affected, letting RMS parse the file
6192 * specification for us as well. I have set errno using only
6193 * values documented in the utime() man page for VMS POSIX.
6195 retsts = sys$parse(&myfab,0,0);
6196 if (!(retsts & 1)) {
6197 set_vaxc_errno(retsts);
6198 if (retsts == RMS$_PRV) set_errno(EACCES);
6199 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6200 else set_errno(EVMSERR);
6203 retsts = sys$search(&myfab,0,0);
6204 if (!(retsts & 1)) {
6205 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6206 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6207 set_vaxc_errno(retsts);
6208 if (retsts == RMS$_PRV) set_errno(EACCES);
6209 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6210 else set_errno(EVMSERR);
6214 devdsc.dsc$w_length = mynam.nam$b_dev;
6215 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6217 retsts = sys$assign(&devdsc,&chan,0,0);
6218 if (!(retsts & 1)) {
6219 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6220 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6221 set_vaxc_errno(retsts);
6222 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6223 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6224 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6225 else set_errno(EVMSERR);
6229 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6230 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6232 memset((void *) &myfib, 0, sizeof myfib);
6233 #if defined(__DECC) || defined(__DECCXX)
6234 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6235 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6236 /* This prevents the revision time of the file being reset to the current
6237 * time as a result of our IO$_MODIFY $QIO. */
6238 myfib.fib$l_acctl = FIB$M_NORECORD;
6240 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6241 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6242 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6244 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6245 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6246 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6247 _ckvmssts(sys$dassgn(chan));
6248 if (retsts & 1) retsts = iosb[0];
6249 if (!(retsts & 1)) {
6250 set_vaxc_errno(retsts);
6251 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6252 else set_errno(EVMSERR);
6257 } /* end of my_utime() */
6261 * flex_stat, flex_fstat
6262 * basic stat, but gets it right when asked to stat
6263 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6266 /* encode_dev packs a VMS device name string into an integer to allow
6267 * simple comparisons. This can be used, for example, to check whether two
6268 * files are located on the same device, by comparing their encoded device
6269 * names. Even a string comparison would not do, because stat() reuses the
6270 * device name buffer for each call; so without encode_dev, it would be
6271 * necessary to save the buffer and use strcmp (this would mean a number of
6272 * changes to the standard Perl code, to say nothing of what a Perl script
6275 * The device lock id, if it exists, should be unique (unless perhaps compared
6276 * with lock ids transferred from other nodes). We have a lock id if the disk is
6277 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6278 * device names. Thus we use the lock id in preference, and only if that isn't
6279 * available, do we try to pack the device name into an integer (flagged by
6280 * the sign bit (LOCKID_MASK) being set).
6282 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6283 * name and its encoded form, but it seems very unlikely that we will find
6284 * two files on different disks that share the same encoded device names,
6285 * and even more remote that they will share the same file id (if the test
6286 * is to check for the same file).
6288 * A better method might be to use sys$device_scan on the first call, and to
6289 * search for the device, returning an index into the cached array.
6290 * The number returned would be more intelligable.
6291 * This is probably not worth it, and anyway would take quite a bit longer
6292 * on the first call.
6294 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6295 static mydev_t encode_dev (pTHX_ const char *dev)
6298 unsigned long int f;
6303 if (!dev || !dev[0]) return 0;
6307 struct dsc$descriptor_s dev_desc;
6308 unsigned long int status, lockid, item = DVI$_LOCKID;
6310 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6311 can try that first. */
6312 dev_desc.dsc$w_length = strlen (dev);
6313 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6314 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6315 dev_desc.dsc$a_pointer = (char *) dev;
6316 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6317 if (lockid) return (lockid & ~LOCKID_MASK);
6321 /* Otherwise we try to encode the device name */
6325 for (q = dev + strlen(dev); q--; q >= dev) {
6328 else if (isalpha (toupper (*q)))
6329 c= toupper (*q) - 'A' + (char)10;
6331 continue; /* Skip '$'s */
6333 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6335 enc += f * (unsigned long int) c;
6337 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6339 } /* end of encode_dev() */
6341 static char namecache[NAM$C_MAXRSS+1];
6344 is_null_device(name)
6347 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6348 The underscore prefix, controller letter, and unit number are
6349 independently optional; for our purposes, the colon punctuation
6350 is not. The colon can be trailed by optional directory and/or
6351 filename, but two consecutive colons indicates a nodename rather
6352 than a device. [pr] */
6353 if (*name == '_') ++name;
6354 if (tolower(*name++) != 'n') return 0;
6355 if (tolower(*name++) != 'l') return 0;
6356 if (tolower(*name) == 'a') ++name;
6357 if (*name == '0') ++name;
6358 return (*name++ == ':') && (*name != ':');
6361 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6362 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6363 * subset of the applicable information.
6366 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6368 char fname_phdev[NAM$C_MAXRSS+1];
6369 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6371 char fname[NAM$C_MAXRSS+1];
6372 unsigned long int retsts;
6373 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6374 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6376 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6377 device name on successive calls */
6378 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6379 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6380 namdsc.dsc$a_pointer = fname;
6381 namdsc.dsc$w_length = sizeof fname - 1;
6383 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6384 &namdsc,&namdsc.dsc$w_length,0,0);
6386 fname[namdsc.dsc$w_length] = '\0';
6388 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6389 * but if someone has redefined that logical, Perl gets very lost. Since
6390 * we have the physical device name from the stat buffer, just paste it on.
6392 strcpy( fname_phdev, statbufp->st_devnam );
6393 strcat( fname_phdev, strrchr(fname, ':') );
6395 return cando_by_name(bit,effective,fname_phdev);
6397 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6398 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6402 return FALSE; /* Should never get to here */
6404 } /* end of cando() */
6408 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6410 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6412 static char usrname[L_cuserid];
6413 static struct dsc$descriptor_s usrdsc =
6414 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6415 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6416 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6417 unsigned short int retlen;
6418 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6419 union prvdef curprv;
6420 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6421 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6422 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6425 if (!fname || !*fname) return FALSE;
6426 /* Make sure we expand logical names, since sys$check_access doesn't */
6427 if (!strpbrk(fname,"/]>:")) {
6428 strcpy(fileified,fname);
6429 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6432 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6433 retlen = namdsc.dsc$w_length = strlen(vmsname);
6434 namdsc.dsc$a_pointer = vmsname;
6435 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6436 vmsname[retlen-1] == ':') {
6437 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6438 namdsc.dsc$w_length = strlen(fileified);
6439 namdsc.dsc$a_pointer = fileified;
6442 if (!usrdsc.dsc$w_length) {
6444 usrdsc.dsc$w_length = strlen(usrname);
6448 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6449 access = ARM$M_EXECUTE; break;
6450 case S_IRUSR: case S_IRGRP: case S_IROTH:
6451 access = ARM$M_READ; break;
6452 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6453 access = ARM$M_WRITE; break;
6454 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6455 access = ARM$M_DELETE; break;
6460 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6461 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6462 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6463 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6464 set_vaxc_errno(retsts);
6465 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6466 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6467 else set_errno(ENOENT);
6470 if (retsts == SS$_NORMAL) {
6471 if (!privused) return TRUE;
6472 /* We can get access, but only by using privs. Do we have the
6473 necessary privs currently enabled? */
6474 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6475 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6476 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6477 !curprv.prv$v_bypass) return FALSE;
6478 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6479 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6480 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6483 if (retsts == SS$_ACCONFLICT) {
6488 return FALSE; /* Should never get here */
6490 } /* end of cando_by_name() */
6494 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6496 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6498 if (!fstat(fd,(stat_t *) statbufp)) {
6499 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6500 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6501 # ifdef RTL_USES_UTC
6504 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6505 statbufp->st_atime = _toloc(statbufp->st_atime);
6506 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6511 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6515 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6516 statbufp->st_atime = _toutc(statbufp->st_atime);
6517 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6524 } /* end of flex_fstat() */
6527 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6529 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6531 char fileified[NAM$C_MAXRSS+1];
6532 char temp_fspec[NAM$C_MAXRSS+300];
6535 if (!fspec) return retval;
6536 strcpy(temp_fspec, fspec);
6537 if (statbufp == (Stat_t *) &PL_statcache)
6538 do_tovmsspec(temp_fspec,namecache,0);
6539 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6540 memset(statbufp,0,sizeof *statbufp);
6541 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6542 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6543 statbufp->st_uid = 0x00010001;
6544 statbufp->st_gid = 0x0001;
6545 time((time_t *)&statbufp->st_mtime);
6546 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6550 /* Try for a directory name first. If fspec contains a filename without
6551 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6552 * and sea:[wine.dark]water. exist, we prefer the directory here.
6553 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6554 * not sea:[wine.dark]., if the latter exists. If the intended target is
6555 * the file with null type, specify this by calling flex_stat() with
6556 * a '.' at the end of fspec.
6558 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6559 retval = stat(fileified,(stat_t *) statbufp);
6560 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6561 strcpy(namecache,fileified);
6563 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6565 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6566 # ifdef RTL_USES_UTC
6569 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6570 statbufp->st_atime = _toloc(statbufp->st_atime);
6571 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6576 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6580 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6581 statbufp->st_atime = _toutc(statbufp->st_atime);
6582 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6588 } /* end of flex_stat() */
6592 /*{{{char *my_getlogin()*/
6593 /* VMS cuserid == Unix getlogin, except calling sequence */
6597 static char user[L_cuserid];
6598 return cuserid(user);
6603 /* rmscopy - copy a file using VMS RMS routines
6605 * Copies contents and attributes of spec_in to spec_out, except owner
6606 * and protection information. Name and type of spec_in are used as
6607 * defaults for spec_out. The third parameter specifies whether rmscopy()
6608 * should try to propagate timestamps from the input file to the output file.
6609 * If it is less than 0, no timestamps are preserved. If it is 0, then
6610 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6611 * propagated to the output file at creation iff the output file specification
6612 * did not contain an explicit name or type, and the revision date is always
6613 * updated at the end of the copy operation. If it is greater than 0, then
6614 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6615 * other than the revision date should be propagated, and bit 1 indicates
6616 * that the revision date should be propagated.
6618 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6620 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6621 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6622 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6623 * as part of the Perl standard distribution under the terms of the
6624 * GNU General Public License or the Perl Artistic License. Copies
6625 * of each may be found in the Perl standard distribution.
6627 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6629 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6631 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6632 rsa[NAM$C_MAXRSS], ubf[32256];
6633 unsigned long int i, sts, sts2;
6634 struct FAB fab_in, fab_out;
6635 struct RAB rab_in, rab_out;
6637 struct XABDAT xabdat;
6638 struct XABFHC xabfhc;
6639 struct XABRDT xabrdt;
6640 struct XABSUM xabsum;
6642 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6643 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6644 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6648 fab_in = cc$rms_fab;
6649 fab_in.fab$l_fna = vmsin;
6650 fab_in.fab$b_fns = strlen(vmsin);
6651 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6652 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6653 fab_in.fab$l_fop = FAB$M_SQO;
6654 fab_in.fab$l_nam = &nam;
6655 fab_in.fab$l_xab = (void *) &xabdat;
6658 nam.nam$l_rsa = rsa;
6659 nam.nam$b_rss = sizeof(rsa);
6660 nam.nam$l_esa = esa;
6661 nam.nam$b_ess = sizeof (esa);
6662 nam.nam$b_esl = nam.nam$b_rsl = 0;
6664 xabdat = cc$rms_xabdat; /* To get creation date */
6665 xabdat.xab$l_nxt = (void *) &xabfhc;
6667 xabfhc = cc$rms_xabfhc; /* To get record length */
6668 xabfhc.xab$l_nxt = (void *) &xabsum;
6670 xabsum = cc$rms_xabsum; /* To get key and area information */
6672 if (!((sts = sys$open(&fab_in)) & 1)) {
6673 set_vaxc_errno(sts);
6675 case RMS$_FNF: case RMS$_DNF:
6676 set_errno(ENOENT); break;
6678 set_errno(ENOTDIR); break;
6680 set_errno(ENODEV); break;
6682 set_errno(EINVAL); break;
6684 set_errno(EACCES); break;
6692 fab_out.fab$w_ifi = 0;
6693 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6694 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6695 fab_out.fab$l_fop = FAB$M_SQO;
6696 fab_out.fab$l_fna = vmsout;
6697 fab_out.fab$b_fns = strlen(vmsout);
6698 fab_out.fab$l_dna = nam.nam$l_name;
6699 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6701 if (preserve_dates == 0) { /* Act like DCL COPY */
6702 nam.nam$b_nop = NAM$M_SYNCHK;
6703 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6704 if (!((sts = sys$parse(&fab_out)) & 1)) {
6705 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6706 set_vaxc_errno(sts);
6709 fab_out.fab$l_xab = (void *) &xabdat;
6710 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6712 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6713 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6714 preserve_dates =0; /* bitmask from this point forward */
6716 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6717 if (!((sts = sys$create(&fab_out)) & 1)) {
6718 set_vaxc_errno(sts);
6721 set_errno(ENOENT); break;
6723 set_errno(ENOTDIR); break;
6725 set_errno(ENODEV); break;
6727 set_errno(EINVAL); break;
6729 set_errno(EACCES); break;
6735 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6736 if (preserve_dates & 2) {
6737 /* sys$close() will process xabrdt, not xabdat */
6738 xabrdt = cc$rms_xabrdt;
6740 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6742 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6743 * is unsigned long[2], while DECC & VAXC use a struct */
6744 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6746 fab_out.fab$l_xab = (void *) &xabrdt;
6749 rab_in = cc$rms_rab;
6750 rab_in.rab$l_fab = &fab_in;
6751 rab_in.rab$l_rop = RAB$M_BIO;
6752 rab_in.rab$l_ubf = ubf;
6753 rab_in.rab$w_usz = sizeof ubf;
6754 if (!((sts = sys$connect(&rab_in)) & 1)) {
6755 sys$close(&fab_in); sys$close(&fab_out);
6756 set_errno(EVMSERR); set_vaxc_errno(sts);
6760 rab_out = cc$rms_rab;
6761 rab_out.rab$l_fab = &fab_out;
6762 rab_out.rab$l_rbf = ubf;
6763 if (!((sts = sys$connect(&rab_out)) & 1)) {
6764 sys$close(&fab_in); sys$close(&fab_out);
6765 set_errno(EVMSERR); set_vaxc_errno(sts);
6769 while ((sts = sys$read(&rab_in))) { /* always true */
6770 if (sts == RMS$_EOF) break;
6771 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6772 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6773 sys$close(&fab_in); sys$close(&fab_out);
6774 set_errno(EVMSERR); set_vaxc_errno(sts);
6779 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6780 sys$close(&fab_in); sys$close(&fab_out);
6781 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6783 set_errno(EVMSERR); set_vaxc_errno(sts);
6789 } /* end of rmscopy() */
6793 /*** The following glue provides 'hooks' to make some of the routines
6794 * from this file available from Perl. These routines are sufficiently
6795 * basic, and are required sufficiently early in the build process,
6796 * that's it's nice to have them available to miniperl as well as the
6797 * full Perl, so they're set up here instead of in an extension. The
6798 * Perl code which handles importation of these names into a given
6799 * package lives in [.VMS]Filespec.pm in @INC.
6803 rmsexpand_fromperl(pTHX_ CV *cv)
6806 char *fspec, *defspec = NULL, *rslt;
6809 if (!items || items > 2)
6810 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6811 fspec = SvPV(ST(0),n_a);
6812 if (!fspec || !*fspec) XSRETURN_UNDEF;
6813 if (items == 2) defspec = SvPV(ST(1),n_a);
6815 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6816 ST(0) = sv_newmortal();
6817 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6822 vmsify_fromperl(pTHX_ CV *cv)
6828 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6829 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6830 ST(0) = sv_newmortal();
6831 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6836 unixify_fromperl(pTHX_ CV *cv)
6842 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6843 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6844 ST(0) = sv_newmortal();
6845 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6850 fileify_fromperl(pTHX_ CV *cv)
6856 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6857 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6858 ST(0) = sv_newmortal();
6859 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6864 pathify_fromperl(pTHX_ CV *cv)
6870 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6871 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6872 ST(0) = sv_newmortal();
6873 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6878 vmspath_fromperl(pTHX_ CV *cv)
6884 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6885 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6886 ST(0) = sv_newmortal();
6887 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6892 unixpath_fromperl(pTHX_ CV *cv)
6898 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6899 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6900 ST(0) = sv_newmortal();
6901 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6906 candelete_fromperl(pTHX_ CV *cv)
6909 char fspec[NAM$C_MAXRSS+1], *fsp;
6914 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6916 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6917 if (SvTYPE(mysv) == SVt_PVGV) {
6918 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6919 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6926 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6927 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6933 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6938 rmscopy_fromperl(pTHX_ CV *cv)
6941 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6943 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6944 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6945 unsigned long int sts;
6950 if (items < 2 || items > 3)
6951 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6953 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6954 if (SvTYPE(mysv) == SVt_PVGV) {
6955 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6956 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6963 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6964 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6969 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6970 if (SvTYPE(mysv) == SVt_PVGV) {
6971 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6972 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6979 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6980 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6985 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6987 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6993 mod2fname(pTHX_ CV *cv)
6996 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6997 workbuff[NAM$C_MAXRSS*1 + 1];
6998 int total_namelen = 3, counter, num_entries;
6999 /* ODS-5 ups this, but we want to be consistent, so... */
7000 int max_name_len = 39;
7001 AV *in_array = (AV *)SvRV(ST(0));
7003 num_entries = av_len(in_array);
7005 /* All the names start with PL_. */
7006 strcpy(ultimate_name, "PL_");
7008 /* Clean up our working buffer */
7009 Zero(work_name, sizeof(work_name), char);
7011 /* Run through the entries and build up a working name */
7012 for(counter = 0; counter <= num_entries; counter++) {
7013 /* If it's not the first name then tack on a __ */
7015 strcat(work_name, "__");
7017 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7021 /* Check to see if we actually have to bother...*/
7022 if (strlen(work_name) + 3 <= max_name_len) {
7023 strcat(ultimate_name, work_name);
7025 /* It's too darned big, so we need to go strip. We use the same */
7026 /* algorithm as xsubpp does. First, strip out doubled __ */
7027 char *source, *dest, last;
7030 for (source = work_name; *source; source++) {
7031 if (last == *source && last == '_') {
7037 /* Go put it back */
7038 strcpy(work_name, workbuff);
7039 /* Is it still too big? */
7040 if (strlen(work_name) + 3 > max_name_len) {
7041 /* Strip duplicate letters */
7044 for (source = work_name; *source; source++) {
7045 if (last == toupper(*source)) {
7049 last = toupper(*source);
7051 strcpy(work_name, workbuff);
7054 /* Is it *still* too big? */
7055 if (strlen(work_name) + 3 > max_name_len) {
7056 /* Too bad, we truncate */
7057 work_name[max_name_len - 2] = 0;
7059 strcat(ultimate_name, work_name);
7062 /* Okay, return it */
7063 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7068 hushexit_fromperl(pTHX_ CV *cv)
7073 VMSISH_HUSHED = SvTRUE(ST(0));
7075 ST(0) = boolSV(VMSISH_HUSHED);
7080 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7081 struct interp_intern *dst)
7083 memcpy(dst,src,sizeof(struct interp_intern));
7087 Perl_sys_intern_clear(pTHX)
7092 Perl_sys_intern_init(pTHX)
7100 MY_INV_RAND_MAX = 1./x;
7102 VMSCMD.dsc$a_pointer = NULL;
7103 VMSCMD.dsc$w_length = 0;
7104 VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
7105 VMSCMD.dsc$b_class = DSC$K_CLASS_S;
7112 char* file = __FILE__;
7113 char temp_buff[512];
7114 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7115 no_translate_barewords = TRUE;
7117 no_translate_barewords = FALSE;
7120 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7121 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7122 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7123 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7124 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7125 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7126 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7127 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7128 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7129 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7130 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7132 store_pipelocs(aTHX);