3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
41 #include <str$routines.h>
46 /* Older versions of ssdef.h don't have these */
47 #ifndef SS$_INVFILFOROP
48 # define SS$_INVFILFOROP 3930
50 #ifndef SS$_NOSUCHOBJECT
51 # define SS$_NOSUCHOBJECT 2696
54 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
55 #define PERLIO_NOT_STDIO 0
57 /* Don't replace system definitions of vfork, getenv, and stat,
58 * code below needs to get to the underlying CRTL routines. */
59 #define DONT_MASK_RTL_CALLS
63 /* Anticipating future expansion in lexical warnings . . . */
65 # define WARN_INTERNAL WARN_MISC
68 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
69 # define RTL_USES_UTC 1
73 /* gcc's header files don't #define direct access macros
74 * corresponding to VAXC's variant structs */
76 # define uic$v_format uic$r_uic_form.uic$v_format
77 # define uic$v_group uic$r_uic_form.uic$v_group
78 # define uic$v_member uic$r_uic_form.uic$v_member
79 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
80 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
81 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
82 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
85 #if defined(NEED_AN_H_ERRNO)
90 unsigned short int buflen;
91 unsigned short int itmcode;
93 unsigned short int *retlen;
96 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
97 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
98 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
99 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
100 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
101 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
102 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
103 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
104 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
106 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
107 #define PERL_LNM_MAX_ALLOWED_INDEX 127
109 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
110 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
112 static char *__mystrtolower(char *str)
114 if (str) for (; *str; ++str) *str= tolower(*str);
118 static struct dsc$descriptor_s fildevdsc =
119 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
120 static struct dsc$descriptor_s crtlenvdsc =
121 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
122 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
123 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
124 static struct dsc$descriptor_s **env_tables = defenv;
125 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
127 /* True if we shouldn't treat barewords as logicals during directory */
129 static int no_translate_barewords;
132 static int tz_updated = 1;
135 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
137 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
138 struct dsc$descriptor_s **tabvec, unsigned long int flags)
140 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
141 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
142 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
143 unsigned char acmode;
144 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
146 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
147 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
149 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
150 #if defined(PERL_IMPLICIT_CONTEXT)
152 # if defined(USE_5005THREADS)
153 /* We jump through these hoops because we can be called at */
154 /* platform-specific initialization time, which is before anything is */
155 /* set up--we can't even do a plain dTHX since that relies on the */
156 /* interpreter structure to be initialized */
158 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
164 aTHX = PERL_GET_INTERP;
172 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
175 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
176 *cp2 = _toupper(*cp1);
177 if (cp1 - lnm > LNM$C_NAMLENGTH) {
178 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
182 lnmdsc.dsc$w_length = cp1 - lnm;
183 lnmdsc.dsc$a_pointer = uplnm;
184 uplnm[lnmdsc.dsc$w_length] = '\0';
185 secure = flags & PERL__TRNENV_SECURE;
186 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
187 if (!tabvec || !*tabvec) tabvec = env_tables;
189 for (curtab = 0; tabvec[curtab]; curtab++) {
190 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
191 if (!ivenv && !secure) {
196 Perl_warn(aTHX_ "Can't read CRTL environ\n");
199 retsts = SS$_NOLOGNAM;
200 for (i = 0; environ[i]; i++) {
201 if ((eq = strchr(environ[i],'=')) &&
202 !strncmp(environ[i],uplnm,eq - environ[i])) {
204 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
205 if (!eqvlen) continue;
210 if (retsts != SS$_NOLOGNAM) break;
213 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
214 !str$case_blind_compare(&tmpdsc,&clisym)) {
215 if (!ivsym && !secure) {
216 unsigned short int deflen = LNM$C_NAMLENGTH;
217 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
218 /* dynamic dsc to accomodate possible long value */
219 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
220 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
223 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
225 /* Special hack--we might be called before the interpreter's */
226 /* fully initialized, in which case either thr or PL_curcop */
227 /* might be bogus. We have to check, since ckWARN needs them */
228 /* both to be valid if running threaded */
229 #if defined(USE_5005THREADS)
230 if (thr && PL_curcop) {
232 if (ckWARN(WARN_MISC)) {
233 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
235 #if defined(USE_5005THREADS)
237 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
242 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
244 _ckvmssts(lib$sfree1_dd(&eqvdsc));
245 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
246 if (retsts == LIB$_NOSUCHSYM) continue;
251 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
252 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
253 if (retsts == SS$_NOLOGNAM) continue;
254 /* PPFs have a prefix */
257 *((int *)uplnm) == *((int *)"SYS$") &&
259 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
260 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
261 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
262 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
263 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
264 memcpy(eqv,eqv+4,eqvlen-4);
270 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
271 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
272 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
273 retsts == SS$_NOLOGNAM) {
274 set_errno(EINVAL); set_vaxc_errno(retsts);
276 else _ckvmssts(retsts);
278 } /* end of vmstrnenv */
281 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
282 /* Define as a function so we can access statics. */
283 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
285 return vmstrnenv(lnm,eqv,idx,fildev,
286 #ifdef SECURE_INTERNAL_GETENV
287 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
296 * Note: Uses Perl temp to store result so char * can be returned to
297 * caller; this pointer will be invalidated at next Perl statement
299 * We define this as a function rather than a macro in terms of my_getenv_len()
300 * so that it'll work when PL_curinterp is undefined (and we therefore can't
303 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
305 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
307 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
308 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
309 unsigned long int idx = 0;
310 int trnsuccess, success, secure, saverr, savvmserr;
313 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
314 /* Set up a temporary buffer for the return value; Perl will
315 * clean it up at the next statement transition */
316 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
317 if (!tmpsv) return NULL;
320 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
321 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
322 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
323 getcwd(eqv,LNM$C_NAMLENGTH);
327 if ((cp2 = strchr(lnm,';')) != NULL) {
329 uplnm[cp2-lnm] = '\0';
330 idx = strtoul(cp2+1,NULL,0);
333 /* Impose security constraints only if tainting */
335 /* Impose security constraints only if tainting */
336 secure = PL_curinterp ? PL_tainting : will_taint;
337 saverr = errno; savvmserr = vaxc$errno;
340 success = vmstrnenv(lnm,eqv,idx,
341 secure ? fildev : NULL,
342 #ifdef SECURE_INTERNAL_GETENV
343 secure ? PERL__TRNENV_SECURE : 0
348 /* Discard NOLOGNAM on internal calls since we're often looking
349 * for an optional name, and this "error" often shows up as the
350 * (bogus) exit status for a die() call later on. */
351 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
352 return success ? eqv : Nullch;
355 } /* end of my_getenv() */
359 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
361 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
363 char *buf, *cp1, *cp2;
364 unsigned long idx = 0;
365 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
366 int secure, saverr, savvmserr;
369 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
370 /* Set up a temporary buffer for the return value; Perl will
371 * clean it up at the next statement transition */
372 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
373 if (!tmpsv) return NULL;
376 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
377 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
378 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
379 getcwd(buf,LNM$C_NAMLENGTH);
384 if ((cp2 = strchr(lnm,';')) != NULL) {
387 idx = strtoul(cp2+1,NULL,0);
391 /* Impose security constraints only if tainting */
392 secure = PL_curinterp ? PL_tainting : will_taint;
393 saverr = errno; savvmserr = vaxc$errno;
396 *len = vmstrnenv(lnm,buf,idx,
397 secure ? fildev : NULL,
398 #ifdef SECURE_INTERNAL_GETENV
399 secure ? PERL__TRNENV_SECURE : 0
404 /* Discard NOLOGNAM on internal calls since we're often looking
405 * for an optional name, and this "error" often shows up as the
406 * (bogus) exit status for a die() call later on. */
407 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
408 return *len ? buf : Nullch;
411 } /* end of my_getenv_len() */
414 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
416 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
418 /*{{{ void prime_env_iter() */
421 /* Fill the %ENV associative array with all logical names we can
422 * find, in preparation for iterating over it.
425 static int primed = 0;
426 HV *seenhv = NULL, *envhv;
428 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
429 unsigned short int chan;
430 #ifndef CLI$M_TRUSTED
431 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
433 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
434 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
436 bool have_sym = FALSE, have_lnm = FALSE;
437 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
438 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
439 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
440 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
441 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
442 #if defined(PERL_IMPLICIT_CONTEXT)
445 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
446 static perl_mutex primenv_mutex;
447 MUTEX_INIT(&primenv_mutex);
450 #if defined(PERL_IMPLICIT_CONTEXT)
451 /* We jump through these hoops because we can be called at */
452 /* platform-specific initialization time, which is before anything is */
453 /* set up--we can't even do a plain dTHX since that relies on the */
454 /* interpreter structure to be initialized */
455 #if defined(USE_5005THREADS)
457 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
463 aTHX = PERL_GET_INTERP;
470 if (primed || !PL_envgv) return;
471 MUTEX_LOCK(&primenv_mutex);
472 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
473 envhv = GvHVn(PL_envgv);
474 /* Perform a dummy fetch as an lval to insure that the hash table is
475 * set up. Otherwise, the hv_store() will turn into a nullop. */
476 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
478 for (i = 0; env_tables[i]; i++) {
479 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
480 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
481 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
483 if (have_sym || have_lnm) {
484 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
485 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
486 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
487 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
490 for (i--; i >= 0; i--) {
491 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
494 for (j = 0; environ[j]; j++) {
495 if (!(start = strchr(environ[j],'='))) {
496 if (ckWARN(WARN_INTERNAL))
497 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
501 sv = newSVpv(start,0);
503 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
508 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
509 !str$case_blind_compare(&tmpdsc,&clisym)) {
510 strcpy(cmd,"Show Symbol/Global *");
511 cmddsc.dsc$w_length = 20;
512 if (env_tables[i]->dsc$w_length == 12 &&
513 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
514 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
515 flags = defflags | CLI$M_NOLOGNAM;
518 strcpy(cmd,"Show Logical *");
519 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
520 strcat(cmd," /Table=");
521 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
522 cmddsc.dsc$w_length = strlen(cmd);
524 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
525 flags = defflags | CLI$M_NOCLISYM;
528 /* Create a new subprocess to execute each command, to exclude the
529 * remote possibility that someone could subvert a mbx or file used
530 * to write multiple commands to a single subprocess.
533 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
534 0,&riseandshine,0,0,&clidsc,&clitabdsc);
535 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
536 defflags &= ~CLI$M_TRUSTED;
537 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
539 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
540 if (seenhv) SvREFCNT_dec(seenhv);
543 char *cp1, *cp2, *key;
544 unsigned long int sts, iosb[2], retlen, keylen;
547 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
548 if (sts & 1) sts = iosb[0] & 0xffff;
549 if (sts == SS$_ENDOFFILE) {
551 while (substs == 0) { sys$hiber(); wakect++;}
552 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
557 retlen = iosb[0] >> 16;
558 if (!retlen) continue; /* blank line */
560 if (iosb[1] != subpid) {
562 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
566 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
567 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
569 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
570 if (*cp1 == '(' || /* Logical name table name */
571 *cp1 == '=' /* Next eqv of searchlist */) continue;
572 if (*cp1 == '"') cp1++;
573 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
574 key = cp1; keylen = cp2 - cp1;
575 if (keylen && hv_exists(seenhv,key,keylen)) continue;
576 while (*cp2 && *cp2 != '=') cp2++;
577 while (*cp2 && *cp2 == '=') cp2++;
578 while (*cp2 && *cp2 == ' ') cp2++;
579 if (*cp2 == '"') { /* String translation; may embed "" */
580 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
581 cp2++; cp1--; /* Skip "" surrounding translation */
583 else { /* Numeric translation */
584 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
585 cp1--; /* stop on last non-space char */
587 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
588 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
591 PERL_HASH(hash,key,keylen);
592 sv = newSVpvn(cp2,cp1 - cp2 + 1);
594 hv_store(envhv,key,keylen,sv,hash);
595 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
597 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
598 /* get the PPFs for this process, not the subprocess */
599 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
600 char eqv[LNM$C_NAMLENGTH+1];
602 for (i = 0; ppfs[i]; i++) {
603 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
604 sv = newSVpv(eqv,trnlen);
606 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
611 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
612 if (buf) Safefree(buf);
613 if (seenhv) SvREFCNT_dec(seenhv);
614 MUTEX_UNLOCK(&primenv_mutex);
617 } /* end of prime_env_iter */
621 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
622 /* Define or delete an element in the same "environment" as
623 * vmstrnenv(). If an element is to be deleted, it's removed from
624 * the first place it's found. If it's to be set, it's set in the
625 * place designated by the first element of the table vector.
626 * Like setenv() returns 0 for success, non-zero on error.
629 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
631 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
632 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
633 unsigned long int retsts, usermode = PSL$C_USER;
634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
638 $DESCRIPTOR(local,"_LOCAL");
640 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
641 *cp2 = _toupper(*cp1);
642 if (cp1 - lnm > LNM$C_NAMLENGTH) {
643 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
647 lnmdsc.dsc$w_length = cp1 - lnm;
648 if (!tabvec || !*tabvec) tabvec = env_tables;
650 if (!eqv) { /* we're deleting n element */
651 for (curtab = 0; tabvec[curtab]; curtab++) {
652 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
654 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
655 if ((cp1 = strchr(environ[i],'=')) &&
656 !strncmp(environ[i],lnm,cp1 - environ[i])) {
658 return setenv(lnm,"",1) ? vaxc$errno : 0;
661 ivenv = 1; retsts = SS$_NOLOGNAM;
663 if (ckWARN(WARN_INTERNAL))
664 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
665 ivenv = 1; retsts = SS$_NOSUCHPGM;
671 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
672 !str$case_blind_compare(&tmpdsc,&clisym)) {
673 unsigned int symtype;
674 if (tabvec[curtab]->dsc$w_length == 12 &&
675 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
676 !str$case_blind_compare(&tmpdsc,&local))
677 symtype = LIB$K_CLI_LOCAL_SYM;
678 else symtype = LIB$K_CLI_GLOBAL_SYM;
679 retsts = lib$delete_symbol(&lnmdsc,&symtype);
680 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
681 if (retsts == LIB$_NOSUCHSYM) continue;
685 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
686 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
687 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
688 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
689 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
693 else { /* we're defining a value */
694 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
696 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
698 if (ckWARN(WARN_INTERNAL))
699 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
700 retsts = SS$_NOSUCHPGM;
704 eqvdsc.dsc$a_pointer = eqv;
705 eqvdsc.dsc$w_length = strlen(eqv);
706 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
707 !str$case_blind_compare(&tmpdsc,&clisym)) {
708 unsigned int symtype;
709 if (tabvec[0]->dsc$w_length == 12 &&
710 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
711 !str$case_blind_compare(&tmpdsc,&local))
712 symtype = LIB$K_CLI_LOCAL_SYM;
713 else symtype = LIB$K_CLI_GLOBAL_SYM;
714 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
717 if (!*eqv) eqvdsc.dsc$w_length = 1;
718 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
719 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
720 if (ckWARN(WARN_MISC)) {
721 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
724 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
730 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
731 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
732 set_errno(EVMSERR); break;
733 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
734 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
735 set_errno(EINVAL); break;
742 set_vaxc_errno(retsts);
743 return (int) retsts || 44; /* retsts should never be 0, but just in case */
746 /* We reset error values on success because Perl does an hv_fetch()
747 * before each hv_store(), and if the thing we're setting didn't
748 * previously exist, we've got a leftover error message. (Of course,
749 * this fails in the face of
750 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
751 * in that the error reported in $! isn't spurious,
752 * but it's right more often than not.)
754 set_errno(0); set_vaxc_errno(retsts);
758 } /* end of vmssetenv() */
761 /*{{{ void my_setenv(char *lnm, char *eqv)*/
762 /* This has to be a function since there's a prototype for it in proto.h */
764 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
767 int len = strlen(lnm);
771 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
772 if (!strcmp(uplnm,"DEFAULT")) {
773 if (eqv && *eqv) chdir(eqv);
778 if (len == 6 || len == 2) {
781 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
783 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
784 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
788 (void) vmssetenv(lnm,eqv,NULL);
792 /*{{{static void vmssetuserlnm(char *name, char *eqv);
794 * sets a user-mode logical in the process logical name table
795 * used for redirection of sys$error
798 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
800 $DESCRIPTOR(d_tab, "LNM$PROCESS");
801 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
802 unsigned long int iss, attr = LNM$M_CONFINE;
803 unsigned char acmode = PSL$C_USER;
804 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
806 d_name.dsc$a_pointer = name;
807 d_name.dsc$w_length = strlen(name);
809 lnmlst[0].buflen = strlen(eqv);
810 lnmlst[0].bufadr = eqv;
812 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
813 if (!(iss&1)) lib$signal(iss);
818 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
819 /* my_crypt - VMS password hashing
820 * my_crypt() provides an interface compatible with the Unix crypt()
821 * C library function, and uses sys$hash_password() to perform VMS
822 * password hashing. The quadword hashed password value is returned
823 * as a NUL-terminated 8 character string. my_crypt() does not change
824 * the case of its string arguments; in order to match the behavior
825 * of LOGINOUT et al., alphabetic characters in both arguments must
826 * be upcased by the caller.
829 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
831 # ifndef UAI$C_PREFERRED_ALGORITHM
832 # define UAI$C_PREFERRED_ALGORITHM 127
834 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
835 unsigned short int salt = 0;
836 unsigned long int sts;
838 unsigned short int dsc$w_length;
839 unsigned char dsc$b_type;
840 unsigned char dsc$b_class;
841 const char * dsc$a_pointer;
842 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
843 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
844 struct itmlst_3 uailst[3] = {
845 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
846 { sizeof salt, UAI$_SALT, &salt, 0},
847 { 0, 0, NULL, NULL}};
850 usrdsc.dsc$w_length = strlen(usrname);
851 usrdsc.dsc$a_pointer = usrname;
852 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
854 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
858 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
864 if (sts != RMS$_RNF) return NULL;
867 txtdsc.dsc$w_length = strlen(textpasswd);
868 txtdsc.dsc$a_pointer = textpasswd;
869 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
870 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
873 return (char *) hash;
875 } /* end of my_crypt() */
879 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
880 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
881 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
883 /*{{{int do_rmdir(char *name)*/
885 Perl_do_rmdir(pTHX_ char *name)
887 char dirfile[NAM$C_MAXRSS+1];
891 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
892 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
893 else retval = kill_file(dirfile);
896 } /* end of do_rmdir */
900 * Delete any file to which user has control access, regardless of whether
901 * delete access is explicitly allowed.
902 * Limitations: User must have write access to parent directory.
903 * Does not block signals or ASTs; if interrupted in midstream
904 * may leave file with an altered ACL.
907 /*{{{int kill_file(char *name)*/
909 Perl_kill_file(pTHX_ char *name)
911 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
912 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
913 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
914 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
916 unsigned char myace$b_length;
917 unsigned char myace$b_type;
918 unsigned short int myace$w_flags;
919 unsigned long int myace$l_access;
920 unsigned long int myace$l_ident;
921 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
922 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
923 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
925 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
926 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
927 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
928 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
929 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
930 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
932 /* Expand the input spec using RMS, since the CRTL remove() and
933 * system services won't do this by themselves, so we may miss
934 * a file "hiding" behind a logical name or search list. */
935 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
936 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
937 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
938 /* If not, can changing protections help? */
939 if (vaxc$errno != RMS$_PRV) return -1;
941 /* No, so we get our own UIC to use as a rights identifier,
942 * and the insert an ACE at the head of the ACL which allows us
943 * to delete the file.
945 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
946 fildsc.dsc$w_length = strlen(rspec);
947 fildsc.dsc$a_pointer = rspec;
949 newace.myace$l_ident = oldace.myace$l_ident;
950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
952 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
953 set_errno(ENOENT); break;
955 set_errno(ENOTDIR); break;
957 set_errno(ENODEV); break;
958 case RMS$_SYN: case SS$_INVFILFOROP:
959 set_errno(EINVAL); break;
961 set_errno(EACCES); break;
965 set_vaxc_errno(aclsts);
968 /* Grab any existing ACEs with this identifier in case we fail */
969 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
970 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
971 || fndsts == SS$_NOMOREACE ) {
972 /* Add the new ACE . . . */
973 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
975 if ((rmsts = remove(name))) {
976 /* We blew it - dir with files in it, no write priv for
977 * parent directory, etc. Put things back the way they were. */
978 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
981 addlst[0].bufadr = &oldace;
982 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
989 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
990 /* We just deleted it, so of course it's not there. Some versions of
991 * VMS seem to return success on the unlock operation anyhow (after all
992 * the unlock is successful), but others don't.
994 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
995 if (aclsts & 1) aclsts = fndsts;
998 set_vaxc_errno(aclsts);
1004 } /* end of kill_file() */
1008 /*{{{int my_mkdir(char *,Mode_t)*/
1010 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1012 STRLEN dirlen = strlen(dir);
1014 /* zero length string sometimes gives ACCVIO */
1015 if (dirlen == 0) return -1;
1017 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1018 * null file name/type. However, it's commonplace under Unix,
1019 * so we'll allow it for a gain in portability.
1021 if (dir[dirlen-1] == '/') {
1022 char *newdir = savepvn(dir,dirlen-1);
1023 int ret = mkdir(newdir,mode);
1027 else return mkdir(dir,mode);
1028 } /* end of my_mkdir */
1031 /*{{{int my_chdir(char *)*/
1033 Perl_my_chdir(pTHX_ char *dir)
1035 STRLEN dirlen = strlen(dir);
1037 /* zero length string sometimes gives ACCVIO */
1038 if (dirlen == 0) return -1;
1040 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1042 * null file name/type. However, it's commonplace under Unix,
1043 * so we'll allow it for a gain in portability.
1045 if (dir[dirlen-1] == '/') {
1046 char *newdir = savepvn(dir,dirlen-1);
1047 int ret = chdir(newdir);
1051 else return chdir(dir);
1052 } /* end of my_chdir */
1056 /*{{{FILE *my_tmpfile()*/
1063 if ((fp = tmpfile())) return fp;
1065 New(1323,cp,L_tmpnam+24,char);
1066 strcpy(cp,"Sys$Scratch:");
1067 tmpnam(cp+strlen(cp));
1068 strcat(cp,".Perltmp");
1069 fp = fopen(cp,"w+","fop=dlt");
1076 #ifndef HOMEGROWN_POSIX_SIGNALS
1078 * The C RTL's sigaction fails to check for invalid signal numbers so we
1079 * help it out a bit. The docs are correct, but the actual routine doesn't
1080 * do what the docs say it will.
1082 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1084 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1085 struct sigaction* oact)
1087 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1088 SETERRNO(EINVAL, SS$_INVARG);
1091 return sigaction(sig, act, oact);
1096 #ifdef KILL_BY_SIGPRC
1097 #include <errnodef.h>
1099 /* okay, this is some BLATENT hackery ...
1100 we use this if the kill() in the CRTL uses sys$forcex, causing the
1101 target process to do a sys$exit, which usually can't be handled
1102 gracefully...certainly not by Perl and the %SIG{} mechanism.
1104 Instead we use the (undocumented) system service sys$sigprc.
1105 It has the same parameters as sys$forcex, but throws an exception
1106 in the target process rather than calling sys$exit.
1108 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1109 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1110 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1111 with condition codes C$_SIG0+nsig*8, catching the exception on the
1112 target process and resignaling with appropriate arguments.
1114 But we don't have that VMS 7.0+ exception handler, so if you
1115 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1117 Also note that SIGTERM is listed in the docs as being "unimplemented",
1118 yet always seems to be signaled with a VMS condition code of 4 (and
1119 correctly handled for that code). So we hardwire it in.
1121 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1122 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1123 than signalling with an unrecognized (and unhandled by CRTL) code.
1126 #define _MY_SIG_MAX 17
1129 Perl_sig_to_vmscondition(int sig)
1131 static unsigned int sig_code[_MY_SIG_MAX+1] =
1134 SS$_HANGUP, /* 1 SIGHUP */
1135 SS$_CONTROLC, /* 2 SIGINT */
1136 SS$_CONTROLY, /* 3 SIGQUIT */
1137 SS$_RADRMOD, /* 4 SIGILL */
1138 SS$_BREAK, /* 5 SIGTRAP */
1139 SS$_OPCCUS, /* 6 SIGABRT */
1140 SS$_COMPAT, /* 7 SIGEMT */
1142 SS$_FLTOVF, /* 8 SIGFPE VAX */
1144 SS$_HPARITH, /* 8 SIGFPE AXP */
1146 SS$_ABORT, /* 9 SIGKILL */
1147 SS$_ACCVIO, /* 10 SIGBUS */
1148 SS$_ACCVIO, /* 11 SIGSEGV */
1149 SS$_BADPARAM, /* 12 SIGSYS */
1150 SS$_NOMBX, /* 13 SIGPIPE */
1151 SS$_ASTFLT, /* 14 SIGALRM */
1157 #if __VMS_VER >= 60200000
1158 static int initted = 0;
1161 sig_code[16] = C$_SIGUSR1;
1162 sig_code[17] = C$_SIGUSR2;
1166 if (sig < _SIG_MIN) return 0;
1167 if (sig > _MY_SIG_MAX) return 0;
1168 return sig_code[sig];
1173 Perl_my_kill(int pid, int sig)
1178 int sys$sigprc(unsigned int *pidadr,
1179 struct dsc$descriptor_s *prcname,
1182 code = Perl_sig_to_vmscondition(sig);
1184 if (!pid || !code) {
1188 iss = sys$sigprc((unsigned int *)&pid,0,code);
1189 if (iss&1) return 0;
1193 set_errno(EPERM); break;
1195 case SS$_NOSUCHNODE:
1196 case SS$_UNREACHABLE:
1197 set_errno(ESRCH); break;
1199 set_errno(ENOMEM); break;
1204 set_vaxc_errno(iss);
1210 /* default piping mailbox size */
1211 #define PERL_BUFSIZ 512
1215 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1217 unsigned long int mbxbufsiz;
1218 static unsigned long int syssize = 0;
1219 unsigned long int dviitm = DVI$_DEVNAM;
1220 char csize[LNM$C_NAMLENGTH+1];
1223 unsigned long syiitm = SYI$_MAXBUF;
1225 * Get the SYSGEN parameter MAXBUF
1227 * If the logical 'PERL_MBX_SIZE' is defined
1228 * use the value of the logical instead of PERL_BUFSIZ, but
1229 * keep the size between 128 and MAXBUF.
1232 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1235 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1236 mbxbufsiz = atoi(csize);
1238 mbxbufsiz = PERL_BUFSIZ;
1240 if (mbxbufsiz < 128) mbxbufsiz = 128;
1241 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1243 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1245 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1246 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1248 } /* end of create_mbx() */
1251 /*{{{ my_popen and my_pclose*/
1253 typedef struct _iosb IOSB;
1254 typedef struct _iosb* pIOSB;
1255 typedef struct _pipe Pipe;
1256 typedef struct _pipe* pPipe;
1257 typedef struct pipe_details Info;
1258 typedef struct pipe_details* pInfo;
1259 typedef struct _srqp RQE;
1260 typedef struct _srqp* pRQE;
1261 typedef struct _tochildbuf CBuf;
1262 typedef struct _tochildbuf* pCBuf;
1265 unsigned short status;
1266 unsigned short count;
1267 unsigned long dvispec;
1270 #pragma member_alignment save
1271 #pragma nomember_alignment quadword
1272 struct _srqp { /* VMS self-relative queue entry */
1273 unsigned long qptr[2];
1275 #pragma member_alignment restore
1276 static RQE RQE_ZERO = {0,0};
1278 struct _tochildbuf {
1281 unsigned short size;
1289 unsigned short chan_in;
1290 unsigned short chan_out;
1292 unsigned int bufsize;
1304 #if defined(PERL_IMPLICIT_CONTEXT)
1305 void *thx; /* Either a thread or an interpreter */
1306 /* pointer, depending on how we're built */
1314 PerlIO *fp; /* file pointer to pipe mailbox */
1315 int useFILE; /* using stdio, not perlio */
1316 int pid; /* PID of subprocess */
1317 int mode; /* == 'r' if pipe open for reading */
1318 int done; /* subprocess has completed */
1319 int waiting; /* waiting for completion/closure */
1320 int closing; /* my_pclose is closing this pipe */
1321 unsigned long completion; /* termination status of subprocess */
1322 pPipe in; /* pipe in to sub */
1323 pPipe out; /* pipe out of sub */
1324 pPipe err; /* pipe of sub's sys$error */
1325 int in_done; /* true when in pipe finished */
1330 struct exit_control_block
1332 struct exit_control_block *flink;
1333 unsigned long int (*exit_routine)();
1334 unsigned long int arg_count;
1335 unsigned long int *status_address;
1336 unsigned long int exit_status;
1339 #define RETRY_DELAY "0 ::0.20"
1340 #define MAX_RETRY 50
1342 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1343 static unsigned long mypid;
1344 static unsigned long delaytime[2];
1346 static pInfo open_pipes = NULL;
1347 static $DESCRIPTOR(nl_desc, "NL:");
1349 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1353 static unsigned long int
1354 pipe_exit_routine(pTHX)
1357 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1358 int sts, did_stuff, need_eof, j;
1361 flush any pending i/o
1367 PerlIO_flush(info->fp); /* first, flush data */
1369 fflush((FILE *)info->fp);
1375 next we try sending an EOF...ignore if doesn't work, make sure we
1383 _ckvmssts(sys$setast(0));
1384 if (info->in && !info->in->shut_on_empty) {
1385 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1390 _ckvmssts(sys$setast(1));
1394 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1396 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1401 _ckvmssts(sys$setast(0));
1402 if (info->waiting && info->done)
1404 nwait += info->waiting;
1405 _ckvmssts(sys$setast(1));
1415 _ckvmssts(sys$setast(0));
1416 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1417 sts = sys$forcex(&info->pid,0,&abort);
1418 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1421 _ckvmssts(sys$setast(1));
1425 /* again, wait for effect */
1427 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1432 _ckvmssts(sys$setast(0));
1433 if (info->waiting && info->done)
1435 nwait += info->waiting;
1436 _ckvmssts(sys$setast(1));
1445 _ckvmssts(sys$setast(0));
1446 if (!info->done) { /* We tried to be nice . . . */
1447 sts = sys$delprc(&info->pid,0);
1448 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1450 _ckvmssts(sys$setast(1));
1455 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1456 else if (!(sts & 1)) retsts = sts;
1461 static struct exit_control_block pipe_exitblock =
1462 {(struct exit_control_block *) 0,
1463 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1465 static void pipe_mbxtofd_ast(pPipe p);
1466 static void pipe_tochild1_ast(pPipe p);
1467 static void pipe_tochild2_ast(pPipe p);
1470 popen_completion_ast(pInfo info)
1472 pInfo i = open_pipes;
1476 if (i == info) break;
1479 if (!i) return; /* unlinked, probably freed too */
1481 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1485 Writing to subprocess ...
1486 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1488 chan_out may be waiting for "done" flag, or hung waiting
1489 for i/o completion to child...cancel the i/o. This will
1490 put it into "snarf mode" (done but no EOF yet) that discards
1493 Output from subprocess (stdout, stderr) needs to be flushed and
1494 shut down. We try sending an EOF, but if the mbx is full the pipe
1495 routine should still catch the "shut_on_empty" flag, telling it to
1496 use immediate-style reads so that "mbx empty" -> EOF.
1500 if (info->in && !info->in_done) { /* only for mode=w */
1501 if (info->in->shut_on_empty && info->in->need_wake) {
1502 info->in->need_wake = FALSE;
1503 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1505 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1509 if (info->out && !info->out_done) { /* were we also piping output? */
1510 info->out->shut_on_empty = TRUE;
1511 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1512 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1513 _ckvmssts_noperl(iss);
1516 if (info->err && !info->err_done) { /* we were piping stderr */
1517 info->err->shut_on_empty = TRUE;
1518 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1519 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1520 _ckvmssts_noperl(iss);
1522 _ckvmssts_noperl(sys$setef(pipe_ef));
1526 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1527 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1530 we actually differ from vmstrnenv since we use this to
1531 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1532 are pointing to the same thing
1535 static unsigned short
1536 popen_translate(pTHX_ char *logical, char *result)
1539 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1540 $DESCRIPTOR(d_log,"");
1542 unsigned short length;
1543 unsigned short code;
1545 unsigned short *retlenaddr;
1547 unsigned short l, ifi;
1549 d_log.dsc$a_pointer = logical;
1550 d_log.dsc$w_length = strlen(logical);
1552 itmlst[0].code = LNM$_STRING;
1553 itmlst[0].length = 255;
1554 itmlst[0].buffer_addr = result;
1555 itmlst[0].retlenaddr = &l;
1558 itmlst[1].length = 0;
1559 itmlst[1].buffer_addr = 0;
1560 itmlst[1].retlenaddr = 0;
1562 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1563 if (iss == SS$_NOLOGNAM) {
1567 if (!(iss&1)) lib$signal(iss);
1570 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1571 strip it off and return the ifi, if any
1574 if (result[0] == 0x1b && result[1] == 0x00) {
1575 memcpy(&ifi,result+2,2);
1576 strcpy(result,result+4);
1578 return ifi; /* this is the RMS internal file id */
1581 static void pipe_infromchild_ast(pPipe p);
1584 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1585 inside an AST routine without worrying about reentrancy and which Perl
1586 memory allocator is being used.
1588 We read data and queue up the buffers, then spit them out one at a
1589 time to the output mailbox when the output mailbox is ready for one.
1592 #define INITIAL_TOCHILDQUEUE 2
1595 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1599 char mbx1[64], mbx2[64];
1600 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1601 DSC$K_CLASS_S, mbx1},
1602 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1603 DSC$K_CLASS_S, mbx2};
1604 unsigned int dviitm = DVI$_DEVBUFSIZ;
1607 New(1368, p, 1, Pipe);
1609 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1610 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1611 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1614 p->shut_on_empty = FALSE;
1615 p->need_wake = FALSE;
1618 p->iosb.status = SS$_NORMAL;
1619 p->iosb2.status = SS$_NORMAL;
1625 #ifdef PERL_IMPLICIT_CONTEXT
1629 n = sizeof(CBuf) + p->bufsize;
1631 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1632 _ckvmssts(lib$get_vm(&n, &b));
1633 b->buf = (char *) b + sizeof(CBuf);
1634 _ckvmssts(lib$insqhi(b, &p->free));
1637 pipe_tochild2_ast(p);
1638 pipe_tochild1_ast(p);
1644 /* reads the MBX Perl is writing, and queues */
1647 pipe_tochild1_ast(pPipe p)
1650 int iss = p->iosb.status;
1651 int eof = (iss == SS$_ENDOFFILE);
1652 #ifdef PERL_IMPLICIT_CONTEXT
1658 p->shut_on_empty = TRUE;
1660 _ckvmssts(sys$dassgn(p->chan_in));
1666 b->size = p->iosb.count;
1667 _ckvmssts(lib$insqhi(b, &p->wait));
1669 p->need_wake = FALSE;
1670 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1673 p->retry = 1; /* initial call */
1676 if (eof) { /* flush the free queue, return when done */
1677 int n = sizeof(CBuf) + p->bufsize;
1679 iss = lib$remqti(&p->free, &b);
1680 if (iss == LIB$_QUEWASEMP) return;
1682 _ckvmssts(lib$free_vm(&n, &b));
1686 iss = lib$remqti(&p->free, &b);
1687 if (iss == LIB$_QUEWASEMP) {
1688 int n = sizeof(CBuf) + p->bufsize;
1689 _ckvmssts(lib$get_vm(&n, &b));
1690 b->buf = (char *) b + sizeof(CBuf);
1696 iss = sys$qio(0,p->chan_in,
1697 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1699 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1700 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1705 /* writes queued buffers to output, waits for each to complete before
1709 pipe_tochild2_ast(pPipe p)
1712 int iss = p->iosb2.status;
1713 int n = sizeof(CBuf) + p->bufsize;
1714 int done = (p->info && p->info->done) ||
1715 iss == SS$_CANCEL || iss == SS$_ABORT;
1716 #if defined(PERL_IMPLICIT_CONTEXT)
1721 if (p->type) { /* type=1 has old buffer, dispose */
1722 if (p->shut_on_empty) {
1723 _ckvmssts(lib$free_vm(&n, &b));
1725 _ckvmssts(lib$insqhi(b, &p->free));
1730 iss = lib$remqti(&p->wait, &b);
1731 if (iss == LIB$_QUEWASEMP) {
1732 if (p->shut_on_empty) {
1734 _ckvmssts(sys$dassgn(p->chan_out));
1735 *p->pipe_done = TRUE;
1736 _ckvmssts(sys$setef(pipe_ef));
1738 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1739 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1743 p->need_wake = TRUE;
1753 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1754 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1756 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1757 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1766 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1769 char mbx1[64], mbx2[64];
1770 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1771 DSC$K_CLASS_S, mbx1},
1772 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1773 DSC$K_CLASS_S, mbx2};
1774 unsigned int dviitm = DVI$_DEVBUFSIZ;
1776 New(1367, p, 1, Pipe);
1777 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1778 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1780 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1781 New(1367, p->buf, p->bufsize, char);
1782 p->shut_on_empty = FALSE;
1785 p->iosb.status = SS$_NORMAL;
1786 #if defined(PERL_IMPLICIT_CONTEXT)
1789 pipe_infromchild_ast(p);
1797 pipe_infromchild_ast(pPipe p)
1799 int iss = p->iosb.status;
1800 int eof = (iss == SS$_ENDOFFILE);
1801 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1802 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1803 #if defined(PERL_IMPLICIT_CONTEXT)
1807 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1808 _ckvmssts(sys$dassgn(p->chan_out));
1813 input shutdown if EOF from self (done or shut_on_empty)
1814 output shutdown if closing flag set (my_pclose)
1815 send data/eof from child or eof from self
1816 otherwise, re-read (snarf of data from child)
1821 if (myeof && p->chan_in) { /* input shutdown */
1822 _ckvmssts(sys$dassgn(p->chan_in));
1827 if (myeof || kideof) { /* pass EOF to parent */
1828 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1829 pipe_infromchild_ast, p,
1832 } else if (eof) { /* eat EOF --- fall through to read*/
1834 } else { /* transmit data */
1835 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1836 pipe_infromchild_ast,p,
1837 p->buf, p->iosb.count, 0, 0, 0, 0));
1843 /* everything shut? flag as done */
1845 if (!p->chan_in && !p->chan_out) {
1846 *p->pipe_done = TRUE;
1847 _ckvmssts(sys$setef(pipe_ef));
1851 /* write completed (or read, if snarfing from child)
1852 if still have input active,
1853 queue read...immediate mode if shut_on_empty so we get EOF if empty
1855 check if Perl reading, generate EOFs as needed
1861 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1862 pipe_infromchild_ast,p,
1863 p->buf, p->bufsize, 0, 0, 0, 0);
1864 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1866 } else { /* send EOFs for extra reads */
1867 p->iosb.status = SS$_ENDOFFILE;
1868 p->iosb.dvispec = 0;
1869 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1871 pipe_infromchild_ast, p, 0, 0, 0, 0));
1877 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1881 unsigned long dviitm = DVI$_DEVBUFSIZ;
1883 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1884 DSC$K_CLASS_S, mbx};
1886 /* things like terminals and mbx's don't need this filter */
1887 if (fd && fstat(fd,&s) == 0) {
1888 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1889 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1890 DSC$K_CLASS_S, s.st_dev};
1892 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1893 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1894 strcpy(out, s.st_dev);
1899 New(1366, p, 1, Pipe);
1900 p->fd_out = dup(fd);
1901 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1902 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1903 New(1366, p->buf, p->bufsize+1, char);
1904 p->shut_on_empty = FALSE;
1909 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1910 pipe_mbxtofd_ast, p,
1911 p->buf, p->bufsize, 0, 0, 0, 0));
1917 pipe_mbxtofd_ast(pPipe p)
1919 int iss = p->iosb.status;
1920 int done = p->info->done;
1922 int eof = (iss == SS$_ENDOFFILE);
1923 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1924 int err = !(iss&1) && !eof;
1925 #if defined(PERL_IMPLICIT_CONTEXT)
1929 if (done && myeof) { /* end piping */
1931 sys$dassgn(p->chan_in);
1932 *p->pipe_done = TRUE;
1933 _ckvmssts(sys$setef(pipe_ef));
1937 if (!err && !eof) { /* good data to send to file */
1938 p->buf[p->iosb.count] = '\n';
1939 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1942 if (p->retry < MAX_RETRY) {
1943 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1953 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1954 pipe_mbxtofd_ast, p,
1955 p->buf, p->bufsize, 0, 0, 0, 0);
1956 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1961 typedef struct _pipeloc PLOC;
1962 typedef struct _pipeloc* pPLOC;
1966 char dir[NAM$C_MAXRSS+1];
1968 static pPLOC head_PLOC = 0;
1971 free_pipelocs(pTHX_ void *head)
1974 pPLOC *pHead = (pPLOC *)head;
1986 store_pipelocs(pTHX)
1995 char temp[NAM$C_MAXRSS+1];
1999 free_pipelocs(aTHX_ &head_PLOC);
2001 /* the . directory from @INC comes last */
2004 p->next = head_PLOC;
2006 strcpy(p->dir,"./");
2008 /* get the directory from $^X */
2010 #ifdef PERL_IMPLICIT_CONTEXT
2011 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2013 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2015 strcpy(temp, PL_origargv[0]);
2016 x = strrchr(temp,']');
2019 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2021 p->next = head_PLOC;
2023 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2024 p->dir[NAM$C_MAXRSS] = '\0';
2028 /* reverse order of @INC entries, skip "." since entered above */
2030 #ifdef PERL_IMPLICIT_CONTEXT
2033 if (PL_incgv) av = GvAVn(PL_incgv);
2035 for (i = 0; av && i <= AvFILL(av); i++) {
2036 dirsv = *av_fetch(av,i,TRUE);
2038 if (SvROK(dirsv)) continue;
2039 dir = SvPVx(dirsv,n_a);
2040 if (strcmp(dir,".") == 0) continue;
2041 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2045 p->next = head_PLOC;
2047 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2048 p->dir[NAM$C_MAXRSS] = '\0';
2051 /* most likely spot (ARCHLIB) put first in the list */
2054 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2056 p->next = head_PLOC;
2058 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2059 p->dir[NAM$C_MAXRSS] = '\0';
2068 static int vmspipe_file_status = 0;
2069 static char vmspipe_file[NAM$C_MAXRSS+1];
2071 /* already found? Check and use ... need read+execute permission */
2073 if (vmspipe_file_status == 1) {
2074 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2075 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2076 return vmspipe_file;
2078 vmspipe_file_status = 0;
2081 /* scan through stored @INC, $^X */
2083 if (vmspipe_file_status == 0) {
2084 char file[NAM$C_MAXRSS+1];
2085 pPLOC p = head_PLOC;
2088 strcpy(file, p->dir);
2089 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2090 file[NAM$C_MAXRSS] = '\0';
2093 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2095 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2096 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2097 vmspipe_file_status = 1;
2098 return vmspipe_file;
2101 vmspipe_file_status = -1; /* failed, use tempfiles */
2108 vmspipe_tempfile(pTHX)
2110 char file[NAM$C_MAXRSS+1];
2112 static int index = 0;
2115 /* create a tempfile */
2117 /* we can't go from W, shr=get to R, shr=get without
2118 an intermediate vulnerable state, so don't bother trying...
2120 and lib$spawn doesn't shr=put, so have to close the write
2122 So... match up the creation date/time and the FID to
2123 make sure we're dealing with the same file
2128 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2129 fp = fopen(file,"w");
2131 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2132 fp = fopen(file,"w");
2134 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2135 fp = fopen(file,"w");
2138 if (!fp) return 0; /* we're hosed */
2140 fprintf(fp,"$! 'f$verify(0)\n");
2141 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2142 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2143 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2144 fprintf(fp,"$ perl_on = \"set noon\"\n");
2145 fprintf(fp,"$ perl_exit = \"exit\"\n");
2146 fprintf(fp,"$ perl_del = \"delete\"\n");
2147 fprintf(fp,"$ pif = \"if\"\n");
2148 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2149 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2150 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2151 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2152 fprintf(fp,"$! --- build command line to get max possible length\n");
2153 fprintf(fp,"$c=perl_popen_cmd0\n");
2154 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2155 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2156 fprintf(fp,"$x=perl_popen_cmd3\n");
2157 fprintf(fp,"$c=c+x\n");
2158 fprintf(fp,"$! --- get rid of global symbols\n");
2159 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2160 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2161 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2162 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2163 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2164 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2165 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2166 fprintf(fp,"$ perl_on\n");
2167 fprintf(fp,"$ 'c\n");
2168 fprintf(fp,"$ perl_status = $STATUS\n");
2169 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2170 fprintf(fp,"$ perl_exit 'perl_status'\n");
2173 fgetname(fp, file, 1);
2174 fstat(fileno(fp), &s0);
2177 fp = fopen(file,"r","shr=get");
2179 fstat(fileno(fp), &s1);
2181 if (s0.st_ino[0] != s1.st_ino[0] ||
2182 s0.st_ino[1] != s1.st_ino[1] ||
2183 s0.st_ino[2] != s1.st_ino[2] ||
2184 s0.st_ctime != s1.st_ctime ) {
2195 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2197 static int handler_set_up = FALSE;
2198 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2199 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2201 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2202 char in[512], out[512], err[512], mbx[512];
2204 char tfilebuf[NAM$C_MAXRSS+1];
2206 char cmd_sym_name[20];
2207 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2208 DSC$K_CLASS_S, symbol};
2209 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2211 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2212 DSC$K_CLASS_S, cmd_sym_name};
2213 struct dsc$descriptor_s *vmscmd;
2214 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2215 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2216 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2218 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2220 /* once-per-program initialization...
2221 note that the SETAST calls and the dual test of pipe_ef
2222 makes sure that only the FIRST thread through here does
2223 the initialization...all other threads wait until it's
2226 Yeah, uglier than a pthread call, it's got all the stuff inline
2227 rather than in a separate routine.
2231 _ckvmssts(sys$setast(0));
2233 unsigned long int pidcode = JPI$_PID;
2234 $DESCRIPTOR(d_delay, RETRY_DELAY);
2235 _ckvmssts(lib$get_ef(&pipe_ef));
2236 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2237 _ckvmssts(sys$bintim(&d_delay, delaytime));
2239 if (!handler_set_up) {
2240 _ckvmssts(sys$dclexh(&pipe_exitblock));
2241 handler_set_up = TRUE;
2243 _ckvmssts(sys$setast(1));
2246 /* see if we can find a VMSPIPE.COM */
2249 vmspipe = find_vmspipe(aTHX);
2251 strcpy(tfilebuf+1,vmspipe);
2252 } else { /* uh, oh...we're in tempfile hell */
2253 tpipe = vmspipe_tempfile(aTHX);
2254 if (!tpipe) { /* a fish popular in Boston */
2255 if (ckWARN(WARN_PIPE)) {
2256 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2260 fgetname(tpipe,tfilebuf+1,1);
2262 vmspipedsc.dsc$a_pointer = tfilebuf;
2263 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2265 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2268 case RMS$_FNF: case RMS$_DNF:
2269 set_errno(ENOENT); break;
2271 set_errno(ENOTDIR); break;
2273 set_errno(ENODEV); break;
2275 set_errno(EACCES); break;
2277 set_errno(EINVAL); break;
2278 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2279 set_errno(E2BIG); break;
2280 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2281 _ckvmssts(sts); /* fall through */
2282 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2285 set_vaxc_errno(sts);
2286 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2287 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2292 New(1301,info,1,Info);
2294 strcpy(mode,in_mode);
2297 info->completion = 0;
2298 info->closing = FALSE;
2305 info->in_done = TRUE;
2306 info->out_done = TRUE;
2307 info->err_done = TRUE;
2308 in[0] = out[0] = err[0] = '\0';
2310 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2314 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2319 if (*mode == 'r') { /* piping from subroutine */
2321 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2323 info->out->pipe_done = &info->out_done;
2324 info->out_done = FALSE;
2325 info->out->info = info;
2327 if (!info->useFILE) {
2328 info->fp = PerlIO_open(mbx, mode);
2330 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2331 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2334 if (!info->fp && info->out) {
2335 sys$cancel(info->out->chan_out);
2337 while (!info->out_done) {
2339 _ckvmssts(sys$setast(0));
2340 done = info->out_done;
2341 if (!done) _ckvmssts(sys$clref(pipe_ef));
2342 _ckvmssts(sys$setast(1));
2343 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2346 if (info->out->buf) Safefree(info->out->buf);
2347 Safefree(info->out);
2353 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2355 info->err->pipe_done = &info->err_done;
2356 info->err_done = FALSE;
2357 info->err->info = info;
2360 } else if (*mode == 'w') { /* piping to subroutine */
2362 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2364 info->out->pipe_done = &info->out_done;
2365 info->out_done = FALSE;
2366 info->out->info = info;
2369 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2371 info->err->pipe_done = &info->err_done;
2372 info->err_done = FALSE;
2373 info->err->info = info;
2376 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2377 if (!info->useFILE) {
2378 info->fp = PerlIO_open(mbx, mode);
2380 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2381 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2385 info->in->pipe_done = &info->in_done;
2386 info->in_done = FALSE;
2387 info->in->info = info;
2391 if (!info->fp && info->in) {
2393 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2394 0, 0, 0, 0, 0, 0, 0, 0));
2396 while (!info->in_done) {
2398 _ckvmssts(sys$setast(0));
2399 done = info->in_done;
2400 if (!done) _ckvmssts(sys$clref(pipe_ef));
2401 _ckvmssts(sys$setast(1));
2402 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2405 if (info->in->buf) Safefree(info->in->buf);
2413 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2414 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2416 info->out->pipe_done = &info->out_done;
2417 info->out_done = FALSE;
2418 info->out->info = info;
2421 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2423 info->err->pipe_done = &info->err_done;
2424 info->err_done = FALSE;
2425 info->err->info = info;
2429 symbol[MAX_DCL_SYMBOL] = '\0';
2431 strncpy(symbol, in, MAX_DCL_SYMBOL);
2432 d_symbol.dsc$w_length = strlen(symbol);
2433 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2435 strncpy(symbol, err, MAX_DCL_SYMBOL);
2436 d_symbol.dsc$w_length = strlen(symbol);
2437 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2439 strncpy(symbol, out, MAX_DCL_SYMBOL);
2440 d_symbol.dsc$w_length = strlen(symbol);
2441 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2443 p = vmscmd->dsc$a_pointer;
2444 while (*p && *p != '\n') p++;
2445 *p = '\0'; /* truncate on \n */
2446 p = vmscmd->dsc$a_pointer;
2447 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2448 if (*p == '$') p++; /* remove leading $ */
2449 while (*p == ' ' || *p == '\t') p++;
2451 for (j = 0; j < 4; j++) {
2452 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2453 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2455 strncpy(symbol, p, MAX_DCL_SYMBOL);
2456 d_symbol.dsc$w_length = strlen(symbol);
2457 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2459 if (strlen(p) > MAX_DCL_SYMBOL) {
2460 p += MAX_DCL_SYMBOL;
2465 _ckvmssts(sys$setast(0));
2466 info->next=open_pipes; /* prepend to list */
2468 _ckvmssts(sys$setast(1));
2469 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2470 0, &info->pid, &info->completion,
2471 0, popen_completion_ast,info,0,0,0));
2473 /* if we were using a tempfile, close it now */
2475 if (tpipe) fclose(tpipe);
2477 /* once the subprocess is spawned, it has copied the symbols and
2478 we can get rid of ours */
2480 for (j = 0; j < 4; j++) {
2481 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2482 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2483 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2485 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2486 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2487 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2488 vms_execfree(vmscmd);
2490 #ifdef PERL_IMPLICIT_CONTEXT
2493 PL_forkprocess = info->pid;
2498 _ckvmssts(sys$setast(0));
2500 if (!done) _ckvmssts(sys$clref(pipe_ef));
2501 _ckvmssts(sys$setast(1));
2502 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2504 *psts = info->completion;
2505 my_pclose(info->fp);
2510 } /* end of safe_popen */
2513 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2515 Perl_my_popen(pTHX_ char *cmd, char *mode)
2519 TAINT_PROPER("popen");
2520 PERL_FLUSHALL_FOR_CHILD;
2521 return safe_popen(aTHX_ cmd,mode,&sts);
2526 /*{{{ I32 my_pclose(PerlIO *fp)*/
2527 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2529 pInfo info, last = NULL;
2530 unsigned long int retsts;
2533 for (info = open_pipes; info != NULL; last = info, info = info->next)
2534 if (info->fp == fp) break;
2536 if (info == NULL) { /* no such pipe open */
2537 set_errno(ECHILD); /* quoth POSIX */
2538 set_vaxc_errno(SS$_NONEXPR);
2542 /* If we were writing to a subprocess, insure that someone reading from
2543 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2544 * produce an EOF record in the mailbox.
2546 * well, at least sometimes it *does*, so we have to watch out for
2547 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2551 PerlIO_flush(info->fp); /* first, flush data */
2553 fflush((FILE *)info->fp);
2556 _ckvmssts(sys$setast(0));
2557 info->closing = TRUE;
2558 done = info->done && info->in_done && info->out_done && info->err_done;
2559 /* hanging on write to Perl's input? cancel it */
2560 if (info->mode == 'r' && info->out && !info->out_done) {
2561 if (info->out->chan_out) {
2562 _ckvmssts(sys$cancel(info->out->chan_out));
2563 if (!info->out->chan_in) { /* EOF generation, need AST */
2564 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2568 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2569 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2571 _ckvmssts(sys$setast(1));
2574 PerlIO_close(info->fp);
2576 fclose((FILE *)info->fp);
2579 we have to wait until subprocess completes, but ALSO wait until all
2580 the i/o completes...otherwise we'll be freeing the "info" structure
2581 that the i/o ASTs could still be using...
2585 _ckvmssts(sys$setast(0));
2586 done = info->done && info->in_done && info->out_done && info->err_done;
2587 if (!done) _ckvmssts(sys$clref(pipe_ef));
2588 _ckvmssts(sys$setast(1));
2589 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2591 retsts = info->completion;
2593 /* remove from list of open pipes */
2594 _ckvmssts(sys$setast(0));
2595 if (last) last->next = info->next;
2596 else open_pipes = info->next;
2597 _ckvmssts(sys$setast(1));
2599 /* free buffers and structures */
2602 if (info->in->buf) Safefree(info->in->buf);
2606 if (info->out->buf) Safefree(info->out->buf);
2607 Safefree(info->out);
2610 if (info->err->buf) Safefree(info->err->buf);
2611 Safefree(info->err);
2617 } /* end of my_pclose() */
2619 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2620 /* Roll our own prototype because we want this regardless of whether
2621 * _VMS_WAIT is defined.
2623 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2625 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2626 created with popen(); otherwise partially emulate waitpid() unless
2627 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2628 Also check processes not considered by the CRTL waitpid().
2630 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2632 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2638 if (statusp) *statusp = 0;
2640 for (info = open_pipes; info != NULL; info = info->next)
2641 if (info->pid == pid) break;
2643 if (info != NULL) { /* we know about this child */
2644 while (!info->done) {
2645 _ckvmssts(sys$setast(0));
2647 if (!done) _ckvmssts(sys$clref(pipe_ef));
2648 _ckvmssts(sys$setast(1));
2649 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2652 if (statusp) *statusp = info->completion;
2656 else { /* this child is not one of our own pipe children */
2658 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2660 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2661 * in 7.2 did we get a version that fills in the VMS completion
2662 * status as Perl has always tried to do.
2665 sts = __vms_waitpid( pid, statusp, flags );
2667 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2670 /* If the real waitpid tells us the child does not exist, we
2671 * fall through here to implement waiting for a child that
2672 * was created by some means other than exec() (say, spawned
2673 * from DCL) or to wait for a process that is not a subprocess
2674 * of the current process.
2677 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2679 $DESCRIPTOR(intdsc,"0 00:00:01");
2680 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2681 unsigned long int pidcode = JPI$_PID, mypid;
2682 unsigned long int interval[2];
2683 int termination_mbu = 0;
2684 unsigned short qio_iosb[4];
2685 unsigned int jpi_iosb[2];
2686 struct itmlst_3 jpilist[3] = {
2687 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2688 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2691 char trmmbx[NAM$C_DVI+1];
2692 $DESCRIPTOR(trmmbxdsc,trmmbx);
2693 struct accdef trmmsg;
2694 unsigned short int mbxchan;
2697 /* Sorry folks, we don't presently implement rooting around for
2698 the first child we can find, and we definitely don't want to
2699 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2705 /* Get the owner of the child so I can warn if it's not mine, plus
2706 * get the termination mailbox. If the process doesn't exist or I
2707 * don't have the privs to look at it, I can go home early.
2709 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2710 if (sts & 1) sts = jpi_iosb[0];
2722 set_vaxc_errno(sts);
2726 if (ckWARN(WARN_EXEC)) {
2727 /* remind folks they are asking for non-standard waitpid behavior */
2728 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2729 if (ownerpid != mypid)
2730 Perl_warner(aTHX_ WARN_EXEC,
2731 "waitpid: process %x is not a child of process %x",
2735 /* It's possible to have a mailbox unit number but no actual mailbox; we
2736 * check for this by assigning a channel to it, which we need anyway.
2738 if (termination_mbu != 0) {
2739 sprintf(trmmbx, "MBA%d:", termination_mbu);
2740 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2741 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2742 if (sts == SS$_NOSUCHDEV) {
2743 termination_mbu = 0; /* set up to take "no mailbox" case */
2748 /* If the process doesn't have a termination mailbox, then simply check
2749 * on it once a second until it's not there anymore.
2751 if (termination_mbu == 0) {
2752 _ckvmssts(sys$bintim(&intdsc,interval));
2753 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2754 _ckvmssts(sys$schdwk(0,0,interval,0));
2755 _ckvmssts(sys$hiber());
2757 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2760 /* If we do have a termination mailbox, post reads to it until we get a
2761 * termination message, discarding messages of the wrong type or for other
2762 * processes. If there is a place to put the final status, then do so.
2766 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2767 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2768 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2769 if (sts & 1) sts = qio_iosb[0];
2772 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2773 && trmmsg.acc$l_pid == pid ) {
2775 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2776 sts = sys$dassgn(mbxchan);
2780 } /* termination_mbu ? */
2785 } /* else one of our own pipe children */
2787 } /* end of waitpid() */
2792 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2794 my_gconvert(double val, int ndig, int trail, char *buf)
2796 static char __gcvtbuf[DBL_DIG+1];
2799 loc = buf ? buf : __gcvtbuf;
2801 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2803 sprintf(loc,"%.*g",ndig,val);
2809 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2810 return gcvt(val,ndig,loc);
2813 loc[0] = '0'; loc[1] = '\0';
2821 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2822 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2823 * to expand file specification. Allows for a single default file
2824 * specification and a simple mask of options. If outbuf is non-NULL,
2825 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2826 * the resultant file specification is placed. If outbuf is NULL, the
2827 * resultant file specification is placed into a static buffer.
2828 * The third argument, if non-NULL, is taken to be a default file
2829 * specification string. The fourth argument is unused at present.
2830 * rmesexpand() returns the address of the resultant string if
2831 * successful, and NULL on error.
2833 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2836 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2838 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2839 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2840 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2841 struct FAB myfab = cc$rms_fab;
2842 struct NAM mynam = cc$rms_nam;
2844 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2846 if (!filespec || !*filespec) {
2847 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2851 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2852 else outbuf = __rmsexpand_retbuf;
2854 if ((isunix = (strchr(filespec,'/') != NULL))) {
2855 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2856 filespec = vmsfspec;
2859 myfab.fab$l_fna = filespec;
2860 myfab.fab$b_fns = strlen(filespec);
2861 myfab.fab$l_nam = &mynam;
2863 if (defspec && *defspec) {
2864 if (strchr(defspec,'/') != NULL) {
2865 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2868 myfab.fab$l_dna = defspec;
2869 myfab.fab$b_dns = strlen(defspec);
2872 mynam.nam$l_esa = esa;
2873 mynam.nam$b_ess = sizeof esa;
2874 mynam.nam$l_rsa = outbuf;
2875 mynam.nam$b_rss = NAM$C_MAXRSS;
2877 retsts = sys$parse(&myfab,0,0);
2878 if (!(retsts & 1)) {
2879 mynam.nam$b_nop |= NAM$M_SYNCHK;
2880 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2881 retsts = sys$parse(&myfab,0,0);
2882 if (retsts & 1) goto expanded;
2884 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2885 (void) sys$parse(&myfab,0,0); /* Free search context */
2886 if (out) Safefree(out);
2887 set_vaxc_errno(retsts);
2888 if (retsts == RMS$_PRV) set_errno(EACCES);
2889 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2890 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2891 else set_errno(EVMSERR);
2894 retsts = sys$search(&myfab,0,0);
2895 if (!(retsts & 1) && retsts != RMS$_FNF) {
2896 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2897 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2898 if (out) Safefree(out);
2899 set_vaxc_errno(retsts);
2900 if (retsts == RMS$_PRV) set_errno(EACCES);
2901 else set_errno(EVMSERR);
2905 /* If the input filespec contained any lowercase characters,
2906 * downcase the result for compatibility with Unix-minded code. */
2908 for (out = myfab.fab$l_fna; *out; out++)
2909 if (islower(*out)) { haslower = 1; break; }
2910 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2911 else { out = esa; speclen = mynam.nam$b_esl; }
2912 /* Trim off null fields added by $PARSE
2913 * If type > 1 char, must have been specified in original or default spec
2914 * (not true for version; $SEARCH may have added version of existing file).
2916 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2917 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2918 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2919 if (trimver || trimtype) {
2920 if (defspec && *defspec) {
2921 char defesa[NAM$C_MAXRSS];
2922 struct FAB deffab = cc$rms_fab;
2923 struct NAM defnam = cc$rms_nam;
2925 deffab.fab$l_nam = &defnam;
2926 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2927 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2928 defnam.nam$b_nop = NAM$M_SYNCHK;
2929 if (sys$parse(&deffab,0,0) & 1) {
2930 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2931 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2934 if (trimver) speclen = mynam.nam$l_ver - out;
2936 /* If we didn't already trim version, copy down */
2937 if (speclen > mynam.nam$l_ver - out)
2938 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2939 speclen - (mynam.nam$l_ver - out));
2940 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2943 /* If we just had a directory spec on input, $PARSE "helpfully"
2944 * adds an empty name and type for us */
2945 if (mynam.nam$l_name == mynam.nam$l_type &&
2946 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2947 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2948 speclen = mynam.nam$l_name - out;
2949 out[speclen] = '\0';
2950 if (haslower) __mystrtolower(out);
2952 /* Have we been working with an expanded, but not resultant, spec? */
2953 /* Also, convert back to Unix syntax if necessary. */
2954 if (!mynam.nam$b_rsl) {
2956 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2958 else strcpy(outbuf,esa);
2961 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2962 strcpy(outbuf,tmpfspec);
2964 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2965 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2966 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2970 /* External entry points */
2971 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2972 { return do_rmsexpand(spec,buf,0,def,opt); }
2973 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2974 { return do_rmsexpand(spec,buf,1,def,opt); }
2978 ** The following routines are provided to make life easier when
2979 ** converting among VMS-style and Unix-style directory specifications.
2980 ** All will take input specifications in either VMS or Unix syntax. On
2981 ** failure, all return NULL. If successful, the routines listed below
2982 ** return a pointer to a buffer containing the appropriately
2983 ** reformatted spec (and, therefore, subsequent calls to that routine
2984 ** will clobber the result), while the routines of the same names with
2985 ** a _ts suffix appended will return a pointer to a mallocd string
2986 ** containing the appropriately reformatted spec.
2987 ** In all cases, only explicit syntax is altered; no check is made that
2988 ** the resulting string is valid or that the directory in question
2991 ** fileify_dirspec() - convert a directory spec into the name of the
2992 ** directory file (i.e. what you can stat() to see if it's a dir).
2993 ** The style (VMS or Unix) of the result is the same as the style
2994 ** of the parameter passed in.
2995 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2996 ** what you prepend to a filename to indicate what directory it's in).
2997 ** The style (VMS or Unix) of the result is the same as the style
2998 ** of the parameter passed in.
2999 ** tounixpath() - convert a directory spec into a Unix-style path.
3000 ** tovmspath() - convert a directory spec into a VMS-style path.
3001 ** tounixspec() - convert any file spec into a Unix-style file spec.
3002 ** tovmsspec() - convert any file spec into a VMS-style spec.
3004 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3005 ** Permission is given to distribute this code as part of the Perl
3006 ** standard distribution under the terms of the GNU General Public
3007 ** License or the Perl Artistic License. Copies of each may be
3008 ** found in the Perl standard distribution.
3011 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3012 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3014 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3015 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3016 char *retspec, *cp1, *cp2, *lastdir;
3017 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3019 if (!dir || !*dir) {
3020 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3022 dirlen = strlen(dir);
3023 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3024 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3025 strcpy(trndir,"/sys$disk/000000");
3029 if (dirlen > NAM$C_MAXRSS) {
3030 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3032 if (!strpbrk(dir+1,"/]>:")) {
3033 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3034 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
3036 dirlen = strlen(dir);
3039 strncpy(trndir,dir,dirlen);
3040 trndir[dirlen] = '\0';
3043 /* If we were handed a rooted logical name or spec, treat it like a
3044 * simple directory, so that
3045 * $ Define myroot dev:[dir.]
3046 * ... do_fileify_dirspec("myroot",buf,1) ...
3047 * does something useful.
3049 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3050 dir[--dirlen] = '\0';
3051 dir[dirlen-1] = ']';
3053 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3054 dir[--dirlen] = '\0';
3055 dir[dirlen-1] = '>';
3058 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3059 /* If we've got an explicit filename, we can just shuffle the string. */
3060 if (*(cp1+1)) hasfilename = 1;
3061 /* Similarly, we can just back up a level if we've got multiple levels
3062 of explicit directories in a VMS spec which ends with directories. */
3064 for (cp2 = cp1; cp2 > dir; cp2--) {
3066 *cp2 = *cp1; *cp1 = '\0';
3070 if (*cp2 == '[' || *cp2 == '<') break;
3075 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3076 if (dir[0] == '.') {
3077 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3078 return do_fileify_dirspec("[]",buf,ts);
3079 else if (dir[1] == '.' &&
3080 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3081 return do_fileify_dirspec("[-]",buf,ts);
3083 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3084 dirlen -= 1; /* to last element */
3085 lastdir = strrchr(dir,'/');
3087 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3088 /* If we have "/." or "/..", VMSify it and let the VMS code
3089 * below expand it, rather than repeating the code to handle
3090 * relative components of a filespec here */
3092 if (*(cp1+2) == '.') cp1++;
3093 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3094 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3095 if (strchr(vmsdir,'/') != NULL) {
3096 /* If do_tovmsspec() returned it, it must have VMS syntax
3097 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3098 * the time to check this here only so we avoid a recursion
3099 * loop; otherwise, gigo.
3101 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3103 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3104 return do_tounixspec(trndir,buf,ts);
3107 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3108 lastdir = strrchr(dir,'/');
3110 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3111 /* Ditto for specs that end in an MFD -- let the VMS code
3112 * figure out whether it's a real device or a rooted logical. */
3113 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3114 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3115 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3116 return do_tounixspec(trndir,buf,ts);
3119 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3120 !(lastdir = cp1 = strrchr(dir,']')) &&
3121 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3122 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3124 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3125 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3126 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3127 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3128 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3129 (ver || *cp3)))))) {
3131 set_vaxc_errno(RMS$_DIR);
3137 /* If we lead off with a device or rooted logical, add the MFD
3138 if we're specifying a top-level directory. */
3139 if (lastdir && *dir == '/') {
3141 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3148 retlen = dirlen + (addmfd ? 13 : 6);
3149 if (buf) retspec = buf;
3150 else if (ts) New(1309,retspec,retlen+1,char);
3151 else retspec = __fileify_retbuf;
3153 dirlen = lastdir - dir;
3154 memcpy(retspec,dir,dirlen);
3155 strcpy(&retspec[dirlen],"/000000");
3156 strcpy(&retspec[dirlen+7],lastdir);
3159 memcpy(retspec,dir,dirlen);
3160 retspec[dirlen] = '\0';
3162 /* We've picked up everything up to the directory file name.
3163 Now just add the type and version, and we're set. */
3164 strcat(retspec,".dir;1");
3167 else { /* VMS-style directory spec */
3168 char esa[NAM$C_MAXRSS+1], term, *cp;
3169 unsigned long int sts, cmplen, haslower = 0;
3170 struct FAB dirfab = cc$rms_fab;
3171 struct NAM savnam, dirnam = cc$rms_nam;
3173 dirfab.fab$b_fns = strlen(dir);
3174 dirfab.fab$l_fna = dir;
3175 dirfab.fab$l_nam = &dirnam;
3176 dirfab.fab$l_dna = ".DIR;1";
3177 dirfab.fab$b_dns = 6;
3178 dirnam.nam$b_ess = NAM$C_MAXRSS;
3179 dirnam.nam$l_esa = esa;
3181 for (cp = dir; *cp; cp++)
3182 if (islower(*cp)) { haslower = 1; break; }
3183 if (!((sts = sys$parse(&dirfab))&1)) {
3184 if (dirfab.fab$l_sts == RMS$_DIR) {
3185 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3186 sts = sys$parse(&dirfab) & 1;
3190 set_vaxc_errno(dirfab.fab$l_sts);
3196 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3197 /* Yes; fake the fnb bits so we'll check type below */
3198 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3200 else { /* No; just work with potential name */
3201 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3203 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3204 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3205 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3210 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3211 cp1 = strchr(esa,']');
3212 if (!cp1) cp1 = strchr(esa,'>');
3213 if (cp1) { /* Should always be true */
3214 dirnam.nam$b_esl -= cp1 - esa - 1;
3215 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3218 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3219 /* Yep; check version while we're at it, if it's there. */
3220 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3221 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3222 /* Something other than .DIR[;1]. Bzzt. */
3223 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3224 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3226 set_vaxc_errno(RMS$_DIR);
3230 esa[dirnam.nam$b_esl] = '\0';
3231 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3232 /* They provided at least the name; we added the type, if necessary, */
3233 if (buf) retspec = buf; /* in sys$parse() */
3234 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3235 else retspec = __fileify_retbuf;
3236 strcpy(retspec,esa);
3237 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3238 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3241 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3242 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3244 dirnam.nam$b_esl -= 9;
3246 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3247 if (cp1 == NULL) { /* should never happen */
3248 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3249 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3254 retlen = strlen(esa);
3255 if ((cp1 = strrchr(esa,'.')) != NULL) {
3256 /* There's more than one directory in the path. Just roll back. */
3258 if (buf) retspec = buf;
3259 else if (ts) New(1311,retspec,retlen+7,char);
3260 else retspec = __fileify_retbuf;
3261 strcpy(retspec,esa);
3264 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3265 /* Go back and expand rooted logical name */
3266 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3267 if (!(sys$parse(&dirfab) & 1)) {
3268 dirnam.nam$l_rlf = NULL;
3269 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3271 set_vaxc_errno(dirfab.fab$l_sts);
3274 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3275 if (buf) retspec = buf;
3276 else if (ts) New(1312,retspec,retlen+16,char);
3277 else retspec = __fileify_retbuf;
3278 cp1 = strstr(esa,"][");
3279 if (!cp1) cp1 = strstr(esa,"]<");
3281 memcpy(retspec,esa,dirlen);
3282 if (!strncmp(cp1+2,"000000]",7)) {
3283 retspec[dirlen-1] = '\0';
3284 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3285 if (*cp1 == '.') *cp1 = ']';
3287 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3288 memcpy(cp1+1,"000000]",7);
3292 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3293 retspec[retlen] = '\0';
3294 /* Convert last '.' to ']' */
3295 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3296 if (*cp1 == '.') *cp1 = ']';
3298 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3299 memcpy(cp1+1,"000000]",7);
3303 else { /* This is a top-level dir. Add the MFD to the path. */
3304 if (buf) retspec = buf;
3305 else if (ts) New(1312,retspec,retlen+16,char);
3306 else retspec = __fileify_retbuf;
3309 while (*cp1 != ':') *(cp2++) = *(cp1++);
3310 strcpy(cp2,":[000000]");
3315 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3316 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3317 /* We've set up the string up through the filename. Add the
3318 type and version, and we're done. */
3319 strcat(retspec,".DIR;1");
3321 /* $PARSE may have upcased filespec, so convert output to lower
3322 * case if input contained any lowercase characters. */
3323 if (haslower) __mystrtolower(retspec);
3326 } /* end of do_fileify_dirspec() */
3328 /* External entry points */
3329 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3330 { return do_fileify_dirspec(dir,buf,0); }
3331 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3332 { return do_fileify_dirspec(dir,buf,1); }
3334 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3335 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3337 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3338 unsigned long int retlen;
3339 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3341 if (!dir || !*dir) {
3342 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3345 if (*dir) strcpy(trndir,dir);
3346 else getcwd(trndir,sizeof trndir - 1);
3348 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3349 && my_trnlnm(trndir,trndir,0)) {
3350 STRLEN trnlen = strlen(trndir);
3352 /* Trap simple rooted lnms, and return lnm:[000000] */
3353 if (!strcmp(trndir+trnlen-2,".]")) {
3354 if (buf) retpath = buf;
3355 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3356 else retpath = __pathify_retbuf;
3357 strcpy(retpath,dir);
3358 strcat(retpath,":[000000]");
3364 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3365 if (*dir == '.' && (*(dir+1) == '\0' ||
3366 (*(dir+1) == '.' && *(dir+2) == '\0')))
3367 retlen = 2 + (*(dir+1) != '\0');
3369 if ( !(cp1 = strrchr(dir,'/')) &&
3370 !(cp1 = strrchr(dir,']')) &&
3371 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3372 if ((cp2 = strchr(cp1,'.')) != NULL &&
3373 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3374 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3375 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3376 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3378 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3379 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3380 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3381 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3382 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3383 (ver || *cp3)))))) {
3385 set_vaxc_errno(RMS$_DIR);
3388 retlen = cp2 - dir + 1;
3390 else { /* No file type present. Treat the filename as a directory. */
3391 retlen = strlen(dir) + 1;
3394 if (buf) retpath = buf;
3395 else if (ts) New(1313,retpath,retlen+1,char);
3396 else retpath = __pathify_retbuf;
3397 strncpy(retpath,dir,retlen-1);
3398 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3399 retpath[retlen-1] = '/'; /* with '/', add it. */
3400 retpath[retlen] = '\0';
3402 else retpath[retlen-1] = '\0';
3404 else { /* VMS-style directory spec */
3405 char esa[NAM$C_MAXRSS+1], *cp;
3406 unsigned long int sts, cmplen, haslower;
3407 struct FAB dirfab = cc$rms_fab;
3408 struct NAM savnam, dirnam = cc$rms_nam;
3410 /* If we've got an explicit filename, we can just shuffle the string. */
3411 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3412 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3413 if ((cp2 = strchr(cp1,'.')) != NULL) {
3415 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3416 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3417 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3418 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3419 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3420 (ver || *cp3)))))) {
3422 set_vaxc_errno(RMS$_DIR);
3426 else { /* No file type, so just draw name into directory part */
3427 for (cp2 = cp1; *cp2; cp2++) ;
3430 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3432 /* We've now got a VMS 'path'; fall through */
3434 dirfab.fab$b_fns = strlen(dir);
3435 dirfab.fab$l_fna = dir;
3436 if (dir[dirfab.fab$b_fns-1] == ']' ||
3437 dir[dirfab.fab$b_fns-1] == '>' ||
3438 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3439 if (buf) retpath = buf;
3440 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3441 else retpath = __pathify_retbuf;
3442 strcpy(retpath,dir);
3445 dirfab.fab$l_dna = ".DIR;1";
3446 dirfab.fab$b_dns = 6;
3447 dirfab.fab$l_nam = &dirnam;
3448 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3449 dirnam.nam$l_esa = esa;
3451 for (cp = dir; *cp; cp++)
3452 if (islower(*cp)) { haslower = 1; break; }
3454 if (!(sts = (sys$parse(&dirfab)&1))) {
3455 if (dirfab.fab$l_sts == RMS$_DIR) {
3456 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3457 sts = sys$parse(&dirfab) & 1;
3461 set_vaxc_errno(dirfab.fab$l_sts);
3467 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3468 if (dirfab.fab$l_sts != RMS$_FNF) {
3469 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3470 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3472 set_vaxc_errno(dirfab.fab$l_sts);
3475 dirnam = savnam; /* No; just work with potential name */
3478 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3479 /* Yep; check version while we're at it, if it's there. */
3480 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3481 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3482 /* Something other than .DIR[;1]. Bzzt. */
3483 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3484 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3486 set_vaxc_errno(RMS$_DIR);
3490 /* OK, the type was fine. Now pull any file name into the
3492 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3494 cp1 = strrchr(esa,'>');
3495 *dirnam.nam$l_type = '>';
3498 *(dirnam.nam$l_type + 1) = '\0';
3499 retlen = dirnam.nam$l_type - esa + 2;
3500 if (buf) retpath = buf;
3501 else if (ts) New(1314,retpath,retlen,char);
3502 else retpath = __pathify_retbuf;
3503 strcpy(retpath,esa);
3504 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3505 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3506 /* $PARSE may have upcased filespec, so convert output to lower
3507 * case if input contained any lowercase characters. */
3508 if (haslower) __mystrtolower(retpath);
3512 } /* end of do_pathify_dirspec() */
3514 /* External entry points */
3515 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3516 { return do_pathify_dirspec(dir,buf,0); }
3517 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3518 { return do_pathify_dirspec(dir,buf,1); }
3520 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3521 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3523 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3524 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3525 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3527 if (spec == NULL) return NULL;
3528 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3529 if (buf) rslt = buf;
3531 retlen = strlen(spec);
3532 cp1 = strchr(spec,'[');
3533 if (!cp1) cp1 = strchr(spec,'<');
3535 for (cp1++; *cp1; cp1++) {
3536 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3537 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3538 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3541 New(1315,rslt,retlen+2+2*expand,char);
3543 else rslt = __tounixspec_retbuf;
3544 if (strchr(spec,'/') != NULL) {
3551 dirend = strrchr(spec,']');
3552 if (dirend == NULL) dirend = strrchr(spec,'>');
3553 if (dirend == NULL) dirend = strchr(spec,':');
3554 if (dirend == NULL) {
3558 if (*cp2 != '[' && *cp2 != '<') {
3561 else { /* the VMS spec begins with directories */
3563 if (*cp2 == ']' || *cp2 == '>') {
3564 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3567 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3568 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3569 if (ts) Safefree(rslt);
3574 while (*cp3 != ':' && *cp3) cp3++;
3576 if (strchr(cp3,']') != NULL) break;
3577 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3579 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3580 retlen = devlen + dirlen;
3581 Renew(rslt,retlen+1+2*expand,char);
3587 *(cp1++) = *(cp3++);
3588 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3592 else if ( *cp2 == '.') {
3593 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3594 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3600 for (; cp2 <= dirend; cp2++) {
3603 if (*(cp2+1) == '[') cp2++;
3605 else if (*cp2 == ']' || *cp2 == '>') {
3606 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3608 else if (*cp2 == '.') {
3610 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3611 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3612 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3613 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3614 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3616 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3617 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3621 else if (*cp2 == '-') {
3622 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3623 while (*cp2 == '-') {
3625 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3627 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3628 if (ts) Safefree(rslt); /* filespecs like */
3629 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3633 else *(cp1++) = *cp2;
3635 else *(cp1++) = *cp2;
3637 while (*cp2) *(cp1++) = *(cp2++);
3642 } /* end of do_tounixspec() */
3644 /* External entry points */
3645 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3646 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3648 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3649 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3650 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3651 char *rslt, *dirend;
3652 register char *cp1, *cp2;
3653 unsigned long int infront = 0, hasdir = 1;
3655 if (path == NULL) return NULL;
3656 if (buf) rslt = buf;
3657 else if (ts) New(1316,rslt,strlen(path)+9,char);
3658 else rslt = __tovmsspec_retbuf;
3659 if (strpbrk(path,"]:>") ||
3660 (dirend = strrchr(path,'/')) == NULL) {
3661 if (path[0] == '.') {
3662 if (path[1] == '\0') strcpy(rslt,"[]");
3663 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3664 else strcpy(rslt,path); /* probably garbage */
3666 else strcpy(rslt,path);
3669 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3670 if (!*(dirend+2)) dirend +=2;
3671 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3672 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3677 char trndev[NAM$C_MAXRSS+1];
3681 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3683 if (!buf & ts) Renew(rslt,18,char);
3684 strcpy(rslt,"sys$disk:[000000]");
3687 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3689 islnm = my_trnlnm(rslt,trndev,0);
3690 trnend = islnm ? strlen(trndev) - 1 : 0;
3691 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3692 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3693 /* If the first element of the path is a logical name, determine
3694 * whether it has to be translated so we can add more directories. */
3695 if (!islnm || rooted) {
3698 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3702 if (cp2 != dirend) {
3703 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3704 strcpy(rslt,trndev);
3705 cp1 = rslt + trnend;
3718 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3719 cp2 += 2; /* skip over "./" - it's redundant */
3720 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3722 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3723 *(cp1++) = '-'; /* "../" --> "-" */
3726 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3727 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3728 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3729 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3732 if (cp2 > dirend) cp2 = dirend;
3734 else *(cp1++) = '.';
3736 for (; cp2 < dirend; cp2++) {
3738 if (*(cp2-1) == '/') continue;
3739 if (*(cp1-1) != '.') *(cp1++) = '.';
3742 else if (!infront && *cp2 == '.') {
3743 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3744 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3745 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3746 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3747 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3748 else { /* back up over previous directory name */
3750 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3751 if (*(cp1-1) == '[') {
3752 memcpy(cp1,"000000.",7);
3757 if (cp2 == dirend) break;
3759 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3760 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3761 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3762 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3764 *(cp1++) = '.'; /* Simulate trailing '/' */
3765 cp2 += 2; /* for loop will incr this to == dirend */
3767 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3769 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3772 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3773 if (*cp2 == '.') *(cp1++) = '_';
3774 else *(cp1++) = *cp2;
3778 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3779 if (hasdir) *(cp1++) = ']';
3780 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3781 while (*cp2) *(cp1++) = *(cp2++);
3786 } /* end of do_tovmsspec() */
3788 /* External entry points */
3789 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3790 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3792 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3793 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3794 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3796 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3798 if (path == NULL) return NULL;
3799 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3800 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3801 if (buf) return buf;
3803 vmslen = strlen(vmsified);
3804 New(1317,cp,vmslen+1,char);
3805 memcpy(cp,vmsified,vmslen);
3810 strcpy(__tovmspath_retbuf,vmsified);
3811 return __tovmspath_retbuf;
3814 } /* end of do_tovmspath() */
3816 /* External entry points */
3817 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3818 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3821 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3822 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3823 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3825 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3827 if (path == NULL) return NULL;
3828 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3829 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3830 if (buf) return buf;
3832 unixlen = strlen(unixified);
3833 New(1317,cp,unixlen+1,char);
3834 memcpy(cp,unixified,unixlen);
3839 strcpy(__tounixpath_retbuf,unixified);
3840 return __tounixpath_retbuf;
3843 } /* end of do_tounixpath() */
3845 /* External entry points */
3846 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3847 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3850 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3852 *****************************************************************************
3854 * Copyright (C) 1989-1994 by *
3855 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3857 * Permission is hereby granted for the reproduction of this software, *
3858 * on condition that this copyright notice is included in the reproduction, *
3859 * and that such reproduction is not for purposes of profit or material *
3862 * 27-Aug-1994 Modified for inclusion in perl5 *
3863 * by Charles Bailey bailey@newman.upenn.edu *
3864 *****************************************************************************
3868 * getredirection() is intended to aid in porting C programs
3869 * to VMS (Vax-11 C). The native VMS environment does not support
3870 * '>' and '<' I/O redirection, or command line wild card expansion,
3871 * or a command line pipe mechanism using the '|' AND background
3872 * command execution '&'. All of these capabilities are provided to any
3873 * C program which calls this procedure as the first thing in the
3875 * The piping mechanism will probably work with almost any 'filter' type
3876 * of program. With suitable modification, it may useful for other
3877 * portability problems as well.
3879 * Author: Mark Pizzolato mark@infocomm.com
3883 struct list_item *next;
3887 static void add_item(struct list_item **head,
3888 struct list_item **tail,
3892 static void mp_expand_wild_cards(pTHX_ char *item,
3893 struct list_item **head,
3894 struct list_item **tail,
3897 static int background_process(int argc, char **argv);
3899 static void pipe_and_fork(pTHX_ char **cmargv);
3901 /*{{{ void getredirection(int *ac, char ***av)*/
3903 mp_getredirection(pTHX_ int *ac, char ***av)
3905 * Process vms redirection arg's. Exit if any error is seen.
3906 * If getredirection() processes an argument, it is erased
3907 * from the vector. getredirection() returns a new argc and argv value.
3908 * In the event that a background command is requested (by a trailing "&"),
3909 * this routine creates a background subprocess, and simply exits the program.
3911 * Warning: do not try to simplify the code for vms. The code
3912 * presupposes that getredirection() is called before any data is
3913 * read from stdin or written to stdout.
3915 * Normal usage is as follows:
3921 * getredirection(&argc, &argv);
3925 int argc = *ac; /* Argument Count */
3926 char **argv = *av; /* Argument Vector */
3927 char *ap; /* Argument pointer */
3928 int j; /* argv[] index */
3929 int item_count = 0; /* Count of Items in List */
3930 struct list_item *list_head = 0; /* First Item in List */
3931 struct list_item *list_tail; /* Last Item in List */
3932 char *in = NULL; /* Input File Name */
3933 char *out = NULL; /* Output File Name */
3934 char *outmode = "w"; /* Mode to Open Output File */
3935 char *err = NULL; /* Error File Name */
3936 char *errmode = "w"; /* Mode to Open Error File */
3937 int cmargc = 0; /* Piped Command Arg Count */
3938 char **cmargv = NULL;/* Piped Command Arg Vector */
3941 * First handle the case where the last thing on the line ends with
3942 * a '&'. This indicates the desire for the command to be run in a
3943 * subprocess, so we satisfy that desire.
3946 if (0 == strcmp("&", ap))
3947 exit(background_process(--argc, argv));
3948 if (*ap && '&' == ap[strlen(ap)-1])
3950 ap[strlen(ap)-1] = '\0';
3951 exit(background_process(argc, argv));
3954 * Now we handle the general redirection cases that involve '>', '>>',
3955 * '<', and pipes '|'.
3957 for (j = 0; j < argc; ++j)
3959 if (0 == strcmp("<", argv[j]))
3963 fprintf(stderr,"No input file after < on command line");
3964 exit(LIB$_WRONUMARG);
3969 if ('<' == *(ap = argv[j]))
3974 if (0 == strcmp(">", ap))
3978 fprintf(stderr,"No output file after > on command line");
3979 exit(LIB$_WRONUMARG);
3998 fprintf(stderr,"No output file after > or >> on command line");
3999 exit(LIB$_WRONUMARG);
4003 if (('2' == *ap) && ('>' == ap[1]))
4020 fprintf(stderr,"No output file after 2> or 2>> on command line");
4021 exit(LIB$_WRONUMARG);
4025 if (0 == strcmp("|", argv[j]))
4029 fprintf(stderr,"No command into which to pipe on command line");
4030 exit(LIB$_WRONUMARG);
4032 cmargc = argc-(j+1);
4033 cmargv = &argv[j+1];
4037 if ('|' == *(ap = argv[j]))
4045 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4048 * Allocate and fill in the new argument vector, Some Unix's terminate
4049 * the list with an extra null pointer.
4051 New(1302, argv, item_count+1, char *);
4053 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4054 argv[j] = list_head->value;
4060 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4061 exit(LIB$_INVARGORD);
4063 pipe_and_fork(aTHX_ cmargv);
4066 /* Check for input from a pipe (mailbox) */
4068 if (in == NULL && 1 == isapipe(0))
4070 char mbxname[L_tmpnam];
4072 long int dvi_item = DVI$_DEVBUFSIZ;
4073 $DESCRIPTOR(mbxnam, "");
4074 $DESCRIPTOR(mbxdevnam, "");
4076 /* Input from a pipe, reopen it in binary mode to disable */
4077 /* carriage control processing. */
4079 fgetname(stdin, mbxname);
4080 mbxnam.dsc$a_pointer = mbxname;
4081 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4082 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4083 mbxdevnam.dsc$a_pointer = mbxname;
4084 mbxdevnam.dsc$w_length = sizeof(mbxname);
4085 dvi_item = DVI$_DEVNAM;
4086 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4087 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4090 freopen(mbxname, "rb", stdin);
4093 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4097 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4099 fprintf(stderr,"Can't open input file %s as stdin",in);
4102 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4104 fprintf(stderr,"Can't open output file %s as stdout",out);
4107 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4110 if (strcmp(err,"&1") == 0) {
4111 dup2(fileno(stdout), fileno(stderr));
4112 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4115 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4117 fprintf(stderr,"Can't open error file %s as stderr",err);
4121 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4125 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4128 #ifdef ARGPROC_DEBUG
4129 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4130 for (j = 0; j < *ac; ++j)
4131 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4133 /* Clear errors we may have hit expanding wildcards, so they don't
4134 show up in Perl's $! later */
4135 set_errno(0); set_vaxc_errno(1);
4136 } /* end of getredirection() */
4139 static void add_item(struct list_item **head,
4140 struct list_item **tail,
4146 New(1303,*head,1,struct list_item);
4150 New(1304,(*tail)->next,1,struct list_item);
4151 *tail = (*tail)->next;
4153 (*tail)->value = value;
4157 static void mp_expand_wild_cards(pTHX_ char *item,
4158 struct list_item **head,
4159 struct list_item **tail,
4163 unsigned long int context = 0;
4169 char vmsspec[NAM$C_MAXRSS+1];
4170 $DESCRIPTOR(filespec, "");
4171 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4172 $DESCRIPTOR(resultspec, "");
4173 unsigned long int zero = 0, sts;
4175 for (cp = item; *cp; cp++) {
4176 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4177 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4179 if (!*cp || isspace(*cp))
4181 add_item(head, tail, item, count);
4184 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4185 resultspec.dsc$b_class = DSC$K_CLASS_D;
4186 resultspec.dsc$a_pointer = NULL;
4187 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4188 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4189 if (!isunix || !filespec.dsc$a_pointer)
4190 filespec.dsc$a_pointer = item;
4191 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4193 * Only return version specs, if the caller specified a version
4195 had_version = strchr(item, ';');
4197 * Only return device and directory specs, if the caller specifed either.
4199 had_device = strchr(item, ':');
4200 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4202 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4203 &defaultspec, 0, 0, &zero))))
4208 New(1305,string,resultspec.dsc$w_length+1,char);
4209 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4210 string[resultspec.dsc$w_length] = '\0';
4211 if (NULL == had_version)
4212 *((char *)strrchr(string, ';')) = '\0';
4213 if ((!had_directory) && (had_device == NULL))
4215 if (NULL == (devdir = strrchr(string, ']')))
4216 devdir = strrchr(string, '>');
4217 strcpy(string, devdir + 1);
4220 * Be consistent with what the C RTL has already done to the rest of
4221 * the argv items and lowercase all of these names.
4223 for (c = string; *c; ++c)
4226 if (isunix) trim_unixpath(string,item,1);
4227 add_item(head, tail, string, count);
4230 if (sts != RMS$_NMF)
4232 set_vaxc_errno(sts);
4235 case RMS$_FNF: case RMS$_DNF:
4236 set_errno(ENOENT); break;
4238 set_errno(ENOTDIR); break;
4240 set_errno(ENODEV); break;
4241 case RMS$_FNM: case RMS$_SYN:
4242 set_errno(EINVAL); break;
4244 set_errno(EACCES); break;
4246 _ckvmssts_noperl(sts);
4250 add_item(head, tail, item, count);
4251 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4252 _ckvmssts_noperl(lib$find_file_end(&context));
4255 static int child_st[2];/* Event Flag set when child process completes */
4257 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4259 static unsigned long int exit_handler(int *status)
4263 if (0 == child_st[0])
4265 #ifdef ARGPROC_DEBUG
4266 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4268 fflush(stdout); /* Have to flush pipe for binary data to */
4269 /* terminate properly -- <tp@mccall.com> */
4270 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4271 sys$dassgn(child_chan);
4273 sys$synch(0, child_st);
4278 static void sig_child(int chan)
4280 #ifdef ARGPROC_DEBUG
4281 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4283 if (child_st[0] == 0)
4287 static struct exit_control_block exit_block =
4292 &exit_block.exit_status,
4297 pipe_and_fork(pTHX_ char **cmargv)
4300 struct dsc$descriptor_s *vmscmd;
4301 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4302 int sts, j, l, ismcr, quote, tquote = 0;
4304 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4305 vms_execfree(vmscmd);
4310 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4311 && toupper(*(q+2)) == 'R' && !*(q+3);
4313 while (q && l < MAX_DCL_LINE_LENGTH) {
4315 if (j > 0 && quote) {
4321 if (ismcr && j > 1) quote = 1;
4322 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4325 if (quote || tquote) {
4331 if ((quote||tquote) && *q == '"') {
4341 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4343 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4347 static int background_process(int argc, char **argv)
4349 char command[2048] = "$";
4350 $DESCRIPTOR(value, "");
4351 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4352 static $DESCRIPTOR(null, "NLA0:");
4353 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4355 $DESCRIPTOR(pidstr, "");
4357 unsigned long int flags = 17, one = 1, retsts;
4359 strcat(command, argv[0]);
4362 strcat(command, " \"");
4363 strcat(command, *(++argv));
4364 strcat(command, "\"");
4366 value.dsc$a_pointer = command;
4367 value.dsc$w_length = strlen(value.dsc$a_pointer);
4368 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4369 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4370 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4371 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4374 _ckvmssts_noperl(retsts);
4376 #ifdef ARGPROC_DEBUG
4377 PerlIO_printf(Perl_debug_log, "%s\n", command);
4379 sprintf(pidstring, "%08X", pid);
4380 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4381 pidstr.dsc$a_pointer = pidstring;
4382 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4383 lib$set_symbol(&pidsymbol, &pidstr);
4387 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4390 /* OS-specific initialization at image activation (not thread startup) */
4391 /* Older VAXC header files lack these constants */
4392 #ifndef JPI$_RIGHTS_SIZE
4393 # define JPI$_RIGHTS_SIZE 817
4395 #ifndef KGB$M_SUBSYSTEM
4396 # define KGB$M_SUBSYSTEM 0x8
4399 /*{{{void vms_image_init(int *, char ***)*/
4401 vms_image_init(int *argcp, char ***argvp)
4403 char eqv[LNM$C_NAMLENGTH+1] = "";
4404 unsigned int len, tabct = 8, tabidx = 0;
4405 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4406 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4407 unsigned short int dummy, rlen;
4408 struct dsc$descriptor_s **tabvec;
4409 #if defined(PERL_IMPLICIT_CONTEXT)
4412 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4413 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4414 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4417 #ifdef KILL_BY_SIGPRC
4418 (void) Perl_csighandler_init();
4421 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4422 _ckvmssts_noperl(iosb[0]);
4423 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4424 if (iprv[i]) { /* Running image installed with privs? */
4425 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4430 /* Rights identifiers might trigger tainting as well. */
4431 if (!will_taint && (rlen || rsz)) {
4432 while (rlen < rsz) {
4433 /* We didn't get all the identifiers on the first pass. Allocate a
4434 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4435 * were needed to hold all identifiers at time of last call; we'll
4436 * allocate that many unsigned long ints), and go back and get 'em.
4437 * If it gave us less than it wanted to despite ample buffer space,
4438 * something's broken. Is your system missing a system identifier?
4440 if (rsz <= jpilist[1].buflen) {
4441 /* Perl_croak accvios when used this early in startup. */
4442 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4443 rsz, (unsigned long) jpilist[1].buflen,
4444 "Check your rights database for corruption.\n");
4447 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4448 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4449 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4450 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4451 _ckvmssts_noperl(iosb[0]);
4453 mask = jpilist[1].bufadr;
4454 /* Check attribute flags for each identifier (2nd longword); protected
4455 * subsystem identifiers trigger tainting.
4457 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4458 if (mask[i] & KGB$M_SUBSYSTEM) {
4463 if (mask != rlst) Safefree(mask);
4465 /* We need to use this hack to tell Perl it should run with tainting,
4466 * since its tainting flag may be part of the PL_curinterp struct, which
4467 * hasn't been allocated when vms_image_init() is called.
4471 New(1320,newap,*argcp+2,char **);
4472 newap[0] = argvp[0];
4474 Copy(argvp[1],newap[2],*argcp-1,char **);
4475 /* We orphan the old argv, since we don't know where it's come from,
4476 * so we don't know how to free it.
4478 *argcp++; argvp = newap;
4480 else { /* Did user explicitly request tainting? */
4482 char *cp, **av = *argvp;
4483 for (i = 1; i < *argcp; i++) {
4484 if (*av[i] != '-') break;
4485 for (cp = av[i]+1; *cp; cp++) {
4486 if (*cp == 'T') { will_taint = 1; break; }
4487 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4488 strchr("DFIiMmx",*cp)) break;
4490 if (will_taint) break;
4495 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4497 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4498 else if (tabidx >= tabct) {
4500 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4502 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4503 tabvec[tabidx]->dsc$w_length = 0;
4504 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4505 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4506 tabvec[tabidx]->dsc$a_pointer = NULL;
4507 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4509 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4511 getredirection(argcp,argvp);
4512 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4514 # include <reentrancy.h>
4515 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4524 * Trim Unix-style prefix off filespec, so it looks like what a shell
4525 * glob expansion would return (i.e. from specified prefix on, not
4526 * full path). Note that returned filespec is Unix-style, regardless
4527 * of whether input filespec was VMS-style or Unix-style.
4529 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4530 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4531 * vector of options; at present, only bit 0 is used, and if set tells
4532 * trim unixpath to try the current default directory as a prefix when
4533 * presented with a possibly ambiguous ... wildcard.
4535 * Returns !=0 on success, with trimmed filespec replacing contents of
4536 * fspec, and 0 on failure, with contents of fpsec unchanged.
4538 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4540 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4542 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4543 *template, *base, *end, *cp1, *cp2;
4544 register int tmplen, reslen = 0, dirs = 0;
4546 if (!wildspec || !fspec) return 0;
4547 if (strpbrk(wildspec,"]>:") != NULL) {
4548 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4549 else template = unixwild;
4551 else template = wildspec;
4552 if (strpbrk(fspec,"]>:") != NULL) {
4553 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4554 else base = unixified;
4555 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4556 * check to see that final result fits into (isn't longer than) fspec */
4557 reslen = strlen(fspec);
4561 /* No prefix or absolute path on wildcard, so nothing to remove */
4562 if (!*template || *template == '/') {
4563 if (base == fspec) return 1;
4564 tmplen = strlen(unixified);
4565 if (tmplen > reslen) return 0; /* not enough space */
4566 /* Copy unixified resultant, including trailing NUL */
4567 memmove(fspec,unixified,tmplen+1);
4571 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4572 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4573 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4574 for (cp1 = end ;cp1 >= base; cp1--)
4575 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4577 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4581 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4582 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4583 int ells = 1, totells, segdirs, match;
4584 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4585 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4587 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4589 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4590 if (ellipsis == template && opts & 1) {
4591 /* Template begins with an ellipsis. Since we can't tell how many
4592 * directory names at the front of the resultant to keep for an
4593 * arbitrary starting point, we arbitrarily choose the current
4594 * default directory as a starting point. If it's there as a prefix,
4595 * clip it off. If not, fall through and act as if the leading
4596 * ellipsis weren't there (i.e. return shortest possible path that
4597 * could match template).
4599 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4600 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4601 if (_tolower(*cp1) != _tolower(*cp2)) break;
4602 segdirs = dirs - totells; /* Min # of dirs we must have left */
4603 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4604 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4605 memcpy(fspec,cp2+1,end - cp2);
4609 /* First off, back up over constant elements at end of path */
4611 for (front = end ; front >= base; front--)
4612 if (*front == '/' && !dirs--) { front++; break; }
4614 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4615 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4616 if (cp1 != '\0') return 0; /* Path too long. */
4618 *cp2 = '\0'; /* Pick up with memcpy later */
4619 lcfront = lcres + (front - base);
4620 /* Now skip over each ellipsis and try to match the path in front of it. */
4622 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4623 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4624 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4625 if (cp1 < template) break; /* template started with an ellipsis */
4626 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4627 ellipsis = cp1; continue;
4629 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4631 for (segdirs = 0, cp2 = tpl;
4632 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4634 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4635 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4636 if (*cp2 == '/') segdirs++;
4638 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4639 /* Back up at least as many dirs as in template before matching */
4640 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4641 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4642 for (match = 0; cp1 > lcres;) {
4643 resdsc.dsc$a_pointer = cp1;
4644 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4646 if (match == 1) lcfront = cp1;
4648 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4650 if (!match) return 0; /* Can't find prefix ??? */
4651 if (match > 1 && opts & 1) {
4652 /* This ... wildcard could cover more than one set of dirs (i.e.
4653 * a set of similar dir names is repeated). If the template
4654 * contains more than 1 ..., upstream elements could resolve the
4655 * ambiguity, but it's not worth a full backtracking setup here.
4656 * As a quick heuristic, clip off the current default directory
4657 * if it's present to find the trimmed spec, else use the
4658 * shortest string that this ... could cover.
4660 char def[NAM$C_MAXRSS+1], *st;
4662 if (getcwd(def, sizeof def,0) == NULL) return 0;
4663 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4664 if (_tolower(*cp1) != _tolower(*cp2)) break;
4665 segdirs = dirs - totells; /* Min # of dirs we must have left */
4666 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4667 if (*cp1 == '\0' && *cp2 == '/') {
4668 memcpy(fspec,cp2+1,end - cp2);
4671 /* Nope -- stick with lcfront from above and keep going. */
4674 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4679 } /* end of trim_unixpath() */
4684 * VMS readdir() routines.
4685 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4687 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4688 * Minor modifications to original routines.
4691 /* Number of elements in vms_versions array */
4692 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4695 * Open a directory, return a handle for later use.
4697 /*{{{ DIR *opendir(char*name) */
4699 Perl_opendir(pTHX_ char *name)
4702 char dir[NAM$C_MAXRSS+1];
4705 if (do_tovmspath(name,dir,0) == NULL) {
4708 if (flex_stat(dir,&sb) == -1) return NULL;
4709 if (!S_ISDIR(sb.st_mode)) {
4710 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4713 if (!cando_by_name(S_IRUSR,0,dir)) {
4714 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4717 /* Get memory for the handle, and the pattern. */
4719 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4721 /* Fill in the fields; mainly playing with the descriptor. */
4722 (void)sprintf(dd->pattern, "%s*.*",dir);
4725 dd->vms_wantversions = 0;
4726 dd->pat.dsc$a_pointer = dd->pattern;
4727 dd->pat.dsc$w_length = strlen(dd->pattern);
4728 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4729 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4732 } /* end of opendir() */
4736 * Set the flag to indicate we want versions or not.
4738 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4740 vmsreaddirversions(DIR *dd, int flag)
4742 dd->vms_wantversions = flag;
4747 * Free up an opened directory.
4749 /*{{{ void closedir(DIR *dd)*/
4753 (void)lib$find_file_end(&dd->context);
4754 Safefree(dd->pattern);
4755 Safefree((char *)dd);
4760 * Collect all the version numbers for the current file.
4763 collectversions(pTHX_ DIR *dd)
4765 struct dsc$descriptor_s pat;
4766 struct dsc$descriptor_s res;
4768 char *p, *text, buff[sizeof dd->entry.d_name];
4770 unsigned long context, tmpsts;
4772 /* Convenient shorthand. */
4775 /* Add the version wildcard, ignoring the "*.*" put on before */
4776 i = strlen(dd->pattern);
4777 New(1308,text,i + e->d_namlen + 3,char);
4778 (void)strcpy(text, dd->pattern);
4779 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4781 /* Set up the pattern descriptor. */
4782 pat.dsc$a_pointer = text;
4783 pat.dsc$w_length = i + e->d_namlen - 1;
4784 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4785 pat.dsc$b_class = DSC$K_CLASS_S;
4787 /* Set up result descriptor. */
4788 res.dsc$a_pointer = buff;
4789 res.dsc$w_length = sizeof buff - 2;
4790 res.dsc$b_dtype = DSC$K_DTYPE_T;
4791 res.dsc$b_class = DSC$K_CLASS_S;
4793 /* Read files, collecting versions. */
4794 for (context = 0, e->vms_verscount = 0;
4795 e->vms_verscount < VERSIZE(e);
4796 e->vms_verscount++) {
4797 tmpsts = lib$find_file(&pat, &res, &context);
4798 if (tmpsts == RMS$_NMF || context == 0) break;
4800 buff[sizeof buff - 1] = '\0';
4801 if ((p = strchr(buff, ';')))
4802 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4804 e->vms_versions[e->vms_verscount] = -1;
4807 _ckvmssts(lib$find_file_end(&context));
4810 } /* end of collectversions() */
4813 * Read the next entry from the directory.
4815 /*{{{ struct dirent *readdir(DIR *dd)*/
4817 Perl_readdir(pTHX_ DIR *dd)
4819 struct dsc$descriptor_s res;
4820 char *p, buff[sizeof dd->entry.d_name];
4821 unsigned long int tmpsts;
4823 /* Set up result descriptor, and get next file. */
4824 res.dsc$a_pointer = buff;
4825 res.dsc$w_length = sizeof buff - 2;
4826 res.dsc$b_dtype = DSC$K_DTYPE_T;
4827 res.dsc$b_class = DSC$K_CLASS_S;
4828 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4829 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4830 if (!(tmpsts & 1)) {
4831 set_vaxc_errno(tmpsts);
4834 set_errno(EACCES); break;
4836 set_errno(ENODEV); break;
4838 set_errno(ENOTDIR); break;
4839 case RMS$_FNF: case RMS$_DNF:
4840 set_errno(ENOENT); break;
4847 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4848 buff[sizeof buff - 1] = '\0';
4849 for (p = buff; *p; p++) *p = _tolower(*p);
4850 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4853 /* Skip any directory component and just copy the name. */
4854 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4855 else (void)strcpy(dd->entry.d_name, buff);
4857 /* Clobber the version. */
4858 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4860 dd->entry.d_namlen = strlen(dd->entry.d_name);
4861 dd->entry.vms_verscount = 0;
4862 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4865 } /* end of readdir() */
4869 * Return something that can be used in a seekdir later.
4871 /*{{{ long telldir(DIR *dd)*/
4880 * Return to a spot where we used to be. Brute force.
4882 /*{{{ void seekdir(DIR *dd,long count)*/
4884 Perl_seekdir(pTHX_ DIR *dd, long count)
4886 int vms_wantversions;
4888 /* If we haven't done anything yet... */
4892 /* Remember some state, and clear it. */
4893 vms_wantversions = dd->vms_wantversions;
4894 dd->vms_wantversions = 0;
4895 _ckvmssts(lib$find_file_end(&dd->context));
4898 /* The increment is in readdir(). */
4899 for (dd->count = 0; dd->count < count; )
4902 dd->vms_wantversions = vms_wantversions;
4904 } /* end of seekdir() */
4907 /* VMS subprocess management
4909 * my_vfork() - just a vfork(), after setting a flag to record that
4910 * the current script is trying a Unix-style fork/exec.
4912 * vms_do_aexec() and vms_do_exec() are called in response to the
4913 * perl 'exec' function. If this follows a vfork call, then they
4914 * call out the the regular perl routines in doio.c which do an
4915 * execvp (for those who really want to try this under VMS).
4916 * Otherwise, they do exactly what the perl docs say exec should
4917 * do - terminate the current script and invoke a new command
4918 * (See below for notes on command syntax.)
4920 * do_aspawn() and do_spawn() implement the VMS side of the perl
4921 * 'system' function.
4923 * Note on command arguments to perl 'exec' and 'system': When handled
4924 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4925 * are concatenated to form a DCL command string. If the first arg
4926 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4927 * the the command string is handed off to DCL directly. Otherwise,
4928 * the first token of the command is taken as the filespec of an image
4929 * to run. The filespec is expanded using a default type of '.EXE' and
4930 * the process defaults for device, directory, etc., and if found, the resultant
4931 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4932 * the command string as parameters. This is perhaps a bit complicated,
4933 * but I hope it will form a happy medium between what VMS folks expect
4934 * from lib$spawn and what Unix folks expect from exec.
4937 static int vfork_called;
4939 /*{{{int my_vfork()*/
4950 vms_execfree(struct dsc$descriptor_s *vmscmd)
4953 if (vmscmd->dsc$a_pointer) {
4954 Safefree(vmscmd->dsc$a_pointer);
4961 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4963 char *junk, *tmps = Nullch;
4964 register size_t cmdlen = 0;
4971 tmps = SvPV(really,rlen);
4978 for (idx++; idx <= sp; idx++) {
4980 junk = SvPVx(*idx,rlen);
4981 cmdlen += rlen ? rlen + 1 : 0;
4984 New(401,PL_Cmd,cmdlen+1,char);
4986 if (tmps && *tmps) {
4987 strcpy(PL_Cmd,tmps);
4990 else *PL_Cmd = '\0';
4991 while (++mark <= sp) {
4993 char *s = SvPVx(*mark,n_a);
4995 if (*PL_Cmd) strcat(PL_Cmd," ");
5001 } /* end of setup_argstr() */
5004 static unsigned long int
5005 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5006 struct dsc$descriptor_s **pvmscmd)
5008 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5009 $DESCRIPTOR(defdsc,".EXE");
5010 $DESCRIPTOR(defdsc2,".");
5011 $DESCRIPTOR(resdsc,resspec);
5012 struct dsc$descriptor_s *vmscmd;
5013 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5014 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5015 register char *s, *rest, *cp, *wordbreak;
5018 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5019 vmscmd->dsc$a_pointer = NULL;
5020 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5021 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5022 vmscmd->dsc$w_length = 0;
5023 if (pvmscmd) *pvmscmd = vmscmd;
5025 if (suggest_quote) *suggest_quote = 0;
5027 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5028 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5030 while (*s && isspace(*s)) s++;
5032 if (*s == '@' || *s == '$') {
5033 vmsspec[0] = *s; rest = s + 1;
5034 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5036 else { cp = vmsspec; rest = s; }
5037 if (*rest == '.' || *rest == '/') {
5040 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5041 rest++, cp2++) *cp2 = *rest;
5043 if (do_tovmsspec(resspec,cp,0)) {
5046 for (cp2 = vmsspec + strlen(vmsspec);
5047 *rest && cp2 - vmsspec < sizeof vmsspec;
5048 rest++, cp2++) *cp2 = *rest;
5053 /* Intuit whether verb (first word of cmd) is a DCL command:
5054 * - if first nonspace char is '@', it's a DCL indirection
5056 * - if verb contains a filespec separator, it's not a DCL command
5057 * - if it doesn't, caller tells us whether to default to a DCL
5058 * command, or to a local image unless told it's DCL (by leading '$')
5062 if (suggest_quote) *suggest_quote = 1;
5064 register char *filespec = strpbrk(s,":<[.;");
5065 rest = wordbreak = strpbrk(s," \"\t/");
5066 if (!wordbreak) wordbreak = s + strlen(s);
5067 if (*s == '$') check_img = 0;
5068 if (filespec && (filespec < wordbreak)) isdcl = 0;
5069 else isdcl = !check_img;
5073 imgdsc.dsc$a_pointer = s;
5074 imgdsc.dsc$w_length = wordbreak - s;
5075 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5077 _ckvmssts(lib$find_file_end(&cxt));
5078 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5079 if (!(retsts & 1) && *s == '$') {
5080 _ckvmssts(lib$find_file_end(&cxt));
5081 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5082 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5084 _ckvmssts(lib$find_file_end(&cxt));
5085 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5089 _ckvmssts(lib$find_file_end(&cxt));
5094 while (*s && !isspace(*s)) s++;
5097 /* check that it's really not DCL with no file extension */
5098 fp = fopen(resspec,"r","ctx=bin,shr=get");
5100 char b[4] = {0,0,0,0};
5101 read(fileno(fp),b,4);
5102 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5105 if (check_img && isdcl) return RMS$_FNF;
5107 if (cando_by_name(S_IXUSR,0,resspec)) {
5108 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5110 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5111 if (suggest_quote) *suggest_quote = 1;
5113 strcpy(vmscmd->dsc$a_pointer,"@");
5114 if (suggest_quote) *suggest_quote = 1;
5116 strcat(vmscmd->dsc$a_pointer,resspec);
5117 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5118 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5119 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5121 else retsts = RMS$_PRV;
5124 /* It's either a DCL command or we couldn't find a suitable image */
5125 vmscmd->dsc$w_length = strlen(cmd);
5126 /* if (cmd == PL_Cmd) {
5127 vmscmd->dsc$a_pointer = PL_Cmd;
5128 if (suggest_quote) *suggest_quote = 1;
5131 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5133 /* check if it's a symbol (for quoting purposes) */
5134 if (suggest_quote && !*suggest_quote) {
5136 char equiv[LNM$C_NAMLENGTH];
5137 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5138 eqvdsc.dsc$a_pointer = equiv;
5140 iss = lib$get_symbol(vmscmd,&eqvdsc);
5141 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5143 if (!(retsts & 1)) {
5144 /* just hand off status values likely to be due to user error */
5145 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5146 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5147 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5148 else { _ckvmssts(retsts); }
5151 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5153 } /* end of setup_cmddsc() */
5156 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5158 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5161 if (vfork_called) { /* this follows a vfork - act Unixish */
5163 if (vfork_called < 0) {
5164 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5167 else return do_aexec(really,mark,sp);
5169 /* no vfork - act VMSish */
5170 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5175 } /* end of vms_do_aexec() */
5178 /* {{{bool vms_do_exec(char *cmd) */
5180 Perl_vms_do_exec(pTHX_ char *cmd)
5182 struct dsc$descriptor_s *vmscmd;
5184 if (vfork_called) { /* this follows a vfork - act Unixish */
5186 if (vfork_called < 0) {
5187 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5190 else return do_exec(cmd);
5193 { /* no vfork - act VMSish */
5194 unsigned long int retsts;
5197 TAINT_PROPER("exec");
5198 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5199 retsts = lib$do_command(vmscmd);
5202 case RMS$_FNF: case RMS$_DNF:
5203 set_errno(ENOENT); break;
5205 set_errno(ENOTDIR); break;
5207 set_errno(ENODEV); break;
5209 set_errno(EACCES); break;
5211 set_errno(EINVAL); break;
5212 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5213 set_errno(E2BIG); break;
5214 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5215 _ckvmssts(retsts); /* fall through */
5216 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5219 set_vaxc_errno(retsts);
5220 if (ckWARN(WARN_EXEC)) {
5221 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
5222 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5224 vms_execfree(vmscmd);
5229 } /* end of vms_do_exec() */
5232 unsigned long int Perl_do_spawn(pTHX_ char *);
5234 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5236 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5238 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5241 } /* end of do_aspawn() */
5244 /* {{{unsigned long int do_spawn(char *cmd) */
5246 Perl_do_spawn(pTHX_ char *cmd)
5248 unsigned long int sts, substs;
5251 TAINT_PROPER("spawn");
5252 if (!cmd || !*cmd) {
5253 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5256 case RMS$_FNF: case RMS$_DNF:
5257 set_errno(ENOENT); break;
5259 set_errno(ENOTDIR); break;
5261 set_errno(ENODEV); break;
5263 set_errno(EACCES); break;
5265 set_errno(EINVAL); break;
5266 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5267 set_errno(E2BIG); break;
5268 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5269 _ckvmssts(sts); /* fall through */
5270 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5273 set_vaxc_errno(sts);
5274 if (ckWARN(WARN_EXEC)) {
5275 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
5282 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5285 } /* end of do_spawn() */
5289 static unsigned int *sockflags, sockflagsize;
5292 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5293 * routines found in some versions of the CRTL can't deal with sockets.
5294 * We don't shim the other file open routines since a socket isn't
5295 * likely to be opened by a name.
5297 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5298 FILE *my_fdopen(int fd, const char *mode)
5300 FILE *fp = fdopen(fd, (char *) mode);
5303 unsigned int fdoff = fd / sizeof(unsigned int);
5304 struct stat sbuf; /* native stat; we don't need flex_stat */
5305 if (!sockflagsize || fdoff > sockflagsize) {
5306 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5307 else New (1324,sockflags,fdoff+2,unsigned int);
5308 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5309 sockflagsize = fdoff + 2;
5311 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5312 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5321 * Clear the corresponding bit when the (possibly) socket stream is closed.
5322 * There still a small hole: we miss an implicit close which might occur
5323 * via freopen(). >> Todo
5325 /*{{{ int my_fclose(FILE *fp)*/
5326 int my_fclose(FILE *fp) {
5328 unsigned int fd = fileno(fp);
5329 unsigned int fdoff = fd / sizeof(unsigned int);
5331 if (sockflagsize && fdoff <= sockflagsize)
5332 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5340 * A simple fwrite replacement which outputs itmsz*nitm chars without
5341 * introducing record boundaries every itmsz chars.
5342 * We are using fputs, which depends on a terminating null. We may
5343 * well be writing binary data, so we need to accommodate not only
5344 * data with nulls sprinkled in the middle but also data with no null
5347 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5349 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5351 register char *cp, *end, *cpd, *data;
5352 register unsigned int fd = fileno(dest);
5353 register unsigned int fdoff = fd / sizeof(unsigned int);
5355 int bufsize = itmsz * nitm + 1;
5357 if (fdoff < sockflagsize &&
5358 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5359 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5363 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5364 memcpy( data, src, itmsz*nitm );
5365 data[itmsz*nitm] = '\0';
5367 end = data + itmsz * nitm;
5368 retval = (int) nitm; /* on success return # items written */
5371 while (cpd <= end) {
5372 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5373 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5375 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5379 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5382 } /* end of my_fwrite() */
5385 /*{{{ int my_flush(FILE *fp)*/
5387 Perl_my_flush(pTHX_ FILE *fp)
5390 if ((res = fflush(fp)) == 0 && fp) {
5391 #ifdef VMS_DO_SOCKETS
5393 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5395 res = fsync(fileno(fp));
5398 * If the flush succeeded but set end-of-file, we need to clear
5399 * the error because our caller may check ferror(). BTW, this
5400 * probably means we just flushed an empty file.
5402 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5409 * Here are replacements for the following Unix routines in the VMS environment:
5410 * getpwuid Get information for a particular UIC or UID
5411 * getpwnam Get information for a named user
5412 * getpwent Get information for each user in the rights database
5413 * setpwent Reset search to the start of the rights database
5414 * endpwent Finish searching for users in the rights database
5416 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5417 * (defined in pwd.h), which contains the following fields:-
5419 * char *pw_name; Username (in lower case)
5420 * char *pw_passwd; Hashed password
5421 * unsigned int pw_uid; UIC
5422 * unsigned int pw_gid; UIC group number
5423 * char *pw_unixdir; Default device/directory (VMS-style)
5424 * char *pw_gecos; Owner name
5425 * char *pw_dir; Default device/directory (Unix-style)
5426 * char *pw_shell; Default CLI name (eg. DCL)
5428 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5430 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5431 * not the UIC member number (eg. what's returned by getuid()),
5432 * getpwuid() can accept either as input (if uid is specified, the caller's
5433 * UIC group is used), though it won't recognise gid=0.
5435 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5436 * information about other users in your group or in other groups, respectively.
5437 * If the required privilege is not available, then these routines fill only
5438 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5441 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5444 /* sizes of various UAF record fields */
5445 #define UAI$S_USERNAME 12
5446 #define UAI$S_IDENT 31
5447 #define UAI$S_OWNER 31
5448 #define UAI$S_DEFDEV 31
5449 #define UAI$S_DEFDIR 63
5450 #define UAI$S_DEFCLI 31
5453 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5454 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5455 (uic).uic$v_group != UIC$K_WILD_GROUP)
5457 static char __empty[]= "";
5458 static struct passwd __passwd_empty=
5459 {(char *) __empty, (char *) __empty, 0, 0,
5460 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5461 static int contxt= 0;
5462 static struct passwd __pwdcache;
5463 static char __pw_namecache[UAI$S_IDENT+1];
5466 * This routine does most of the work extracting the user information.
5468 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5471 unsigned char length;
5472 char pw_gecos[UAI$S_OWNER+1];
5474 static union uicdef uic;
5476 unsigned char length;
5477 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5480 unsigned char length;
5481 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5484 unsigned char length;
5485 char pw_shell[UAI$S_DEFCLI+1];
5487 static char pw_passwd[UAI$S_PWD+1];
5489 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5490 struct dsc$descriptor_s name_desc;
5491 unsigned long int sts;
5493 static struct itmlst_3 itmlst[]= {
5494 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5495 {sizeof(uic), UAI$_UIC, &uic, &luic},
5496 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5497 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5498 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5499 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5500 {0, 0, NULL, NULL}};
5502 name_desc.dsc$w_length= strlen(name);
5503 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5504 name_desc.dsc$b_class= DSC$K_CLASS_S;
5505 name_desc.dsc$a_pointer= (char *) name;
5507 /* Note that sys$getuai returns many fields as counted strings. */
5508 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5509 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5510 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5512 else { _ckvmssts(sts); }
5513 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5515 if ((int) owner.length < lowner) lowner= (int) owner.length;
5516 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5517 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5518 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5519 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5520 owner.pw_gecos[lowner]= '\0';
5521 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5522 defcli.pw_shell[ldefcli]= '\0';
5523 if (valid_uic(uic)) {
5524 pwd->pw_uid= uic.uic$l_uic;
5525 pwd->pw_gid= uic.uic$v_group;
5528 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5529 pwd->pw_passwd= pw_passwd;
5530 pwd->pw_gecos= owner.pw_gecos;
5531 pwd->pw_dir= defdev.pw_dir;
5532 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5533 pwd->pw_shell= defcli.pw_shell;
5534 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5536 ldir= strlen(pwd->pw_unixdir) - 1;
5537 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5540 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5541 __mystrtolower(pwd->pw_unixdir);
5546 * Get information for a named user.
5548 /*{{{struct passwd *getpwnam(char *name)*/
5549 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5551 struct dsc$descriptor_s name_desc;
5553 unsigned long int status, sts;
5555 __pwdcache = __passwd_empty;
5556 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5557 /* We still may be able to determine pw_uid and pw_gid */
5558 name_desc.dsc$w_length= strlen(name);
5559 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5560 name_desc.dsc$b_class= DSC$K_CLASS_S;
5561 name_desc.dsc$a_pointer= (char *) name;
5562 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5563 __pwdcache.pw_uid= uic.uic$l_uic;
5564 __pwdcache.pw_gid= uic.uic$v_group;
5567 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5568 set_vaxc_errno(sts);
5569 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5572 else { _ckvmssts(sts); }
5575 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5576 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5577 __pwdcache.pw_name= __pw_namecache;
5579 } /* end of my_getpwnam() */
5583 * Get information for a particular UIC or UID.
5584 * Called by my_getpwent with uid=-1 to list all users.
5586 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5587 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5589 const $DESCRIPTOR(name_desc,__pw_namecache);
5590 unsigned short lname;
5592 unsigned long int status;
5594 if (uid == (unsigned int) -1) {
5596 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5597 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5598 set_vaxc_errno(status);
5599 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5603 else { _ckvmssts(status); }
5604 } while (!valid_uic (uic));
5608 if (!uic.uic$v_group)
5609 uic.uic$v_group= PerlProc_getgid();
5611 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5612 else status = SS$_IVIDENT;
5613 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5614 status == RMS$_PRV) {
5615 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5618 else { _ckvmssts(status); }
5620 __pw_namecache[lname]= '\0';
5621 __mystrtolower(__pw_namecache);
5623 __pwdcache = __passwd_empty;
5624 __pwdcache.pw_name = __pw_namecache;
5626 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5627 The identifier's value is usually the UIC, but it doesn't have to be,
5628 so if we can, we let fillpasswd update this. */
5629 __pwdcache.pw_uid = uic.uic$l_uic;
5630 __pwdcache.pw_gid = uic.uic$v_group;
5632 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5635 } /* end of my_getpwuid() */
5639 * Get information for next user.
5641 /*{{{struct passwd *my_getpwent()*/
5642 struct passwd *Perl_my_getpwent(pTHX)
5644 return (my_getpwuid((unsigned int) -1));
5649 * Finish searching rights database for users.
5651 /*{{{void my_endpwent()*/
5652 void Perl_my_endpwent(pTHX)
5655 _ckvmssts(sys$finish_rdb(&contxt));
5661 #ifdef HOMEGROWN_POSIX_SIGNALS
5662 /* Signal handling routines, pulled into the core from POSIX.xs.
5664 * We need these for threads, so they've been rolled into the core,
5665 * rather than left in POSIX.xs.
5667 * (DRS, Oct 23, 1997)
5670 /* sigset_t is atomic under VMS, so these routines are easy */
5671 /*{{{int my_sigemptyset(sigset_t *) */
5672 int my_sigemptyset(sigset_t *set) {
5673 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5679 /*{{{int my_sigfillset(sigset_t *)*/
5680 int my_sigfillset(sigset_t *set) {
5682 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5683 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5689 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5690 int my_sigaddset(sigset_t *set, int sig) {
5691 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5692 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5693 *set |= (1 << (sig - 1));
5699 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5700 int my_sigdelset(sigset_t *set, int sig) {
5701 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5702 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5703 *set &= ~(1 << (sig - 1));
5709 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5710 int my_sigismember(sigset_t *set, int sig) {
5711 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5712 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5713 return *set & (1 << (sig - 1));
5718 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5719 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5722 /* If set and oset are both null, then things are badly wrong. Bail out. */
5723 if ((oset == NULL) && (set == NULL)) {
5724 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5728 /* If set's null, then we're just handling a fetch. */
5730 tempmask = sigblock(0);
5735 tempmask = sigsetmask(*set);
5738 tempmask = sigblock(*set);
5741 tempmask = sigblock(0);
5742 sigsetmask(*oset & ~tempmask);
5745 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5750 /* Did they pass us an oset? If so, stick our holding mask into it */
5757 #endif /* HOMEGROWN_POSIX_SIGNALS */
5760 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5761 * my_utime(), and flex_stat(), all of which operate on UTC unless
5762 * VMSISH_TIMES is true.
5764 /* method used to handle UTC conversions:
5765 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5767 static int gmtime_emulation_type;
5768 /* number of secs to add to UTC POSIX-style time to get local time */
5769 static long int utc_offset_secs;
5771 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5772 * in vmsish.h. #undef them here so we can call the CRTL routines
5781 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5782 * qualifier with the extern prefix pragma. This provisional
5783 * hack circumvents this prefix pragma problem in previous
5786 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5787 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5788 # pragma __extern_prefix save
5789 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5790 # define gmtime decc$__utctz_gmtime
5791 # define localtime decc$__utctz_localtime
5792 # define time decc$__utc_time
5793 # pragma __extern_prefix restore
5795 struct tm *gmtime(), *localtime();
5801 static time_t toutc_dst(time_t loc) {
5804 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5805 loc -= utc_offset_secs;
5806 if (rsltmp->tm_isdst) loc -= 3600;
5809 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5810 ((gmtime_emulation_type || my_time(NULL)), \
5811 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5812 ((secs) - utc_offset_secs))))
5814 static time_t toloc_dst(time_t utc) {
5817 utc += utc_offset_secs;
5818 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5819 if (rsltmp->tm_isdst) utc += 3600;
5822 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5823 ((gmtime_emulation_type || my_time(NULL)), \
5824 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5825 ((secs) + utc_offset_secs))))
5827 #ifndef RTL_USES_UTC
5830 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5831 DST starts on 1st sun of april at 02:00 std time
5832 ends on last sun of october at 02:00 dst time
5833 see the UCX management command reference, SET CONFIG TIMEZONE
5834 for formatting info.
5836 No, it's not as general as it should be, but then again, NOTHING
5837 will handle UK times in a sensible way.
5842 parse the DST start/end info:
5843 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5847 tz_parse_startend(char *s, struct tm *w, int *past)
5849 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5850 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5855 if (!past) return 0;
5858 if (w->tm_year % 4 == 0) ly = 1;
5859 if (w->tm_year % 100 == 0) ly = 0;
5860 if (w->tm_year+1900 % 400 == 0) ly = 1;
5863 dozjd = isdigit(*s);
5864 if (*s == 'J' || *s == 'j' || dozjd) {
5865 if (!dozjd && !isdigit(*++s)) return 0;
5868 d = d*10 + *s++ - '0';
5870 d = d*10 + *s++ - '0';
5873 if (d == 0) return 0;
5874 if (d > 366) return 0;
5876 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5879 } else if (*s == 'M' || *s == 'm') {
5880 if (!isdigit(*++s)) return 0;
5882 if (isdigit(*s)) m = 10*m + *s++ - '0';
5883 if (*s != '.') return 0;
5884 if (!isdigit(*++s)) return 0;
5886 if (n < 1 || n > 5) return 0;
5887 if (*s != '.') return 0;
5888 if (!isdigit(*++s)) return 0;
5890 if (d > 6) return 0;
5894 if (!isdigit(*++s)) return 0;
5896 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5898 if (!isdigit(*++s)) return 0;
5900 if (isdigit(*s)) min = 10*min + *s++ - '0';
5902 if (!isdigit(*++s)) return 0;
5904 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5914 if (w->tm_yday < d) goto before;
5915 if (w->tm_yday > d) goto after;
5917 if (w->tm_mon+1 < m) goto before;
5918 if (w->tm_mon+1 > m) goto after;
5920 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5921 k = d - j; /* mday of first d */
5923 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5924 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5925 if (w->tm_mday < k) goto before;
5926 if (w->tm_mday > k) goto after;
5929 if (w->tm_hour < hour) goto before;
5930 if (w->tm_hour > hour) goto after;
5931 if (w->tm_min < min) goto before;
5932 if (w->tm_min > min) goto after;
5933 if (w->tm_sec < sec) goto before;
5947 /* parse the offset: (+|-)hh[:mm[:ss]] */
5950 tz_parse_offset(char *s, int *offset)
5952 int hour = 0, min = 0, sec = 0;
5955 if (!offset) return 0;
5957 if (*s == '-') {neg++; s++;}
5959 if (!isdigit(*s)) return 0;
5961 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5962 if (hour > 24) return 0;
5964 if (!isdigit(*++s)) return 0;
5966 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5967 if (min > 59) return 0;
5969 if (!isdigit(*++s)) return 0;
5971 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5972 if (sec > 59) return 0;
5976 *offset = (hour*60+min)*60 + sec;
5977 if (neg) *offset = -*offset;
5982 input time is w, whatever type of time the CRTL localtime() uses.
5983 sets dst, the zone, and the gmtoff (seconds)
5985 caches the value of TZ and UCX$TZ env variables; note that
5986 my_setenv looks for these and sets a flag if they're changed
5989 We have to watch out for the "australian" case (dst starts in
5990 october, ends in april)...flagged by "reverse" and checked by
5991 scanning through the months of the previous year.
5996 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6001 char *dstzone, *tz, *s_start, *s_end;
6002 int std_off, dst_off, isdst;
6003 int y, dststart, dstend;
6004 static char envtz[1025]; /* longer than any logical, symbol, ... */
6005 static char ucxtz[1025];
6006 static char reversed = 0;
6012 reversed = -1; /* flag need to check */
6013 envtz[0] = ucxtz[0] = '\0';
6014 tz = my_getenv("TZ",0);
6015 if (tz) strcpy(envtz, tz);
6016 tz = my_getenv("UCX$TZ",0);
6017 if (tz) strcpy(ucxtz, tz);
6018 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6021 if (!*tz) tz = ucxtz;
6024 while (isalpha(*s)) s++;
6025 s = tz_parse_offset(s, &std_off);
6027 if (!*s) { /* no DST, hurray we're done! */
6033 while (isalpha(*s)) s++;
6034 s2 = tz_parse_offset(s, &dst_off);
6038 dst_off = std_off - 3600;
6041 if (!*s) { /* default dst start/end?? */
6042 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6043 s = strchr(ucxtz,',');
6045 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6047 if (*s != ',') return 0;
6050 when = _toutc(when); /* convert to utc */
6051 when = when - std_off; /* convert to pseudolocal time*/
6053 w2 = localtime(&when);
6056 s = tz_parse_startend(s_start,w2,&dststart);
6058 if (*s != ',') return 0;
6061 when = _toutc(when); /* convert to utc */
6062 when = when - dst_off; /* convert to pseudolocal time*/
6063 w2 = localtime(&when);
6064 if (w2->tm_year != y) { /* spans a year, just check one time */
6065 when += dst_off - std_off;
6066 w2 = localtime(&when);
6069 s = tz_parse_startend(s_end,w2,&dstend);
6072 if (reversed == -1) { /* need to check if start later than end */
6076 if (when < 2*365*86400) {
6077 when += 2*365*86400;
6081 w2 =localtime(&when);
6082 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6084 for (j = 0; j < 12; j++) {
6085 w2 =localtime(&when);
6086 (void) tz_parse_startend(s_start,w2,&ds);
6087 (void) tz_parse_startend(s_end,w2,&de);
6088 if (ds != de) break;
6092 if (de && !ds) reversed = 1;
6095 isdst = dststart && !dstend;
6096 if (reversed) isdst = dststart || !dstend;
6099 if (dst) *dst = isdst;
6100 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6101 if (isdst) tz = dstzone;
6103 while(isalpha(*tz)) *zone++ = *tz++;
6109 #endif /* !RTL_USES_UTC */
6111 /* my_time(), my_localtime(), my_gmtime()
6112 * By default traffic in UTC time values, using CRTL gmtime() or
6113 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6114 * Note: We need to use these functions even when the CRTL has working
6115 * UTC support, since they also handle C<use vmsish qw(times);>
6117 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6118 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6121 /*{{{time_t my_time(time_t *timep)*/
6122 time_t Perl_my_time(pTHX_ time_t *timep)
6127 if (gmtime_emulation_type == 0) {
6129 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6130 /* results of calls to gmtime() and localtime() */
6131 /* for same &base */
6133 gmtime_emulation_type++;
6134 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6135 char off[LNM$C_NAMLENGTH+1];;
6137 gmtime_emulation_type++;
6138 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6139 gmtime_emulation_type++;
6140 utc_offset_secs = 0;
6141 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6143 else { utc_offset_secs = atol(off); }
6145 else { /* We've got a working gmtime() */
6146 struct tm gmt, local;
6149 tm_p = localtime(&base);
6151 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6152 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6153 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6154 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6160 # ifdef RTL_USES_UTC
6161 if (VMSISH_TIME) when = _toloc(when);
6163 if (!VMSISH_TIME) when = _toutc(when);
6166 if (timep != NULL) *timep = when;
6169 } /* end of my_time() */
6173 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6175 Perl_my_gmtime(pTHX_ const time_t *timep)
6181 if (timep == NULL) {
6182 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6185 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6189 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6191 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6192 return gmtime(&when);
6194 /* CRTL localtime() wants local time as input, so does no tz correction */
6195 rsltmp = localtime(&when);
6196 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6199 } /* end of my_gmtime() */
6203 /*{{{struct tm *my_localtime(const time_t *timep)*/
6205 Perl_my_localtime(pTHX_ const time_t *timep)
6207 time_t when, whenutc;
6211 if (timep == NULL) {
6212 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6215 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6216 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6219 # ifdef RTL_USES_UTC
6221 if (VMSISH_TIME) when = _toutc(when);
6223 /* CRTL localtime() wants UTC as input, does tz correction itself */
6224 return localtime(&when);
6226 # else /* !RTL_USES_UTC */
6229 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6230 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6233 #ifndef RTL_USES_UTC
6234 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6235 when = whenutc - offset; /* pseudolocal time*/
6238 /* CRTL localtime() wants local time as input, so does no tz correction */
6239 rsltmp = localtime(&when);
6240 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6244 } /* end of my_localtime() */
6247 /* Reset definitions for later calls */
6248 #define gmtime(t) my_gmtime(t)
6249 #define localtime(t) my_localtime(t)
6250 #define time(t) my_time(t)
6253 /* my_utime - update modification time of a file
6254 * calling sequence is identical to POSIX utime(), but under
6255 * VMS only the modification time is changed; ODS-2 does not
6256 * maintain access times. Restrictions differ from the POSIX
6257 * definition in that the time can be changed as long as the
6258 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6259 * no separate checks are made to insure that the caller is the
6260 * owner of the file or has special privs enabled.
6261 * Code here is based on Joe Meadows' FILE utility.
6264 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6265 * to VMS epoch (01-JAN-1858 00:00:00.00)
6266 * in 100 ns intervals.
6268 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6270 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6271 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6274 long int bintime[2], len = 2, lowbit, unixtime,
6275 secscale = 10000000; /* seconds --> 100 ns intervals */
6276 unsigned long int chan, iosb[2], retsts;
6277 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6278 struct FAB myfab = cc$rms_fab;
6279 struct NAM mynam = cc$rms_nam;
6280 #if defined (__DECC) && defined (__VAX)
6281 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6282 * at least through VMS V6.1, which causes a type-conversion warning.
6284 # pragma message save
6285 # pragma message disable cvtdiftypes
6287 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6288 struct fibdef myfib;
6289 #if defined (__DECC) && defined (__VAX)
6290 /* This should be right after the declaration of myatr, but due
6291 * to a bug in VAX DEC C, this takes effect a statement early.
6293 # pragma message restore
6295 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6296 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6297 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6299 if (file == NULL || *file == '\0') {
6301 set_vaxc_errno(LIB$_INVARG);
6304 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6306 if (utimes != NULL) {
6307 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6308 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6309 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6310 * as input, we force the sign bit to be clear by shifting unixtime right
6311 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6313 lowbit = (utimes->modtime & 1) ? secscale : 0;
6314 unixtime = (long int) utimes->modtime;
6316 /* If input was UTC; convert to local for sys svc */
6317 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6319 unixtime >>= 1; secscale <<= 1;
6320 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6321 if (!(retsts & 1)) {
6323 set_vaxc_errno(retsts);
6326 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6327 if (!(retsts & 1)) {
6329 set_vaxc_errno(retsts);
6334 /* Just get the current time in VMS format directly */
6335 retsts = sys$gettim(bintime);
6336 if (!(retsts & 1)) {
6338 set_vaxc_errno(retsts);
6343 myfab.fab$l_fna = vmsspec;
6344 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6345 myfab.fab$l_nam = &mynam;
6346 mynam.nam$l_esa = esa;
6347 mynam.nam$b_ess = (unsigned char) sizeof esa;
6348 mynam.nam$l_rsa = rsa;
6349 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6351 /* Look for the file to be affected, letting RMS parse the file
6352 * specification for us as well. I have set errno using only
6353 * values documented in the utime() man page for VMS POSIX.
6355 retsts = sys$parse(&myfab,0,0);
6356 if (!(retsts & 1)) {
6357 set_vaxc_errno(retsts);
6358 if (retsts == RMS$_PRV) set_errno(EACCES);
6359 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6360 else set_errno(EVMSERR);
6363 retsts = sys$search(&myfab,0,0);
6364 if (!(retsts & 1)) {
6365 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6366 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6367 set_vaxc_errno(retsts);
6368 if (retsts == RMS$_PRV) set_errno(EACCES);
6369 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6370 else set_errno(EVMSERR);
6374 devdsc.dsc$w_length = mynam.nam$b_dev;
6375 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6377 retsts = sys$assign(&devdsc,&chan,0,0);
6378 if (!(retsts & 1)) {
6379 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6380 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6381 set_vaxc_errno(retsts);
6382 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6383 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6384 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6385 else set_errno(EVMSERR);
6389 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6390 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6392 memset((void *) &myfib, 0, sizeof myfib);
6393 #if defined(__DECC) || defined(__DECCXX)
6394 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6395 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6396 /* This prevents the revision time of the file being reset to the current
6397 * time as a result of our IO$_MODIFY $QIO. */
6398 myfib.fib$l_acctl = FIB$M_NORECORD;
6400 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6401 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6402 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6404 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6405 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6406 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6407 _ckvmssts(sys$dassgn(chan));
6408 if (retsts & 1) retsts = iosb[0];
6409 if (!(retsts & 1)) {
6410 set_vaxc_errno(retsts);
6411 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6412 else set_errno(EVMSERR);
6417 } /* end of my_utime() */
6421 * flex_stat, flex_fstat
6422 * basic stat, but gets it right when asked to stat
6423 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6426 /* encode_dev packs a VMS device name string into an integer to allow
6427 * simple comparisons. This can be used, for example, to check whether two
6428 * files are located on the same device, by comparing their encoded device
6429 * names. Even a string comparison would not do, because stat() reuses the
6430 * device name buffer for each call; so without encode_dev, it would be
6431 * necessary to save the buffer and use strcmp (this would mean a number of
6432 * changes to the standard Perl code, to say nothing of what a Perl script
6435 * The device lock id, if it exists, should be unique (unless perhaps compared
6436 * with lock ids transferred from other nodes). We have a lock id if the disk is
6437 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6438 * device names. Thus we use the lock id in preference, and only if that isn't
6439 * available, do we try to pack the device name into an integer (flagged by
6440 * the sign bit (LOCKID_MASK) being set).
6442 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6443 * name and its encoded form, but it seems very unlikely that we will find
6444 * two files on different disks that share the same encoded device names,
6445 * and even more remote that they will share the same file id (if the test
6446 * is to check for the same file).
6448 * A better method might be to use sys$device_scan on the first call, and to
6449 * search for the device, returning an index into the cached array.
6450 * The number returned would be more intelligable.
6451 * This is probably not worth it, and anyway would take quite a bit longer
6452 * on the first call.
6454 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6455 static mydev_t encode_dev (pTHX_ const char *dev)
6458 unsigned long int f;
6463 if (!dev || !dev[0]) return 0;
6467 struct dsc$descriptor_s dev_desc;
6468 unsigned long int status, lockid, item = DVI$_LOCKID;
6470 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6471 can try that first. */
6472 dev_desc.dsc$w_length = strlen (dev);
6473 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6474 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6475 dev_desc.dsc$a_pointer = (char *) dev;
6476 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6477 if (lockid) return (lockid & ~LOCKID_MASK);
6481 /* Otherwise we try to encode the device name */
6485 for (q = dev + strlen(dev); q--; q >= dev) {
6488 else if (isalpha (toupper (*q)))
6489 c= toupper (*q) - 'A' + (char)10;
6491 continue; /* Skip '$'s */
6493 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6495 enc += f * (unsigned long int) c;
6497 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6499 } /* end of encode_dev() */
6501 static char namecache[NAM$C_MAXRSS+1];
6504 is_null_device(name)
6507 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6508 The underscore prefix, controller letter, and unit number are
6509 independently optional; for our purposes, the colon punctuation
6510 is not. The colon can be trailed by optional directory and/or
6511 filename, but two consecutive colons indicates a nodename rather
6512 than a device. [pr] */
6513 if (*name == '_') ++name;
6514 if (tolower(*name++) != 'n') return 0;
6515 if (tolower(*name++) != 'l') return 0;
6516 if (tolower(*name) == 'a') ++name;
6517 if (*name == '0') ++name;
6518 return (*name++ == ':') && (*name != ':');
6521 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6522 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6523 * subset of the applicable information.
6526 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6528 char fname_phdev[NAM$C_MAXRSS+1];
6529 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6531 char fname[NAM$C_MAXRSS+1];
6532 unsigned long int retsts;
6533 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6534 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6536 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6537 device name on successive calls */
6538 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6539 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6540 namdsc.dsc$a_pointer = fname;
6541 namdsc.dsc$w_length = sizeof fname - 1;
6543 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6544 &namdsc,&namdsc.dsc$w_length,0,0);
6546 fname[namdsc.dsc$w_length] = '\0';
6548 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6549 * but if someone has redefined that logical, Perl gets very lost. Since
6550 * we have the physical device name from the stat buffer, just paste it on.
6552 strcpy( fname_phdev, statbufp->st_devnam );
6553 strcat( fname_phdev, strrchr(fname, ':') );
6555 return cando_by_name(bit,effective,fname_phdev);
6557 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6558 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6562 return FALSE; /* Should never get to here */
6564 } /* end of cando() */
6568 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6570 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6572 static char usrname[L_cuserid];
6573 static struct dsc$descriptor_s usrdsc =
6574 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6575 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6576 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6577 unsigned short int retlen;
6578 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6579 union prvdef curprv;
6580 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6581 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6582 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6585 if (!fname || !*fname) return FALSE;
6586 /* Make sure we expand logical names, since sys$check_access doesn't */
6587 if (!strpbrk(fname,"/]>:")) {
6588 strcpy(fileified,fname);
6589 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6592 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6593 retlen = namdsc.dsc$w_length = strlen(vmsname);
6594 namdsc.dsc$a_pointer = vmsname;
6595 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6596 vmsname[retlen-1] == ':') {
6597 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6598 namdsc.dsc$w_length = strlen(fileified);
6599 namdsc.dsc$a_pointer = fileified;
6602 if (!usrdsc.dsc$w_length) {
6604 usrdsc.dsc$w_length = strlen(usrname);
6608 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6609 access = ARM$M_EXECUTE; break;
6610 case S_IRUSR: case S_IRGRP: case S_IROTH:
6611 access = ARM$M_READ; break;
6612 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6613 access = ARM$M_WRITE; break;
6614 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6615 access = ARM$M_DELETE; break;
6620 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6621 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6622 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6623 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6624 set_vaxc_errno(retsts);
6625 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6626 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6627 else set_errno(ENOENT);
6630 if (retsts == SS$_NORMAL) {
6631 if (!privused) return TRUE;
6632 /* We can get access, but only by using privs. Do we have the
6633 necessary privs currently enabled? */
6634 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6635 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6636 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6637 !curprv.prv$v_bypass) return FALSE;
6638 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6639 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6640 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6643 if (retsts == SS$_ACCONFLICT) {
6648 return FALSE; /* Should never get here */
6650 } /* end of cando_by_name() */
6654 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6656 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6658 if (!fstat(fd,(stat_t *) statbufp)) {
6659 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6660 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6661 # ifdef RTL_USES_UTC
6664 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6665 statbufp->st_atime = _toloc(statbufp->st_atime);
6666 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6671 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6675 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6676 statbufp->st_atime = _toutc(statbufp->st_atime);
6677 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6684 } /* end of flex_fstat() */
6687 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6689 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6691 char fileified[NAM$C_MAXRSS+1];
6692 char temp_fspec[NAM$C_MAXRSS+300];
6695 if (!fspec) return retval;
6696 strcpy(temp_fspec, fspec);
6697 if (statbufp == (Stat_t *) &PL_statcache)
6698 do_tovmsspec(temp_fspec,namecache,0);
6699 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6700 memset(statbufp,0,sizeof *statbufp);
6701 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6702 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6703 statbufp->st_uid = 0x00010001;
6704 statbufp->st_gid = 0x0001;
6705 time((time_t *)&statbufp->st_mtime);
6706 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6710 /* Try for a directory name first. If fspec contains a filename without
6711 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6712 * and sea:[wine.dark]water. exist, we prefer the directory here.
6713 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6714 * not sea:[wine.dark]., if the latter exists. If the intended target is
6715 * the file with null type, specify this by calling flex_stat() with
6716 * a '.' at the end of fspec.
6718 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6719 retval = stat(fileified,(stat_t *) statbufp);
6720 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6721 strcpy(namecache,fileified);
6723 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6725 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6726 # ifdef RTL_USES_UTC
6729 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6730 statbufp->st_atime = _toloc(statbufp->st_atime);
6731 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6736 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6740 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6741 statbufp->st_atime = _toutc(statbufp->st_atime);
6742 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6748 } /* end of flex_stat() */
6752 /*{{{char *my_getlogin()*/
6753 /* VMS cuserid == Unix getlogin, except calling sequence */
6757 static char user[L_cuserid];
6758 return cuserid(user);
6763 /* rmscopy - copy a file using VMS RMS routines
6765 * Copies contents and attributes of spec_in to spec_out, except owner
6766 * and protection information. Name and type of spec_in are used as
6767 * defaults for spec_out. The third parameter specifies whether rmscopy()
6768 * should try to propagate timestamps from the input file to the output file.
6769 * If it is less than 0, no timestamps are preserved. If it is 0, then
6770 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6771 * propagated to the output file at creation iff the output file specification
6772 * did not contain an explicit name or type, and the revision date is always
6773 * updated at the end of the copy operation. If it is greater than 0, then
6774 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6775 * other than the revision date should be propagated, and bit 1 indicates
6776 * that the revision date should be propagated.
6778 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6780 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6781 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6782 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6783 * as part of the Perl standard distribution under the terms of the
6784 * GNU General Public License or the Perl Artistic License. Copies
6785 * of each may be found in the Perl standard distribution.
6787 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6789 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6791 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6792 rsa[NAM$C_MAXRSS], ubf[32256];
6793 unsigned long int i, sts, sts2;
6794 struct FAB fab_in, fab_out;
6795 struct RAB rab_in, rab_out;
6797 struct XABDAT xabdat;
6798 struct XABFHC xabfhc;
6799 struct XABRDT xabrdt;
6800 struct XABSUM xabsum;
6802 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6803 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6804 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6808 fab_in = cc$rms_fab;
6809 fab_in.fab$l_fna = vmsin;
6810 fab_in.fab$b_fns = strlen(vmsin);
6811 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6812 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6813 fab_in.fab$l_fop = FAB$M_SQO;
6814 fab_in.fab$l_nam = &nam;
6815 fab_in.fab$l_xab = (void *) &xabdat;
6818 nam.nam$l_rsa = rsa;
6819 nam.nam$b_rss = sizeof(rsa);
6820 nam.nam$l_esa = esa;
6821 nam.nam$b_ess = sizeof (esa);
6822 nam.nam$b_esl = nam.nam$b_rsl = 0;
6824 xabdat = cc$rms_xabdat; /* To get creation date */
6825 xabdat.xab$l_nxt = (void *) &xabfhc;
6827 xabfhc = cc$rms_xabfhc; /* To get record length */
6828 xabfhc.xab$l_nxt = (void *) &xabsum;
6830 xabsum = cc$rms_xabsum; /* To get key and area information */
6832 if (!((sts = sys$open(&fab_in)) & 1)) {
6833 set_vaxc_errno(sts);
6835 case RMS$_FNF: case RMS$_DNF:
6836 set_errno(ENOENT); break;
6838 set_errno(ENOTDIR); break;
6840 set_errno(ENODEV); break;
6842 set_errno(EINVAL); break;
6844 set_errno(EACCES); break;
6852 fab_out.fab$w_ifi = 0;
6853 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6854 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6855 fab_out.fab$l_fop = FAB$M_SQO;
6856 fab_out.fab$l_fna = vmsout;
6857 fab_out.fab$b_fns = strlen(vmsout);
6858 fab_out.fab$l_dna = nam.nam$l_name;
6859 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6861 if (preserve_dates == 0) { /* Act like DCL COPY */
6862 nam.nam$b_nop = NAM$M_SYNCHK;
6863 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6864 if (!((sts = sys$parse(&fab_out)) & 1)) {
6865 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6866 set_vaxc_errno(sts);
6869 fab_out.fab$l_xab = (void *) &xabdat;
6870 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6872 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6873 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6874 preserve_dates =0; /* bitmask from this point forward */
6876 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6877 if (!((sts = sys$create(&fab_out)) & 1)) {
6878 set_vaxc_errno(sts);
6881 set_errno(ENOENT); break;
6883 set_errno(ENOTDIR); break;
6885 set_errno(ENODEV); break;
6887 set_errno(EINVAL); break;
6889 set_errno(EACCES); break;
6895 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6896 if (preserve_dates & 2) {
6897 /* sys$close() will process xabrdt, not xabdat */
6898 xabrdt = cc$rms_xabrdt;
6900 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6902 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6903 * is unsigned long[2], while DECC & VAXC use a struct */
6904 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6906 fab_out.fab$l_xab = (void *) &xabrdt;
6909 rab_in = cc$rms_rab;
6910 rab_in.rab$l_fab = &fab_in;
6911 rab_in.rab$l_rop = RAB$M_BIO;
6912 rab_in.rab$l_ubf = ubf;
6913 rab_in.rab$w_usz = sizeof ubf;
6914 if (!((sts = sys$connect(&rab_in)) & 1)) {
6915 sys$close(&fab_in); sys$close(&fab_out);
6916 set_errno(EVMSERR); set_vaxc_errno(sts);
6920 rab_out = cc$rms_rab;
6921 rab_out.rab$l_fab = &fab_out;
6922 rab_out.rab$l_rbf = ubf;
6923 if (!((sts = sys$connect(&rab_out)) & 1)) {
6924 sys$close(&fab_in); sys$close(&fab_out);
6925 set_errno(EVMSERR); set_vaxc_errno(sts);
6929 while ((sts = sys$read(&rab_in))) { /* always true */
6930 if (sts == RMS$_EOF) break;
6931 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6932 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6933 sys$close(&fab_in); sys$close(&fab_out);
6934 set_errno(EVMSERR); set_vaxc_errno(sts);
6939 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6940 sys$close(&fab_in); sys$close(&fab_out);
6941 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6943 set_errno(EVMSERR); set_vaxc_errno(sts);
6949 } /* end of rmscopy() */
6953 /*** The following glue provides 'hooks' to make some of the routines
6954 * from this file available from Perl. These routines are sufficiently
6955 * basic, and are required sufficiently early in the build process,
6956 * that's it's nice to have them available to miniperl as well as the
6957 * full Perl, so they're set up here instead of in an extension. The
6958 * Perl code which handles importation of these names into a given
6959 * package lives in [.VMS]Filespec.pm in @INC.
6963 rmsexpand_fromperl(pTHX_ CV *cv)
6966 char *fspec, *defspec = NULL, *rslt;
6969 if (!items || items > 2)
6970 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6971 fspec = SvPV(ST(0),n_a);
6972 if (!fspec || !*fspec) XSRETURN_UNDEF;
6973 if (items == 2) defspec = SvPV(ST(1),n_a);
6975 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6976 ST(0) = sv_newmortal();
6977 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6982 vmsify_fromperl(pTHX_ CV *cv)
6988 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6989 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6990 ST(0) = sv_newmortal();
6991 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6996 unixify_fromperl(pTHX_ CV *cv)
7002 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7003 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7004 ST(0) = sv_newmortal();
7005 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7010 fileify_fromperl(pTHX_ CV *cv)
7016 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7017 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7018 ST(0) = sv_newmortal();
7019 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7024 pathify_fromperl(pTHX_ CV *cv)
7030 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7031 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7032 ST(0) = sv_newmortal();
7033 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7038 vmspath_fromperl(pTHX_ CV *cv)
7044 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7045 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7046 ST(0) = sv_newmortal();
7047 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7052 unixpath_fromperl(pTHX_ CV *cv)
7058 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7059 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7060 ST(0) = sv_newmortal();
7061 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7066 candelete_fromperl(pTHX_ CV *cv)
7069 char fspec[NAM$C_MAXRSS+1], *fsp;
7074 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7076 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7077 if (SvTYPE(mysv) == SVt_PVGV) {
7078 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7079 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7086 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7087 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7093 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7098 rmscopy_fromperl(pTHX_ CV *cv)
7101 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7103 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7104 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7105 unsigned long int sts;
7110 if (items < 2 || items > 3)
7111 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7113 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7114 if (SvTYPE(mysv) == SVt_PVGV) {
7115 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7116 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7123 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7124 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7129 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7130 if (SvTYPE(mysv) == SVt_PVGV) {
7131 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7132 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7139 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7140 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7145 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7147 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7153 mod2fname(pTHX_ CV *cv)
7156 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7157 workbuff[NAM$C_MAXRSS*1 + 1];
7158 int total_namelen = 3, counter, num_entries;
7159 /* ODS-5 ups this, but we want to be consistent, so... */
7160 int max_name_len = 39;
7161 AV *in_array = (AV *)SvRV(ST(0));
7163 num_entries = av_len(in_array);
7165 /* All the names start with PL_. */
7166 strcpy(ultimate_name, "PL_");
7168 /* Clean up our working buffer */
7169 Zero(work_name, sizeof(work_name), char);
7171 /* Run through the entries and build up a working name */
7172 for(counter = 0; counter <= num_entries; counter++) {
7173 /* If it's not the first name then tack on a __ */
7175 strcat(work_name, "__");
7177 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7181 /* Check to see if we actually have to bother...*/
7182 if (strlen(work_name) + 3 <= max_name_len) {
7183 strcat(ultimate_name, work_name);
7185 /* It's too darned big, so we need to go strip. We use the same */
7186 /* algorithm as xsubpp does. First, strip out doubled __ */
7187 char *source, *dest, last;
7190 for (source = work_name; *source; source++) {
7191 if (last == *source && last == '_') {
7197 /* Go put it back */
7198 strcpy(work_name, workbuff);
7199 /* Is it still too big? */
7200 if (strlen(work_name) + 3 > max_name_len) {
7201 /* Strip duplicate letters */
7204 for (source = work_name; *source; source++) {
7205 if (last == toupper(*source)) {
7209 last = toupper(*source);
7211 strcpy(work_name, workbuff);
7214 /* Is it *still* too big? */
7215 if (strlen(work_name) + 3 > max_name_len) {
7216 /* Too bad, we truncate */
7217 work_name[max_name_len - 2] = 0;
7219 strcat(ultimate_name, work_name);
7222 /* Okay, return it */
7223 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7228 hushexit_fromperl(pTHX_ CV *cv)
7233 VMSISH_HUSHED = SvTRUE(ST(0));
7235 ST(0) = boolSV(VMSISH_HUSHED);
7240 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7241 struct interp_intern *dst)
7243 memcpy(dst,src,sizeof(struct interp_intern));
7247 Perl_sys_intern_clear(pTHX)
7252 Perl_sys_intern_init(pTHX)
7254 unsigned int ix = RAND_MAX;
7260 MY_INV_RAND_MAX = 1./x;
7267 char* file = __FILE__;
7268 char temp_buff[512];
7269 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7270 no_translate_barewords = TRUE;
7272 no_translate_barewords = FALSE;
7275 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7276 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7277 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7278 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7279 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7280 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7281 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7282 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7283 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7284 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7285 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7287 store_pipelocs(aTHX); /* will redo any earlier attempts */