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_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
235 #if defined(USE_5005THREADS)
237 Perl_warner(aTHX_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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 /* We implement our own kill() using the undocumented system service
1100 sys$sigprc for one of two reasons:
1102 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1103 target process to do a sys$exit, which usually can't be handled
1104 gracefully...certainly not by Perl and the %SIG{} mechanism.
1106 2.) If the kill() in the CRTL can't be called from a signal
1107 handler without disappearing into the ether, i.e., the signal
1108 it purportedly sends is never trapped. Still true as of VMS 7.3.
1110 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1111 in the target process rather than calling sys$exit.
1113 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1114 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1115 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1116 with condition codes C$_SIG0+nsig*8, catching the exception on the
1117 target process and resignaling with appropriate arguments.
1119 But we don't have that VMS 7.0+ exception handler, so if you
1120 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1122 Also note that SIGTERM is listed in the docs as being "unimplemented",
1123 yet always seems to be signaled with a VMS condition code of 4 (and
1124 correctly handled for that code). So we hardwire it in.
1126 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1127 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1128 than signalling with an unrecognized (and unhandled by CRTL) code.
1131 #define _MY_SIG_MAX 17
1134 Perl_sig_to_vmscondition(int sig)
1136 static unsigned int sig_code[_MY_SIG_MAX+1] =
1139 SS$_HANGUP, /* 1 SIGHUP */
1140 SS$_CONTROLC, /* 2 SIGINT */
1141 SS$_CONTROLY, /* 3 SIGQUIT */
1142 SS$_RADRMOD, /* 4 SIGILL */
1143 SS$_BREAK, /* 5 SIGTRAP */
1144 SS$_OPCCUS, /* 6 SIGABRT */
1145 SS$_COMPAT, /* 7 SIGEMT */
1147 SS$_FLTOVF, /* 8 SIGFPE VAX */
1149 SS$_HPARITH, /* 8 SIGFPE AXP */
1151 SS$_ABORT, /* 9 SIGKILL */
1152 SS$_ACCVIO, /* 10 SIGBUS */
1153 SS$_ACCVIO, /* 11 SIGSEGV */
1154 SS$_BADPARAM, /* 12 SIGSYS */
1155 SS$_NOMBX, /* 13 SIGPIPE */
1156 SS$_ASTFLT, /* 14 SIGALRM */
1162 #if __VMS_VER >= 60200000
1163 static int initted = 0;
1166 sig_code[16] = C$_SIGUSR1;
1167 sig_code[17] = C$_SIGUSR2;
1171 if (sig < _SIG_MIN) return 0;
1172 if (sig > _MY_SIG_MAX) return 0;
1173 return sig_code[sig];
1178 Perl_my_kill(int pid, int sig)
1183 int sys$sigprc(unsigned int *pidadr,
1184 struct dsc$descriptor_s *prcname,
1187 code = Perl_sig_to_vmscondition(sig);
1189 if (!pid || !code) {
1193 iss = sys$sigprc((unsigned int *)&pid,0,code);
1194 if (iss&1) return 0;
1198 set_errno(EPERM); break;
1200 case SS$_NOSUCHNODE:
1201 case SS$_UNREACHABLE:
1202 set_errno(ESRCH); break;
1204 set_errno(ENOMEM); break;
1209 set_vaxc_errno(iss);
1215 /* default piping mailbox size */
1216 #define PERL_BUFSIZ 512
1220 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1222 unsigned long int mbxbufsiz;
1223 static unsigned long int syssize = 0;
1224 unsigned long int dviitm = DVI$_DEVNAM;
1225 char csize[LNM$C_NAMLENGTH+1];
1228 unsigned long syiitm = SYI$_MAXBUF;
1230 * Get the SYSGEN parameter MAXBUF
1232 * If the logical 'PERL_MBX_SIZE' is defined
1233 * use the value of the logical instead of PERL_BUFSIZ, but
1234 * keep the size between 128 and MAXBUF.
1237 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1240 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1241 mbxbufsiz = atoi(csize);
1243 mbxbufsiz = PERL_BUFSIZ;
1245 if (mbxbufsiz < 128) mbxbufsiz = 128;
1246 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1248 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1250 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1251 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1253 } /* end of create_mbx() */
1256 /*{{{ my_popen and my_pclose*/
1258 typedef struct _iosb IOSB;
1259 typedef struct _iosb* pIOSB;
1260 typedef struct _pipe Pipe;
1261 typedef struct _pipe* pPipe;
1262 typedef struct pipe_details Info;
1263 typedef struct pipe_details* pInfo;
1264 typedef struct _srqp RQE;
1265 typedef struct _srqp* pRQE;
1266 typedef struct _tochildbuf CBuf;
1267 typedef struct _tochildbuf* pCBuf;
1270 unsigned short status;
1271 unsigned short count;
1272 unsigned long dvispec;
1275 #pragma member_alignment save
1276 #pragma nomember_alignment quadword
1277 struct _srqp { /* VMS self-relative queue entry */
1278 unsigned long qptr[2];
1280 #pragma member_alignment restore
1281 static RQE RQE_ZERO = {0,0};
1283 struct _tochildbuf {
1286 unsigned short size;
1294 unsigned short chan_in;
1295 unsigned short chan_out;
1297 unsigned int bufsize;
1309 #if defined(PERL_IMPLICIT_CONTEXT)
1310 void *thx; /* Either a thread or an interpreter */
1311 /* pointer, depending on how we're built */
1319 PerlIO *fp; /* file pointer to pipe mailbox */
1320 int useFILE; /* using stdio, not perlio */
1321 int pid; /* PID of subprocess */
1322 int mode; /* == 'r' if pipe open for reading */
1323 int done; /* subprocess has completed */
1324 int waiting; /* waiting for completion/closure */
1325 int closing; /* my_pclose is closing this pipe */
1326 unsigned long completion; /* termination status of subprocess */
1327 pPipe in; /* pipe in to sub */
1328 pPipe out; /* pipe out of sub */
1329 pPipe err; /* pipe of sub's sys$error */
1330 int in_done; /* true when in pipe finished */
1335 struct exit_control_block
1337 struct exit_control_block *flink;
1338 unsigned long int (*exit_routine)();
1339 unsigned long int arg_count;
1340 unsigned long int *status_address;
1341 unsigned long int exit_status;
1344 #define RETRY_DELAY "0 ::0.20"
1345 #define MAX_RETRY 50
1347 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1348 static unsigned long mypid;
1349 static unsigned long delaytime[2];
1351 static pInfo open_pipes = NULL;
1352 static $DESCRIPTOR(nl_desc, "NL:");
1354 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1358 static unsigned long int
1359 pipe_exit_routine(pTHX)
1362 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1363 int sts, did_stuff, need_eof, j;
1366 flush any pending i/o
1372 PerlIO_flush(info->fp); /* first, flush data */
1374 fflush((FILE *)info->fp);
1380 next we try sending an EOF...ignore if doesn't work, make sure we
1388 _ckvmssts(sys$setast(0));
1389 if (info->in && !info->in->shut_on_empty) {
1390 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1395 _ckvmssts(sys$setast(1));
1399 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1401 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1406 _ckvmssts(sys$setast(0));
1407 if (info->waiting && info->done)
1409 nwait += info->waiting;
1410 _ckvmssts(sys$setast(1));
1420 _ckvmssts(sys$setast(0));
1421 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1422 sts = sys$forcex(&info->pid,0,&abort);
1423 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1426 _ckvmssts(sys$setast(1));
1430 /* again, wait for effect */
1432 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1437 _ckvmssts(sys$setast(0));
1438 if (info->waiting && info->done)
1440 nwait += info->waiting;
1441 _ckvmssts(sys$setast(1));
1450 _ckvmssts(sys$setast(0));
1451 if (!info->done) { /* We tried to be nice . . . */
1452 sts = sys$delprc(&info->pid,0);
1453 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1455 _ckvmssts(sys$setast(1));
1460 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1461 else if (!(sts & 1)) retsts = sts;
1466 static struct exit_control_block pipe_exitblock =
1467 {(struct exit_control_block *) 0,
1468 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1470 static void pipe_mbxtofd_ast(pPipe p);
1471 static void pipe_tochild1_ast(pPipe p);
1472 static void pipe_tochild2_ast(pPipe p);
1475 popen_completion_ast(pInfo info)
1477 pInfo i = open_pipes;
1481 if (i == info) break;
1484 if (!i) return; /* unlinked, probably freed too */
1486 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1490 Writing to subprocess ...
1491 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1493 chan_out may be waiting for "done" flag, or hung waiting
1494 for i/o completion to child...cancel the i/o. This will
1495 put it into "snarf mode" (done but no EOF yet) that discards
1498 Output from subprocess (stdout, stderr) needs to be flushed and
1499 shut down. We try sending an EOF, but if the mbx is full the pipe
1500 routine should still catch the "shut_on_empty" flag, telling it to
1501 use immediate-style reads so that "mbx empty" -> EOF.
1505 if (info->in && !info->in_done) { /* only for mode=w */
1506 if (info->in->shut_on_empty && info->in->need_wake) {
1507 info->in->need_wake = FALSE;
1508 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1510 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1514 if (info->out && !info->out_done) { /* were we also piping output? */
1515 info->out->shut_on_empty = TRUE;
1516 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1517 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1518 _ckvmssts_noperl(iss);
1521 if (info->err && !info->err_done) { /* we were piping stderr */
1522 info->err->shut_on_empty = TRUE;
1523 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1524 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1525 _ckvmssts_noperl(iss);
1527 _ckvmssts_noperl(sys$setef(pipe_ef));
1531 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1532 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1535 we actually differ from vmstrnenv since we use this to
1536 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1537 are pointing to the same thing
1540 static unsigned short
1541 popen_translate(pTHX_ char *logical, char *result)
1544 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1545 $DESCRIPTOR(d_log,"");
1547 unsigned short length;
1548 unsigned short code;
1550 unsigned short *retlenaddr;
1552 unsigned short l, ifi;
1554 d_log.dsc$a_pointer = logical;
1555 d_log.dsc$w_length = strlen(logical);
1557 itmlst[0].code = LNM$_STRING;
1558 itmlst[0].length = 255;
1559 itmlst[0].buffer_addr = result;
1560 itmlst[0].retlenaddr = &l;
1563 itmlst[1].length = 0;
1564 itmlst[1].buffer_addr = 0;
1565 itmlst[1].retlenaddr = 0;
1567 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1568 if (iss == SS$_NOLOGNAM) {
1572 if (!(iss&1)) lib$signal(iss);
1575 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1576 strip it off and return the ifi, if any
1579 if (result[0] == 0x1b && result[1] == 0x00) {
1580 memcpy(&ifi,result+2,2);
1581 strcpy(result,result+4);
1583 return ifi; /* this is the RMS internal file id */
1586 static void pipe_infromchild_ast(pPipe p);
1589 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1590 inside an AST routine without worrying about reentrancy and which Perl
1591 memory allocator is being used.
1593 We read data and queue up the buffers, then spit them out one at a
1594 time to the output mailbox when the output mailbox is ready for one.
1597 #define INITIAL_TOCHILDQUEUE 2
1600 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1604 char mbx1[64], mbx2[64];
1605 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1606 DSC$K_CLASS_S, mbx1},
1607 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1608 DSC$K_CLASS_S, mbx2};
1609 unsigned int dviitm = DVI$_DEVBUFSIZ;
1612 New(1368, p, 1, Pipe);
1614 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1615 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1616 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1619 p->shut_on_empty = FALSE;
1620 p->need_wake = FALSE;
1623 p->iosb.status = SS$_NORMAL;
1624 p->iosb2.status = SS$_NORMAL;
1630 #ifdef PERL_IMPLICIT_CONTEXT
1634 n = sizeof(CBuf) + p->bufsize;
1636 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1637 _ckvmssts(lib$get_vm(&n, &b));
1638 b->buf = (char *) b + sizeof(CBuf);
1639 _ckvmssts(lib$insqhi(b, &p->free));
1642 pipe_tochild2_ast(p);
1643 pipe_tochild1_ast(p);
1649 /* reads the MBX Perl is writing, and queues */
1652 pipe_tochild1_ast(pPipe p)
1655 int iss = p->iosb.status;
1656 int eof = (iss == SS$_ENDOFFILE);
1657 #ifdef PERL_IMPLICIT_CONTEXT
1663 p->shut_on_empty = TRUE;
1665 _ckvmssts(sys$dassgn(p->chan_in));
1671 b->size = p->iosb.count;
1672 _ckvmssts(lib$insqhi(b, &p->wait));
1674 p->need_wake = FALSE;
1675 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1678 p->retry = 1; /* initial call */
1681 if (eof) { /* flush the free queue, return when done */
1682 int n = sizeof(CBuf) + p->bufsize;
1684 iss = lib$remqti(&p->free, &b);
1685 if (iss == LIB$_QUEWASEMP) return;
1687 _ckvmssts(lib$free_vm(&n, &b));
1691 iss = lib$remqti(&p->free, &b);
1692 if (iss == LIB$_QUEWASEMP) {
1693 int n = sizeof(CBuf) + p->bufsize;
1694 _ckvmssts(lib$get_vm(&n, &b));
1695 b->buf = (char *) b + sizeof(CBuf);
1701 iss = sys$qio(0,p->chan_in,
1702 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1704 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1705 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1710 /* writes queued buffers to output, waits for each to complete before
1714 pipe_tochild2_ast(pPipe p)
1717 int iss = p->iosb2.status;
1718 int n = sizeof(CBuf) + p->bufsize;
1719 int done = (p->info && p->info->done) ||
1720 iss == SS$_CANCEL || iss == SS$_ABORT;
1721 #if defined(PERL_IMPLICIT_CONTEXT)
1726 if (p->type) { /* type=1 has old buffer, dispose */
1727 if (p->shut_on_empty) {
1728 _ckvmssts(lib$free_vm(&n, &b));
1730 _ckvmssts(lib$insqhi(b, &p->free));
1735 iss = lib$remqti(&p->wait, &b);
1736 if (iss == LIB$_QUEWASEMP) {
1737 if (p->shut_on_empty) {
1739 _ckvmssts(sys$dassgn(p->chan_out));
1740 *p->pipe_done = TRUE;
1741 _ckvmssts(sys$setef(pipe_ef));
1743 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1744 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1748 p->need_wake = TRUE;
1758 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1759 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1761 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1762 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1771 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1774 char mbx1[64], mbx2[64];
1775 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1776 DSC$K_CLASS_S, mbx1},
1777 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1778 DSC$K_CLASS_S, mbx2};
1779 unsigned int dviitm = DVI$_DEVBUFSIZ;
1781 New(1367, p, 1, Pipe);
1782 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1783 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1785 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1786 New(1367, p->buf, p->bufsize, char);
1787 p->shut_on_empty = FALSE;
1790 p->iosb.status = SS$_NORMAL;
1791 #if defined(PERL_IMPLICIT_CONTEXT)
1794 pipe_infromchild_ast(p);
1802 pipe_infromchild_ast(pPipe p)
1804 int iss = p->iosb.status;
1805 int eof = (iss == SS$_ENDOFFILE);
1806 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1807 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1808 #if defined(PERL_IMPLICIT_CONTEXT)
1812 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1813 _ckvmssts(sys$dassgn(p->chan_out));
1818 input shutdown if EOF from self (done or shut_on_empty)
1819 output shutdown if closing flag set (my_pclose)
1820 send data/eof from child or eof from self
1821 otherwise, re-read (snarf of data from child)
1826 if (myeof && p->chan_in) { /* input shutdown */
1827 _ckvmssts(sys$dassgn(p->chan_in));
1832 if (myeof || kideof) { /* pass EOF to parent */
1833 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1834 pipe_infromchild_ast, p,
1837 } else if (eof) { /* eat EOF --- fall through to read*/
1839 } else { /* transmit data */
1840 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1841 pipe_infromchild_ast,p,
1842 p->buf, p->iosb.count, 0, 0, 0, 0));
1848 /* everything shut? flag as done */
1850 if (!p->chan_in && !p->chan_out) {
1851 *p->pipe_done = TRUE;
1852 _ckvmssts(sys$setef(pipe_ef));
1856 /* write completed (or read, if snarfing from child)
1857 if still have input active,
1858 queue read...immediate mode if shut_on_empty so we get EOF if empty
1860 check if Perl reading, generate EOFs as needed
1866 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1867 pipe_infromchild_ast,p,
1868 p->buf, p->bufsize, 0, 0, 0, 0);
1869 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1871 } else { /* send EOFs for extra reads */
1872 p->iosb.status = SS$_ENDOFFILE;
1873 p->iosb.dvispec = 0;
1874 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1876 pipe_infromchild_ast, p, 0, 0, 0, 0));
1882 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1886 unsigned long dviitm = DVI$_DEVBUFSIZ;
1888 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1889 DSC$K_CLASS_S, mbx};
1891 /* things like terminals and mbx's don't need this filter */
1892 if (fd && fstat(fd,&s) == 0) {
1893 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1894 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1895 DSC$K_CLASS_S, s.st_dev};
1897 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1898 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1899 strcpy(out, s.st_dev);
1904 New(1366, p, 1, Pipe);
1905 p->fd_out = dup(fd);
1906 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1907 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1908 New(1366, p->buf, p->bufsize+1, char);
1909 p->shut_on_empty = FALSE;
1914 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1915 pipe_mbxtofd_ast, p,
1916 p->buf, p->bufsize, 0, 0, 0, 0));
1922 pipe_mbxtofd_ast(pPipe p)
1924 int iss = p->iosb.status;
1925 int done = p->info->done;
1927 int eof = (iss == SS$_ENDOFFILE);
1928 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1929 int err = !(iss&1) && !eof;
1930 #if defined(PERL_IMPLICIT_CONTEXT)
1934 if (done && myeof) { /* end piping */
1936 sys$dassgn(p->chan_in);
1937 *p->pipe_done = TRUE;
1938 _ckvmssts(sys$setef(pipe_ef));
1942 if (!err && !eof) { /* good data to send to file */
1943 p->buf[p->iosb.count] = '\n';
1944 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1947 if (p->retry < MAX_RETRY) {
1948 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1958 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1959 pipe_mbxtofd_ast, p,
1960 p->buf, p->bufsize, 0, 0, 0, 0);
1961 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1966 typedef struct _pipeloc PLOC;
1967 typedef struct _pipeloc* pPLOC;
1971 char dir[NAM$C_MAXRSS+1];
1973 static pPLOC head_PLOC = 0;
1976 free_pipelocs(pTHX_ void *head)
1979 pPLOC *pHead = (pPLOC *)head;
1991 store_pipelocs(pTHX)
2000 char temp[NAM$C_MAXRSS+1];
2004 free_pipelocs(aTHX_ &head_PLOC);
2006 /* the . directory from @INC comes last */
2009 p->next = head_PLOC;
2011 strcpy(p->dir,"./");
2013 /* get the directory from $^X */
2015 #ifdef PERL_IMPLICIT_CONTEXT
2016 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2018 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2020 strcpy(temp, PL_origargv[0]);
2021 x = strrchr(temp,']');
2024 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2026 p->next = head_PLOC;
2028 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2029 p->dir[NAM$C_MAXRSS] = '\0';
2033 /* reverse order of @INC entries, skip "." since entered above */
2035 #ifdef PERL_IMPLICIT_CONTEXT
2038 if (PL_incgv) av = GvAVn(PL_incgv);
2040 for (i = 0; av && i <= AvFILL(av); i++) {
2041 dirsv = *av_fetch(av,i,TRUE);
2043 if (SvROK(dirsv)) continue;
2044 dir = SvPVx(dirsv,n_a);
2045 if (strcmp(dir,".") == 0) continue;
2046 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2050 p->next = head_PLOC;
2052 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2053 p->dir[NAM$C_MAXRSS] = '\0';
2056 /* most likely spot (ARCHLIB) put first in the list */
2059 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2061 p->next = head_PLOC;
2063 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2064 p->dir[NAM$C_MAXRSS] = '\0';
2073 static int vmspipe_file_status = 0;
2074 static char vmspipe_file[NAM$C_MAXRSS+1];
2076 /* already found? Check and use ... need read+execute permission */
2078 if (vmspipe_file_status == 1) {
2079 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2080 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2081 return vmspipe_file;
2083 vmspipe_file_status = 0;
2086 /* scan through stored @INC, $^X */
2088 if (vmspipe_file_status == 0) {
2089 char file[NAM$C_MAXRSS+1];
2090 pPLOC p = head_PLOC;
2093 strcpy(file, p->dir);
2094 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2095 file[NAM$C_MAXRSS] = '\0';
2098 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2100 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2101 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2102 vmspipe_file_status = 1;
2103 return vmspipe_file;
2106 vmspipe_file_status = -1; /* failed, use tempfiles */
2113 vmspipe_tempfile(pTHX)
2115 char file[NAM$C_MAXRSS+1];
2117 static int index = 0;
2120 /* create a tempfile */
2122 /* we can't go from W, shr=get to R, shr=get without
2123 an intermediate vulnerable state, so don't bother trying...
2125 and lib$spawn doesn't shr=put, so have to close the write
2127 So... match up the creation date/time and the FID to
2128 make sure we're dealing with the same file
2133 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2134 fp = fopen(file,"w");
2136 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2137 fp = fopen(file,"w");
2139 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2140 fp = fopen(file,"w");
2143 if (!fp) return 0; /* we're hosed */
2145 fprintf(fp,"$! 'f$verify(0)\n");
2146 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2147 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2148 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2149 fprintf(fp,"$ perl_on = \"set noon\"\n");
2150 fprintf(fp,"$ perl_exit = \"exit\"\n");
2151 fprintf(fp,"$ perl_del = \"delete\"\n");
2152 fprintf(fp,"$ pif = \"if\"\n");
2153 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2154 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2155 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2156 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2157 fprintf(fp,"$! --- build command line to get max possible length\n");
2158 fprintf(fp,"$c=perl_popen_cmd0\n");
2159 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2160 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2161 fprintf(fp,"$x=perl_popen_cmd3\n");
2162 fprintf(fp,"$c=c+x\n");
2163 fprintf(fp,"$! --- get rid of global symbols\n");
2164 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2165 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2166 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2167 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2168 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2169 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2170 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2171 fprintf(fp,"$ perl_on\n");
2172 fprintf(fp,"$ 'c\n");
2173 fprintf(fp,"$ perl_status = $STATUS\n");
2174 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2175 fprintf(fp,"$ perl_exit 'perl_status'\n");
2178 fgetname(fp, file, 1);
2179 fstat(fileno(fp), &s0);
2182 fp = fopen(file,"r","shr=get");
2184 fstat(fileno(fp), &s1);
2186 if (s0.st_ino[0] != s1.st_ino[0] ||
2187 s0.st_ino[1] != s1.st_ino[1] ||
2188 s0.st_ino[2] != s1.st_ino[2] ||
2189 s0.st_ctime != s1.st_ctime ) {
2200 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2202 static int handler_set_up = FALSE;
2203 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2204 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2206 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2207 char in[512], out[512], err[512], mbx[512];
2209 char tfilebuf[NAM$C_MAXRSS+1];
2211 char cmd_sym_name[20];
2212 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2213 DSC$K_CLASS_S, symbol};
2214 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2216 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2217 DSC$K_CLASS_S, cmd_sym_name};
2218 struct dsc$descriptor_s *vmscmd;
2219 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2220 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2221 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2223 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2225 /* once-per-program initialization...
2226 note that the SETAST calls and the dual test of pipe_ef
2227 makes sure that only the FIRST thread through here does
2228 the initialization...all other threads wait until it's
2231 Yeah, uglier than a pthread call, it's got all the stuff inline
2232 rather than in a separate routine.
2236 _ckvmssts(sys$setast(0));
2238 unsigned long int pidcode = JPI$_PID;
2239 $DESCRIPTOR(d_delay, RETRY_DELAY);
2240 _ckvmssts(lib$get_ef(&pipe_ef));
2241 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2242 _ckvmssts(sys$bintim(&d_delay, delaytime));
2244 if (!handler_set_up) {
2245 _ckvmssts(sys$dclexh(&pipe_exitblock));
2246 handler_set_up = TRUE;
2248 _ckvmssts(sys$setast(1));
2251 /* see if we can find a VMSPIPE.COM */
2254 vmspipe = find_vmspipe(aTHX);
2256 strcpy(tfilebuf+1,vmspipe);
2257 } else { /* uh, oh...we're in tempfile hell */
2258 tpipe = vmspipe_tempfile(aTHX);
2259 if (!tpipe) { /* a fish popular in Boston */
2260 if (ckWARN(WARN_PIPE)) {
2261 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2265 fgetname(tpipe,tfilebuf+1,1);
2267 vmspipedsc.dsc$a_pointer = tfilebuf;
2268 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2270 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2273 case RMS$_FNF: case RMS$_DNF:
2274 set_errno(ENOENT); break;
2276 set_errno(ENOTDIR); break;
2278 set_errno(ENODEV); break;
2280 set_errno(EACCES); break;
2282 set_errno(EINVAL); break;
2283 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2284 set_errno(E2BIG); break;
2285 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2286 _ckvmssts(sts); /* fall through */
2287 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2290 set_vaxc_errno(sts);
2291 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2292 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2297 New(1301,info,1,Info);
2299 strcpy(mode,in_mode);
2302 info->completion = 0;
2303 info->closing = FALSE;
2310 info->in_done = TRUE;
2311 info->out_done = TRUE;
2312 info->err_done = TRUE;
2313 in[0] = out[0] = err[0] = '\0';
2315 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2319 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2324 if (*mode == 'r') { /* piping from subroutine */
2326 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2328 info->out->pipe_done = &info->out_done;
2329 info->out_done = FALSE;
2330 info->out->info = info;
2332 if (!info->useFILE) {
2333 info->fp = PerlIO_open(mbx, mode);
2335 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2336 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2339 if (!info->fp && info->out) {
2340 sys$cancel(info->out->chan_out);
2342 while (!info->out_done) {
2344 _ckvmssts(sys$setast(0));
2345 done = info->out_done;
2346 if (!done) _ckvmssts(sys$clref(pipe_ef));
2347 _ckvmssts(sys$setast(1));
2348 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2351 if (info->out->buf) Safefree(info->out->buf);
2352 Safefree(info->out);
2358 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2360 info->err->pipe_done = &info->err_done;
2361 info->err_done = FALSE;
2362 info->err->info = info;
2365 } else if (*mode == 'w') { /* piping to subroutine */
2367 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2369 info->out->pipe_done = &info->out_done;
2370 info->out_done = FALSE;
2371 info->out->info = info;
2374 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2376 info->err->pipe_done = &info->err_done;
2377 info->err_done = FALSE;
2378 info->err->info = info;
2381 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2382 if (!info->useFILE) {
2383 info->fp = PerlIO_open(mbx, mode);
2385 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2386 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2390 info->in->pipe_done = &info->in_done;
2391 info->in_done = FALSE;
2392 info->in->info = info;
2396 if (!info->fp && info->in) {
2398 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2399 0, 0, 0, 0, 0, 0, 0, 0));
2401 while (!info->in_done) {
2403 _ckvmssts(sys$setast(0));
2404 done = info->in_done;
2405 if (!done) _ckvmssts(sys$clref(pipe_ef));
2406 _ckvmssts(sys$setast(1));
2407 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2410 if (info->in->buf) Safefree(info->in->buf);
2418 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2419 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2421 info->out->pipe_done = &info->out_done;
2422 info->out_done = FALSE;
2423 info->out->info = info;
2426 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2428 info->err->pipe_done = &info->err_done;
2429 info->err_done = FALSE;
2430 info->err->info = info;
2434 symbol[MAX_DCL_SYMBOL] = '\0';
2436 strncpy(symbol, in, MAX_DCL_SYMBOL);
2437 d_symbol.dsc$w_length = strlen(symbol);
2438 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2440 strncpy(symbol, err, MAX_DCL_SYMBOL);
2441 d_symbol.dsc$w_length = strlen(symbol);
2442 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2444 strncpy(symbol, out, MAX_DCL_SYMBOL);
2445 d_symbol.dsc$w_length = strlen(symbol);
2446 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2448 p = vmscmd->dsc$a_pointer;
2449 while (*p && *p != '\n') p++;
2450 *p = '\0'; /* truncate on \n */
2451 p = vmscmd->dsc$a_pointer;
2452 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2453 if (*p == '$') p++; /* remove leading $ */
2454 while (*p == ' ' || *p == '\t') p++;
2456 for (j = 0; j < 4; j++) {
2457 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2458 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2460 strncpy(symbol, p, MAX_DCL_SYMBOL);
2461 d_symbol.dsc$w_length = strlen(symbol);
2462 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2464 if (strlen(p) > MAX_DCL_SYMBOL) {
2465 p += MAX_DCL_SYMBOL;
2470 _ckvmssts(sys$setast(0));
2471 info->next=open_pipes; /* prepend to list */
2473 _ckvmssts(sys$setast(1));
2474 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2475 0, &info->pid, &info->completion,
2476 0, popen_completion_ast,info,0,0,0));
2478 /* if we were using a tempfile, close it now */
2480 if (tpipe) fclose(tpipe);
2482 /* once the subprocess is spawned, it has copied the symbols and
2483 we can get rid of ours */
2485 for (j = 0; j < 4; j++) {
2486 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2487 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2488 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2490 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2491 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2492 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2493 vms_execfree(vmscmd);
2495 #ifdef PERL_IMPLICIT_CONTEXT
2498 PL_forkprocess = info->pid;
2503 _ckvmssts(sys$setast(0));
2505 if (!done) _ckvmssts(sys$clref(pipe_ef));
2506 _ckvmssts(sys$setast(1));
2507 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2509 *psts = info->completion;
2510 my_pclose(info->fp);
2515 } /* end of safe_popen */
2518 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2520 Perl_my_popen(pTHX_ char *cmd, char *mode)
2524 TAINT_PROPER("popen");
2525 PERL_FLUSHALL_FOR_CHILD;
2526 return safe_popen(aTHX_ cmd,mode,&sts);
2531 /*{{{ I32 my_pclose(PerlIO *fp)*/
2532 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2534 pInfo info, last = NULL;
2535 unsigned long int retsts;
2538 for (info = open_pipes; info != NULL; last = info, info = info->next)
2539 if (info->fp == fp) break;
2541 if (info == NULL) { /* no such pipe open */
2542 set_errno(ECHILD); /* quoth POSIX */
2543 set_vaxc_errno(SS$_NONEXPR);
2547 /* If we were writing to a subprocess, insure that someone reading from
2548 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2549 * produce an EOF record in the mailbox.
2551 * well, at least sometimes it *does*, so we have to watch out for
2552 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2556 PerlIO_flush(info->fp); /* first, flush data */
2558 fflush((FILE *)info->fp);
2561 _ckvmssts(sys$setast(0));
2562 info->closing = TRUE;
2563 done = info->done && info->in_done && info->out_done && info->err_done;
2564 /* hanging on write to Perl's input? cancel it */
2565 if (info->mode == 'r' && info->out && !info->out_done) {
2566 if (info->out->chan_out) {
2567 _ckvmssts(sys$cancel(info->out->chan_out));
2568 if (!info->out->chan_in) { /* EOF generation, need AST */
2569 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2573 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2574 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2576 _ckvmssts(sys$setast(1));
2579 PerlIO_close(info->fp);
2581 fclose((FILE *)info->fp);
2584 we have to wait until subprocess completes, but ALSO wait until all
2585 the i/o completes...otherwise we'll be freeing the "info" structure
2586 that the i/o ASTs could still be using...
2590 _ckvmssts(sys$setast(0));
2591 done = info->done && info->in_done && info->out_done && info->err_done;
2592 if (!done) _ckvmssts(sys$clref(pipe_ef));
2593 _ckvmssts(sys$setast(1));
2594 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2596 retsts = info->completion;
2598 /* remove from list of open pipes */
2599 _ckvmssts(sys$setast(0));
2600 if (last) last->next = info->next;
2601 else open_pipes = info->next;
2602 _ckvmssts(sys$setast(1));
2604 /* free buffers and structures */
2607 if (info->in->buf) Safefree(info->in->buf);
2611 if (info->out->buf) Safefree(info->out->buf);
2612 Safefree(info->out);
2615 if (info->err->buf) Safefree(info->err->buf);
2616 Safefree(info->err);
2622 } /* end of my_pclose() */
2624 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2625 /* Roll our own prototype because we want this regardless of whether
2626 * _VMS_WAIT is defined.
2628 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2630 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2631 created with popen(); otherwise partially emulate waitpid() unless
2632 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2633 Also check processes not considered by the CRTL waitpid().
2635 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2637 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2643 if (statusp) *statusp = 0;
2645 for (info = open_pipes; info != NULL; info = info->next)
2646 if (info->pid == pid) break;
2648 if (info != NULL) { /* we know about this child */
2649 while (!info->done) {
2650 _ckvmssts(sys$setast(0));
2652 if (!done) _ckvmssts(sys$clref(pipe_ef));
2653 _ckvmssts(sys$setast(1));
2654 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2657 if (statusp) *statusp = info->completion;
2661 else { /* this child is not one of our own pipe children */
2663 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2665 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2666 * in 7.2 did we get a version that fills in the VMS completion
2667 * status as Perl has always tried to do.
2670 sts = __vms_waitpid( pid, statusp, flags );
2672 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2675 /* If the real waitpid tells us the child does not exist, we
2676 * fall through here to implement waiting for a child that
2677 * was created by some means other than exec() (say, spawned
2678 * from DCL) or to wait for a process that is not a subprocess
2679 * of the current process.
2682 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2684 $DESCRIPTOR(intdsc,"0 00:00:01");
2685 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2686 unsigned long int pidcode = JPI$_PID, mypid;
2687 unsigned long int interval[2];
2688 int termination_mbu = 0;
2689 unsigned short qio_iosb[4];
2690 unsigned int jpi_iosb[2];
2691 struct itmlst_3 jpilist[3] = {
2692 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2693 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2696 char trmmbx[NAM$C_DVI+1];
2697 $DESCRIPTOR(trmmbxdsc,trmmbx);
2698 struct accdef trmmsg;
2699 unsigned short int mbxchan;
2702 /* Sorry folks, we don't presently implement rooting around for
2703 the first child we can find, and we definitely don't want to
2704 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2710 /* Get the owner of the child so I can warn if it's not mine, plus
2711 * get the termination mailbox. If the process doesn't exist or I
2712 * don't have the privs to look at it, I can go home early.
2714 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2715 if (sts & 1) sts = jpi_iosb[0];
2727 set_vaxc_errno(sts);
2731 if (ckWARN(WARN_EXEC)) {
2732 /* remind folks they are asking for non-standard waitpid behavior */
2733 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2734 if (ownerpid != mypid)
2735 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2736 "waitpid: process %x is not a child of process %x",
2740 /* It's possible to have a mailbox unit number but no actual mailbox; we
2741 * check for this by assigning a channel to it, which we need anyway.
2743 if (termination_mbu != 0) {
2744 sprintf(trmmbx, "MBA%d:", termination_mbu);
2745 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2746 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2747 if (sts == SS$_NOSUCHDEV) {
2748 termination_mbu = 0; /* set up to take "no mailbox" case */
2753 /* If the process doesn't have a termination mailbox, then simply check
2754 * on it once a second until it's not there anymore.
2756 if (termination_mbu == 0) {
2757 _ckvmssts(sys$bintim(&intdsc,interval));
2758 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2759 _ckvmssts(sys$schdwk(0,0,interval,0));
2760 _ckvmssts(sys$hiber());
2762 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2765 /* If we do have a termination mailbox, post reads to it until we get a
2766 * termination message, discarding messages of the wrong type or for other
2767 * processes. If there is a place to put the final status, then do so.
2771 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2772 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2773 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2774 if (sts & 1) sts = qio_iosb[0];
2777 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2778 && trmmsg.acc$l_pid == pid ) {
2780 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2781 sts = sys$dassgn(mbxchan);
2785 } /* termination_mbu ? */
2790 } /* else one of our own pipe children */
2792 } /* end of waitpid() */
2797 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2799 my_gconvert(double val, int ndig, int trail, char *buf)
2801 static char __gcvtbuf[DBL_DIG+1];
2804 loc = buf ? buf : __gcvtbuf;
2806 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2808 sprintf(loc,"%.*g",ndig,val);
2814 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2815 return gcvt(val,ndig,loc);
2818 loc[0] = '0'; loc[1] = '\0';
2826 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2827 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2828 * to expand file specification. Allows for a single default file
2829 * specification and a simple mask of options. If outbuf is non-NULL,
2830 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2831 * the resultant file specification is placed. If outbuf is NULL, the
2832 * resultant file specification is placed into a static buffer.
2833 * The third argument, if non-NULL, is taken to be a default file
2834 * specification string. The fourth argument is unused at present.
2835 * rmesexpand() returns the address of the resultant string if
2836 * successful, and NULL on error.
2838 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2841 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2843 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2844 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2845 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2846 struct FAB myfab = cc$rms_fab;
2847 struct NAM mynam = cc$rms_nam;
2849 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2851 if (!filespec || !*filespec) {
2852 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2856 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2857 else outbuf = __rmsexpand_retbuf;
2859 if ((isunix = (strchr(filespec,'/') != NULL))) {
2860 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2861 filespec = vmsfspec;
2864 myfab.fab$l_fna = filespec;
2865 myfab.fab$b_fns = strlen(filespec);
2866 myfab.fab$l_nam = &mynam;
2868 if (defspec && *defspec) {
2869 if (strchr(defspec,'/') != NULL) {
2870 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2873 myfab.fab$l_dna = defspec;
2874 myfab.fab$b_dns = strlen(defspec);
2877 mynam.nam$l_esa = esa;
2878 mynam.nam$b_ess = sizeof esa;
2879 mynam.nam$l_rsa = outbuf;
2880 mynam.nam$b_rss = NAM$C_MAXRSS;
2882 retsts = sys$parse(&myfab,0,0);
2883 if (!(retsts & 1)) {
2884 mynam.nam$b_nop |= NAM$M_SYNCHK;
2885 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2886 retsts = sys$parse(&myfab,0,0);
2887 if (retsts & 1) goto expanded;
2889 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2890 (void) sys$parse(&myfab,0,0); /* Free search context */
2891 if (out) Safefree(out);
2892 set_vaxc_errno(retsts);
2893 if (retsts == RMS$_PRV) set_errno(EACCES);
2894 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2895 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2896 else set_errno(EVMSERR);
2899 retsts = sys$search(&myfab,0,0);
2900 if (!(retsts & 1) && retsts != RMS$_FNF) {
2901 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2902 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2903 if (out) Safefree(out);
2904 set_vaxc_errno(retsts);
2905 if (retsts == RMS$_PRV) set_errno(EACCES);
2906 else set_errno(EVMSERR);
2910 /* If the input filespec contained any lowercase characters,
2911 * downcase the result for compatibility with Unix-minded code. */
2913 for (out = myfab.fab$l_fna; *out; out++)
2914 if (islower(*out)) { haslower = 1; break; }
2915 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2916 else { out = esa; speclen = mynam.nam$b_esl; }
2917 /* Trim off null fields added by $PARSE
2918 * If type > 1 char, must have been specified in original or default spec
2919 * (not true for version; $SEARCH may have added version of existing file).
2921 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2922 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2923 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2924 if (trimver || trimtype) {
2925 if (defspec && *defspec) {
2926 char defesa[NAM$C_MAXRSS];
2927 struct FAB deffab = cc$rms_fab;
2928 struct NAM defnam = cc$rms_nam;
2930 deffab.fab$l_nam = &defnam;
2931 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2932 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2933 defnam.nam$b_nop = NAM$M_SYNCHK;
2934 if (sys$parse(&deffab,0,0) & 1) {
2935 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2936 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2939 if (trimver) speclen = mynam.nam$l_ver - out;
2941 /* If we didn't already trim version, copy down */
2942 if (speclen > mynam.nam$l_ver - out)
2943 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2944 speclen - (mynam.nam$l_ver - out));
2945 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2948 /* If we just had a directory spec on input, $PARSE "helpfully"
2949 * adds an empty name and type for us */
2950 if (mynam.nam$l_name == mynam.nam$l_type &&
2951 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2952 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2953 speclen = mynam.nam$l_name - out;
2954 out[speclen] = '\0';
2955 if (haslower) __mystrtolower(out);
2957 /* Have we been working with an expanded, but not resultant, spec? */
2958 /* Also, convert back to Unix syntax if necessary. */
2959 if (!mynam.nam$b_rsl) {
2961 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2963 else strcpy(outbuf,esa);
2966 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2967 strcpy(outbuf,tmpfspec);
2969 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2970 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2971 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2975 /* External entry points */
2976 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2977 { return do_rmsexpand(spec,buf,0,def,opt); }
2978 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2979 { return do_rmsexpand(spec,buf,1,def,opt); }
2983 ** The following routines are provided to make life easier when
2984 ** converting among VMS-style and Unix-style directory specifications.
2985 ** All will take input specifications in either VMS or Unix syntax. On
2986 ** failure, all return NULL. If successful, the routines listed below
2987 ** return a pointer to a buffer containing the appropriately
2988 ** reformatted spec (and, therefore, subsequent calls to that routine
2989 ** will clobber the result), while the routines of the same names with
2990 ** a _ts suffix appended will return a pointer to a mallocd string
2991 ** containing the appropriately reformatted spec.
2992 ** In all cases, only explicit syntax is altered; no check is made that
2993 ** the resulting string is valid or that the directory in question
2996 ** fileify_dirspec() - convert a directory spec into the name of the
2997 ** directory file (i.e. what you can stat() to see if it's a dir).
2998 ** The style (VMS or Unix) of the result is the same as the style
2999 ** of the parameter passed in.
3000 ** pathify_dirspec() - convert a directory spec into a path (i.e.
3001 ** what you prepend to a filename to indicate what directory it's in).
3002 ** The style (VMS or Unix) of the result is the same as the style
3003 ** of the parameter passed in.
3004 ** tounixpath() - convert a directory spec into a Unix-style path.
3005 ** tovmspath() - convert a directory spec into a VMS-style path.
3006 ** tounixspec() - convert any file spec into a Unix-style file spec.
3007 ** tovmsspec() - convert any file spec into a VMS-style spec.
3009 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
3010 ** Permission is given to distribute this code as part of the Perl
3011 ** standard distribution under the terms of the GNU General Public
3012 ** License or the Perl Artistic License. Copies of each may be
3013 ** found in the Perl standard distribution.
3016 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3017 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3019 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3020 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3021 char *retspec, *cp1, *cp2, *lastdir;
3022 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3024 if (!dir || !*dir) {
3025 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3027 dirlen = strlen(dir);
3028 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3029 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3030 strcpy(trndir,"/sys$disk/000000");
3034 if (dirlen > NAM$C_MAXRSS) {
3035 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3037 if (!strpbrk(dir+1,"/]>:")) {
3038 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3039 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
3041 dirlen = strlen(dir);
3044 strncpy(trndir,dir,dirlen);
3045 trndir[dirlen] = '\0';
3048 /* If we were handed a rooted logical name or spec, treat it like a
3049 * simple directory, so that
3050 * $ Define myroot dev:[dir.]
3051 * ... do_fileify_dirspec("myroot",buf,1) ...
3052 * does something useful.
3054 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3055 dir[--dirlen] = '\0';
3056 dir[dirlen-1] = ']';
3058 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3059 dir[--dirlen] = '\0';
3060 dir[dirlen-1] = '>';
3063 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3064 /* If we've got an explicit filename, we can just shuffle the string. */
3065 if (*(cp1+1)) hasfilename = 1;
3066 /* Similarly, we can just back up a level if we've got multiple levels
3067 of explicit directories in a VMS spec which ends with directories. */
3069 for (cp2 = cp1; cp2 > dir; cp2--) {
3071 *cp2 = *cp1; *cp1 = '\0';
3075 if (*cp2 == '[' || *cp2 == '<') break;
3080 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3081 if (dir[0] == '.') {
3082 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3083 return do_fileify_dirspec("[]",buf,ts);
3084 else if (dir[1] == '.' &&
3085 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3086 return do_fileify_dirspec("[-]",buf,ts);
3088 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3089 dirlen -= 1; /* to last element */
3090 lastdir = strrchr(dir,'/');
3092 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3093 /* If we have "/." or "/..", VMSify it and let the VMS code
3094 * below expand it, rather than repeating the code to handle
3095 * relative components of a filespec here */
3097 if (*(cp1+2) == '.') cp1++;
3098 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3099 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3100 if (strchr(vmsdir,'/') != NULL) {
3101 /* If do_tovmsspec() returned it, it must have VMS syntax
3102 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3103 * the time to check this here only so we avoid a recursion
3104 * loop; otherwise, gigo.
3106 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3108 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3109 return do_tounixspec(trndir,buf,ts);
3112 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3113 lastdir = strrchr(dir,'/');
3115 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3116 /* Ditto for specs that end in an MFD -- let the VMS code
3117 * figure out whether it's a real device or a rooted logical. */
3118 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3119 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3120 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3121 return do_tounixspec(trndir,buf,ts);
3124 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3125 !(lastdir = cp1 = strrchr(dir,']')) &&
3126 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3127 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3129 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3130 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3131 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3132 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3133 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3134 (ver || *cp3)))))) {
3136 set_vaxc_errno(RMS$_DIR);
3142 /* If we lead off with a device or rooted logical, add the MFD
3143 if we're specifying a top-level directory. */
3144 if (lastdir && *dir == '/') {
3146 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3153 retlen = dirlen + (addmfd ? 13 : 6);
3154 if (buf) retspec = buf;
3155 else if (ts) New(1309,retspec,retlen+1,char);
3156 else retspec = __fileify_retbuf;
3158 dirlen = lastdir - dir;
3159 memcpy(retspec,dir,dirlen);
3160 strcpy(&retspec[dirlen],"/000000");
3161 strcpy(&retspec[dirlen+7],lastdir);
3164 memcpy(retspec,dir,dirlen);
3165 retspec[dirlen] = '\0';
3167 /* We've picked up everything up to the directory file name.
3168 Now just add the type and version, and we're set. */
3169 strcat(retspec,".dir;1");
3172 else { /* VMS-style directory spec */
3173 char esa[NAM$C_MAXRSS+1], term, *cp;
3174 unsigned long int sts, cmplen, haslower = 0;
3175 struct FAB dirfab = cc$rms_fab;
3176 struct NAM savnam, dirnam = cc$rms_nam;
3178 dirfab.fab$b_fns = strlen(dir);
3179 dirfab.fab$l_fna = dir;
3180 dirfab.fab$l_nam = &dirnam;
3181 dirfab.fab$l_dna = ".DIR;1";
3182 dirfab.fab$b_dns = 6;
3183 dirnam.nam$b_ess = NAM$C_MAXRSS;
3184 dirnam.nam$l_esa = esa;
3186 for (cp = dir; *cp; cp++)
3187 if (islower(*cp)) { haslower = 1; break; }
3188 if (!((sts = sys$parse(&dirfab))&1)) {
3189 if (dirfab.fab$l_sts == RMS$_DIR) {
3190 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3191 sts = sys$parse(&dirfab) & 1;
3195 set_vaxc_errno(dirfab.fab$l_sts);
3201 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3202 /* Yes; fake the fnb bits so we'll check type below */
3203 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3205 else { /* No; just work with potential name */
3206 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3208 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3209 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3210 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3215 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3216 cp1 = strchr(esa,']');
3217 if (!cp1) cp1 = strchr(esa,'>');
3218 if (cp1) { /* Should always be true */
3219 dirnam.nam$b_esl -= cp1 - esa - 1;
3220 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3223 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3224 /* Yep; check version while we're at it, if it's there. */
3225 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3226 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3227 /* Something other than .DIR[;1]. Bzzt. */
3228 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3229 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3231 set_vaxc_errno(RMS$_DIR);
3235 esa[dirnam.nam$b_esl] = '\0';
3236 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3237 /* They provided at least the name; we added the type, if necessary, */
3238 if (buf) retspec = buf; /* in sys$parse() */
3239 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3240 else retspec = __fileify_retbuf;
3241 strcpy(retspec,esa);
3242 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3243 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3246 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3247 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3249 dirnam.nam$b_esl -= 9;
3251 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3252 if (cp1 == NULL) { /* should never happen */
3253 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3254 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3259 retlen = strlen(esa);
3260 if ((cp1 = strrchr(esa,'.')) != NULL) {
3261 /* There's more than one directory in the path. Just roll back. */
3263 if (buf) retspec = buf;
3264 else if (ts) New(1311,retspec,retlen+7,char);
3265 else retspec = __fileify_retbuf;
3266 strcpy(retspec,esa);
3269 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3270 /* Go back and expand rooted logical name */
3271 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3272 if (!(sys$parse(&dirfab) & 1)) {
3273 dirnam.nam$l_rlf = NULL;
3274 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3276 set_vaxc_errno(dirfab.fab$l_sts);
3279 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3280 if (buf) retspec = buf;
3281 else if (ts) New(1312,retspec,retlen+16,char);
3282 else retspec = __fileify_retbuf;
3283 cp1 = strstr(esa,"][");
3284 if (!cp1) cp1 = strstr(esa,"]<");
3286 memcpy(retspec,esa,dirlen);
3287 if (!strncmp(cp1+2,"000000]",7)) {
3288 retspec[dirlen-1] = '\0';
3289 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3290 if (*cp1 == '.') *cp1 = ']';
3292 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3293 memcpy(cp1+1,"000000]",7);
3297 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3298 retspec[retlen] = '\0';
3299 /* Convert last '.' to ']' */
3300 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3301 if (*cp1 == '.') *cp1 = ']';
3303 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3304 memcpy(cp1+1,"000000]",7);
3308 else { /* This is a top-level dir. Add the MFD to the path. */
3309 if (buf) retspec = buf;
3310 else if (ts) New(1312,retspec,retlen+16,char);
3311 else retspec = __fileify_retbuf;
3314 while (*cp1 != ':') *(cp2++) = *(cp1++);
3315 strcpy(cp2,":[000000]");
3320 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3321 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3322 /* We've set up the string up through the filename. Add the
3323 type and version, and we're done. */
3324 strcat(retspec,".DIR;1");
3326 /* $PARSE may have upcased filespec, so convert output to lower
3327 * case if input contained any lowercase characters. */
3328 if (haslower) __mystrtolower(retspec);
3331 } /* end of do_fileify_dirspec() */
3333 /* External entry points */
3334 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3335 { return do_fileify_dirspec(dir,buf,0); }
3336 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3337 { return do_fileify_dirspec(dir,buf,1); }
3339 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3340 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3342 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3343 unsigned long int retlen;
3344 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3346 if (!dir || !*dir) {
3347 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3350 if (*dir) strcpy(trndir,dir);
3351 else getcwd(trndir,sizeof trndir - 1);
3353 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3354 && my_trnlnm(trndir,trndir,0)) {
3355 STRLEN trnlen = strlen(trndir);
3357 /* Trap simple rooted lnms, and return lnm:[000000] */
3358 if (!strcmp(trndir+trnlen-2,".]")) {
3359 if (buf) retpath = buf;
3360 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3361 else retpath = __pathify_retbuf;
3362 strcpy(retpath,dir);
3363 strcat(retpath,":[000000]");
3369 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3370 if (*dir == '.' && (*(dir+1) == '\0' ||
3371 (*(dir+1) == '.' && *(dir+2) == '\0')))
3372 retlen = 2 + (*(dir+1) != '\0');
3374 if ( !(cp1 = strrchr(dir,'/')) &&
3375 !(cp1 = strrchr(dir,']')) &&
3376 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3377 if ((cp2 = strchr(cp1,'.')) != NULL &&
3378 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3379 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3380 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3381 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3383 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3384 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3385 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3386 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3387 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3388 (ver || *cp3)))))) {
3390 set_vaxc_errno(RMS$_DIR);
3393 retlen = cp2 - dir + 1;
3395 else { /* No file type present. Treat the filename as a directory. */
3396 retlen = strlen(dir) + 1;
3399 if (buf) retpath = buf;
3400 else if (ts) New(1313,retpath,retlen+1,char);
3401 else retpath = __pathify_retbuf;
3402 strncpy(retpath,dir,retlen-1);
3403 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3404 retpath[retlen-1] = '/'; /* with '/', add it. */
3405 retpath[retlen] = '\0';
3407 else retpath[retlen-1] = '\0';
3409 else { /* VMS-style directory spec */
3410 char esa[NAM$C_MAXRSS+1], *cp;
3411 unsigned long int sts, cmplen, haslower;
3412 struct FAB dirfab = cc$rms_fab;
3413 struct NAM savnam, dirnam = cc$rms_nam;
3415 /* If we've got an explicit filename, we can just shuffle the string. */
3416 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3417 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3418 if ((cp2 = strchr(cp1,'.')) != NULL) {
3420 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3421 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3422 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3423 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3424 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3425 (ver || *cp3)))))) {
3427 set_vaxc_errno(RMS$_DIR);
3431 else { /* No file type, so just draw name into directory part */
3432 for (cp2 = cp1; *cp2; cp2++) ;
3435 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3437 /* We've now got a VMS 'path'; fall through */
3439 dirfab.fab$b_fns = strlen(dir);
3440 dirfab.fab$l_fna = dir;
3441 if (dir[dirfab.fab$b_fns-1] == ']' ||
3442 dir[dirfab.fab$b_fns-1] == '>' ||
3443 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3444 if (buf) retpath = buf;
3445 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3446 else retpath = __pathify_retbuf;
3447 strcpy(retpath,dir);
3450 dirfab.fab$l_dna = ".DIR;1";
3451 dirfab.fab$b_dns = 6;
3452 dirfab.fab$l_nam = &dirnam;
3453 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3454 dirnam.nam$l_esa = esa;
3456 for (cp = dir; *cp; cp++)
3457 if (islower(*cp)) { haslower = 1; break; }
3459 if (!(sts = (sys$parse(&dirfab)&1))) {
3460 if (dirfab.fab$l_sts == RMS$_DIR) {
3461 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3462 sts = sys$parse(&dirfab) & 1;
3466 set_vaxc_errno(dirfab.fab$l_sts);
3472 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3473 if (dirfab.fab$l_sts != RMS$_FNF) {
3474 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3475 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3477 set_vaxc_errno(dirfab.fab$l_sts);
3480 dirnam = savnam; /* No; just work with potential name */
3483 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3484 /* Yep; check version while we're at it, if it's there. */
3485 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3486 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3487 /* Something other than .DIR[;1]. Bzzt. */
3488 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3489 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3491 set_vaxc_errno(RMS$_DIR);
3495 /* OK, the type was fine. Now pull any file name into the
3497 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3499 cp1 = strrchr(esa,'>');
3500 *dirnam.nam$l_type = '>';
3503 *(dirnam.nam$l_type + 1) = '\0';
3504 retlen = dirnam.nam$l_type - esa + 2;
3505 if (buf) retpath = buf;
3506 else if (ts) New(1314,retpath,retlen,char);
3507 else retpath = __pathify_retbuf;
3508 strcpy(retpath,esa);
3509 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3510 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3511 /* $PARSE may have upcased filespec, so convert output to lower
3512 * case if input contained any lowercase characters. */
3513 if (haslower) __mystrtolower(retpath);
3517 } /* end of do_pathify_dirspec() */
3519 /* External entry points */
3520 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3521 { return do_pathify_dirspec(dir,buf,0); }
3522 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3523 { return do_pathify_dirspec(dir,buf,1); }
3525 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3526 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3528 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3529 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3530 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3532 if (spec == NULL) return NULL;
3533 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3534 if (buf) rslt = buf;
3536 retlen = strlen(spec);
3537 cp1 = strchr(spec,'[');
3538 if (!cp1) cp1 = strchr(spec,'<');
3540 for (cp1++; *cp1; cp1++) {
3541 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3542 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3543 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3546 New(1315,rslt,retlen+2+2*expand,char);
3548 else rslt = __tounixspec_retbuf;
3549 if (strchr(spec,'/') != NULL) {
3556 dirend = strrchr(spec,']');
3557 if (dirend == NULL) dirend = strrchr(spec,'>');
3558 if (dirend == NULL) dirend = strchr(spec,':');
3559 if (dirend == NULL) {
3563 if (*cp2 != '[' && *cp2 != '<') {
3566 else { /* the VMS spec begins with directories */
3568 if (*cp2 == ']' || *cp2 == '>') {
3569 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3572 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3573 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3574 if (ts) Safefree(rslt);
3579 while (*cp3 != ':' && *cp3) cp3++;
3581 if (strchr(cp3,']') != NULL) break;
3582 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3584 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3585 retlen = devlen + dirlen;
3586 Renew(rslt,retlen+1+2*expand,char);
3592 *(cp1++) = *(cp3++);
3593 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3597 else if ( *cp2 == '.') {
3598 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3599 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3605 for (; cp2 <= dirend; cp2++) {
3608 if (*(cp2+1) == '[') cp2++;
3610 else if (*cp2 == ']' || *cp2 == '>') {
3611 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3613 else if (*cp2 == '.') {
3615 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3616 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3617 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3618 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3619 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3621 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3622 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3626 else if (*cp2 == '-') {
3627 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3628 while (*cp2 == '-') {
3630 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3632 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3633 if (ts) Safefree(rslt); /* filespecs like */
3634 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3638 else *(cp1++) = *cp2;
3640 else *(cp1++) = *cp2;
3642 while (*cp2) *(cp1++) = *(cp2++);
3647 } /* end of do_tounixspec() */
3649 /* External entry points */
3650 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3651 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3653 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3654 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3655 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3656 char *rslt, *dirend;
3657 register char *cp1, *cp2;
3658 unsigned long int infront = 0, hasdir = 1;
3660 if (path == NULL) return NULL;
3661 if (buf) rslt = buf;
3662 else if (ts) New(1316,rslt,strlen(path)+9,char);
3663 else rslt = __tovmsspec_retbuf;
3664 if (strpbrk(path,"]:>") ||
3665 (dirend = strrchr(path,'/')) == NULL) {
3666 if (path[0] == '.') {
3667 if (path[1] == '\0') strcpy(rslt,"[]");
3668 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3669 else strcpy(rslt,path); /* probably garbage */
3671 else strcpy(rslt,path);
3674 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3675 if (!*(dirend+2)) dirend +=2;
3676 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3677 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3682 char trndev[NAM$C_MAXRSS+1];
3686 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3688 if (!buf & ts) Renew(rslt,18,char);
3689 strcpy(rslt,"sys$disk:[000000]");
3692 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3694 islnm = my_trnlnm(rslt,trndev,0);
3695 trnend = islnm ? strlen(trndev) - 1 : 0;
3696 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3697 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3698 /* If the first element of the path is a logical name, determine
3699 * whether it has to be translated so we can add more directories. */
3700 if (!islnm || rooted) {
3703 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3707 if (cp2 != dirend) {
3708 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3709 strcpy(rslt,trndev);
3710 cp1 = rslt + trnend;
3723 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3724 cp2 += 2; /* skip over "./" - it's redundant */
3725 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3727 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3728 *(cp1++) = '-'; /* "../" --> "-" */
3731 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3732 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3733 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3734 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3737 if (cp2 > dirend) cp2 = dirend;
3739 else *(cp1++) = '.';
3741 for (; cp2 < dirend; cp2++) {
3743 if (*(cp2-1) == '/') continue;
3744 if (*(cp1-1) != '.') *(cp1++) = '.';
3747 else if (!infront && *cp2 == '.') {
3748 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3749 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3750 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3751 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3752 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3753 else { /* back up over previous directory name */
3755 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3756 if (*(cp1-1) == '[') {
3757 memcpy(cp1,"000000.",7);
3762 if (cp2 == dirend) break;
3764 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3765 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3766 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3767 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3769 *(cp1++) = '.'; /* Simulate trailing '/' */
3770 cp2 += 2; /* for loop will incr this to == dirend */
3772 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3774 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3777 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3778 if (*cp2 == '.') *(cp1++) = '_';
3779 else *(cp1++) = *cp2;
3783 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3784 if (hasdir) *(cp1++) = ']';
3785 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3786 while (*cp2) *(cp1++) = *(cp2++);
3791 } /* end of do_tovmsspec() */
3793 /* External entry points */
3794 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3795 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3797 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3798 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3799 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3801 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3803 if (path == NULL) return NULL;
3804 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3805 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3806 if (buf) return buf;
3808 vmslen = strlen(vmsified);
3809 New(1317,cp,vmslen+1,char);
3810 memcpy(cp,vmsified,vmslen);
3815 strcpy(__tovmspath_retbuf,vmsified);
3816 return __tovmspath_retbuf;
3819 } /* end of do_tovmspath() */
3821 /* External entry points */
3822 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3823 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3826 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3827 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3828 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3830 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3832 if (path == NULL) return NULL;
3833 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3834 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3835 if (buf) return buf;
3837 unixlen = strlen(unixified);
3838 New(1317,cp,unixlen+1,char);
3839 memcpy(cp,unixified,unixlen);
3844 strcpy(__tounixpath_retbuf,unixified);
3845 return __tounixpath_retbuf;
3848 } /* end of do_tounixpath() */
3850 /* External entry points */
3851 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3852 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3855 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3857 *****************************************************************************
3859 * Copyright (C) 1989-1994 by *
3860 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3862 * Permission is hereby granted for the reproduction of this software, *
3863 * on condition that this copyright notice is included in the reproduction, *
3864 * and that such reproduction is not for purposes of profit or material *
3867 * 27-Aug-1994 Modified for inclusion in perl5 *
3868 * by Charles Bailey bailey@newman.upenn.edu *
3869 *****************************************************************************
3873 * getredirection() is intended to aid in porting C programs
3874 * to VMS (Vax-11 C). The native VMS environment does not support
3875 * '>' and '<' I/O redirection, or command line wild card expansion,
3876 * or a command line pipe mechanism using the '|' AND background
3877 * command execution '&'. All of these capabilities are provided to any
3878 * C program which calls this procedure as the first thing in the
3880 * The piping mechanism will probably work with almost any 'filter' type
3881 * of program. With suitable modification, it may useful for other
3882 * portability problems as well.
3884 * Author: Mark Pizzolato mark@infocomm.com
3888 struct list_item *next;
3892 static void add_item(struct list_item **head,
3893 struct list_item **tail,
3897 static void mp_expand_wild_cards(pTHX_ char *item,
3898 struct list_item **head,
3899 struct list_item **tail,
3902 static int background_process(int argc, char **argv);
3904 static void pipe_and_fork(pTHX_ char **cmargv);
3906 /*{{{ void getredirection(int *ac, char ***av)*/
3908 mp_getredirection(pTHX_ int *ac, char ***av)
3910 * Process vms redirection arg's. Exit if any error is seen.
3911 * If getredirection() processes an argument, it is erased
3912 * from the vector. getredirection() returns a new argc and argv value.
3913 * In the event that a background command is requested (by a trailing "&"),
3914 * this routine creates a background subprocess, and simply exits the program.
3916 * Warning: do not try to simplify the code for vms. The code
3917 * presupposes that getredirection() is called before any data is
3918 * read from stdin or written to stdout.
3920 * Normal usage is as follows:
3926 * getredirection(&argc, &argv);
3930 int argc = *ac; /* Argument Count */
3931 char **argv = *av; /* Argument Vector */
3932 char *ap; /* Argument pointer */
3933 int j; /* argv[] index */
3934 int item_count = 0; /* Count of Items in List */
3935 struct list_item *list_head = 0; /* First Item in List */
3936 struct list_item *list_tail; /* Last Item in List */
3937 char *in = NULL; /* Input File Name */
3938 char *out = NULL; /* Output File Name */
3939 char *outmode = "w"; /* Mode to Open Output File */
3940 char *err = NULL; /* Error File Name */
3941 char *errmode = "w"; /* Mode to Open Error File */
3942 int cmargc = 0; /* Piped Command Arg Count */
3943 char **cmargv = NULL;/* Piped Command Arg Vector */
3946 * First handle the case where the last thing on the line ends with
3947 * a '&'. This indicates the desire for the command to be run in a
3948 * subprocess, so we satisfy that desire.
3951 if (0 == strcmp("&", ap))
3952 exit(background_process(--argc, argv));
3953 if (*ap && '&' == ap[strlen(ap)-1])
3955 ap[strlen(ap)-1] = '\0';
3956 exit(background_process(argc, argv));
3959 * Now we handle the general redirection cases that involve '>', '>>',
3960 * '<', and pipes '|'.
3962 for (j = 0; j < argc; ++j)
3964 if (0 == strcmp("<", argv[j]))
3968 fprintf(stderr,"No input file after < on command line");
3969 exit(LIB$_WRONUMARG);
3974 if ('<' == *(ap = argv[j]))
3979 if (0 == strcmp(">", ap))
3983 fprintf(stderr,"No output file after > on command line");
3984 exit(LIB$_WRONUMARG);
4003 fprintf(stderr,"No output file after > or >> on command line");
4004 exit(LIB$_WRONUMARG);
4008 if (('2' == *ap) && ('>' == ap[1]))
4025 fprintf(stderr,"No output file after 2> or 2>> on command line");
4026 exit(LIB$_WRONUMARG);
4030 if (0 == strcmp("|", argv[j]))
4034 fprintf(stderr,"No command into which to pipe on command line");
4035 exit(LIB$_WRONUMARG);
4037 cmargc = argc-(j+1);
4038 cmargv = &argv[j+1];
4042 if ('|' == *(ap = argv[j]))
4050 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4053 * Allocate and fill in the new argument vector, Some Unix's terminate
4054 * the list with an extra null pointer.
4056 New(1302, argv, item_count+1, char *);
4058 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4059 argv[j] = list_head->value;
4065 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4066 exit(LIB$_INVARGORD);
4068 pipe_and_fork(aTHX_ cmargv);
4071 /* Check for input from a pipe (mailbox) */
4073 if (in == NULL && 1 == isapipe(0))
4075 char mbxname[L_tmpnam];
4077 long int dvi_item = DVI$_DEVBUFSIZ;
4078 $DESCRIPTOR(mbxnam, "");
4079 $DESCRIPTOR(mbxdevnam, "");
4081 /* Input from a pipe, reopen it in binary mode to disable */
4082 /* carriage control processing. */
4084 fgetname(stdin, mbxname);
4085 mbxnam.dsc$a_pointer = mbxname;
4086 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4087 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4088 mbxdevnam.dsc$a_pointer = mbxname;
4089 mbxdevnam.dsc$w_length = sizeof(mbxname);
4090 dvi_item = DVI$_DEVNAM;
4091 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4092 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4095 freopen(mbxname, "rb", stdin);
4098 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4102 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4104 fprintf(stderr,"Can't open input file %s as stdin",in);
4107 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4109 fprintf(stderr,"Can't open output file %s as stdout",out);
4112 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4115 if (strcmp(err,"&1") == 0) {
4116 dup2(fileno(stdout), fileno(stderr));
4117 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4120 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4122 fprintf(stderr,"Can't open error file %s as stderr",err);
4126 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4130 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4133 #ifdef ARGPROC_DEBUG
4134 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4135 for (j = 0; j < *ac; ++j)
4136 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4138 /* Clear errors we may have hit expanding wildcards, so they don't
4139 show up in Perl's $! later */
4140 set_errno(0); set_vaxc_errno(1);
4141 } /* end of getredirection() */
4144 static void add_item(struct list_item **head,
4145 struct list_item **tail,
4151 New(1303,*head,1,struct list_item);
4155 New(1304,(*tail)->next,1,struct list_item);
4156 *tail = (*tail)->next;
4158 (*tail)->value = value;
4162 static void mp_expand_wild_cards(pTHX_ char *item,
4163 struct list_item **head,
4164 struct list_item **tail,
4168 unsigned long int context = 0;
4174 char vmsspec[NAM$C_MAXRSS+1];
4175 $DESCRIPTOR(filespec, "");
4176 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4177 $DESCRIPTOR(resultspec, "");
4178 unsigned long int zero = 0, sts;
4180 for (cp = item; *cp; cp++) {
4181 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4182 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4184 if (!*cp || isspace(*cp))
4186 add_item(head, tail, item, count);
4189 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4190 resultspec.dsc$b_class = DSC$K_CLASS_D;
4191 resultspec.dsc$a_pointer = NULL;
4192 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4193 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4194 if (!isunix || !filespec.dsc$a_pointer)
4195 filespec.dsc$a_pointer = item;
4196 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4198 * Only return version specs, if the caller specified a version
4200 had_version = strchr(item, ';');
4202 * Only return device and directory specs, if the caller specifed either.
4204 had_device = strchr(item, ':');
4205 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4207 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4208 &defaultspec, 0, 0, &zero))))
4213 New(1305,string,resultspec.dsc$w_length+1,char);
4214 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4215 string[resultspec.dsc$w_length] = '\0';
4216 if (NULL == had_version)
4217 *((char *)strrchr(string, ';')) = '\0';
4218 if ((!had_directory) && (had_device == NULL))
4220 if (NULL == (devdir = strrchr(string, ']')))
4221 devdir = strrchr(string, '>');
4222 strcpy(string, devdir + 1);
4225 * Be consistent with what the C RTL has already done to the rest of
4226 * the argv items and lowercase all of these names.
4228 for (c = string; *c; ++c)
4231 if (isunix) trim_unixpath(string,item,1);
4232 add_item(head, tail, string, count);
4235 if (sts != RMS$_NMF)
4237 set_vaxc_errno(sts);
4240 case RMS$_FNF: case RMS$_DNF:
4241 set_errno(ENOENT); break;
4243 set_errno(ENOTDIR); break;
4245 set_errno(ENODEV); break;
4246 case RMS$_FNM: case RMS$_SYN:
4247 set_errno(EINVAL); break;
4249 set_errno(EACCES); break;
4251 _ckvmssts_noperl(sts);
4255 add_item(head, tail, item, count);
4256 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4257 _ckvmssts_noperl(lib$find_file_end(&context));
4260 static int child_st[2];/* Event Flag set when child process completes */
4262 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4264 static unsigned long int exit_handler(int *status)
4268 if (0 == child_st[0])
4270 #ifdef ARGPROC_DEBUG
4271 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4273 fflush(stdout); /* Have to flush pipe for binary data to */
4274 /* terminate properly -- <tp@mccall.com> */
4275 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4276 sys$dassgn(child_chan);
4278 sys$synch(0, child_st);
4283 static void sig_child(int chan)
4285 #ifdef ARGPROC_DEBUG
4286 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4288 if (child_st[0] == 0)
4292 static struct exit_control_block exit_block =
4297 &exit_block.exit_status,
4302 pipe_and_fork(pTHX_ char **cmargv)
4305 struct dsc$descriptor_s *vmscmd;
4306 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4307 int sts, j, l, ismcr, quote, tquote = 0;
4309 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4310 vms_execfree(vmscmd);
4315 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4316 && toupper(*(q+2)) == 'R' && !*(q+3);
4318 while (q && l < MAX_DCL_LINE_LENGTH) {
4320 if (j > 0 && quote) {
4326 if (ismcr && j > 1) quote = 1;
4327 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4330 if (quote || tquote) {
4336 if ((quote||tquote) && *q == '"') {
4346 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4348 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4352 static int background_process(int argc, char **argv)
4354 char command[2048] = "$";
4355 $DESCRIPTOR(value, "");
4356 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4357 static $DESCRIPTOR(null, "NLA0:");
4358 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4360 $DESCRIPTOR(pidstr, "");
4362 unsigned long int flags = 17, one = 1, retsts;
4364 strcat(command, argv[0]);
4367 strcat(command, " \"");
4368 strcat(command, *(++argv));
4369 strcat(command, "\"");
4371 value.dsc$a_pointer = command;
4372 value.dsc$w_length = strlen(value.dsc$a_pointer);
4373 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4374 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4375 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4376 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4379 _ckvmssts_noperl(retsts);
4381 #ifdef ARGPROC_DEBUG
4382 PerlIO_printf(Perl_debug_log, "%s\n", command);
4384 sprintf(pidstring, "%08X", pid);
4385 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4386 pidstr.dsc$a_pointer = pidstring;
4387 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4388 lib$set_symbol(&pidsymbol, &pidstr);
4392 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4395 /* OS-specific initialization at image activation (not thread startup) */
4396 /* Older VAXC header files lack these constants */
4397 #ifndef JPI$_RIGHTS_SIZE
4398 # define JPI$_RIGHTS_SIZE 817
4400 #ifndef KGB$M_SUBSYSTEM
4401 # define KGB$M_SUBSYSTEM 0x8
4404 /*{{{void vms_image_init(int *, char ***)*/
4406 vms_image_init(int *argcp, char ***argvp)
4408 char eqv[LNM$C_NAMLENGTH+1] = "";
4409 unsigned int len, tabct = 8, tabidx = 0;
4410 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4411 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4412 unsigned short int dummy, rlen;
4413 struct dsc$descriptor_s **tabvec;
4414 #if defined(PERL_IMPLICIT_CONTEXT)
4417 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4418 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4419 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4422 #ifdef KILL_BY_SIGPRC
4423 (void) Perl_csighandler_init();
4426 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4427 _ckvmssts_noperl(iosb[0]);
4428 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4429 if (iprv[i]) { /* Running image installed with privs? */
4430 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4435 /* Rights identifiers might trigger tainting as well. */
4436 if (!will_taint && (rlen || rsz)) {
4437 while (rlen < rsz) {
4438 /* We didn't get all the identifiers on the first pass. Allocate a
4439 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4440 * were needed to hold all identifiers at time of last call; we'll
4441 * allocate that many unsigned long ints), and go back and get 'em.
4442 * If it gave us less than it wanted to despite ample buffer space,
4443 * something's broken. Is your system missing a system identifier?
4445 if (rsz <= jpilist[1].buflen) {
4446 /* Perl_croak accvios when used this early in startup. */
4447 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4448 rsz, (unsigned long) jpilist[1].buflen,
4449 "Check your rights database for corruption.\n");
4452 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4453 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4454 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4455 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4456 _ckvmssts_noperl(iosb[0]);
4458 mask = jpilist[1].bufadr;
4459 /* Check attribute flags for each identifier (2nd longword); protected
4460 * subsystem identifiers trigger tainting.
4462 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4463 if (mask[i] & KGB$M_SUBSYSTEM) {
4468 if (mask != rlst) Safefree(mask);
4470 /* We need to use this hack to tell Perl it should run with tainting,
4471 * since its tainting flag may be part of the PL_curinterp struct, which
4472 * hasn't been allocated when vms_image_init() is called.
4476 New(1320,newap,*argcp+2,char **);
4477 newap[0] = argvp[0];
4479 Copy(argvp[1],newap[2],*argcp-1,char **);
4480 /* We orphan the old argv, since we don't know where it's come from,
4481 * so we don't know how to free it.
4483 *argcp++; argvp = newap;
4485 else { /* Did user explicitly request tainting? */
4487 char *cp, **av = *argvp;
4488 for (i = 1; i < *argcp; i++) {
4489 if (*av[i] != '-') break;
4490 for (cp = av[i]+1; *cp; cp++) {
4491 if (*cp == 'T') { will_taint = 1; break; }
4492 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4493 strchr("DFIiMmx",*cp)) break;
4495 if (will_taint) break;
4500 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4502 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4503 else if (tabidx >= tabct) {
4505 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4507 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4508 tabvec[tabidx]->dsc$w_length = 0;
4509 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4510 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4511 tabvec[tabidx]->dsc$a_pointer = NULL;
4512 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4514 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4516 getredirection(argcp,argvp);
4517 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4519 # include <reentrancy.h>
4520 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4529 * Trim Unix-style prefix off filespec, so it looks like what a shell
4530 * glob expansion would return (i.e. from specified prefix on, not
4531 * full path). Note that returned filespec is Unix-style, regardless
4532 * of whether input filespec was VMS-style or Unix-style.
4534 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4535 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4536 * vector of options; at present, only bit 0 is used, and if set tells
4537 * trim unixpath to try the current default directory as a prefix when
4538 * presented with a possibly ambiguous ... wildcard.
4540 * Returns !=0 on success, with trimmed filespec replacing contents of
4541 * fspec, and 0 on failure, with contents of fpsec unchanged.
4543 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4545 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4547 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4548 *template, *base, *end, *cp1, *cp2;
4549 register int tmplen, reslen = 0, dirs = 0;
4551 if (!wildspec || !fspec) return 0;
4552 if (strpbrk(wildspec,"]>:") != NULL) {
4553 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4554 else template = unixwild;
4556 else template = wildspec;
4557 if (strpbrk(fspec,"]>:") != NULL) {
4558 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4559 else base = unixified;
4560 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4561 * check to see that final result fits into (isn't longer than) fspec */
4562 reslen = strlen(fspec);
4566 /* No prefix or absolute path on wildcard, so nothing to remove */
4567 if (!*template || *template == '/') {
4568 if (base == fspec) return 1;
4569 tmplen = strlen(unixified);
4570 if (tmplen > reslen) return 0; /* not enough space */
4571 /* Copy unixified resultant, including trailing NUL */
4572 memmove(fspec,unixified,tmplen+1);
4576 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4577 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4578 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4579 for (cp1 = end ;cp1 >= base; cp1--)
4580 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4582 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4586 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4587 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4588 int ells = 1, totells, segdirs, match;
4589 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4590 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4592 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4594 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4595 if (ellipsis == template && opts & 1) {
4596 /* Template begins with an ellipsis. Since we can't tell how many
4597 * directory names at the front of the resultant to keep for an
4598 * arbitrary starting point, we arbitrarily choose the current
4599 * default directory as a starting point. If it's there as a prefix,
4600 * clip it off. If not, fall through and act as if the leading
4601 * ellipsis weren't there (i.e. return shortest possible path that
4602 * could match template).
4604 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4605 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4606 if (_tolower(*cp1) != _tolower(*cp2)) break;
4607 segdirs = dirs - totells; /* Min # of dirs we must have left */
4608 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4609 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4610 memcpy(fspec,cp2+1,end - cp2);
4614 /* First off, back up over constant elements at end of path */
4616 for (front = end ; front >= base; front--)
4617 if (*front == '/' && !dirs--) { front++; break; }
4619 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4620 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4621 if (cp1 != '\0') return 0; /* Path too long. */
4623 *cp2 = '\0'; /* Pick up with memcpy later */
4624 lcfront = lcres + (front - base);
4625 /* Now skip over each ellipsis and try to match the path in front of it. */
4627 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4628 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4629 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4630 if (cp1 < template) break; /* template started with an ellipsis */
4631 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4632 ellipsis = cp1; continue;
4634 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4636 for (segdirs = 0, cp2 = tpl;
4637 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4639 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4640 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4641 if (*cp2 == '/') segdirs++;
4643 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4644 /* Back up at least as many dirs as in template before matching */
4645 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4646 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4647 for (match = 0; cp1 > lcres;) {
4648 resdsc.dsc$a_pointer = cp1;
4649 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4651 if (match == 1) lcfront = cp1;
4653 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4655 if (!match) return 0; /* Can't find prefix ??? */
4656 if (match > 1 && opts & 1) {
4657 /* This ... wildcard could cover more than one set of dirs (i.e.
4658 * a set of similar dir names is repeated). If the template
4659 * contains more than 1 ..., upstream elements could resolve the
4660 * ambiguity, but it's not worth a full backtracking setup here.
4661 * As a quick heuristic, clip off the current default directory
4662 * if it's present to find the trimmed spec, else use the
4663 * shortest string that this ... could cover.
4665 char def[NAM$C_MAXRSS+1], *st;
4667 if (getcwd(def, sizeof def,0) == NULL) return 0;
4668 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4669 if (_tolower(*cp1) != _tolower(*cp2)) break;
4670 segdirs = dirs - totells; /* Min # of dirs we must have left */
4671 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4672 if (*cp1 == '\0' && *cp2 == '/') {
4673 memcpy(fspec,cp2+1,end - cp2);
4676 /* Nope -- stick with lcfront from above and keep going. */
4679 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4684 } /* end of trim_unixpath() */
4689 * VMS readdir() routines.
4690 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4692 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4693 * Minor modifications to original routines.
4696 /* Number of elements in vms_versions array */
4697 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4700 * Open a directory, return a handle for later use.
4702 /*{{{ DIR *opendir(char*name) */
4704 Perl_opendir(pTHX_ char *name)
4707 char dir[NAM$C_MAXRSS+1];
4710 if (do_tovmspath(name,dir,0) == NULL) {
4713 /* Check access before stat; otherwise stat does not
4714 * accurately report whether it's a directory.
4716 if (!cando_by_name(S_IRUSR,0,dir)) {
4717 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4720 if (flex_stat(dir,&sb) == -1) return NULL;
4721 if (!S_ISDIR(sb.st_mode)) {
4722 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4725 /* Get memory for the handle, and the pattern. */
4727 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4729 /* Fill in the fields; mainly playing with the descriptor. */
4730 (void)sprintf(dd->pattern, "%s*.*",dir);
4733 dd->vms_wantversions = 0;
4734 dd->pat.dsc$a_pointer = dd->pattern;
4735 dd->pat.dsc$w_length = strlen(dd->pattern);
4736 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4737 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4740 } /* end of opendir() */
4744 * Set the flag to indicate we want versions or not.
4746 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4748 vmsreaddirversions(DIR *dd, int flag)
4750 dd->vms_wantversions = flag;
4755 * Free up an opened directory.
4757 /*{{{ void closedir(DIR *dd)*/
4761 (void)lib$find_file_end(&dd->context);
4762 Safefree(dd->pattern);
4763 Safefree((char *)dd);
4768 * Collect all the version numbers for the current file.
4771 collectversions(pTHX_ DIR *dd)
4773 struct dsc$descriptor_s pat;
4774 struct dsc$descriptor_s res;
4776 char *p, *text, buff[sizeof dd->entry.d_name];
4778 unsigned long context, tmpsts;
4780 /* Convenient shorthand. */
4783 /* Add the version wildcard, ignoring the "*.*" put on before */
4784 i = strlen(dd->pattern);
4785 New(1308,text,i + e->d_namlen + 3,char);
4786 (void)strcpy(text, dd->pattern);
4787 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4789 /* Set up the pattern descriptor. */
4790 pat.dsc$a_pointer = text;
4791 pat.dsc$w_length = i + e->d_namlen - 1;
4792 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4793 pat.dsc$b_class = DSC$K_CLASS_S;
4795 /* Set up result descriptor. */
4796 res.dsc$a_pointer = buff;
4797 res.dsc$w_length = sizeof buff - 2;
4798 res.dsc$b_dtype = DSC$K_DTYPE_T;
4799 res.dsc$b_class = DSC$K_CLASS_S;
4801 /* Read files, collecting versions. */
4802 for (context = 0, e->vms_verscount = 0;
4803 e->vms_verscount < VERSIZE(e);
4804 e->vms_verscount++) {
4805 tmpsts = lib$find_file(&pat, &res, &context);
4806 if (tmpsts == RMS$_NMF || context == 0) break;
4808 buff[sizeof buff - 1] = '\0';
4809 if ((p = strchr(buff, ';')))
4810 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4812 e->vms_versions[e->vms_verscount] = -1;
4815 _ckvmssts(lib$find_file_end(&context));
4818 } /* end of collectversions() */
4821 * Read the next entry from the directory.
4823 /*{{{ struct dirent *readdir(DIR *dd)*/
4825 Perl_readdir(pTHX_ DIR *dd)
4827 struct dsc$descriptor_s res;
4828 char *p, buff[sizeof dd->entry.d_name];
4829 unsigned long int tmpsts;
4831 /* Set up result descriptor, and get next file. */
4832 res.dsc$a_pointer = buff;
4833 res.dsc$w_length = sizeof buff - 2;
4834 res.dsc$b_dtype = DSC$K_DTYPE_T;
4835 res.dsc$b_class = DSC$K_CLASS_S;
4836 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4837 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4838 if (!(tmpsts & 1)) {
4839 set_vaxc_errno(tmpsts);
4842 set_errno(EACCES); break;
4844 set_errno(ENODEV); break;
4846 set_errno(ENOTDIR); break;
4847 case RMS$_FNF: case RMS$_DNF:
4848 set_errno(ENOENT); break;
4855 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4856 buff[sizeof buff - 1] = '\0';
4857 for (p = buff; *p; p++) *p = _tolower(*p);
4858 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4861 /* Skip any directory component and just copy the name. */
4862 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4863 else (void)strcpy(dd->entry.d_name, buff);
4865 /* Clobber the version. */
4866 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4868 dd->entry.d_namlen = strlen(dd->entry.d_name);
4869 dd->entry.vms_verscount = 0;
4870 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4873 } /* end of readdir() */
4877 * Return something that can be used in a seekdir later.
4879 /*{{{ long telldir(DIR *dd)*/
4888 * Return to a spot where we used to be. Brute force.
4890 /*{{{ void seekdir(DIR *dd,long count)*/
4892 Perl_seekdir(pTHX_ DIR *dd, long count)
4894 int vms_wantversions;
4896 /* If we haven't done anything yet... */
4900 /* Remember some state, and clear it. */
4901 vms_wantversions = dd->vms_wantversions;
4902 dd->vms_wantversions = 0;
4903 _ckvmssts(lib$find_file_end(&dd->context));
4906 /* The increment is in readdir(). */
4907 for (dd->count = 0; dd->count < count; )
4910 dd->vms_wantversions = vms_wantversions;
4912 } /* end of seekdir() */
4915 /* VMS subprocess management
4917 * my_vfork() - just a vfork(), after setting a flag to record that
4918 * the current script is trying a Unix-style fork/exec.
4920 * vms_do_aexec() and vms_do_exec() are called in response to the
4921 * perl 'exec' function. If this follows a vfork call, then they
4922 * call out the the regular perl routines in doio.c which do an
4923 * execvp (for those who really want to try this under VMS).
4924 * Otherwise, they do exactly what the perl docs say exec should
4925 * do - terminate the current script and invoke a new command
4926 * (See below for notes on command syntax.)
4928 * do_aspawn() and do_spawn() implement the VMS side of the perl
4929 * 'system' function.
4931 * Note on command arguments to perl 'exec' and 'system': When handled
4932 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4933 * are concatenated to form a DCL command string. If the first arg
4934 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4935 * the the command string is handed off to DCL directly. Otherwise,
4936 * the first token of the command is taken as the filespec of an image
4937 * to run. The filespec is expanded using a default type of '.EXE' and
4938 * the process defaults for device, directory, etc., and if found, the resultant
4939 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4940 * the command string as parameters. This is perhaps a bit complicated,
4941 * but I hope it will form a happy medium between what VMS folks expect
4942 * from lib$spawn and what Unix folks expect from exec.
4945 static int vfork_called;
4947 /*{{{int my_vfork()*/
4958 vms_execfree(struct dsc$descriptor_s *vmscmd)
4961 if (vmscmd->dsc$a_pointer) {
4962 Safefree(vmscmd->dsc$a_pointer);
4969 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4971 char *junk, *tmps = Nullch;
4972 register size_t cmdlen = 0;
4979 tmps = SvPV(really,rlen);
4986 for (idx++; idx <= sp; idx++) {
4988 junk = SvPVx(*idx,rlen);
4989 cmdlen += rlen ? rlen + 1 : 0;
4992 New(401,PL_Cmd,cmdlen+1,char);
4994 if (tmps && *tmps) {
4995 strcpy(PL_Cmd,tmps);
4998 else *PL_Cmd = '\0';
4999 while (++mark <= sp) {
5001 char *s = SvPVx(*mark,n_a);
5003 if (*PL_Cmd) strcat(PL_Cmd," ");
5009 } /* end of setup_argstr() */
5012 static unsigned long int
5013 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5014 struct dsc$descriptor_s **pvmscmd)
5016 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5017 $DESCRIPTOR(defdsc,".EXE");
5018 $DESCRIPTOR(defdsc2,".");
5019 $DESCRIPTOR(resdsc,resspec);
5020 struct dsc$descriptor_s *vmscmd;
5021 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5022 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5023 register char *s, *rest, *cp, *wordbreak;
5026 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5027 vmscmd->dsc$a_pointer = NULL;
5028 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5029 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5030 vmscmd->dsc$w_length = 0;
5031 if (pvmscmd) *pvmscmd = vmscmd;
5033 if (suggest_quote) *suggest_quote = 0;
5035 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5036 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5038 while (*s && isspace(*s)) s++;
5040 if (*s == '@' || *s == '$') {
5041 vmsspec[0] = *s; rest = s + 1;
5042 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5044 else { cp = vmsspec; rest = s; }
5045 if (*rest == '.' || *rest == '/') {
5048 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5049 rest++, cp2++) *cp2 = *rest;
5051 if (do_tovmsspec(resspec,cp,0)) {
5054 for (cp2 = vmsspec + strlen(vmsspec);
5055 *rest && cp2 - vmsspec < sizeof vmsspec;
5056 rest++, cp2++) *cp2 = *rest;
5061 /* Intuit whether verb (first word of cmd) is a DCL command:
5062 * - if first nonspace char is '@', it's a DCL indirection
5064 * - if verb contains a filespec separator, it's not a DCL command
5065 * - if it doesn't, caller tells us whether to default to a DCL
5066 * command, or to a local image unless told it's DCL (by leading '$')
5070 if (suggest_quote) *suggest_quote = 1;
5072 register char *filespec = strpbrk(s,":<[.;");
5073 rest = wordbreak = strpbrk(s," \"\t/");
5074 if (!wordbreak) wordbreak = s + strlen(s);
5075 if (*s == '$') check_img = 0;
5076 if (filespec && (filespec < wordbreak)) isdcl = 0;
5077 else isdcl = !check_img;
5081 imgdsc.dsc$a_pointer = s;
5082 imgdsc.dsc$w_length = wordbreak - s;
5083 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5085 _ckvmssts(lib$find_file_end(&cxt));
5086 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5087 if (!(retsts & 1) && *s == '$') {
5088 _ckvmssts(lib$find_file_end(&cxt));
5089 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5090 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5092 _ckvmssts(lib$find_file_end(&cxt));
5093 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5097 _ckvmssts(lib$find_file_end(&cxt));
5102 while (*s && !isspace(*s)) s++;
5105 /* check that it's really not DCL with no file extension */
5106 fp = fopen(resspec,"r","ctx=bin,shr=get");
5108 char b[4] = {0,0,0,0};
5109 read(fileno(fp),b,4);
5110 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5113 if (check_img && isdcl) return RMS$_FNF;
5115 if (cando_by_name(S_IXUSR,0,resspec)) {
5116 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5118 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5119 if (suggest_quote) *suggest_quote = 1;
5121 strcpy(vmscmd->dsc$a_pointer,"@");
5122 if (suggest_quote) *suggest_quote = 1;
5124 strcat(vmscmd->dsc$a_pointer,resspec);
5125 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5126 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5127 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5129 else retsts = RMS$_PRV;
5132 /* It's either a DCL command or we couldn't find a suitable image */
5133 vmscmd->dsc$w_length = strlen(cmd);
5134 /* if (cmd == PL_Cmd) {
5135 vmscmd->dsc$a_pointer = PL_Cmd;
5136 if (suggest_quote) *suggest_quote = 1;
5139 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5141 /* check if it's a symbol (for quoting purposes) */
5142 if (suggest_quote && !*suggest_quote) {
5144 char equiv[LNM$C_NAMLENGTH];
5145 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5146 eqvdsc.dsc$a_pointer = equiv;
5148 iss = lib$get_symbol(vmscmd,&eqvdsc);
5149 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5151 if (!(retsts & 1)) {
5152 /* just hand off status values likely to be due to user error */
5153 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5154 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5155 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5156 else { _ckvmssts(retsts); }
5159 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5161 } /* end of setup_cmddsc() */
5164 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5166 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5169 if (vfork_called) { /* this follows a vfork - act Unixish */
5171 if (vfork_called < 0) {
5172 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5175 else return do_aexec(really,mark,sp);
5177 /* no vfork - act VMSish */
5178 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5183 } /* end of vms_do_aexec() */
5186 /* {{{bool vms_do_exec(char *cmd) */
5188 Perl_vms_do_exec(pTHX_ char *cmd)
5190 struct dsc$descriptor_s *vmscmd;
5192 if (vfork_called) { /* this follows a vfork - act Unixish */
5194 if (vfork_called < 0) {
5195 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5198 else return do_exec(cmd);
5201 { /* no vfork - act VMSish */
5202 unsigned long int retsts;
5205 TAINT_PROPER("exec");
5206 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5207 retsts = lib$do_command(vmscmd);
5210 case RMS$_FNF: case RMS$_DNF:
5211 set_errno(ENOENT); break;
5213 set_errno(ENOTDIR); break;
5215 set_errno(ENODEV); break;
5217 set_errno(EACCES); break;
5219 set_errno(EINVAL); break;
5220 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5221 set_errno(E2BIG); break;
5222 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5223 _ckvmssts(retsts); /* fall through */
5224 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5227 set_vaxc_errno(retsts);
5228 if (ckWARN(WARN_EXEC)) {
5229 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5230 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5232 vms_execfree(vmscmd);
5237 } /* end of vms_do_exec() */
5240 unsigned long int Perl_do_spawn(pTHX_ char *);
5242 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5244 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5246 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5249 } /* end of do_aspawn() */
5252 /* {{{unsigned long int do_spawn(char *cmd) */
5254 Perl_do_spawn(pTHX_ char *cmd)
5256 unsigned long int sts, substs;
5259 TAINT_PROPER("spawn");
5260 if (!cmd || !*cmd) {
5261 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5264 case RMS$_FNF: case RMS$_DNF:
5265 set_errno(ENOENT); break;
5267 set_errno(ENOTDIR); break;
5269 set_errno(ENODEV); break;
5271 set_errno(EACCES); break;
5273 set_errno(EINVAL); break;
5274 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5275 set_errno(E2BIG); break;
5276 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5277 _ckvmssts(sts); /* fall through */
5278 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5281 set_vaxc_errno(sts);
5282 if (ckWARN(WARN_EXEC)) {
5283 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5290 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5293 } /* end of do_spawn() */
5297 static unsigned int *sockflags, sockflagsize;
5300 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5301 * routines found in some versions of the CRTL can't deal with sockets.
5302 * We don't shim the other file open routines since a socket isn't
5303 * likely to be opened by a name.
5305 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5306 FILE *my_fdopen(int fd, const char *mode)
5308 FILE *fp = fdopen(fd, (char *) mode);
5311 unsigned int fdoff = fd / sizeof(unsigned int);
5312 struct stat sbuf; /* native stat; we don't need flex_stat */
5313 if (!sockflagsize || fdoff > sockflagsize) {
5314 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5315 else New (1324,sockflags,fdoff+2,unsigned int);
5316 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5317 sockflagsize = fdoff + 2;
5319 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5320 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5329 * Clear the corresponding bit when the (possibly) socket stream is closed.
5330 * There still a small hole: we miss an implicit close which might occur
5331 * via freopen(). >> Todo
5333 /*{{{ int my_fclose(FILE *fp)*/
5334 int my_fclose(FILE *fp) {
5336 unsigned int fd = fileno(fp);
5337 unsigned int fdoff = fd / sizeof(unsigned int);
5339 if (sockflagsize && fdoff <= sockflagsize)
5340 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5348 * A simple fwrite replacement which outputs itmsz*nitm chars without
5349 * introducing record boundaries every itmsz chars.
5350 * We are using fputs, which depends on a terminating null. We may
5351 * well be writing binary data, so we need to accommodate not only
5352 * data with nulls sprinkled in the middle but also data with no null
5355 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5357 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5359 register char *cp, *end, *cpd, *data;
5360 register unsigned int fd = fileno(dest);
5361 register unsigned int fdoff = fd / sizeof(unsigned int);
5363 int bufsize = itmsz * nitm + 1;
5365 if (fdoff < sockflagsize &&
5366 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5367 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5371 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5372 memcpy( data, src, itmsz*nitm );
5373 data[itmsz*nitm] = '\0';
5375 end = data + itmsz * nitm;
5376 retval = (int) nitm; /* on success return # items written */
5379 while (cpd <= end) {
5380 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5381 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5383 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5387 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5390 } /* end of my_fwrite() */
5393 /*{{{ int my_flush(FILE *fp)*/
5395 Perl_my_flush(pTHX_ FILE *fp)
5398 if ((res = fflush(fp)) == 0 && fp) {
5399 #ifdef VMS_DO_SOCKETS
5401 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5403 res = fsync(fileno(fp));
5406 * If the flush succeeded but set end-of-file, we need to clear
5407 * the error because our caller may check ferror(). BTW, this
5408 * probably means we just flushed an empty file.
5410 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5417 * Here are replacements for the following Unix routines in the VMS environment:
5418 * getpwuid Get information for a particular UIC or UID
5419 * getpwnam Get information for a named user
5420 * getpwent Get information for each user in the rights database
5421 * setpwent Reset search to the start of the rights database
5422 * endpwent Finish searching for users in the rights database
5424 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5425 * (defined in pwd.h), which contains the following fields:-
5427 * char *pw_name; Username (in lower case)
5428 * char *pw_passwd; Hashed password
5429 * unsigned int pw_uid; UIC
5430 * unsigned int pw_gid; UIC group number
5431 * char *pw_unixdir; Default device/directory (VMS-style)
5432 * char *pw_gecos; Owner name
5433 * char *pw_dir; Default device/directory (Unix-style)
5434 * char *pw_shell; Default CLI name (eg. DCL)
5436 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5438 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5439 * not the UIC member number (eg. what's returned by getuid()),
5440 * getpwuid() can accept either as input (if uid is specified, the caller's
5441 * UIC group is used), though it won't recognise gid=0.
5443 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5444 * information about other users in your group or in other groups, respectively.
5445 * If the required privilege is not available, then these routines fill only
5446 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5449 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5452 /* sizes of various UAF record fields */
5453 #define UAI$S_USERNAME 12
5454 #define UAI$S_IDENT 31
5455 #define UAI$S_OWNER 31
5456 #define UAI$S_DEFDEV 31
5457 #define UAI$S_DEFDIR 63
5458 #define UAI$S_DEFCLI 31
5461 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5462 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5463 (uic).uic$v_group != UIC$K_WILD_GROUP)
5465 static char __empty[]= "";
5466 static struct passwd __passwd_empty=
5467 {(char *) __empty, (char *) __empty, 0, 0,
5468 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5469 static int contxt= 0;
5470 static struct passwd __pwdcache;
5471 static char __pw_namecache[UAI$S_IDENT+1];
5474 * This routine does most of the work extracting the user information.
5476 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5479 unsigned char length;
5480 char pw_gecos[UAI$S_OWNER+1];
5482 static union uicdef uic;
5484 unsigned char length;
5485 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5488 unsigned char length;
5489 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5492 unsigned char length;
5493 char pw_shell[UAI$S_DEFCLI+1];
5495 static char pw_passwd[UAI$S_PWD+1];
5497 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5498 struct dsc$descriptor_s name_desc;
5499 unsigned long int sts;
5501 static struct itmlst_3 itmlst[]= {
5502 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5503 {sizeof(uic), UAI$_UIC, &uic, &luic},
5504 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5505 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5506 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5507 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5508 {0, 0, NULL, NULL}};
5510 name_desc.dsc$w_length= strlen(name);
5511 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5512 name_desc.dsc$b_class= DSC$K_CLASS_S;
5513 name_desc.dsc$a_pointer= (char *) name;
5515 /* Note that sys$getuai returns many fields as counted strings. */
5516 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5517 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5518 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5520 else { _ckvmssts(sts); }
5521 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5523 if ((int) owner.length < lowner) lowner= (int) owner.length;
5524 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5525 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5526 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5527 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5528 owner.pw_gecos[lowner]= '\0';
5529 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5530 defcli.pw_shell[ldefcli]= '\0';
5531 if (valid_uic(uic)) {
5532 pwd->pw_uid= uic.uic$l_uic;
5533 pwd->pw_gid= uic.uic$v_group;
5536 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5537 pwd->pw_passwd= pw_passwd;
5538 pwd->pw_gecos= owner.pw_gecos;
5539 pwd->pw_dir= defdev.pw_dir;
5540 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5541 pwd->pw_shell= defcli.pw_shell;
5542 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5544 ldir= strlen(pwd->pw_unixdir) - 1;
5545 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5548 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5549 __mystrtolower(pwd->pw_unixdir);
5554 * Get information for a named user.
5556 /*{{{struct passwd *getpwnam(char *name)*/
5557 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5559 struct dsc$descriptor_s name_desc;
5561 unsigned long int status, sts;
5563 __pwdcache = __passwd_empty;
5564 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5565 /* We still may be able to determine pw_uid and pw_gid */
5566 name_desc.dsc$w_length= strlen(name);
5567 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5568 name_desc.dsc$b_class= DSC$K_CLASS_S;
5569 name_desc.dsc$a_pointer= (char *) name;
5570 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5571 __pwdcache.pw_uid= uic.uic$l_uic;
5572 __pwdcache.pw_gid= uic.uic$v_group;
5575 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5576 set_vaxc_errno(sts);
5577 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5580 else { _ckvmssts(sts); }
5583 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5584 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5585 __pwdcache.pw_name= __pw_namecache;
5587 } /* end of my_getpwnam() */
5591 * Get information for a particular UIC or UID.
5592 * Called by my_getpwent with uid=-1 to list all users.
5594 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5595 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5597 const $DESCRIPTOR(name_desc,__pw_namecache);
5598 unsigned short lname;
5600 unsigned long int status;
5602 if (uid == (unsigned int) -1) {
5604 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5605 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5606 set_vaxc_errno(status);
5607 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5611 else { _ckvmssts(status); }
5612 } while (!valid_uic (uic));
5616 if (!uic.uic$v_group)
5617 uic.uic$v_group= PerlProc_getgid();
5619 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5620 else status = SS$_IVIDENT;
5621 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5622 status == RMS$_PRV) {
5623 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5626 else { _ckvmssts(status); }
5628 __pw_namecache[lname]= '\0';
5629 __mystrtolower(__pw_namecache);
5631 __pwdcache = __passwd_empty;
5632 __pwdcache.pw_name = __pw_namecache;
5634 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5635 The identifier's value is usually the UIC, but it doesn't have to be,
5636 so if we can, we let fillpasswd update this. */
5637 __pwdcache.pw_uid = uic.uic$l_uic;
5638 __pwdcache.pw_gid = uic.uic$v_group;
5640 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5643 } /* end of my_getpwuid() */
5647 * Get information for next user.
5649 /*{{{struct passwd *my_getpwent()*/
5650 struct passwd *Perl_my_getpwent(pTHX)
5652 return (my_getpwuid((unsigned int) -1));
5657 * Finish searching rights database for users.
5659 /*{{{void my_endpwent()*/
5660 void Perl_my_endpwent(pTHX)
5663 _ckvmssts(sys$finish_rdb(&contxt));
5669 #ifdef HOMEGROWN_POSIX_SIGNALS
5670 /* Signal handling routines, pulled into the core from POSIX.xs.
5672 * We need these for threads, so they've been rolled into the core,
5673 * rather than left in POSIX.xs.
5675 * (DRS, Oct 23, 1997)
5678 /* sigset_t is atomic under VMS, so these routines are easy */
5679 /*{{{int my_sigemptyset(sigset_t *) */
5680 int my_sigemptyset(sigset_t *set) {
5681 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5687 /*{{{int my_sigfillset(sigset_t *)*/
5688 int my_sigfillset(sigset_t *set) {
5690 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5691 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5697 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5698 int my_sigaddset(sigset_t *set, int sig) {
5699 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5700 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5701 *set |= (1 << (sig - 1));
5707 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5708 int my_sigdelset(sigset_t *set, int sig) {
5709 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5710 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5711 *set &= ~(1 << (sig - 1));
5717 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5718 int my_sigismember(sigset_t *set, int sig) {
5719 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5720 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5721 return *set & (1 << (sig - 1));
5726 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5727 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5730 /* If set and oset are both null, then things are badly wrong. Bail out. */
5731 if ((oset == NULL) && (set == NULL)) {
5732 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5736 /* If set's null, then we're just handling a fetch. */
5738 tempmask = sigblock(0);
5743 tempmask = sigsetmask(*set);
5746 tempmask = sigblock(*set);
5749 tempmask = sigblock(0);
5750 sigsetmask(*oset & ~tempmask);
5753 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5758 /* Did they pass us an oset? If so, stick our holding mask into it */
5765 #endif /* HOMEGROWN_POSIX_SIGNALS */
5768 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5769 * my_utime(), and flex_stat(), all of which operate on UTC unless
5770 * VMSISH_TIMES is true.
5772 /* method used to handle UTC conversions:
5773 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5775 static int gmtime_emulation_type;
5776 /* number of secs to add to UTC POSIX-style time to get local time */
5777 static long int utc_offset_secs;
5779 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5780 * in vmsish.h. #undef them here so we can call the CRTL routines
5789 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5790 * qualifier with the extern prefix pragma. This provisional
5791 * hack circumvents this prefix pragma problem in previous
5794 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5795 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5796 # pragma __extern_prefix save
5797 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5798 # define gmtime decc$__utctz_gmtime
5799 # define localtime decc$__utctz_localtime
5800 # define time decc$__utc_time
5801 # pragma __extern_prefix restore
5803 struct tm *gmtime(), *localtime();
5809 static time_t toutc_dst(time_t loc) {
5812 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5813 loc -= utc_offset_secs;
5814 if (rsltmp->tm_isdst) loc -= 3600;
5817 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5818 ((gmtime_emulation_type || my_time(NULL)), \
5819 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5820 ((secs) - utc_offset_secs))))
5822 static time_t toloc_dst(time_t utc) {
5825 utc += utc_offset_secs;
5826 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5827 if (rsltmp->tm_isdst) utc += 3600;
5830 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5831 ((gmtime_emulation_type || my_time(NULL)), \
5832 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5833 ((secs) + utc_offset_secs))))
5835 #ifndef RTL_USES_UTC
5838 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5839 DST starts on 1st sun of april at 02:00 std time
5840 ends on last sun of october at 02:00 dst time
5841 see the UCX management command reference, SET CONFIG TIMEZONE
5842 for formatting info.
5844 No, it's not as general as it should be, but then again, NOTHING
5845 will handle UK times in a sensible way.
5850 parse the DST start/end info:
5851 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5855 tz_parse_startend(char *s, struct tm *w, int *past)
5857 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5858 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5863 if (!past) return 0;
5866 if (w->tm_year % 4 == 0) ly = 1;
5867 if (w->tm_year % 100 == 0) ly = 0;
5868 if (w->tm_year+1900 % 400 == 0) ly = 1;
5871 dozjd = isdigit(*s);
5872 if (*s == 'J' || *s == 'j' || dozjd) {
5873 if (!dozjd && !isdigit(*++s)) return 0;
5876 d = d*10 + *s++ - '0';
5878 d = d*10 + *s++ - '0';
5881 if (d == 0) return 0;
5882 if (d > 366) return 0;
5884 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5887 } else if (*s == 'M' || *s == 'm') {
5888 if (!isdigit(*++s)) return 0;
5890 if (isdigit(*s)) m = 10*m + *s++ - '0';
5891 if (*s != '.') return 0;
5892 if (!isdigit(*++s)) return 0;
5894 if (n < 1 || n > 5) return 0;
5895 if (*s != '.') return 0;
5896 if (!isdigit(*++s)) return 0;
5898 if (d > 6) return 0;
5902 if (!isdigit(*++s)) return 0;
5904 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5906 if (!isdigit(*++s)) return 0;
5908 if (isdigit(*s)) min = 10*min + *s++ - '0';
5910 if (!isdigit(*++s)) return 0;
5912 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5922 if (w->tm_yday < d) goto before;
5923 if (w->tm_yday > d) goto after;
5925 if (w->tm_mon+1 < m) goto before;
5926 if (w->tm_mon+1 > m) goto after;
5928 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5929 k = d - j; /* mday of first d */
5931 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5932 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5933 if (w->tm_mday < k) goto before;
5934 if (w->tm_mday > k) goto after;
5937 if (w->tm_hour < hour) goto before;
5938 if (w->tm_hour > hour) goto after;
5939 if (w->tm_min < min) goto before;
5940 if (w->tm_min > min) goto after;
5941 if (w->tm_sec < sec) goto before;
5955 /* parse the offset: (+|-)hh[:mm[:ss]] */
5958 tz_parse_offset(char *s, int *offset)
5960 int hour = 0, min = 0, sec = 0;
5963 if (!offset) return 0;
5965 if (*s == '-') {neg++; s++;}
5967 if (!isdigit(*s)) return 0;
5969 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5970 if (hour > 24) return 0;
5972 if (!isdigit(*++s)) return 0;
5974 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5975 if (min > 59) return 0;
5977 if (!isdigit(*++s)) return 0;
5979 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5980 if (sec > 59) return 0;
5984 *offset = (hour*60+min)*60 + sec;
5985 if (neg) *offset = -*offset;
5990 input time is w, whatever type of time the CRTL localtime() uses.
5991 sets dst, the zone, and the gmtoff (seconds)
5993 caches the value of TZ and UCX$TZ env variables; note that
5994 my_setenv looks for these and sets a flag if they're changed
5997 We have to watch out for the "australian" case (dst starts in
5998 october, ends in april)...flagged by "reverse" and checked by
5999 scanning through the months of the previous year.
6004 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
6009 char *dstzone, *tz, *s_start, *s_end;
6010 int std_off, dst_off, isdst;
6011 int y, dststart, dstend;
6012 static char envtz[1025]; /* longer than any logical, symbol, ... */
6013 static char ucxtz[1025];
6014 static char reversed = 0;
6020 reversed = -1; /* flag need to check */
6021 envtz[0] = ucxtz[0] = '\0';
6022 tz = my_getenv("TZ",0);
6023 if (tz) strcpy(envtz, tz);
6024 tz = my_getenv("UCX$TZ",0);
6025 if (tz) strcpy(ucxtz, tz);
6026 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6029 if (!*tz) tz = ucxtz;
6032 while (isalpha(*s)) s++;
6033 s = tz_parse_offset(s, &std_off);
6035 if (!*s) { /* no DST, hurray we're done! */
6041 while (isalpha(*s)) s++;
6042 s2 = tz_parse_offset(s, &dst_off);
6046 dst_off = std_off - 3600;
6049 if (!*s) { /* default dst start/end?? */
6050 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6051 s = strchr(ucxtz,',');
6053 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6055 if (*s != ',') return 0;
6058 when = _toutc(when); /* convert to utc */
6059 when = when - std_off; /* convert to pseudolocal time*/
6061 w2 = localtime(&when);
6064 s = tz_parse_startend(s_start,w2,&dststart);
6066 if (*s != ',') return 0;
6069 when = _toutc(when); /* convert to utc */
6070 when = when - dst_off; /* convert to pseudolocal time*/
6071 w2 = localtime(&when);
6072 if (w2->tm_year != y) { /* spans a year, just check one time */
6073 when += dst_off - std_off;
6074 w2 = localtime(&when);
6077 s = tz_parse_startend(s_end,w2,&dstend);
6080 if (reversed == -1) { /* need to check if start later than end */
6084 if (when < 2*365*86400) {
6085 when += 2*365*86400;
6089 w2 =localtime(&when);
6090 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6092 for (j = 0; j < 12; j++) {
6093 w2 =localtime(&when);
6094 (void) tz_parse_startend(s_start,w2,&ds);
6095 (void) tz_parse_startend(s_end,w2,&de);
6096 if (ds != de) break;
6100 if (de && !ds) reversed = 1;
6103 isdst = dststart && !dstend;
6104 if (reversed) isdst = dststart || !dstend;
6107 if (dst) *dst = isdst;
6108 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6109 if (isdst) tz = dstzone;
6111 while(isalpha(*tz)) *zone++ = *tz++;
6117 #endif /* !RTL_USES_UTC */
6119 /* my_time(), my_localtime(), my_gmtime()
6120 * By default traffic in UTC time values, using CRTL gmtime() or
6121 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6122 * Note: We need to use these functions even when the CRTL has working
6123 * UTC support, since they also handle C<use vmsish qw(times);>
6125 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6126 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6129 /*{{{time_t my_time(time_t *timep)*/
6130 time_t Perl_my_time(pTHX_ time_t *timep)
6135 if (gmtime_emulation_type == 0) {
6137 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6138 /* results of calls to gmtime() and localtime() */
6139 /* for same &base */
6141 gmtime_emulation_type++;
6142 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6143 char off[LNM$C_NAMLENGTH+1];;
6145 gmtime_emulation_type++;
6146 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6147 gmtime_emulation_type++;
6148 utc_offset_secs = 0;
6149 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6151 else { utc_offset_secs = atol(off); }
6153 else { /* We've got a working gmtime() */
6154 struct tm gmt, local;
6157 tm_p = localtime(&base);
6159 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6160 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6161 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6162 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6168 # ifdef RTL_USES_UTC
6169 if (VMSISH_TIME) when = _toloc(when);
6171 if (!VMSISH_TIME) when = _toutc(when);
6174 if (timep != NULL) *timep = when;
6177 } /* end of my_time() */
6181 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6183 Perl_my_gmtime(pTHX_ const time_t *timep)
6189 if (timep == NULL) {
6190 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6193 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6197 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6199 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6200 return gmtime(&when);
6202 /* CRTL localtime() wants local time as input, so does no tz correction */
6203 rsltmp = localtime(&when);
6204 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6207 } /* end of my_gmtime() */
6211 /*{{{struct tm *my_localtime(const time_t *timep)*/
6213 Perl_my_localtime(pTHX_ const time_t *timep)
6215 time_t when, whenutc;
6219 if (timep == NULL) {
6220 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6223 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6224 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6227 # ifdef RTL_USES_UTC
6229 if (VMSISH_TIME) when = _toutc(when);
6231 /* CRTL localtime() wants UTC as input, does tz correction itself */
6232 return localtime(&when);
6234 # else /* !RTL_USES_UTC */
6237 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6238 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6241 #ifndef RTL_USES_UTC
6242 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6243 when = whenutc - offset; /* pseudolocal time*/
6246 /* CRTL localtime() wants local time as input, so does no tz correction */
6247 rsltmp = localtime(&when);
6248 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6252 } /* end of my_localtime() */
6255 /* Reset definitions for later calls */
6256 #define gmtime(t) my_gmtime(t)
6257 #define localtime(t) my_localtime(t)
6258 #define time(t) my_time(t)
6261 /* my_utime - update modification time of a file
6262 * calling sequence is identical to POSIX utime(), but under
6263 * VMS only the modification time is changed; ODS-2 does not
6264 * maintain access times. Restrictions differ from the POSIX
6265 * definition in that the time can be changed as long as the
6266 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6267 * no separate checks are made to insure that the caller is the
6268 * owner of the file or has special privs enabled.
6269 * Code here is based on Joe Meadows' FILE utility.
6272 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6273 * to VMS epoch (01-JAN-1858 00:00:00.00)
6274 * in 100 ns intervals.
6276 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6278 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6279 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6282 long int bintime[2], len = 2, lowbit, unixtime,
6283 secscale = 10000000; /* seconds --> 100 ns intervals */
6284 unsigned long int chan, iosb[2], retsts;
6285 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6286 struct FAB myfab = cc$rms_fab;
6287 struct NAM mynam = cc$rms_nam;
6288 #if defined (__DECC) && defined (__VAX)
6289 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6290 * at least through VMS V6.1, which causes a type-conversion warning.
6292 # pragma message save
6293 # pragma message disable cvtdiftypes
6295 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6296 struct fibdef myfib;
6297 #if defined (__DECC) && defined (__VAX)
6298 /* This should be right after the declaration of myatr, but due
6299 * to a bug in VAX DEC C, this takes effect a statement early.
6301 # pragma message restore
6303 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6304 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6305 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6307 if (file == NULL || *file == '\0') {
6309 set_vaxc_errno(LIB$_INVARG);
6312 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6314 if (utimes != NULL) {
6315 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6316 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6317 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6318 * as input, we force the sign bit to be clear by shifting unixtime right
6319 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6321 lowbit = (utimes->modtime & 1) ? secscale : 0;
6322 unixtime = (long int) utimes->modtime;
6324 /* If input was UTC; convert to local for sys svc */
6325 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6327 unixtime >>= 1; secscale <<= 1;
6328 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6329 if (!(retsts & 1)) {
6331 set_vaxc_errno(retsts);
6334 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6335 if (!(retsts & 1)) {
6337 set_vaxc_errno(retsts);
6342 /* Just get the current time in VMS format directly */
6343 retsts = sys$gettim(bintime);
6344 if (!(retsts & 1)) {
6346 set_vaxc_errno(retsts);
6351 myfab.fab$l_fna = vmsspec;
6352 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6353 myfab.fab$l_nam = &mynam;
6354 mynam.nam$l_esa = esa;
6355 mynam.nam$b_ess = (unsigned char) sizeof esa;
6356 mynam.nam$l_rsa = rsa;
6357 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6359 /* Look for the file to be affected, letting RMS parse the file
6360 * specification for us as well. I have set errno using only
6361 * values documented in the utime() man page for VMS POSIX.
6363 retsts = sys$parse(&myfab,0,0);
6364 if (!(retsts & 1)) {
6365 set_vaxc_errno(retsts);
6366 if (retsts == RMS$_PRV) set_errno(EACCES);
6367 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6368 else set_errno(EVMSERR);
6371 retsts = sys$search(&myfab,0,0);
6372 if (!(retsts & 1)) {
6373 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6374 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6375 set_vaxc_errno(retsts);
6376 if (retsts == RMS$_PRV) set_errno(EACCES);
6377 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6378 else set_errno(EVMSERR);
6382 devdsc.dsc$w_length = mynam.nam$b_dev;
6383 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6385 retsts = sys$assign(&devdsc,&chan,0,0);
6386 if (!(retsts & 1)) {
6387 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6388 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6389 set_vaxc_errno(retsts);
6390 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6391 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6392 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6393 else set_errno(EVMSERR);
6397 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6398 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6400 memset((void *) &myfib, 0, sizeof myfib);
6401 #if defined(__DECC) || defined(__DECCXX)
6402 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6403 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6404 /* This prevents the revision time of the file being reset to the current
6405 * time as a result of our IO$_MODIFY $QIO. */
6406 myfib.fib$l_acctl = FIB$M_NORECORD;
6408 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6409 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6410 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6412 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6413 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6414 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6415 _ckvmssts(sys$dassgn(chan));
6416 if (retsts & 1) retsts = iosb[0];
6417 if (!(retsts & 1)) {
6418 set_vaxc_errno(retsts);
6419 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6420 else set_errno(EVMSERR);
6425 } /* end of my_utime() */
6429 * flex_stat, flex_fstat
6430 * basic stat, but gets it right when asked to stat
6431 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6434 /* encode_dev packs a VMS device name string into an integer to allow
6435 * simple comparisons. This can be used, for example, to check whether two
6436 * files are located on the same device, by comparing their encoded device
6437 * names. Even a string comparison would not do, because stat() reuses the
6438 * device name buffer for each call; so without encode_dev, it would be
6439 * necessary to save the buffer and use strcmp (this would mean a number of
6440 * changes to the standard Perl code, to say nothing of what a Perl script
6443 * The device lock id, if it exists, should be unique (unless perhaps compared
6444 * with lock ids transferred from other nodes). We have a lock id if the disk is
6445 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6446 * device names. Thus we use the lock id in preference, and only if that isn't
6447 * available, do we try to pack the device name into an integer (flagged by
6448 * the sign bit (LOCKID_MASK) being set).
6450 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6451 * name and its encoded form, but it seems very unlikely that we will find
6452 * two files on different disks that share the same encoded device names,
6453 * and even more remote that they will share the same file id (if the test
6454 * is to check for the same file).
6456 * A better method might be to use sys$device_scan on the first call, and to
6457 * search for the device, returning an index into the cached array.
6458 * The number returned would be more intelligable.
6459 * This is probably not worth it, and anyway would take quite a bit longer
6460 * on the first call.
6462 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6463 static mydev_t encode_dev (pTHX_ const char *dev)
6466 unsigned long int f;
6471 if (!dev || !dev[0]) return 0;
6475 struct dsc$descriptor_s dev_desc;
6476 unsigned long int status, lockid, item = DVI$_LOCKID;
6478 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6479 can try that first. */
6480 dev_desc.dsc$w_length = strlen (dev);
6481 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6482 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6483 dev_desc.dsc$a_pointer = (char *) dev;
6484 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6485 if (lockid) return (lockid & ~LOCKID_MASK);
6489 /* Otherwise we try to encode the device name */
6493 for (q = dev + strlen(dev); q--; q >= dev) {
6496 else if (isalpha (toupper (*q)))
6497 c= toupper (*q) - 'A' + (char)10;
6499 continue; /* Skip '$'s */
6501 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6503 enc += f * (unsigned long int) c;
6505 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6507 } /* end of encode_dev() */
6509 static char namecache[NAM$C_MAXRSS+1];
6512 is_null_device(name)
6515 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6516 The underscore prefix, controller letter, and unit number are
6517 independently optional; for our purposes, the colon punctuation
6518 is not. The colon can be trailed by optional directory and/or
6519 filename, but two consecutive colons indicates a nodename rather
6520 than a device. [pr] */
6521 if (*name == '_') ++name;
6522 if (tolower(*name++) != 'n') return 0;
6523 if (tolower(*name++) != 'l') return 0;
6524 if (tolower(*name) == 'a') ++name;
6525 if (*name == '0') ++name;
6526 return (*name++ == ':') && (*name != ':');
6529 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6530 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6531 * subset of the applicable information.
6534 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6536 char fname_phdev[NAM$C_MAXRSS+1];
6537 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6539 char fname[NAM$C_MAXRSS+1];
6540 unsigned long int retsts;
6541 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6542 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6544 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6545 device name on successive calls */
6546 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6547 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6548 namdsc.dsc$a_pointer = fname;
6549 namdsc.dsc$w_length = sizeof fname - 1;
6551 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6552 &namdsc,&namdsc.dsc$w_length,0,0);
6554 fname[namdsc.dsc$w_length] = '\0';
6556 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6557 * but if someone has redefined that logical, Perl gets very lost. Since
6558 * we have the physical device name from the stat buffer, just paste it on.
6560 strcpy( fname_phdev, statbufp->st_devnam );
6561 strcat( fname_phdev, strrchr(fname, ':') );
6563 return cando_by_name(bit,effective,fname_phdev);
6565 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6566 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6570 return FALSE; /* Should never get to here */
6572 } /* end of cando() */
6576 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6578 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6580 static char usrname[L_cuserid];
6581 static struct dsc$descriptor_s usrdsc =
6582 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6583 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6584 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6585 unsigned short int retlen;
6586 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6587 union prvdef curprv;
6588 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6589 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6590 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6591 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6593 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6595 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6597 if (!fname || !*fname) return FALSE;
6598 /* Make sure we expand logical names, since sys$check_access doesn't */
6599 if (!strpbrk(fname,"/]>:")) {
6600 strcpy(fileified,fname);
6601 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6604 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6605 retlen = namdsc.dsc$w_length = strlen(vmsname);
6606 namdsc.dsc$a_pointer = vmsname;
6607 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6608 vmsname[retlen-1] == ':') {
6609 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6610 namdsc.dsc$w_length = strlen(fileified);
6611 namdsc.dsc$a_pointer = fileified;
6615 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6616 access = ARM$M_EXECUTE; break;
6617 case S_IRUSR: case S_IRGRP: case S_IROTH:
6618 access = ARM$M_READ; break;
6619 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6620 access = ARM$M_WRITE; break;
6621 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6622 access = ARM$M_DELETE; break;
6627 /* Before we call $check_access, create a user profile with the current
6628 * process privs since otherwise it just uses the default privs from the
6629 * UAF and might give false positives or negatives.
6632 /* get current process privs and username */
6633 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6636 /* find out the space required for the profile */
6637 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6638 &usrprodsc.dsc$w_length,0));
6640 /* allocate space for the profile and get it filled in */
6641 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6642 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6643 &usrprodsc.dsc$w_length,0));
6645 /* use the profile to check access to the file; free profile & analyze results */
6646 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6647 Safefree(usrprodsc.dsc$a_pointer);
6648 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6649 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6650 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6651 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6652 set_vaxc_errno(retsts);
6653 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6654 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6655 else set_errno(ENOENT);
6658 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6663 return FALSE; /* Should never get here */
6665 } /* end of cando_by_name() */
6669 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6671 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6673 if (!fstat(fd,(stat_t *) statbufp)) {
6674 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6675 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6676 # ifdef RTL_USES_UTC
6679 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6680 statbufp->st_atime = _toloc(statbufp->st_atime);
6681 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6686 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6690 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6691 statbufp->st_atime = _toutc(statbufp->st_atime);
6692 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6699 } /* end of flex_fstat() */
6702 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6704 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6706 char fileified[NAM$C_MAXRSS+1];
6707 char temp_fspec[NAM$C_MAXRSS+300];
6710 if (!fspec) return retval;
6711 strcpy(temp_fspec, fspec);
6712 if (statbufp == (Stat_t *) &PL_statcache)
6713 do_tovmsspec(temp_fspec,namecache,0);
6714 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6715 memset(statbufp,0,sizeof *statbufp);
6716 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6717 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6718 statbufp->st_uid = 0x00010001;
6719 statbufp->st_gid = 0x0001;
6720 time((time_t *)&statbufp->st_mtime);
6721 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6725 /* Try for a directory name first. If fspec contains a filename without
6726 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6727 * and sea:[wine.dark]water. exist, we prefer the directory here.
6728 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6729 * not sea:[wine.dark]., if the latter exists. If the intended target is
6730 * the file with null type, specify this by calling flex_stat() with
6731 * a '.' at the end of fspec.
6733 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6734 retval = stat(fileified,(stat_t *) statbufp);
6735 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6736 strcpy(namecache,fileified);
6738 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6740 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6741 # ifdef RTL_USES_UTC
6744 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6745 statbufp->st_atime = _toloc(statbufp->st_atime);
6746 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6751 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6755 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6756 statbufp->st_atime = _toutc(statbufp->st_atime);
6757 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6763 } /* end of flex_stat() */
6767 /*{{{char *my_getlogin()*/
6768 /* VMS cuserid == Unix getlogin, except calling sequence */
6772 static char user[L_cuserid];
6773 return cuserid(user);
6778 /* rmscopy - copy a file using VMS RMS routines
6780 * Copies contents and attributes of spec_in to spec_out, except owner
6781 * and protection information. Name and type of spec_in are used as
6782 * defaults for spec_out. The third parameter specifies whether rmscopy()
6783 * should try to propagate timestamps from the input file to the output file.
6784 * If it is less than 0, no timestamps are preserved. If it is 0, then
6785 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6786 * propagated to the output file at creation iff the output file specification
6787 * did not contain an explicit name or type, and the revision date is always
6788 * updated at the end of the copy operation. If it is greater than 0, then
6789 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6790 * other than the revision date should be propagated, and bit 1 indicates
6791 * that the revision date should be propagated.
6793 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6795 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6796 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6797 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6798 * as part of the Perl standard distribution under the terms of the
6799 * GNU General Public License or the Perl Artistic License. Copies
6800 * of each may be found in the Perl standard distribution.
6802 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6804 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6806 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6807 rsa[NAM$C_MAXRSS], ubf[32256];
6808 unsigned long int i, sts, sts2;
6809 struct FAB fab_in, fab_out;
6810 struct RAB rab_in, rab_out;
6812 struct XABDAT xabdat;
6813 struct XABFHC xabfhc;
6814 struct XABRDT xabrdt;
6815 struct XABSUM xabsum;
6817 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6818 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6819 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6823 fab_in = cc$rms_fab;
6824 fab_in.fab$l_fna = vmsin;
6825 fab_in.fab$b_fns = strlen(vmsin);
6826 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6827 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6828 fab_in.fab$l_fop = FAB$M_SQO;
6829 fab_in.fab$l_nam = &nam;
6830 fab_in.fab$l_xab = (void *) &xabdat;
6833 nam.nam$l_rsa = rsa;
6834 nam.nam$b_rss = sizeof(rsa);
6835 nam.nam$l_esa = esa;
6836 nam.nam$b_ess = sizeof (esa);
6837 nam.nam$b_esl = nam.nam$b_rsl = 0;
6839 xabdat = cc$rms_xabdat; /* To get creation date */
6840 xabdat.xab$l_nxt = (void *) &xabfhc;
6842 xabfhc = cc$rms_xabfhc; /* To get record length */
6843 xabfhc.xab$l_nxt = (void *) &xabsum;
6845 xabsum = cc$rms_xabsum; /* To get key and area information */
6847 if (!((sts = sys$open(&fab_in)) & 1)) {
6848 set_vaxc_errno(sts);
6850 case RMS$_FNF: case RMS$_DNF:
6851 set_errno(ENOENT); break;
6853 set_errno(ENOTDIR); break;
6855 set_errno(ENODEV); break;
6857 set_errno(EINVAL); break;
6859 set_errno(EACCES); break;
6867 fab_out.fab$w_ifi = 0;
6868 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6869 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6870 fab_out.fab$l_fop = FAB$M_SQO;
6871 fab_out.fab$l_fna = vmsout;
6872 fab_out.fab$b_fns = strlen(vmsout);
6873 fab_out.fab$l_dna = nam.nam$l_name;
6874 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6876 if (preserve_dates == 0) { /* Act like DCL COPY */
6877 nam.nam$b_nop = NAM$M_SYNCHK;
6878 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6879 if (!((sts = sys$parse(&fab_out)) & 1)) {
6880 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6881 set_vaxc_errno(sts);
6884 fab_out.fab$l_xab = (void *) &xabdat;
6885 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6887 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6888 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6889 preserve_dates =0; /* bitmask from this point forward */
6891 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6892 if (!((sts = sys$create(&fab_out)) & 1)) {
6893 set_vaxc_errno(sts);
6896 set_errno(ENOENT); break;
6898 set_errno(ENOTDIR); break;
6900 set_errno(ENODEV); break;
6902 set_errno(EINVAL); break;
6904 set_errno(EACCES); break;
6910 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6911 if (preserve_dates & 2) {
6912 /* sys$close() will process xabrdt, not xabdat */
6913 xabrdt = cc$rms_xabrdt;
6915 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6917 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6918 * is unsigned long[2], while DECC & VAXC use a struct */
6919 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6921 fab_out.fab$l_xab = (void *) &xabrdt;
6924 rab_in = cc$rms_rab;
6925 rab_in.rab$l_fab = &fab_in;
6926 rab_in.rab$l_rop = RAB$M_BIO;
6927 rab_in.rab$l_ubf = ubf;
6928 rab_in.rab$w_usz = sizeof ubf;
6929 if (!((sts = sys$connect(&rab_in)) & 1)) {
6930 sys$close(&fab_in); sys$close(&fab_out);
6931 set_errno(EVMSERR); set_vaxc_errno(sts);
6935 rab_out = cc$rms_rab;
6936 rab_out.rab$l_fab = &fab_out;
6937 rab_out.rab$l_rbf = ubf;
6938 if (!((sts = sys$connect(&rab_out)) & 1)) {
6939 sys$close(&fab_in); sys$close(&fab_out);
6940 set_errno(EVMSERR); set_vaxc_errno(sts);
6944 while ((sts = sys$read(&rab_in))) { /* always true */
6945 if (sts == RMS$_EOF) break;
6946 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6947 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6948 sys$close(&fab_in); sys$close(&fab_out);
6949 set_errno(EVMSERR); set_vaxc_errno(sts);
6954 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6955 sys$close(&fab_in); sys$close(&fab_out);
6956 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6958 set_errno(EVMSERR); set_vaxc_errno(sts);
6964 } /* end of rmscopy() */
6968 /*** The following glue provides 'hooks' to make some of the routines
6969 * from this file available from Perl. These routines are sufficiently
6970 * basic, and are required sufficiently early in the build process,
6971 * that's it's nice to have them available to miniperl as well as the
6972 * full Perl, so they're set up here instead of in an extension. The
6973 * Perl code which handles importation of these names into a given
6974 * package lives in [.VMS]Filespec.pm in @INC.
6978 rmsexpand_fromperl(pTHX_ CV *cv)
6981 char *fspec, *defspec = NULL, *rslt;
6984 if (!items || items > 2)
6985 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6986 fspec = SvPV(ST(0),n_a);
6987 if (!fspec || !*fspec) XSRETURN_UNDEF;
6988 if (items == 2) defspec = SvPV(ST(1),n_a);
6990 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6991 ST(0) = sv_newmortal();
6992 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6997 vmsify_fromperl(pTHX_ CV *cv)
7003 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
7004 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
7005 ST(0) = sv_newmortal();
7006 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7011 unixify_fromperl(pTHX_ CV *cv)
7017 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7018 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7019 ST(0) = sv_newmortal();
7020 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7025 fileify_fromperl(pTHX_ CV *cv)
7031 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7032 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7033 ST(0) = sv_newmortal();
7034 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7039 pathify_fromperl(pTHX_ CV *cv)
7045 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7046 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7047 ST(0) = sv_newmortal();
7048 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7053 vmspath_fromperl(pTHX_ CV *cv)
7059 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7060 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7061 ST(0) = sv_newmortal();
7062 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7067 unixpath_fromperl(pTHX_ CV *cv)
7073 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7074 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7075 ST(0) = sv_newmortal();
7076 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7081 candelete_fromperl(pTHX_ CV *cv)
7084 char fspec[NAM$C_MAXRSS+1], *fsp;
7089 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7091 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7092 if (SvTYPE(mysv) == SVt_PVGV) {
7093 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7094 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7101 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7102 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7108 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7113 rmscopy_fromperl(pTHX_ CV *cv)
7116 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7118 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7119 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7120 unsigned long int sts;
7125 if (items < 2 || items > 3)
7126 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7128 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7129 if (SvTYPE(mysv) == SVt_PVGV) {
7130 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7131 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7138 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7139 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7144 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7145 if (SvTYPE(mysv) == SVt_PVGV) {
7146 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7147 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7154 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7155 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7160 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7162 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7168 mod2fname(pTHX_ CV *cv)
7171 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7172 workbuff[NAM$C_MAXRSS*1 + 1];
7173 int total_namelen = 3, counter, num_entries;
7174 /* ODS-5 ups this, but we want to be consistent, so... */
7175 int max_name_len = 39;
7176 AV *in_array = (AV *)SvRV(ST(0));
7178 num_entries = av_len(in_array);
7180 /* All the names start with PL_. */
7181 strcpy(ultimate_name, "PL_");
7183 /* Clean up our working buffer */
7184 Zero(work_name, sizeof(work_name), char);
7186 /* Run through the entries and build up a working name */
7187 for(counter = 0; counter <= num_entries; counter++) {
7188 /* If it's not the first name then tack on a __ */
7190 strcat(work_name, "__");
7192 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7196 /* Check to see if we actually have to bother...*/
7197 if (strlen(work_name) + 3 <= max_name_len) {
7198 strcat(ultimate_name, work_name);
7200 /* It's too darned big, so we need to go strip. We use the same */
7201 /* algorithm as xsubpp does. First, strip out doubled __ */
7202 char *source, *dest, last;
7205 for (source = work_name; *source; source++) {
7206 if (last == *source && last == '_') {
7212 /* Go put it back */
7213 strcpy(work_name, workbuff);
7214 /* Is it still too big? */
7215 if (strlen(work_name) + 3 > max_name_len) {
7216 /* Strip duplicate letters */
7219 for (source = work_name; *source; source++) {
7220 if (last == toupper(*source)) {
7224 last = toupper(*source);
7226 strcpy(work_name, workbuff);
7229 /* Is it *still* too big? */
7230 if (strlen(work_name) + 3 > max_name_len) {
7231 /* Too bad, we truncate */
7232 work_name[max_name_len - 2] = 0;
7234 strcat(ultimate_name, work_name);
7237 /* Okay, return it */
7238 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7243 hushexit_fromperl(pTHX_ CV *cv)
7248 VMSISH_HUSHED = SvTRUE(ST(0));
7250 ST(0) = boolSV(VMSISH_HUSHED);
7255 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7256 struct interp_intern *dst)
7258 memcpy(dst,src,sizeof(struct interp_intern));
7262 Perl_sys_intern_clear(pTHX)
7267 Perl_sys_intern_init(pTHX)
7269 unsigned int ix = RAND_MAX;
7275 MY_INV_RAND_MAX = 1./x;
7282 char* file = __FILE__;
7283 char temp_buff[512];
7284 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7285 no_translate_barewords = TRUE;
7287 no_translate_barewords = FALSE;
7290 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7291 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7292 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7293 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7294 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7295 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7296 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7297 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7298 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7299 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7300 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7302 store_pipelocs(aTHX); /* will redo any earlier attempts */