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
18 #include <climsgdef.h>
28 #include <libclidef.h>
30 #include <lib$routines.h>
40 #include <str$routines.h>
45 /* Older versions of ssdef.h don't have these */
46 #ifndef SS$_INVFILFOROP
47 # define SS$_INVFILFOROP 3930
49 #ifndef SS$_NOSUCHOBJECT
50 # define SS$_NOSUCHOBJECT 2696
53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
54 #define PERLIO_NOT_STDIO 0
56 /* Don't replace system definitions of vfork, getenv, and stat,
57 * code below needs to get to the underlying CRTL routines. */
58 #define DONT_MASK_RTL_CALLS
62 /* Anticipating future expansion in lexical warnings . . . */
64 # define WARN_INTERNAL WARN_MISC
67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
68 # define RTL_USES_UTC 1
72 /* gcc's header files don't #define direct access macros
73 * corresponding to VAXC's variant structs */
75 # define uic$v_format uic$r_uic_form.uic$v_format
76 # define uic$v_group uic$r_uic_form.uic$v_group
77 # define uic$v_member uic$r_uic_form.uic$v_member
78 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
79 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
80 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
81 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
84 #if defined(NEED_AN_H_ERRNO)
89 unsigned short int buflen;
90 unsigned short int itmcode;
92 unsigned short int *retlen;
95 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
96 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
97 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
98 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
99 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
100 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
101 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
102 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
103 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
106 #define PERL_LNM_MAX_ALLOWED_INDEX 127
108 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
109 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
112 #define PERL_LNM_MAX_ITER 10
114 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
115 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
117 static char *__mystrtolower(char *str)
119 if (str) for (; *str; ++str) *str= tolower(*str);
123 static struct dsc$descriptor_s fildevdsc =
124 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
125 static struct dsc$descriptor_s crtlenvdsc =
126 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
127 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
128 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
129 static struct dsc$descriptor_s **env_tables = defenv;
130 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
132 /* True if we shouldn't treat barewords as logicals during directory */
134 static int no_translate_barewords;
137 static int tz_updated = 1;
140 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
142 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
143 struct dsc$descriptor_s **tabvec, unsigned long int flags)
145 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
146 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
147 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
148 unsigned char acmode;
149 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
150 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
151 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
152 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
154 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
155 #if defined(PERL_IMPLICIT_CONTEXT)
158 aTHX = PERL_GET_INTERP;
164 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
165 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
167 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
168 *cp2 = _toupper(*cp1);
169 if (cp1 - lnm > LNM$C_NAMLENGTH) {
170 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
174 lnmdsc.dsc$w_length = cp1 - lnm;
175 lnmdsc.dsc$a_pointer = uplnm;
176 uplnm[lnmdsc.dsc$w_length] = '\0';
177 secure = flags & PERL__TRNENV_SECURE;
178 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
179 if (!tabvec || !*tabvec) tabvec = env_tables;
181 for (curtab = 0; tabvec[curtab]; curtab++) {
182 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
183 if (!ivenv && !secure) {
188 Perl_warn(aTHX_ "Can't read CRTL environ\n");
191 retsts = SS$_NOLOGNAM;
192 for (i = 0; environ[i]; i++) {
193 if ((eq = strchr(environ[i],'=')) &&
194 !strncmp(environ[i],uplnm,eq - environ[i])) {
196 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
197 if (!eqvlen) continue;
202 if (retsts != SS$_NOLOGNAM) break;
205 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
206 !str$case_blind_compare(&tmpdsc,&clisym)) {
207 if (!ivsym && !secure) {
208 unsigned short int deflen = LNM$C_NAMLENGTH;
209 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
210 /* dynamic dsc to accomodate possible long value */
211 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
212 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
215 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
217 /* Special hack--we might be called before the interpreter's */
218 /* fully initialized, in which case either thr or PL_curcop */
219 /* might be bogus. We have to check, since ckWARN needs them */
220 /* both to be valid if running threaded */
221 if (ckWARN(WARN_MISC)) {
222 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
225 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
227 _ckvmssts(lib$sfree1_dd(&eqvdsc));
228 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
229 if (retsts == LIB$_NOSUCHSYM) continue;
234 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
235 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
236 if (retsts == SS$_NOLOGNAM) continue;
237 /* PPFs have a prefix */
240 *((int *)uplnm) == *((int *)"SYS$") &&
242 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
243 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
244 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
245 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
246 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
247 memcpy(eqv,eqv+4,eqvlen-4);
253 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
254 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
255 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
256 retsts == SS$_NOLOGNAM) {
257 set_errno(EINVAL); set_vaxc_errno(retsts);
259 else _ckvmssts(retsts);
261 } /* end of vmstrnenv */
264 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
265 /* Define as a function so we can access statics. */
266 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
268 return vmstrnenv(lnm,eqv,idx,fildev,
269 #ifdef SECURE_INTERNAL_GETENV
270 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
279 * Note: Uses Perl temp to store result so char * can be returned to
280 * caller; this pointer will be invalidated at next Perl statement
282 * We define this as a function rather than a macro in terms of my_getenv_len()
283 * so that it'll work when PL_curinterp is undefined (and we therefore can't
286 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
288 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
290 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
291 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
292 unsigned long int idx = 0;
293 int trnsuccess, success, secure, saverr, savvmserr;
296 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
297 /* Set up a temporary buffer for the return value; Perl will
298 * clean it up at the next statement transition */
299 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
300 if (!tmpsv) return NULL;
303 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
304 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
305 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
306 getcwd(eqv,LNM$C_NAMLENGTH);
310 if ((cp2 = strchr(lnm,';')) != NULL) {
312 uplnm[cp2-lnm] = '\0';
313 idx = strtoul(cp2+1,NULL,0);
316 /* Impose security constraints only if tainting */
318 /* Impose security constraints only if tainting */
319 secure = PL_curinterp ? PL_tainting : will_taint;
320 saverr = errno; savvmserr = vaxc$errno;
323 success = vmstrnenv(lnm,eqv,idx,
324 secure ? fildev : NULL,
325 #ifdef SECURE_INTERNAL_GETENV
326 secure ? PERL__TRNENV_SECURE : 0
331 /* Discard NOLOGNAM on internal calls since we're often looking
332 * for an optional name, and this "error" often shows up as the
333 * (bogus) exit status for a die() call later on. */
334 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
335 return success ? eqv : Nullch;
338 } /* end of my_getenv() */
342 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
344 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
346 char *buf, *cp1, *cp2;
347 unsigned long idx = 0;
348 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
349 int secure, saverr, savvmserr;
352 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
353 /* Set up a temporary buffer for the return value; Perl will
354 * clean it up at the next statement transition */
355 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
356 if (!tmpsv) return NULL;
359 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
360 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
361 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
362 getcwd(buf,LNM$C_NAMLENGTH);
367 if ((cp2 = strchr(lnm,';')) != NULL) {
370 idx = strtoul(cp2+1,NULL,0);
374 /* Impose security constraints only if tainting */
375 secure = PL_curinterp ? PL_tainting : will_taint;
376 saverr = errno; savvmserr = vaxc$errno;
379 *len = vmstrnenv(lnm,buf,idx,
380 secure ? fildev : NULL,
381 #ifdef SECURE_INTERNAL_GETENV
382 secure ? PERL__TRNENV_SECURE : 0
387 /* Discard NOLOGNAM on internal calls since we're often looking
388 * for an optional name, and this "error" often shows up as the
389 * (bogus) exit status for a die() call later on. */
390 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
391 return *len ? buf : Nullch;
394 } /* end of my_getenv_len() */
397 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
399 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
401 /*{{{ void prime_env_iter() */
404 /* Fill the %ENV associative array with all logical names we can
405 * find, in preparation for iterating over it.
408 static int primed = 0;
409 HV *seenhv = NULL, *envhv;
411 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
412 unsigned short int chan;
413 #ifndef CLI$M_TRUSTED
414 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
416 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
417 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
419 bool have_sym = FALSE, have_lnm = FALSE;
420 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
421 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
422 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
423 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
424 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
425 #if defined(PERL_IMPLICIT_CONTEXT)
428 #if defined(USE_ITHREADS)
429 static perl_mutex primenv_mutex;
430 MUTEX_INIT(&primenv_mutex);
433 #if defined(PERL_IMPLICIT_CONTEXT)
434 /* We jump through these hoops because we can be called at */
435 /* platform-specific initialization time, which is before anything is */
436 /* set up--we can't even do a plain dTHX since that relies on the */
437 /* interpreter structure to be initialized */
439 aTHX = PERL_GET_INTERP;
445 if (primed || !PL_envgv) return;
446 MUTEX_LOCK(&primenv_mutex);
447 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
448 envhv = GvHVn(PL_envgv);
449 /* Perform a dummy fetch as an lval to insure that the hash table is
450 * set up. Otherwise, the hv_store() will turn into a nullop. */
451 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
453 for (i = 0; env_tables[i]; i++) {
454 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
455 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
456 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
458 if (have_sym || have_lnm) {
459 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
460 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
461 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
462 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
465 for (i--; i >= 0; i--) {
466 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
469 for (j = 0; environ[j]; j++) {
470 if (!(start = strchr(environ[j],'='))) {
471 if (ckWARN(WARN_INTERNAL))
472 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
476 sv = newSVpv(start,0);
478 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
483 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
484 !str$case_blind_compare(&tmpdsc,&clisym)) {
485 strcpy(cmd,"Show Symbol/Global *");
486 cmddsc.dsc$w_length = 20;
487 if (env_tables[i]->dsc$w_length == 12 &&
488 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
489 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
490 flags = defflags | CLI$M_NOLOGNAM;
493 strcpy(cmd,"Show Logical *");
494 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
495 strcat(cmd," /Table=");
496 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
497 cmddsc.dsc$w_length = strlen(cmd);
499 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
500 flags = defflags | CLI$M_NOCLISYM;
503 /* Create a new subprocess to execute each command, to exclude the
504 * remote possibility that someone could subvert a mbx or file used
505 * to write multiple commands to a single subprocess.
508 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
509 0,&riseandshine,0,0,&clidsc,&clitabdsc);
510 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
511 defflags &= ~CLI$M_TRUSTED;
512 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
514 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
515 if (seenhv) SvREFCNT_dec(seenhv);
518 char *cp1, *cp2, *key;
519 unsigned long int sts, iosb[2], retlen, keylen;
522 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
523 if (sts & 1) sts = iosb[0] & 0xffff;
524 if (sts == SS$_ENDOFFILE) {
526 while (substs == 0) { sys$hiber(); wakect++;}
527 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
532 retlen = iosb[0] >> 16;
533 if (!retlen) continue; /* blank line */
535 if (iosb[1] != subpid) {
537 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
541 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
542 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
544 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
545 if (*cp1 == '(' || /* Logical name table name */
546 *cp1 == '=' /* Next eqv of searchlist */) continue;
547 if (*cp1 == '"') cp1++;
548 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
549 key = cp1; keylen = cp2 - cp1;
550 if (keylen && hv_exists(seenhv,key,keylen)) continue;
551 while (*cp2 && *cp2 != '=') cp2++;
552 while (*cp2 && *cp2 == '=') cp2++;
553 while (*cp2 && *cp2 == ' ') cp2++;
554 if (*cp2 == '"') { /* String translation; may embed "" */
555 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
556 cp2++; cp1--; /* Skip "" surrounding translation */
558 else { /* Numeric translation */
559 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
560 cp1--; /* stop on last non-space char */
562 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
563 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
566 PERL_HASH(hash,key,keylen);
567 sv = newSVpvn(cp2,cp1 - cp2 + 1);
569 hv_store(envhv,key,keylen,sv,hash);
570 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
572 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
573 /* get the PPFs for this process, not the subprocess */
574 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
575 char eqv[LNM$C_NAMLENGTH+1];
577 for (i = 0; ppfs[i]; i++) {
578 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
579 sv = newSVpv(eqv,trnlen);
581 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
586 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
587 if (buf) Safefree(buf);
588 if (seenhv) SvREFCNT_dec(seenhv);
589 MUTEX_UNLOCK(&primenv_mutex);
592 } /* end of prime_env_iter */
596 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
597 /* Define or delete an element in the same "environment" as
598 * vmstrnenv(). If an element is to be deleted, it's removed from
599 * the first place it's found. If it's to be set, it's set in the
600 * place designated by the first element of the table vector.
601 * Like setenv() returns 0 for success, non-zero on error.
604 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
606 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
607 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
608 unsigned long int retsts, usermode = PSL$C_USER;
609 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
610 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
611 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
612 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
613 $DESCRIPTOR(local,"_LOCAL");
615 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
616 *cp2 = _toupper(*cp1);
617 if (cp1 - lnm > LNM$C_NAMLENGTH) {
618 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
622 lnmdsc.dsc$w_length = cp1 - lnm;
623 if (!tabvec || !*tabvec) tabvec = env_tables;
625 if (!eqv) { /* we're deleting n element */
626 for (curtab = 0; tabvec[curtab]; curtab++) {
627 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
629 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
630 if ((cp1 = strchr(environ[i],'=')) &&
631 !strncmp(environ[i],lnm,cp1 - environ[i])) {
633 return setenv(lnm,"",1) ? vaxc$errno : 0;
636 ivenv = 1; retsts = SS$_NOLOGNAM;
638 if (ckWARN(WARN_INTERNAL))
639 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
640 ivenv = 1; retsts = SS$_NOSUCHPGM;
646 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
647 !str$case_blind_compare(&tmpdsc,&clisym)) {
648 unsigned int symtype;
649 if (tabvec[curtab]->dsc$w_length == 12 &&
650 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
651 !str$case_blind_compare(&tmpdsc,&local))
652 symtype = LIB$K_CLI_LOCAL_SYM;
653 else symtype = LIB$K_CLI_GLOBAL_SYM;
654 retsts = lib$delete_symbol(&lnmdsc,&symtype);
655 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
656 if (retsts == LIB$_NOSUCHSYM) continue;
660 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
661 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
662 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
663 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
664 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
668 else { /* we're defining a value */
669 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
671 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
673 if (ckWARN(WARN_INTERNAL))
674 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
675 retsts = SS$_NOSUCHPGM;
679 eqvdsc.dsc$a_pointer = eqv;
680 eqvdsc.dsc$w_length = strlen(eqv);
681 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
682 !str$case_blind_compare(&tmpdsc,&clisym)) {
683 unsigned int symtype;
684 if (tabvec[0]->dsc$w_length == 12 &&
685 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
686 !str$case_blind_compare(&tmpdsc,&local))
687 symtype = LIB$K_CLI_LOCAL_SYM;
688 else symtype = LIB$K_CLI_GLOBAL_SYM;
689 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
692 if (!*eqv) eqvdsc.dsc$w_length = 1;
693 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
694 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
695 if (ckWARN(WARN_MISC)) {
696 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
699 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
705 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
706 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
707 set_errno(EVMSERR); break;
708 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
709 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
710 set_errno(EINVAL); break;
717 set_vaxc_errno(retsts);
718 return (int) retsts || 44; /* retsts should never be 0, but just in case */
721 /* We reset error values on success because Perl does an hv_fetch()
722 * before each hv_store(), and if the thing we're setting didn't
723 * previously exist, we've got a leftover error message. (Of course,
724 * this fails in the face of
725 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
726 * in that the error reported in $! isn't spurious,
727 * but it's right more often than not.)
729 set_errno(0); set_vaxc_errno(retsts);
733 } /* end of vmssetenv() */
736 /*{{{ void my_setenv(char *lnm, char *eqv)*/
737 /* This has to be a function since there's a prototype for it in proto.h */
739 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
742 int len = strlen(lnm);
746 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
747 if (!strcmp(uplnm,"DEFAULT")) {
748 if (eqv && *eqv) chdir(eqv);
753 if (len == 6 || len == 2) {
756 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
758 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
759 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
763 (void) vmssetenv(lnm,eqv,NULL);
767 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
769 * sets a user-mode logical in the process logical name table
770 * used for redirection of sys$error
773 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
775 $DESCRIPTOR(d_tab, "LNM$PROCESS");
776 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
777 unsigned long int iss, attr = LNM$M_CONFINE;
778 unsigned char acmode = PSL$C_USER;
779 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
781 d_name.dsc$a_pointer = name;
782 d_name.dsc$w_length = strlen(name);
784 lnmlst[0].buflen = strlen(eqv);
785 lnmlst[0].bufadr = eqv;
787 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
788 if (!(iss&1)) lib$signal(iss);
793 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
794 /* my_crypt - VMS password hashing
795 * my_crypt() provides an interface compatible with the Unix crypt()
796 * C library function, and uses sys$hash_password() to perform VMS
797 * password hashing. The quadword hashed password value is returned
798 * as a NUL-terminated 8 character string. my_crypt() does not change
799 * the case of its string arguments; in order to match the behavior
800 * of LOGINOUT et al., alphabetic characters in both arguments must
801 * be upcased by the caller.
804 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
806 # ifndef UAI$C_PREFERRED_ALGORITHM
807 # define UAI$C_PREFERRED_ALGORITHM 127
809 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
810 unsigned short int salt = 0;
811 unsigned long int sts;
813 unsigned short int dsc$w_length;
814 unsigned char dsc$b_type;
815 unsigned char dsc$b_class;
816 const char * dsc$a_pointer;
817 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
818 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
819 struct itmlst_3 uailst[3] = {
820 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
821 { sizeof salt, UAI$_SALT, &salt, 0},
822 { 0, 0, NULL, NULL}};
825 usrdsc.dsc$w_length = strlen(usrname);
826 usrdsc.dsc$a_pointer = usrname;
827 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
829 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
833 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
839 if (sts != RMS$_RNF) return NULL;
842 txtdsc.dsc$w_length = strlen(textpasswd);
843 txtdsc.dsc$a_pointer = textpasswd;
844 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
845 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
848 return (char *) hash;
850 } /* end of my_crypt() */
854 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
855 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
856 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
858 /*{{{int do_rmdir(char *name)*/
860 Perl_do_rmdir(pTHX_ char *name)
862 char dirfile[NAM$C_MAXRSS+1];
866 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
867 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
868 else retval = kill_file(dirfile);
871 } /* end of do_rmdir */
875 * Delete any file to which user has control access, regardless of whether
876 * delete access is explicitly allowed.
877 * Limitations: User must have write access to parent directory.
878 * Does not block signals or ASTs; if interrupted in midstream
879 * may leave file with an altered ACL.
882 /*{{{int kill_file(char *name)*/
884 Perl_kill_file(pTHX_ char *name)
886 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
887 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
888 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
889 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
891 unsigned char myace$b_length;
892 unsigned char myace$b_type;
893 unsigned short int myace$w_flags;
894 unsigned long int myace$l_access;
895 unsigned long int myace$l_ident;
896 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
897 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
898 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
900 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
901 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
902 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
903 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
904 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
905 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
907 /* Expand the input spec using RMS, since the CRTL remove() and
908 * system services won't do this by themselves, so we may miss
909 * a file "hiding" behind a logical name or search list. */
910 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
911 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
912 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
913 /* If not, can changing protections help? */
914 if (vaxc$errno != RMS$_PRV) return -1;
916 /* No, so we get our own UIC to use as a rights identifier,
917 * and the insert an ACE at the head of the ACL which allows us
918 * to delete the file.
920 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
921 fildsc.dsc$w_length = strlen(rspec);
922 fildsc.dsc$a_pointer = rspec;
924 newace.myace$l_ident = oldace.myace$l_ident;
925 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
927 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
928 set_errno(ENOENT); break;
930 set_errno(ENOTDIR); break;
932 set_errno(ENODEV); break;
933 case RMS$_SYN: case SS$_INVFILFOROP:
934 set_errno(EINVAL); break;
936 set_errno(EACCES); break;
940 set_vaxc_errno(aclsts);
943 /* Grab any existing ACEs with this identifier in case we fail */
944 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
945 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
946 || fndsts == SS$_NOMOREACE ) {
947 /* Add the new ACE . . . */
948 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
950 if ((rmsts = remove(name))) {
951 /* We blew it - dir with files in it, no write priv for
952 * parent directory, etc. Put things back the way they were. */
953 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
956 addlst[0].bufadr = &oldace;
957 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
964 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
965 /* We just deleted it, so of course it's not there. Some versions of
966 * VMS seem to return success on the unlock operation anyhow (after all
967 * the unlock is successful), but others don't.
969 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
970 if (aclsts & 1) aclsts = fndsts;
973 set_vaxc_errno(aclsts);
979 } /* end of kill_file() */
983 /*{{{int my_mkdir(char *,Mode_t)*/
985 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
987 STRLEN dirlen = strlen(dir);
989 /* zero length string sometimes gives ACCVIO */
990 if (dirlen == 0) return -1;
992 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
993 * null file name/type. However, it's commonplace under Unix,
994 * so we'll allow it for a gain in portability.
996 if (dir[dirlen-1] == '/') {
997 char *newdir = savepvn(dir,dirlen-1);
998 int ret = mkdir(newdir,mode);
1002 else return mkdir(dir,mode);
1003 } /* end of my_mkdir */
1006 /*{{{int my_chdir(char *)*/
1008 Perl_my_chdir(pTHX_ char *dir)
1010 STRLEN dirlen = strlen(dir);
1012 /* zero length string sometimes gives ACCVIO */
1013 if (dirlen == 0) return -1;
1015 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1017 * null file name/type. However, it's commonplace under Unix,
1018 * so we'll allow it for a gain in portability.
1020 if (dir[dirlen-1] == '/') {
1021 char *newdir = savepvn(dir,dirlen-1);
1022 int ret = chdir(newdir);
1026 else return chdir(dir);
1027 } /* end of my_chdir */
1031 /*{{{FILE *my_tmpfile()*/
1038 if ((fp = tmpfile())) return fp;
1040 New(1323,cp,L_tmpnam+24,char);
1041 strcpy(cp,"Sys$Scratch:");
1042 tmpnam(cp+strlen(cp));
1043 strcat(cp,".Perltmp");
1044 fp = fopen(cp,"w+","fop=dlt");
1051 #ifndef HOMEGROWN_POSIX_SIGNALS
1053 * The C RTL's sigaction fails to check for invalid signal numbers so we
1054 * help it out a bit. The docs are correct, but the actual routine doesn't
1055 * do what the docs say it will.
1057 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1059 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1060 struct sigaction* oact)
1062 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1063 SETERRNO(EINVAL, SS$_INVARG);
1066 return sigaction(sig, act, oact);
1071 #ifdef KILL_BY_SIGPRC
1072 #include <errnodef.h>
1074 /* We implement our own kill() using the undocumented system service
1075 sys$sigprc for one of two reasons:
1077 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1078 target process to do a sys$exit, which usually can't be handled
1079 gracefully...certainly not by Perl and the %SIG{} mechanism.
1081 2.) If the kill() in the CRTL can't be called from a signal
1082 handler without disappearing into the ether, i.e., the signal
1083 it purportedly sends is never trapped. Still true as of VMS 7.3.
1085 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1086 in the target process rather than calling sys$exit.
1088 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1089 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1090 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1091 with condition codes C$_SIG0+nsig*8, catching the exception on the
1092 target process and resignaling with appropriate arguments.
1094 But we don't have that VMS 7.0+ exception handler, so if you
1095 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1097 Also note that SIGTERM is listed in the docs as being "unimplemented",
1098 yet always seems to be signaled with a VMS condition code of 4 (and
1099 correctly handled for that code). So we hardwire it in.
1101 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1102 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1103 than signalling with an unrecognized (and unhandled by CRTL) code.
1106 #define _MY_SIG_MAX 17
1109 Perl_sig_to_vmscondition(int sig)
1111 static unsigned int sig_code[_MY_SIG_MAX+1] =
1114 SS$_HANGUP, /* 1 SIGHUP */
1115 SS$_CONTROLC, /* 2 SIGINT */
1116 SS$_CONTROLY, /* 3 SIGQUIT */
1117 SS$_RADRMOD, /* 4 SIGILL */
1118 SS$_BREAK, /* 5 SIGTRAP */
1119 SS$_OPCCUS, /* 6 SIGABRT */
1120 SS$_COMPAT, /* 7 SIGEMT */
1122 SS$_FLTOVF, /* 8 SIGFPE VAX */
1124 SS$_HPARITH, /* 8 SIGFPE AXP */
1126 SS$_ABORT, /* 9 SIGKILL */
1127 SS$_ACCVIO, /* 10 SIGBUS */
1128 SS$_ACCVIO, /* 11 SIGSEGV */
1129 SS$_BADPARAM, /* 12 SIGSYS */
1130 SS$_NOMBX, /* 13 SIGPIPE */
1131 SS$_ASTFLT, /* 14 SIGALRM */
1137 #if __VMS_VER >= 60200000
1138 static int initted = 0;
1141 sig_code[16] = C$_SIGUSR1;
1142 sig_code[17] = C$_SIGUSR2;
1146 if (sig < _SIG_MIN) return 0;
1147 if (sig > _MY_SIG_MAX) return 0;
1148 return sig_code[sig];
1153 Perl_my_kill(int pid, int sig)
1158 int sys$sigprc(unsigned int *pidadr,
1159 struct dsc$descriptor_s *prcname,
1162 code = Perl_sig_to_vmscondition(sig);
1164 if (!pid || !code) {
1168 iss = sys$sigprc((unsigned int *)&pid,0,code);
1169 if (iss&1) return 0;
1173 set_errno(EPERM); break;
1175 case SS$_NOSUCHNODE:
1176 case SS$_UNREACHABLE:
1177 set_errno(ESRCH); break;
1179 set_errno(ENOMEM); break;
1184 set_vaxc_errno(iss);
1190 /* default piping mailbox size */
1191 #define PERL_BUFSIZ 512
1195 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1197 unsigned long int mbxbufsiz;
1198 static unsigned long int syssize = 0;
1199 unsigned long int dviitm = DVI$_DEVNAM;
1200 char csize[LNM$C_NAMLENGTH+1];
1203 unsigned long syiitm = SYI$_MAXBUF;
1205 * Get the SYSGEN parameter MAXBUF
1207 * If the logical 'PERL_MBX_SIZE' is defined
1208 * use the value of the logical instead of PERL_BUFSIZ, but
1209 * keep the size between 128 and MAXBUF.
1212 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1215 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1216 mbxbufsiz = atoi(csize);
1218 mbxbufsiz = PERL_BUFSIZ;
1220 if (mbxbufsiz < 128) mbxbufsiz = 128;
1221 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1223 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1225 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1226 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1228 } /* end of create_mbx() */
1231 /*{{{ my_popen and my_pclose*/
1233 typedef struct _iosb IOSB;
1234 typedef struct _iosb* pIOSB;
1235 typedef struct _pipe Pipe;
1236 typedef struct _pipe* pPipe;
1237 typedef struct pipe_details Info;
1238 typedef struct pipe_details* pInfo;
1239 typedef struct _srqp RQE;
1240 typedef struct _srqp* pRQE;
1241 typedef struct _tochildbuf CBuf;
1242 typedef struct _tochildbuf* pCBuf;
1245 unsigned short status;
1246 unsigned short count;
1247 unsigned long dvispec;
1250 #pragma member_alignment save
1251 #pragma nomember_alignment quadword
1252 struct _srqp { /* VMS self-relative queue entry */
1253 unsigned long qptr[2];
1255 #pragma member_alignment restore
1256 static RQE RQE_ZERO = {0,0};
1258 struct _tochildbuf {
1261 unsigned short size;
1269 unsigned short chan_in;
1270 unsigned short chan_out;
1272 unsigned int bufsize;
1284 #if defined(PERL_IMPLICIT_CONTEXT)
1285 void *thx; /* Either a thread or an interpreter */
1286 /* pointer, depending on how we're built */
1294 PerlIO *fp; /* file pointer to pipe mailbox */
1295 int useFILE; /* using stdio, not perlio */
1296 int pid; /* PID of subprocess */
1297 int mode; /* == 'r' if pipe open for reading */
1298 int done; /* subprocess has completed */
1299 int waiting; /* waiting for completion/closure */
1300 int closing; /* my_pclose is closing this pipe */
1301 unsigned long completion; /* termination status of subprocess */
1302 pPipe in; /* pipe in to sub */
1303 pPipe out; /* pipe out of sub */
1304 pPipe err; /* pipe of sub's sys$error */
1305 int in_done; /* true when in pipe finished */
1310 struct exit_control_block
1312 struct exit_control_block *flink;
1313 unsigned long int (*exit_routine)();
1314 unsigned long int arg_count;
1315 unsigned long int *status_address;
1316 unsigned long int exit_status;
1319 typedef struct _closed_pipes Xpipe;
1320 typedef struct _closed_pipes* pXpipe;
1322 struct _closed_pipes {
1323 int pid; /* PID of subprocess */
1324 unsigned long completion; /* termination status of subprocess */
1326 #define NKEEPCLOSED 50
1327 static Xpipe closed_list[NKEEPCLOSED];
1328 static int closed_index = 0;
1329 static int closed_num = 0;
1331 #define RETRY_DELAY "0 ::0.20"
1332 #define MAX_RETRY 50
1334 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1335 static unsigned long mypid;
1336 static unsigned long delaytime[2];
1338 static pInfo open_pipes = NULL;
1339 static $DESCRIPTOR(nl_desc, "NL:");
1341 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1345 static unsigned long int
1346 pipe_exit_routine(pTHX)
1349 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1350 int sts, did_stuff, need_eof, j;
1353 flush any pending i/o
1359 PerlIO_flush(info->fp); /* first, flush data */
1361 fflush((FILE *)info->fp);
1367 next we try sending an EOF...ignore if doesn't work, make sure we
1375 _ckvmssts(sys$setast(0));
1376 if (info->in && !info->in->shut_on_empty) {
1377 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1382 _ckvmssts(sys$setast(1));
1386 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1388 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1393 _ckvmssts(sys$setast(0));
1394 if (info->waiting && info->done)
1396 nwait += info->waiting;
1397 _ckvmssts(sys$setast(1));
1407 _ckvmssts(sys$setast(0));
1408 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1409 sts = sys$forcex(&info->pid,0,&abort);
1410 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1413 _ckvmssts(sys$setast(1));
1417 /* again, wait for effect */
1419 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1424 _ckvmssts(sys$setast(0));
1425 if (info->waiting && info->done)
1427 nwait += info->waiting;
1428 _ckvmssts(sys$setast(1));
1437 _ckvmssts(sys$setast(0));
1438 if (!info->done) { /* We tried to be nice . . . */
1439 sts = sys$delprc(&info->pid,0);
1440 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1442 _ckvmssts(sys$setast(1));
1447 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1448 else if (!(sts & 1)) retsts = sts;
1453 static struct exit_control_block pipe_exitblock =
1454 {(struct exit_control_block *) 0,
1455 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1457 static void pipe_mbxtofd_ast(pPipe p);
1458 static void pipe_tochild1_ast(pPipe p);
1459 static void pipe_tochild2_ast(pPipe p);
1462 popen_completion_ast(pInfo info)
1464 pInfo i = open_pipes;
1468 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1469 closed_list[closed_index].pid = info->pid;
1470 closed_list[closed_index].completion = info->completion;
1472 if (closed_index == NKEEPCLOSED)
1477 if (i == info) break;
1480 if (!i) return; /* unlinked, probably freed too */
1485 Writing to subprocess ...
1486 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1488 chan_out may be waiting for "done" flag, or hung waiting
1489 for i/o completion to child...cancel the i/o. This will
1490 put it into "snarf mode" (done but no EOF yet) that discards
1493 Output from subprocess (stdout, stderr) needs to be flushed and
1494 shut down. We try sending an EOF, but if the mbx is full the pipe
1495 routine should still catch the "shut_on_empty" flag, telling it to
1496 use immediate-style reads so that "mbx empty" -> EOF.
1500 if (info->in && !info->in_done) { /* only for mode=w */
1501 if (info->in->shut_on_empty && info->in->need_wake) {
1502 info->in->need_wake = FALSE;
1503 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1505 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1509 if (info->out && !info->out_done) { /* were we also piping output? */
1510 info->out->shut_on_empty = TRUE;
1511 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1512 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1513 _ckvmssts_noperl(iss);
1516 if (info->err && !info->err_done) { /* we were piping stderr */
1517 info->err->shut_on_empty = TRUE;
1518 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1519 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1520 _ckvmssts_noperl(iss);
1522 _ckvmssts_noperl(sys$setef(pipe_ef));
1526 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1527 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1530 we actually differ from vmstrnenv since we use this to
1531 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1532 are pointing to the same thing
1535 static unsigned short
1536 popen_translate(pTHX_ char *logical, char *result)
1539 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1540 $DESCRIPTOR(d_log,"");
1542 unsigned short length;
1543 unsigned short code;
1545 unsigned short *retlenaddr;
1547 unsigned short l, ifi;
1549 d_log.dsc$a_pointer = logical;
1550 d_log.dsc$w_length = strlen(logical);
1552 itmlst[0].code = LNM$_STRING;
1553 itmlst[0].length = 255;
1554 itmlst[0].buffer_addr = result;
1555 itmlst[0].retlenaddr = &l;
1558 itmlst[1].length = 0;
1559 itmlst[1].buffer_addr = 0;
1560 itmlst[1].retlenaddr = 0;
1562 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1563 if (iss == SS$_NOLOGNAM) {
1567 if (!(iss&1)) lib$signal(iss);
1570 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1571 strip it off and return the ifi, if any
1574 if (result[0] == 0x1b && result[1] == 0x00) {
1575 memcpy(&ifi,result+2,2);
1576 strcpy(result,result+4);
1578 return ifi; /* this is the RMS internal file id */
1581 static void pipe_infromchild_ast(pPipe p);
1584 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1585 inside an AST routine without worrying about reentrancy and which Perl
1586 memory allocator is being used.
1588 We read data and queue up the buffers, then spit them out one at a
1589 time to the output mailbox when the output mailbox is ready for one.
1592 #define INITIAL_TOCHILDQUEUE 2
1595 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1599 char mbx1[64], mbx2[64];
1600 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1601 DSC$K_CLASS_S, mbx1},
1602 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1603 DSC$K_CLASS_S, mbx2};
1604 unsigned int dviitm = DVI$_DEVBUFSIZ;
1607 New(1368, p, 1, Pipe);
1609 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1610 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1611 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1614 p->shut_on_empty = FALSE;
1615 p->need_wake = FALSE;
1618 p->iosb.status = SS$_NORMAL;
1619 p->iosb2.status = SS$_NORMAL;
1625 #ifdef PERL_IMPLICIT_CONTEXT
1629 n = sizeof(CBuf) + p->bufsize;
1631 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1632 _ckvmssts(lib$get_vm(&n, &b));
1633 b->buf = (char *) b + sizeof(CBuf);
1634 _ckvmssts(lib$insqhi(b, &p->free));
1637 pipe_tochild2_ast(p);
1638 pipe_tochild1_ast(p);
1644 /* reads the MBX Perl is writing, and queues */
1647 pipe_tochild1_ast(pPipe p)
1650 int iss = p->iosb.status;
1651 int eof = (iss == SS$_ENDOFFILE);
1652 #ifdef PERL_IMPLICIT_CONTEXT
1658 p->shut_on_empty = TRUE;
1660 _ckvmssts(sys$dassgn(p->chan_in));
1666 b->size = p->iosb.count;
1667 _ckvmssts(lib$insqhi(b, &p->wait));
1669 p->need_wake = FALSE;
1670 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1673 p->retry = 1; /* initial call */
1676 if (eof) { /* flush the free queue, return when done */
1677 int n = sizeof(CBuf) + p->bufsize;
1679 iss = lib$remqti(&p->free, &b);
1680 if (iss == LIB$_QUEWASEMP) return;
1682 _ckvmssts(lib$free_vm(&n, &b));
1686 iss = lib$remqti(&p->free, &b);
1687 if (iss == LIB$_QUEWASEMP) {
1688 int n = sizeof(CBuf) + p->bufsize;
1689 _ckvmssts(lib$get_vm(&n, &b));
1690 b->buf = (char *) b + sizeof(CBuf);
1696 iss = sys$qio(0,p->chan_in,
1697 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1699 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1700 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1705 /* writes queued buffers to output, waits for each to complete before
1709 pipe_tochild2_ast(pPipe p)
1712 int iss = p->iosb2.status;
1713 int n = sizeof(CBuf) + p->bufsize;
1714 int done = (p->info && p->info->done) ||
1715 iss == SS$_CANCEL || iss == SS$_ABORT;
1716 #if defined(PERL_IMPLICIT_CONTEXT)
1721 if (p->type) { /* type=1 has old buffer, dispose */
1722 if (p->shut_on_empty) {
1723 _ckvmssts(lib$free_vm(&n, &b));
1725 _ckvmssts(lib$insqhi(b, &p->free));
1730 iss = lib$remqti(&p->wait, &b);
1731 if (iss == LIB$_QUEWASEMP) {
1732 if (p->shut_on_empty) {
1734 _ckvmssts(sys$dassgn(p->chan_out));
1735 *p->pipe_done = TRUE;
1736 _ckvmssts(sys$setef(pipe_ef));
1738 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1739 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1743 p->need_wake = TRUE;
1753 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1754 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1756 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1757 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1766 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1769 char mbx1[64], mbx2[64];
1770 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1771 DSC$K_CLASS_S, mbx1},
1772 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1773 DSC$K_CLASS_S, mbx2};
1774 unsigned int dviitm = DVI$_DEVBUFSIZ;
1776 New(1367, p, 1, Pipe);
1777 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1778 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1780 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1781 New(1367, p->buf, p->bufsize, char);
1782 p->shut_on_empty = FALSE;
1785 p->iosb.status = SS$_NORMAL;
1786 #if defined(PERL_IMPLICIT_CONTEXT)
1789 pipe_infromchild_ast(p);
1797 pipe_infromchild_ast(pPipe p)
1799 int iss = p->iosb.status;
1800 int eof = (iss == SS$_ENDOFFILE);
1801 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1802 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1803 #if defined(PERL_IMPLICIT_CONTEXT)
1807 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1808 _ckvmssts(sys$dassgn(p->chan_out));
1813 input shutdown if EOF from self (done or shut_on_empty)
1814 output shutdown if closing flag set (my_pclose)
1815 send data/eof from child or eof from self
1816 otherwise, re-read (snarf of data from child)
1821 if (myeof && p->chan_in) { /* input shutdown */
1822 _ckvmssts(sys$dassgn(p->chan_in));
1827 if (myeof || kideof) { /* pass EOF to parent */
1828 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1829 pipe_infromchild_ast, p,
1832 } else if (eof) { /* eat EOF --- fall through to read*/
1834 } else { /* transmit data */
1835 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1836 pipe_infromchild_ast,p,
1837 p->buf, p->iosb.count, 0, 0, 0, 0));
1843 /* everything shut? flag as done */
1845 if (!p->chan_in && !p->chan_out) {
1846 *p->pipe_done = TRUE;
1847 _ckvmssts(sys$setef(pipe_ef));
1851 /* write completed (or read, if snarfing from child)
1852 if still have input active,
1853 queue read...immediate mode if shut_on_empty so we get EOF if empty
1855 check if Perl reading, generate EOFs as needed
1861 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1862 pipe_infromchild_ast,p,
1863 p->buf, p->bufsize, 0, 0, 0, 0);
1864 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1866 } else { /* send EOFs for extra reads */
1867 p->iosb.status = SS$_ENDOFFILE;
1868 p->iosb.dvispec = 0;
1869 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1871 pipe_infromchild_ast, p, 0, 0, 0, 0));
1877 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1881 unsigned long dviitm = DVI$_DEVBUFSIZ;
1883 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1884 DSC$K_CLASS_S, mbx};
1886 /* things like terminals and mbx's don't need this filter */
1887 if (fd && fstat(fd,&s) == 0) {
1888 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1889 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1890 DSC$K_CLASS_S, s.st_dev};
1892 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1893 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1894 strcpy(out, s.st_dev);
1899 New(1366, p, 1, Pipe);
1900 p->fd_out = dup(fd);
1901 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1902 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1903 New(1366, p->buf, p->bufsize+1, char);
1904 p->shut_on_empty = FALSE;
1909 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1910 pipe_mbxtofd_ast, p,
1911 p->buf, p->bufsize, 0, 0, 0, 0));
1917 pipe_mbxtofd_ast(pPipe p)
1919 int iss = p->iosb.status;
1920 int done = p->info->done;
1922 int eof = (iss == SS$_ENDOFFILE);
1923 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1924 int err = !(iss&1) && !eof;
1925 #if defined(PERL_IMPLICIT_CONTEXT)
1929 if (done && myeof) { /* end piping */
1931 sys$dassgn(p->chan_in);
1932 *p->pipe_done = TRUE;
1933 _ckvmssts(sys$setef(pipe_ef));
1937 if (!err && !eof) { /* good data to send to file */
1938 p->buf[p->iosb.count] = '\n';
1939 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1942 if (p->retry < MAX_RETRY) {
1943 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1953 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1954 pipe_mbxtofd_ast, p,
1955 p->buf, p->bufsize, 0, 0, 0, 0);
1956 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1961 typedef struct _pipeloc PLOC;
1962 typedef struct _pipeloc* pPLOC;
1966 char dir[NAM$C_MAXRSS+1];
1968 static pPLOC head_PLOC = 0;
1971 free_pipelocs(pTHX_ void *head)
1974 pPLOC *pHead = (pPLOC *)head;
1986 store_pipelocs(pTHX)
1995 char temp[NAM$C_MAXRSS+1];
1999 free_pipelocs(aTHX_ &head_PLOC);
2001 /* the . directory from @INC comes last */
2004 p->next = head_PLOC;
2006 strcpy(p->dir,"./");
2008 /* get the directory from $^X */
2010 #ifdef PERL_IMPLICIT_CONTEXT
2011 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2013 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2015 strcpy(temp, PL_origargv[0]);
2016 x = strrchr(temp,']');
2019 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2021 p->next = head_PLOC;
2023 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2024 p->dir[NAM$C_MAXRSS] = '\0';
2028 /* reverse order of @INC entries, skip "." since entered above */
2030 #ifdef PERL_IMPLICIT_CONTEXT
2033 if (PL_incgv) av = GvAVn(PL_incgv);
2035 for (i = 0; av && i <= AvFILL(av); i++) {
2036 dirsv = *av_fetch(av,i,TRUE);
2038 if (SvROK(dirsv)) continue;
2039 dir = SvPVx(dirsv,n_a);
2040 if (strcmp(dir,".") == 0) continue;
2041 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2045 p->next = head_PLOC;
2047 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2048 p->dir[NAM$C_MAXRSS] = '\0';
2051 /* most likely spot (ARCHLIB) put first in the list */
2054 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2056 p->next = head_PLOC;
2058 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2059 p->dir[NAM$C_MAXRSS] = '\0';
2068 static int vmspipe_file_status = 0;
2069 static char vmspipe_file[NAM$C_MAXRSS+1];
2071 /* already found? Check and use ... need read+execute permission */
2073 if (vmspipe_file_status == 1) {
2074 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2075 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2076 return vmspipe_file;
2078 vmspipe_file_status = 0;
2081 /* scan through stored @INC, $^X */
2083 if (vmspipe_file_status == 0) {
2084 char file[NAM$C_MAXRSS+1];
2085 pPLOC p = head_PLOC;
2088 strcpy(file, p->dir);
2089 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2090 file[NAM$C_MAXRSS] = '\0';
2093 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2095 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2096 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2097 vmspipe_file_status = 1;
2098 return vmspipe_file;
2101 vmspipe_file_status = -1; /* failed, use tempfiles */
2108 vmspipe_tempfile(pTHX)
2110 char file[NAM$C_MAXRSS+1];
2112 static int index = 0;
2115 /* create a tempfile */
2117 /* we can't go from W, shr=get to R, shr=get without
2118 an intermediate vulnerable state, so don't bother trying...
2120 and lib$spawn doesn't shr=put, so have to close the write
2122 So... match up the creation date/time and the FID to
2123 make sure we're dealing with the same file
2128 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2129 fp = fopen(file,"w");
2131 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2132 fp = fopen(file,"w");
2134 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2135 fp = fopen(file,"w");
2138 if (!fp) return 0; /* we're hosed */
2140 fprintf(fp,"$! 'f$verify(0)\n");
2141 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2142 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2143 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2144 fprintf(fp,"$ perl_on = \"set noon\"\n");
2145 fprintf(fp,"$ perl_exit = \"exit\"\n");
2146 fprintf(fp,"$ perl_del = \"delete\"\n");
2147 fprintf(fp,"$ pif = \"if\"\n");
2148 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2149 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2150 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2151 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2152 fprintf(fp,"$! --- build command line to get max possible length\n");
2153 fprintf(fp,"$c=perl_popen_cmd0\n");
2154 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2155 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2156 fprintf(fp,"$x=perl_popen_cmd3\n");
2157 fprintf(fp,"$c=c+x\n");
2158 fprintf(fp,"$! --- get rid of global symbols\n");
2159 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2160 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2161 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2162 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2163 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2164 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2165 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2166 fprintf(fp,"$ perl_on\n");
2167 fprintf(fp,"$ 'c\n");
2168 fprintf(fp,"$ perl_status = $STATUS\n");
2169 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2170 fprintf(fp,"$ perl_exit 'perl_status'\n");
2173 fgetname(fp, file, 1);
2174 fstat(fileno(fp), &s0);
2177 fp = fopen(file,"r","shr=get");
2179 fstat(fileno(fp), &s1);
2181 if (s0.st_ino[0] != s1.st_ino[0] ||
2182 s0.st_ino[1] != s1.st_ino[1] ||
2183 s0.st_ino[2] != s1.st_ino[2] ||
2184 s0.st_ctime != s1.st_ctime ) {
2195 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2197 static int handler_set_up = FALSE;
2198 unsigned long int sts, flags = CLI$M_NOWAIT;
2199 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2201 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2202 char in[512], out[512], err[512], mbx[512];
2204 char tfilebuf[NAM$C_MAXRSS+1];
2206 char cmd_sym_name[20];
2207 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2208 DSC$K_CLASS_S, symbol};
2209 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2211 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2212 DSC$K_CLASS_S, cmd_sym_name};
2213 struct dsc$descriptor_s *vmscmd;
2214 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2215 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2216 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2218 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2220 /* once-per-program initialization...
2221 note that the SETAST calls and the dual test of pipe_ef
2222 makes sure that only the FIRST thread through here does
2223 the initialization...all other threads wait until it's
2226 Yeah, uglier than a pthread call, it's got all the stuff inline
2227 rather than in a separate routine.
2231 _ckvmssts(sys$setast(0));
2233 unsigned long int pidcode = JPI$_PID;
2234 $DESCRIPTOR(d_delay, RETRY_DELAY);
2235 _ckvmssts(lib$get_ef(&pipe_ef));
2236 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2237 _ckvmssts(sys$bintim(&d_delay, delaytime));
2239 if (!handler_set_up) {
2240 _ckvmssts(sys$dclexh(&pipe_exitblock));
2241 handler_set_up = TRUE;
2243 _ckvmssts(sys$setast(1));
2246 /* see if we can find a VMSPIPE.COM */
2249 vmspipe = find_vmspipe(aTHX);
2251 strcpy(tfilebuf+1,vmspipe);
2252 } else { /* uh, oh...we're in tempfile hell */
2253 tpipe = vmspipe_tempfile(aTHX);
2254 if (!tpipe) { /* a fish popular in Boston */
2255 if (ckWARN(WARN_PIPE)) {
2256 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2260 fgetname(tpipe,tfilebuf+1,1);
2262 vmspipedsc.dsc$a_pointer = tfilebuf;
2263 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2265 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2268 case RMS$_FNF: case RMS$_DNF:
2269 set_errno(ENOENT); break;
2271 set_errno(ENOTDIR); break;
2273 set_errno(ENODEV); break;
2275 set_errno(EACCES); break;
2277 set_errno(EINVAL); break;
2278 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2279 set_errno(E2BIG); break;
2280 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2281 _ckvmssts(sts); /* fall through */
2282 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2285 set_vaxc_errno(sts);
2286 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2287 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2292 New(1301,info,1,Info);
2294 strcpy(mode,in_mode);
2297 info->completion = 0;
2298 info->closing = FALSE;
2305 info->in_done = TRUE;
2306 info->out_done = TRUE;
2307 info->err_done = TRUE;
2308 in[0] = out[0] = err[0] = '\0';
2310 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2314 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2319 if (*mode == 'r') { /* piping from subroutine */
2321 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2323 info->out->pipe_done = &info->out_done;
2324 info->out_done = FALSE;
2325 info->out->info = info;
2327 if (!info->useFILE) {
2328 info->fp = PerlIO_open(mbx, mode);
2330 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2331 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2334 if (!info->fp && info->out) {
2335 sys$cancel(info->out->chan_out);
2337 while (!info->out_done) {
2339 _ckvmssts(sys$setast(0));
2340 done = info->out_done;
2341 if (!done) _ckvmssts(sys$clref(pipe_ef));
2342 _ckvmssts(sys$setast(1));
2343 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2346 if (info->out->buf) Safefree(info->out->buf);
2347 Safefree(info->out);
2353 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2355 info->err->pipe_done = &info->err_done;
2356 info->err_done = FALSE;
2357 info->err->info = info;
2360 } else if (*mode == 'w') { /* piping to subroutine */
2362 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2364 info->out->pipe_done = &info->out_done;
2365 info->out_done = FALSE;
2366 info->out->info = info;
2369 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2371 info->err->pipe_done = &info->err_done;
2372 info->err_done = FALSE;
2373 info->err->info = info;
2376 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2377 if (!info->useFILE) {
2378 info->fp = PerlIO_open(mbx, mode);
2380 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2381 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2385 info->in->pipe_done = &info->in_done;
2386 info->in_done = FALSE;
2387 info->in->info = info;
2391 if (!info->fp && info->in) {
2393 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2394 0, 0, 0, 0, 0, 0, 0, 0));
2396 while (!info->in_done) {
2398 _ckvmssts(sys$setast(0));
2399 done = info->in_done;
2400 if (!done) _ckvmssts(sys$clref(pipe_ef));
2401 _ckvmssts(sys$setast(1));
2402 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2405 if (info->in->buf) Safefree(info->in->buf);
2413 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2414 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2416 info->out->pipe_done = &info->out_done;
2417 info->out_done = FALSE;
2418 info->out->info = info;
2421 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2423 info->err->pipe_done = &info->err_done;
2424 info->err_done = FALSE;
2425 info->err->info = info;
2429 symbol[MAX_DCL_SYMBOL] = '\0';
2431 strncpy(symbol, in, MAX_DCL_SYMBOL);
2432 d_symbol.dsc$w_length = strlen(symbol);
2433 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2435 strncpy(symbol, err, MAX_DCL_SYMBOL);
2436 d_symbol.dsc$w_length = strlen(symbol);
2437 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2439 strncpy(symbol, out, MAX_DCL_SYMBOL);
2440 d_symbol.dsc$w_length = strlen(symbol);
2441 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2443 p = vmscmd->dsc$a_pointer;
2444 while (*p && *p != '\n') p++;
2445 *p = '\0'; /* truncate on \n */
2446 p = vmscmd->dsc$a_pointer;
2447 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2448 if (*p == '$') p++; /* remove leading $ */
2449 while (*p == ' ' || *p == '\t') p++;
2451 for (j = 0; j < 4; j++) {
2452 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2453 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2455 strncpy(symbol, p, MAX_DCL_SYMBOL);
2456 d_symbol.dsc$w_length = strlen(symbol);
2457 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2459 if (strlen(p) > MAX_DCL_SYMBOL) {
2460 p += MAX_DCL_SYMBOL;
2465 _ckvmssts(sys$setast(0));
2466 info->next=open_pipes; /* prepend to list */
2468 _ckvmssts(sys$setast(1));
2469 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2470 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2471 * have SYS$COMMAND if we need it.
2473 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2474 0, &info->pid, &info->completion,
2475 0, popen_completion_ast,info,0,0,0));
2477 /* if we were using a tempfile, close it now */
2479 if (tpipe) fclose(tpipe);
2481 /* once the subprocess is spawned, it has copied the symbols and
2482 we can get rid of ours */
2484 for (j = 0; j < 4; j++) {
2485 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2486 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2487 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2489 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2490 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2491 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2492 vms_execfree(vmscmd);
2494 #ifdef PERL_IMPLICIT_CONTEXT
2497 PL_forkprocess = info->pid;
2502 _ckvmssts(sys$setast(0));
2504 if (!done) _ckvmssts(sys$clref(pipe_ef));
2505 _ckvmssts(sys$setast(1));
2506 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2508 *psts = info->completion;
2509 my_pclose(info->fp);
2514 } /* end of safe_popen */
2517 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2519 Perl_my_popen(pTHX_ char *cmd, char *mode)
2523 TAINT_PROPER("popen");
2524 PERL_FLUSHALL_FOR_CHILD;
2525 return safe_popen(aTHX_ cmd,mode,&sts);
2530 /*{{{ I32 my_pclose(PerlIO *fp)*/
2531 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2533 pInfo info, last = NULL;
2534 unsigned long int retsts;
2537 for (info = open_pipes; info != NULL; last = info, info = info->next)
2538 if (info->fp == fp) break;
2540 if (info == NULL) { /* no such pipe open */
2541 set_errno(ECHILD); /* quoth POSIX */
2542 set_vaxc_errno(SS$_NONEXPR);
2546 /* If we were writing to a subprocess, insure that someone reading from
2547 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2548 * produce an EOF record in the mailbox.
2550 * well, at least sometimes it *does*, so we have to watch out for
2551 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2555 PerlIO_flush(info->fp); /* first, flush data */
2557 fflush((FILE *)info->fp);
2560 _ckvmssts(sys$setast(0));
2561 info->closing = TRUE;
2562 done = info->done && info->in_done && info->out_done && info->err_done;
2563 /* hanging on write to Perl's input? cancel it */
2564 if (info->mode == 'r' && info->out && !info->out_done) {
2565 if (info->out->chan_out) {
2566 _ckvmssts(sys$cancel(info->out->chan_out));
2567 if (!info->out->chan_in) { /* EOF generation, need AST */
2568 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2572 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2573 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2575 _ckvmssts(sys$setast(1));
2578 PerlIO_close(info->fp);
2580 fclose((FILE *)info->fp);
2583 we have to wait until subprocess completes, but ALSO wait until all
2584 the i/o completes...otherwise we'll be freeing the "info" structure
2585 that the i/o ASTs could still be using...
2589 _ckvmssts(sys$setast(0));
2590 done = info->done && info->in_done && info->out_done && info->err_done;
2591 if (!done) _ckvmssts(sys$clref(pipe_ef));
2592 _ckvmssts(sys$setast(1));
2593 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2595 retsts = info->completion;
2597 /* remove from list of open pipes */
2598 _ckvmssts(sys$setast(0));
2599 if (last) last->next = info->next;
2600 else open_pipes = info->next;
2601 _ckvmssts(sys$setast(1));
2603 /* free buffers and structures */
2606 if (info->in->buf) Safefree(info->in->buf);
2610 if (info->out->buf) Safefree(info->out->buf);
2611 Safefree(info->out);
2614 if (info->err->buf) Safefree(info->err->buf);
2615 Safefree(info->err);
2621 } /* end of my_pclose() */
2623 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2624 /* Roll our own prototype because we want this regardless of whether
2625 * _VMS_WAIT is defined.
2627 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2629 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2630 created with popen(); otherwise partially emulate waitpid() unless
2631 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2632 Also check processes not considered by the CRTL waitpid().
2634 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2636 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 /* child that already terminated? */
2663 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2664 if (closed_list[j].pid == pid) {
2665 if (statusp) *statusp = closed_list[j].completion;
2670 /* fall through if this child is not one of our own pipe children */
2672 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2674 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2675 * in 7.2 did we get a version that fills in the VMS completion
2676 * status as Perl has always tried to do.
2679 sts = __vms_waitpid( pid, statusp, flags );
2681 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2684 /* If the real waitpid tells us the child does not exist, we
2685 * fall through here to implement waiting for a child that
2686 * was created by some means other than exec() (say, spawned
2687 * from DCL) or to wait for a process that is not a subprocess
2688 * of the current process.
2691 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2694 $DESCRIPTOR(intdsc,"0 00:00:01");
2695 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2696 unsigned long int pidcode = JPI$_PID, mypid;
2697 unsigned long int interval[2];
2698 unsigned int jpi_iosb[2];
2699 struct itmlst_3 jpilist[2] = {
2700 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2705 /* Sorry folks, we don't presently implement rooting around for
2706 the first child we can find, and we definitely don't want to
2707 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2713 /* Get the owner of the child so I can warn if it's not mine. If the
2714 * process doesn't exist or I don't have the privs to look at it,
2715 * I can go home early.
2717 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2718 if (sts & 1) sts = jpi_iosb[0];
2730 set_vaxc_errno(sts);
2734 if (ckWARN(WARN_EXEC)) {
2735 /* remind folks they are asking for non-standard waitpid behavior */
2736 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2737 if (ownerpid != mypid)
2738 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2739 "waitpid: process %x is not a child of process %x",
2743 /* simply check on it once a second until it's not there anymore. */
2745 _ckvmssts(sys$bintim(&intdsc,interval));
2746 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2747 _ckvmssts(sys$schdwk(0,0,interval,0));
2748 _ckvmssts(sys$hiber());
2750 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2755 } /* end of waitpid() */
2760 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2762 my_gconvert(double val, int ndig, int trail, char *buf)
2764 static char __gcvtbuf[DBL_DIG+1];
2767 loc = buf ? buf : __gcvtbuf;
2769 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2771 sprintf(loc,"%.*g",ndig,val);
2777 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2778 return gcvt(val,ndig,loc);
2781 loc[0] = '0'; loc[1] = '\0';
2789 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2790 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2791 * to expand file specification. Allows for a single default file
2792 * specification and a simple mask of options. If outbuf is non-NULL,
2793 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2794 * the resultant file specification is placed. If outbuf is NULL, the
2795 * resultant file specification is placed into a static buffer.
2796 * The third argument, if non-NULL, is taken to be a default file
2797 * specification string. The fourth argument is unused at present.
2798 * rmesexpand() returns the address of the resultant string if
2799 * successful, and NULL on error.
2801 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2804 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2806 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2807 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2808 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2809 struct FAB myfab = cc$rms_fab;
2810 struct NAM mynam = cc$rms_nam;
2812 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2814 if (!filespec || !*filespec) {
2815 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2819 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2820 else outbuf = __rmsexpand_retbuf;
2822 if ((isunix = (strchr(filespec,'/') != NULL))) {
2823 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2824 filespec = vmsfspec;
2827 myfab.fab$l_fna = filespec;
2828 myfab.fab$b_fns = strlen(filespec);
2829 myfab.fab$l_nam = &mynam;
2831 if (defspec && *defspec) {
2832 if (strchr(defspec,'/') != NULL) {
2833 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2836 myfab.fab$l_dna = defspec;
2837 myfab.fab$b_dns = strlen(defspec);
2840 mynam.nam$l_esa = esa;
2841 mynam.nam$b_ess = sizeof esa;
2842 mynam.nam$l_rsa = outbuf;
2843 mynam.nam$b_rss = NAM$C_MAXRSS;
2845 retsts = sys$parse(&myfab,0,0);
2846 if (!(retsts & 1)) {
2847 mynam.nam$b_nop |= NAM$M_SYNCHK;
2848 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2849 retsts = sys$parse(&myfab,0,0);
2850 if (retsts & 1) goto expanded;
2852 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2853 (void) sys$parse(&myfab,0,0); /* Free search context */
2854 if (out) Safefree(out);
2855 set_vaxc_errno(retsts);
2856 if (retsts == RMS$_PRV) set_errno(EACCES);
2857 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2858 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2859 else set_errno(EVMSERR);
2862 retsts = sys$search(&myfab,0,0);
2863 if (!(retsts & 1) && retsts != RMS$_FNF) {
2864 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2865 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2866 if (out) Safefree(out);
2867 set_vaxc_errno(retsts);
2868 if (retsts == RMS$_PRV) set_errno(EACCES);
2869 else set_errno(EVMSERR);
2873 /* If the input filespec contained any lowercase characters,
2874 * downcase the result for compatibility with Unix-minded code. */
2876 for (out = myfab.fab$l_fna; *out; out++)
2877 if (islower(*out)) { haslower = 1; break; }
2878 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2879 else { out = esa; speclen = mynam.nam$b_esl; }
2880 /* Trim off null fields added by $PARSE
2881 * If type > 1 char, must have been specified in original or default spec
2882 * (not true for version; $SEARCH may have added version of existing file).
2884 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2885 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2886 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2887 if (trimver || trimtype) {
2888 if (defspec && *defspec) {
2889 char defesa[NAM$C_MAXRSS];
2890 struct FAB deffab = cc$rms_fab;
2891 struct NAM defnam = cc$rms_nam;
2893 deffab.fab$l_nam = &defnam;
2894 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2895 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2896 defnam.nam$b_nop = NAM$M_SYNCHK;
2897 if (sys$parse(&deffab,0,0) & 1) {
2898 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2899 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2902 if (trimver) speclen = mynam.nam$l_ver - out;
2904 /* If we didn't already trim version, copy down */
2905 if (speclen > mynam.nam$l_ver - out)
2906 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2907 speclen - (mynam.nam$l_ver - out));
2908 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2911 /* If we just had a directory spec on input, $PARSE "helpfully"
2912 * adds an empty name and type for us */
2913 if (mynam.nam$l_name == mynam.nam$l_type &&
2914 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2915 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2916 speclen = mynam.nam$l_name - out;
2917 out[speclen] = '\0';
2918 if (haslower) __mystrtolower(out);
2920 /* Have we been working with an expanded, but not resultant, spec? */
2921 /* Also, convert back to Unix syntax if necessary. */
2922 if (!mynam.nam$b_rsl) {
2924 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2926 else strcpy(outbuf,esa);
2929 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2930 strcpy(outbuf,tmpfspec);
2932 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2933 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2934 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2938 /* External entry points */
2939 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2940 { return do_rmsexpand(spec,buf,0,def,opt); }
2941 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2942 { return do_rmsexpand(spec,buf,1,def,opt); }
2946 ** The following routines are provided to make life easier when
2947 ** converting among VMS-style and Unix-style directory specifications.
2948 ** All will take input specifications in either VMS or Unix syntax. On
2949 ** failure, all return NULL. If successful, the routines listed below
2950 ** return a pointer to a buffer containing the appropriately
2951 ** reformatted spec (and, therefore, subsequent calls to that routine
2952 ** will clobber the result), while the routines of the same names with
2953 ** a _ts suffix appended will return a pointer to a mallocd string
2954 ** containing the appropriately reformatted spec.
2955 ** In all cases, only explicit syntax is altered; no check is made that
2956 ** the resulting string is valid or that the directory in question
2959 ** fileify_dirspec() - convert a directory spec into the name of the
2960 ** directory file (i.e. what you can stat() to see if it's a dir).
2961 ** The style (VMS or Unix) of the result is the same as the style
2962 ** of the parameter passed in.
2963 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2964 ** what you prepend to a filename to indicate what directory it's in).
2965 ** The style (VMS or Unix) of the result is the same as the style
2966 ** of the parameter passed in.
2967 ** tounixpath() - convert a directory spec into a Unix-style path.
2968 ** tovmspath() - convert a directory spec into a VMS-style path.
2969 ** tounixspec() - convert any file spec into a Unix-style file spec.
2970 ** tovmsspec() - convert any file spec into a VMS-style spec.
2972 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2973 ** Permission is given to distribute this code as part of the Perl
2974 ** standard distribution under the terms of the GNU General Public
2975 ** License or the Perl Artistic License. Copies of each may be
2976 ** found in the Perl standard distribution.
2979 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2980 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2982 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2983 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2984 char *retspec, *cp1, *cp2, *lastdir;
2985 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2986 unsigned short int trnlnm_iter_count;
2988 if (!dir || !*dir) {
2989 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2991 dirlen = strlen(dir);
2992 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2993 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2994 strcpy(trndir,"/sys$disk/000000");
2998 if (dirlen > NAM$C_MAXRSS) {
2999 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3001 if (!strpbrk(dir+1,"/]>:")) {
3002 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3003 trnlnm_iter_count = 0;
3004 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3005 trnlnm_iter_count++;
3006 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3009 dirlen = strlen(dir);
3012 strncpy(trndir,dir,dirlen);
3013 trndir[dirlen] = '\0';
3016 /* If we were handed a rooted logical name or spec, treat it like a
3017 * simple directory, so that
3018 * $ Define myroot dev:[dir.]
3019 * ... do_fileify_dirspec("myroot",buf,1) ...
3020 * does something useful.
3022 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3023 dir[--dirlen] = '\0';
3024 dir[dirlen-1] = ']';
3026 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3027 dir[--dirlen] = '\0';
3028 dir[dirlen-1] = '>';
3031 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3032 /* If we've got an explicit filename, we can just shuffle the string. */
3033 if (*(cp1+1)) hasfilename = 1;
3034 /* Similarly, we can just back up a level if we've got multiple levels
3035 of explicit directories in a VMS spec which ends with directories. */
3037 for (cp2 = cp1; cp2 > dir; cp2--) {
3039 *cp2 = *cp1; *cp1 = '\0';
3043 if (*cp2 == '[' || *cp2 == '<') break;
3048 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3049 if (dir[0] == '.') {
3050 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3051 return do_fileify_dirspec("[]",buf,ts);
3052 else if (dir[1] == '.' &&
3053 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3054 return do_fileify_dirspec("[-]",buf,ts);
3056 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3057 dirlen -= 1; /* to last element */
3058 lastdir = strrchr(dir,'/');
3060 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3061 /* If we have "/." or "/..", VMSify it and let the VMS code
3062 * below expand it, rather than repeating the code to handle
3063 * relative components of a filespec here */
3065 if (*(cp1+2) == '.') cp1++;
3066 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3067 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3068 if (strchr(vmsdir,'/') != NULL) {
3069 /* If do_tovmsspec() returned it, it must have VMS syntax
3070 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3071 * the time to check this here only so we avoid a recursion
3072 * loop; otherwise, gigo.
3074 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3076 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3077 return do_tounixspec(trndir,buf,ts);
3080 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3081 lastdir = strrchr(dir,'/');
3083 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3084 /* Ditto for specs that end in an MFD -- let the VMS code
3085 * figure out whether it's a real device or a rooted logical. */
3086 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3087 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3088 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3089 return do_tounixspec(trndir,buf,ts);
3092 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3093 !(lastdir = cp1 = strrchr(dir,']')) &&
3094 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3095 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3097 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3098 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3099 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3100 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3101 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3102 (ver || *cp3)))))) {
3104 set_vaxc_errno(RMS$_DIR);
3110 /* If we lead off with a device or rooted logical, add the MFD
3111 if we're specifying a top-level directory. */
3112 if (lastdir && *dir == '/') {
3114 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3121 retlen = dirlen + (addmfd ? 13 : 6);
3122 if (buf) retspec = buf;
3123 else if (ts) New(1309,retspec,retlen+1,char);
3124 else retspec = __fileify_retbuf;
3126 dirlen = lastdir - dir;
3127 memcpy(retspec,dir,dirlen);
3128 strcpy(&retspec[dirlen],"/000000");
3129 strcpy(&retspec[dirlen+7],lastdir);
3132 memcpy(retspec,dir,dirlen);
3133 retspec[dirlen] = '\0';
3135 /* We've picked up everything up to the directory file name.
3136 Now just add the type and version, and we're set. */
3137 strcat(retspec,".dir;1");
3140 else { /* VMS-style directory spec */
3141 char esa[NAM$C_MAXRSS+1], term, *cp;
3142 unsigned long int sts, cmplen, haslower = 0;
3143 struct FAB dirfab = cc$rms_fab;
3144 struct NAM savnam, dirnam = cc$rms_nam;
3146 dirfab.fab$b_fns = strlen(dir);
3147 dirfab.fab$l_fna = dir;
3148 dirfab.fab$l_nam = &dirnam;
3149 dirfab.fab$l_dna = ".DIR;1";
3150 dirfab.fab$b_dns = 6;
3151 dirnam.nam$b_ess = NAM$C_MAXRSS;
3152 dirnam.nam$l_esa = esa;
3154 for (cp = dir; *cp; cp++)
3155 if (islower(*cp)) { haslower = 1; break; }
3156 if (!((sts = sys$parse(&dirfab))&1)) {
3157 if (dirfab.fab$l_sts == RMS$_DIR) {
3158 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3159 sts = sys$parse(&dirfab) & 1;
3163 set_vaxc_errno(dirfab.fab$l_sts);
3169 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3170 /* Yes; fake the fnb bits so we'll check type below */
3171 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3173 else { /* No; just work with potential name */
3174 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3176 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3177 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3178 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3183 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3184 cp1 = strchr(esa,']');
3185 if (!cp1) cp1 = strchr(esa,'>');
3186 if (cp1) { /* Should always be true */
3187 dirnam.nam$b_esl -= cp1 - esa - 1;
3188 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3191 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3192 /* Yep; check version while we're at it, if it's there. */
3193 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3194 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3195 /* Something other than .DIR[;1]. Bzzt. */
3196 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3197 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3199 set_vaxc_errno(RMS$_DIR);
3203 esa[dirnam.nam$b_esl] = '\0';
3204 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3205 /* They provided at least the name; we added the type, if necessary, */
3206 if (buf) retspec = buf; /* in sys$parse() */
3207 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3208 else retspec = __fileify_retbuf;
3209 strcpy(retspec,esa);
3210 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3211 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3214 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3215 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3217 dirnam.nam$b_esl -= 9;
3219 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3220 if (cp1 == NULL) { /* should never happen */
3221 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3222 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3227 retlen = strlen(esa);
3228 if ((cp1 = strrchr(esa,'.')) != NULL) {
3229 /* There's more than one directory in the path. Just roll back. */
3231 if (buf) retspec = buf;
3232 else if (ts) New(1311,retspec,retlen+7,char);
3233 else retspec = __fileify_retbuf;
3234 strcpy(retspec,esa);
3237 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3238 /* Go back and expand rooted logical name */
3239 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3240 if (!(sys$parse(&dirfab) & 1)) {
3241 dirnam.nam$l_rlf = NULL;
3242 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3244 set_vaxc_errno(dirfab.fab$l_sts);
3247 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3248 if (buf) retspec = buf;
3249 else if (ts) New(1312,retspec,retlen+16,char);
3250 else retspec = __fileify_retbuf;
3251 cp1 = strstr(esa,"][");
3252 if (!cp1) cp1 = strstr(esa,"]<");
3254 memcpy(retspec,esa,dirlen);
3255 if (!strncmp(cp1+2,"000000]",7)) {
3256 retspec[dirlen-1] = '\0';
3257 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3258 if (*cp1 == '.') *cp1 = ']';
3260 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3261 memcpy(cp1+1,"000000]",7);
3265 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3266 retspec[retlen] = '\0';
3267 /* Convert last '.' to ']' */
3268 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3269 if (*cp1 == '.') *cp1 = ']';
3271 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3272 memcpy(cp1+1,"000000]",7);
3276 else { /* This is a top-level dir. Add the MFD to the path. */
3277 if (buf) retspec = buf;
3278 else if (ts) New(1312,retspec,retlen+16,char);
3279 else retspec = __fileify_retbuf;
3282 while (*cp1 != ':') *(cp2++) = *(cp1++);
3283 strcpy(cp2,":[000000]");
3288 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3289 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3290 /* We've set up the string up through the filename. Add the
3291 type and version, and we're done. */
3292 strcat(retspec,".DIR;1");
3294 /* $PARSE may have upcased filespec, so convert output to lower
3295 * case if input contained any lowercase characters. */
3296 if (haslower) __mystrtolower(retspec);
3299 } /* end of do_fileify_dirspec() */
3301 /* External entry points */
3302 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3303 { return do_fileify_dirspec(dir,buf,0); }
3304 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3305 { return do_fileify_dirspec(dir,buf,1); }
3307 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3308 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3310 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3311 unsigned long int retlen;
3312 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3313 unsigned short int trnlnm_iter_count;
3316 if (!dir || !*dir) {
3317 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3320 if (*dir) strcpy(trndir,dir);
3321 else getcwd(trndir,sizeof trndir - 1);
3323 trnlnm_iter_count = 0;
3324 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3325 && my_trnlnm(trndir,trndir,0)) {
3326 trnlnm_iter_count++;
3327 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3328 trnlen = strlen(trndir);
3330 /* Trap simple rooted lnms, and return lnm:[000000] */
3331 if (!strcmp(trndir+trnlen-2,".]")) {
3332 if (buf) retpath = buf;
3333 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3334 else retpath = __pathify_retbuf;
3335 strcpy(retpath,dir);
3336 strcat(retpath,":[000000]");
3342 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3343 if (*dir == '.' && (*(dir+1) == '\0' ||
3344 (*(dir+1) == '.' && *(dir+2) == '\0')))
3345 retlen = 2 + (*(dir+1) != '\0');
3347 if ( !(cp1 = strrchr(dir,'/')) &&
3348 !(cp1 = strrchr(dir,']')) &&
3349 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3350 if ((cp2 = strchr(cp1,'.')) != NULL &&
3351 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3352 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3353 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3354 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3356 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3357 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3358 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3359 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3360 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3361 (ver || *cp3)))))) {
3363 set_vaxc_errno(RMS$_DIR);
3366 retlen = cp2 - dir + 1;
3368 else { /* No file type present. Treat the filename as a directory. */
3369 retlen = strlen(dir) + 1;
3372 if (buf) retpath = buf;
3373 else if (ts) New(1313,retpath,retlen+1,char);
3374 else retpath = __pathify_retbuf;
3375 strncpy(retpath,dir,retlen-1);
3376 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3377 retpath[retlen-1] = '/'; /* with '/', add it. */
3378 retpath[retlen] = '\0';
3380 else retpath[retlen-1] = '\0';
3382 else { /* VMS-style directory spec */
3383 char esa[NAM$C_MAXRSS+1], *cp;
3384 unsigned long int sts, cmplen, haslower;
3385 struct FAB dirfab = cc$rms_fab;
3386 struct NAM savnam, dirnam = cc$rms_nam;
3388 /* If we've got an explicit filename, we can just shuffle the string. */
3389 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3390 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3391 if ((cp2 = strchr(cp1,'.')) != NULL) {
3393 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3394 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3395 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3396 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3397 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3398 (ver || *cp3)))))) {
3400 set_vaxc_errno(RMS$_DIR);
3404 else { /* No file type, so just draw name into directory part */
3405 for (cp2 = cp1; *cp2; cp2++) ;
3408 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3410 /* We've now got a VMS 'path'; fall through */
3412 dirfab.fab$b_fns = strlen(dir);
3413 dirfab.fab$l_fna = dir;
3414 if (dir[dirfab.fab$b_fns-1] == ']' ||
3415 dir[dirfab.fab$b_fns-1] == '>' ||
3416 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3417 if (buf) retpath = buf;
3418 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3419 else retpath = __pathify_retbuf;
3420 strcpy(retpath,dir);
3423 dirfab.fab$l_dna = ".DIR;1";
3424 dirfab.fab$b_dns = 6;
3425 dirfab.fab$l_nam = &dirnam;
3426 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3427 dirnam.nam$l_esa = esa;
3429 for (cp = dir; *cp; cp++)
3430 if (islower(*cp)) { haslower = 1; break; }
3432 if (!(sts = (sys$parse(&dirfab)&1))) {
3433 if (dirfab.fab$l_sts == RMS$_DIR) {
3434 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3435 sts = sys$parse(&dirfab) & 1;
3439 set_vaxc_errno(dirfab.fab$l_sts);
3445 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3446 if (dirfab.fab$l_sts != RMS$_FNF) {
3447 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3448 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3450 set_vaxc_errno(dirfab.fab$l_sts);
3453 dirnam = savnam; /* No; just work with potential name */
3456 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3457 /* Yep; check version while we're at it, if it's there. */
3458 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3459 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3460 /* Something other than .DIR[;1]. Bzzt. */
3461 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3462 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3464 set_vaxc_errno(RMS$_DIR);
3468 /* OK, the type was fine. Now pull any file name into the
3470 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3472 cp1 = strrchr(esa,'>');
3473 *dirnam.nam$l_type = '>';
3476 *(dirnam.nam$l_type + 1) = '\0';
3477 retlen = dirnam.nam$l_type - esa + 2;
3478 if (buf) retpath = buf;
3479 else if (ts) New(1314,retpath,retlen,char);
3480 else retpath = __pathify_retbuf;
3481 strcpy(retpath,esa);
3482 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3483 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3484 /* $PARSE may have upcased filespec, so convert output to lower
3485 * case if input contained any lowercase characters. */
3486 if (haslower) __mystrtolower(retpath);
3490 } /* end of do_pathify_dirspec() */
3492 /* External entry points */
3493 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3494 { return do_pathify_dirspec(dir,buf,0); }
3495 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3496 { return do_pathify_dirspec(dir,buf,1); }
3498 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3499 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3501 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3502 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3503 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3504 unsigned short int trnlnm_iter_count;
3506 if (spec == NULL) return NULL;
3507 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3508 if (buf) rslt = buf;
3510 retlen = strlen(spec);
3511 cp1 = strchr(spec,'[');
3512 if (!cp1) cp1 = strchr(spec,'<');
3514 for (cp1++; *cp1; cp1++) {
3515 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3516 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3517 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3520 New(1315,rslt,retlen+2+2*expand,char);
3522 else rslt = __tounixspec_retbuf;
3523 if (strchr(spec,'/') != NULL) {
3530 dirend = strrchr(spec,']');
3531 if (dirend == NULL) dirend = strrchr(spec,'>');
3532 if (dirend == NULL) dirend = strchr(spec,':');
3533 if (dirend == NULL) {
3537 if (*cp2 != '[' && *cp2 != '<') {
3540 else { /* the VMS spec begins with directories */
3542 if (*cp2 == ']' || *cp2 == '>') {
3543 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3546 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3547 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3548 if (ts) Safefree(rslt);
3551 trnlnm_iter_count = 0;
3554 while (*cp3 != ':' && *cp3) cp3++;
3556 if (strchr(cp3,']') != NULL) break;
3557 trnlnm_iter_count++;
3558 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
3559 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3561 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3562 retlen = devlen + dirlen;
3563 Renew(rslt,retlen+1+2*expand,char);
3569 *(cp1++) = *(cp3++);
3570 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3574 else if ( *cp2 == '.') {
3575 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3576 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3582 for (; cp2 <= dirend; cp2++) {
3585 if (*(cp2+1) == '[') cp2++;
3587 else if (*cp2 == ']' || *cp2 == '>') {
3588 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3590 else if (*cp2 == '.') {
3592 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3593 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3594 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3595 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3596 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3598 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3599 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3603 else if (*cp2 == '-') {
3604 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3605 while (*cp2 == '-') {
3607 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3609 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3610 if (ts) Safefree(rslt); /* filespecs like */
3611 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3615 else *(cp1++) = *cp2;
3617 else *(cp1++) = *cp2;
3619 while (*cp2) *(cp1++) = *(cp2++);
3624 } /* end of do_tounixspec() */
3626 /* External entry points */
3627 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3628 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3630 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3631 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3632 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3633 char *rslt, *dirend;
3634 register char *cp1, *cp2;
3635 unsigned long int infront = 0, hasdir = 1;
3637 if (path == NULL) return NULL;
3638 if (buf) rslt = buf;
3639 else if (ts) New(1316,rslt,strlen(path)+9,char);
3640 else rslt = __tovmsspec_retbuf;
3641 if (strpbrk(path,"]:>") ||
3642 (dirend = strrchr(path,'/')) == NULL) {
3643 if (path[0] == '.') {
3644 if (path[1] == '\0') strcpy(rslt,"[]");
3645 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3646 else strcpy(rslt,path); /* probably garbage */
3648 else strcpy(rslt,path);
3651 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3652 if (!*(dirend+2)) dirend +=2;
3653 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3654 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3659 char trndev[NAM$C_MAXRSS+1];
3663 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3665 if (!buf & ts) Renew(rslt,18,char);
3666 strcpy(rslt,"sys$disk:[000000]");
3669 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3671 islnm = my_trnlnm(rslt,trndev,0);
3672 trnend = islnm ? strlen(trndev) - 1 : 0;
3673 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3674 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3675 /* If the first element of the path is a logical name, determine
3676 * whether it has to be translated so we can add more directories. */
3677 if (!islnm || rooted) {
3680 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3684 if (cp2 != dirend) {
3685 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3686 strcpy(rslt,trndev);
3687 cp1 = rslt + trnend;
3700 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3701 cp2 += 2; /* skip over "./" - it's redundant */
3702 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3704 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3705 *(cp1++) = '-'; /* "../" --> "-" */
3708 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3709 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3710 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3711 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3714 if (cp2 > dirend) cp2 = dirend;
3716 else *(cp1++) = '.';
3718 for (; cp2 < dirend; cp2++) {
3720 if (*(cp2-1) == '/') continue;
3721 if (*(cp1-1) != '.') *(cp1++) = '.';
3724 else if (!infront && *cp2 == '.') {
3725 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3726 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3727 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3728 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3729 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3730 else { /* back up over previous directory name */
3732 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3733 if (*(cp1-1) == '[') {
3734 memcpy(cp1,"000000.",7);
3739 if (cp2 == dirend) break;
3741 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3742 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3743 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3744 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3746 *(cp1++) = '.'; /* Simulate trailing '/' */
3747 cp2 += 2; /* for loop will incr this to == dirend */
3749 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3751 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3754 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3755 if (*cp2 == '.') *(cp1++) = '_';
3756 else *(cp1++) = *cp2;
3760 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3761 if (hasdir) *(cp1++) = ']';
3762 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3763 while (*cp2) *(cp1++) = *(cp2++);
3768 } /* end of do_tovmsspec() */
3770 /* External entry points */
3771 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3772 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3774 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3775 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3776 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3778 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3780 if (path == NULL) return NULL;
3781 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3782 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3783 if (buf) return buf;
3785 vmslen = strlen(vmsified);
3786 New(1317,cp,vmslen+1,char);
3787 memcpy(cp,vmsified,vmslen);
3792 strcpy(__tovmspath_retbuf,vmsified);
3793 return __tovmspath_retbuf;
3796 } /* end of do_tovmspath() */
3798 /* External entry points */
3799 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3800 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3803 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3804 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3805 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3807 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3809 if (path == NULL) return NULL;
3810 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3811 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3812 if (buf) return buf;
3814 unixlen = strlen(unixified);
3815 New(1317,cp,unixlen+1,char);
3816 memcpy(cp,unixified,unixlen);
3821 strcpy(__tounixpath_retbuf,unixified);
3822 return __tounixpath_retbuf;
3825 } /* end of do_tounixpath() */
3827 /* External entry points */
3828 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3829 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3832 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3834 *****************************************************************************
3836 * Copyright (C) 1989-1994 by *
3837 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3839 * Permission is hereby granted for the reproduction of this software, *
3840 * on condition that this copyright notice is included in the reproduction, *
3841 * and that such reproduction is not for purposes of profit or material *
3844 * 27-Aug-1994 Modified for inclusion in perl5 *
3845 * by Charles Bailey bailey@newman.upenn.edu *
3846 *****************************************************************************
3850 * getredirection() is intended to aid in porting C programs
3851 * to VMS (Vax-11 C). The native VMS environment does not support
3852 * '>' and '<' I/O redirection, or command line wild card expansion,
3853 * or a command line pipe mechanism using the '|' AND background
3854 * command execution '&'. All of these capabilities are provided to any
3855 * C program which calls this procedure as the first thing in the
3857 * The piping mechanism will probably work with almost any 'filter' type
3858 * of program. With suitable modification, it may useful for other
3859 * portability problems as well.
3861 * Author: Mark Pizzolato mark@infocomm.com
3865 struct list_item *next;
3869 static void add_item(struct list_item **head,
3870 struct list_item **tail,
3874 static void mp_expand_wild_cards(pTHX_ char *item,
3875 struct list_item **head,
3876 struct list_item **tail,
3879 static int background_process(pTHX_ int argc, char **argv);
3881 static void pipe_and_fork(pTHX_ char **cmargv);
3883 /*{{{ void getredirection(int *ac, char ***av)*/
3885 mp_getredirection(pTHX_ int *ac, char ***av)
3887 * Process vms redirection arg's. Exit if any error is seen.
3888 * If getredirection() processes an argument, it is erased
3889 * from the vector. getredirection() returns a new argc and argv value.
3890 * In the event that a background command is requested (by a trailing "&"),
3891 * this routine creates a background subprocess, and simply exits the program.
3893 * Warning: do not try to simplify the code for vms. The code
3894 * presupposes that getredirection() is called before any data is
3895 * read from stdin or written to stdout.
3897 * Normal usage is as follows:
3903 * getredirection(&argc, &argv);
3907 int argc = *ac; /* Argument Count */
3908 char **argv = *av; /* Argument Vector */
3909 char *ap; /* Argument pointer */
3910 int j; /* argv[] index */
3911 int item_count = 0; /* Count of Items in List */
3912 struct list_item *list_head = 0; /* First Item in List */
3913 struct list_item *list_tail; /* Last Item in List */
3914 char *in = NULL; /* Input File Name */
3915 char *out = NULL; /* Output File Name */
3916 char *outmode = "w"; /* Mode to Open Output File */
3917 char *err = NULL; /* Error File Name */
3918 char *errmode = "w"; /* Mode to Open Error File */
3919 int cmargc = 0; /* Piped Command Arg Count */
3920 char **cmargv = NULL;/* Piped Command Arg Vector */
3923 * First handle the case where the last thing on the line ends with
3924 * a '&'. This indicates the desire for the command to be run in a
3925 * subprocess, so we satisfy that desire.
3928 if (0 == strcmp("&", ap))
3929 exit(background_process(aTHX_ --argc, argv));
3930 if (*ap && '&' == ap[strlen(ap)-1])
3932 ap[strlen(ap)-1] = '\0';
3933 exit(background_process(aTHX_ argc, argv));
3936 * Now we handle the general redirection cases that involve '>', '>>',
3937 * '<', and pipes '|'.
3939 for (j = 0; j < argc; ++j)
3941 if (0 == strcmp("<", argv[j]))
3945 fprintf(stderr,"No input file after < on command line");
3946 exit(LIB$_WRONUMARG);
3951 if ('<' == *(ap = argv[j]))
3956 if (0 == strcmp(">", ap))
3960 fprintf(stderr,"No output file after > on command line");
3961 exit(LIB$_WRONUMARG);
3980 fprintf(stderr,"No output file after > or >> on command line");
3981 exit(LIB$_WRONUMARG);
3985 if (('2' == *ap) && ('>' == ap[1]))
4002 fprintf(stderr,"No output file after 2> or 2>> on command line");
4003 exit(LIB$_WRONUMARG);
4007 if (0 == strcmp("|", argv[j]))
4011 fprintf(stderr,"No command into which to pipe on command line");
4012 exit(LIB$_WRONUMARG);
4014 cmargc = argc-(j+1);
4015 cmargv = &argv[j+1];
4019 if ('|' == *(ap = argv[j]))
4027 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4030 * Allocate and fill in the new argument vector, Some Unix's terminate
4031 * the list with an extra null pointer.
4033 New(1302, argv, item_count+1, char *);
4035 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4036 argv[j] = list_head->value;
4042 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4043 exit(LIB$_INVARGORD);
4045 pipe_and_fork(aTHX_ cmargv);
4048 /* Check for input from a pipe (mailbox) */
4050 if (in == NULL && 1 == isapipe(0))
4052 char mbxname[L_tmpnam];
4054 long int dvi_item = DVI$_DEVBUFSIZ;
4055 $DESCRIPTOR(mbxnam, "");
4056 $DESCRIPTOR(mbxdevnam, "");
4058 /* Input from a pipe, reopen it in binary mode to disable */
4059 /* carriage control processing. */
4061 fgetname(stdin, mbxname);
4062 mbxnam.dsc$a_pointer = mbxname;
4063 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4064 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4065 mbxdevnam.dsc$a_pointer = mbxname;
4066 mbxdevnam.dsc$w_length = sizeof(mbxname);
4067 dvi_item = DVI$_DEVNAM;
4068 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4069 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4072 freopen(mbxname, "rb", stdin);
4075 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4079 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4081 fprintf(stderr,"Can't open input file %s as stdin",in);
4084 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4086 fprintf(stderr,"Can't open output file %s as stdout",out);
4089 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4092 if (strcmp(err,"&1") == 0) {
4093 dup2(fileno(stdout), fileno(stderr));
4094 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4097 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4099 fprintf(stderr,"Can't open error file %s as stderr",err);
4103 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4107 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4110 #ifdef ARGPROC_DEBUG
4111 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4112 for (j = 0; j < *ac; ++j)
4113 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4115 /* Clear errors we may have hit expanding wildcards, so they don't
4116 show up in Perl's $! later */
4117 set_errno(0); set_vaxc_errno(1);
4118 } /* end of getredirection() */
4121 static void add_item(struct list_item **head,
4122 struct list_item **tail,
4128 New(1303,*head,1,struct list_item);
4132 New(1304,(*tail)->next,1,struct list_item);
4133 *tail = (*tail)->next;
4135 (*tail)->value = value;
4139 static void mp_expand_wild_cards(pTHX_ char *item,
4140 struct list_item **head,
4141 struct list_item **tail,
4145 unsigned long int context = 0;
4151 char vmsspec[NAM$C_MAXRSS+1];
4152 $DESCRIPTOR(filespec, "");
4153 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4154 $DESCRIPTOR(resultspec, "");
4155 unsigned long int zero = 0, sts;
4157 for (cp = item; *cp; cp++) {
4158 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4159 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4161 if (!*cp || isspace(*cp))
4163 add_item(head, tail, item, count);
4166 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4167 resultspec.dsc$b_class = DSC$K_CLASS_D;
4168 resultspec.dsc$a_pointer = NULL;
4169 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4170 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4171 if (!isunix || !filespec.dsc$a_pointer)
4172 filespec.dsc$a_pointer = item;
4173 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4175 * Only return version specs, if the caller specified a version
4177 had_version = strchr(item, ';');
4179 * Only return device and directory specs, if the caller specifed either.
4181 had_device = strchr(item, ':');
4182 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4184 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4185 &defaultspec, 0, 0, &zero))))
4190 New(1305,string,resultspec.dsc$w_length+1,char);
4191 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4192 string[resultspec.dsc$w_length] = '\0';
4193 if (NULL == had_version)
4194 *((char *)strrchr(string, ';')) = '\0';
4195 if ((!had_directory) && (had_device == NULL))
4197 if (NULL == (devdir = strrchr(string, ']')))
4198 devdir = strrchr(string, '>');
4199 strcpy(string, devdir + 1);
4202 * Be consistent with what the C RTL has already done to the rest of
4203 * the argv items and lowercase all of these names.
4205 for (c = string; *c; ++c)
4208 if (isunix) trim_unixpath(string,item,1);
4209 add_item(head, tail, string, count);
4212 if (sts != RMS$_NMF)
4214 set_vaxc_errno(sts);
4217 case RMS$_FNF: case RMS$_DNF:
4218 set_errno(ENOENT); break;
4220 set_errno(ENOTDIR); break;
4222 set_errno(ENODEV); break;
4223 case RMS$_FNM: case RMS$_SYN:
4224 set_errno(EINVAL); break;
4226 set_errno(EACCES); break;
4228 _ckvmssts_noperl(sts);
4232 add_item(head, tail, item, count);
4233 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4234 _ckvmssts_noperl(lib$find_file_end(&context));
4237 static int child_st[2];/* Event Flag set when child process completes */
4239 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4241 static unsigned long int exit_handler(int *status)
4245 if (0 == child_st[0])
4247 #ifdef ARGPROC_DEBUG
4248 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4250 fflush(stdout); /* Have to flush pipe for binary data to */
4251 /* terminate properly -- <tp@mccall.com> */
4252 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4253 sys$dassgn(child_chan);
4255 sys$synch(0, child_st);
4260 static void sig_child(int chan)
4262 #ifdef ARGPROC_DEBUG
4263 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4265 if (child_st[0] == 0)
4269 static struct exit_control_block exit_block =
4274 &exit_block.exit_status,
4279 pipe_and_fork(pTHX_ char **cmargv)
4282 struct dsc$descriptor_s *vmscmd;
4283 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4284 int sts, j, l, ismcr, quote, tquote = 0;
4286 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4287 vms_execfree(vmscmd);
4292 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4293 && toupper(*(q+2)) == 'R' && !*(q+3);
4295 while (q && l < MAX_DCL_LINE_LENGTH) {
4297 if (j > 0 && quote) {
4303 if (ismcr && j > 1) quote = 1;
4304 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4307 if (quote || tquote) {
4313 if ((quote||tquote) && *q == '"') {
4323 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4325 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4329 static int background_process(pTHX_ int argc, char **argv)
4331 char command[2048] = "$";
4332 $DESCRIPTOR(value, "");
4333 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4334 static $DESCRIPTOR(null, "NLA0:");
4335 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4337 $DESCRIPTOR(pidstr, "");
4339 unsigned long int flags = 17, one = 1, retsts;
4341 strcat(command, argv[0]);
4344 strcat(command, " \"");
4345 strcat(command, *(++argv));
4346 strcat(command, "\"");
4348 value.dsc$a_pointer = command;
4349 value.dsc$w_length = strlen(value.dsc$a_pointer);
4350 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4351 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4352 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4353 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4356 _ckvmssts_noperl(retsts);
4358 #ifdef ARGPROC_DEBUG
4359 PerlIO_printf(Perl_debug_log, "%s\n", command);
4361 sprintf(pidstring, "%08X", pid);
4362 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4363 pidstr.dsc$a_pointer = pidstring;
4364 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4365 lib$set_symbol(&pidsymbol, &pidstr);
4369 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4372 /* OS-specific initialization at image activation (not thread startup) */
4373 /* Older VAXC header files lack these constants */
4374 #ifndef JPI$_RIGHTS_SIZE
4375 # define JPI$_RIGHTS_SIZE 817
4377 #ifndef KGB$M_SUBSYSTEM
4378 # define KGB$M_SUBSYSTEM 0x8
4381 /*{{{void vms_image_init(int *, char ***)*/
4383 vms_image_init(int *argcp, char ***argvp)
4385 char eqv[LNM$C_NAMLENGTH+1] = "";
4386 unsigned int len, tabct = 8, tabidx = 0;
4387 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4388 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4389 unsigned short int dummy, rlen;
4390 struct dsc$descriptor_s **tabvec;
4391 #if defined(PERL_IMPLICIT_CONTEXT)
4394 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4395 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4396 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4399 #ifdef KILL_BY_SIGPRC
4400 (void) Perl_csighandler_init();
4403 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4404 _ckvmssts_noperl(iosb[0]);
4405 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4406 if (iprv[i]) { /* Running image installed with privs? */
4407 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4412 /* Rights identifiers might trigger tainting as well. */
4413 if (!will_taint && (rlen || rsz)) {
4414 while (rlen < rsz) {
4415 /* We didn't get all the identifiers on the first pass. Allocate a
4416 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4417 * were needed to hold all identifiers at time of last call; we'll
4418 * allocate that many unsigned long ints), and go back and get 'em.
4419 * If it gave us less than it wanted to despite ample buffer space,
4420 * something's broken. Is your system missing a system identifier?
4422 if (rsz <= jpilist[1].buflen) {
4423 /* Perl_croak accvios when used this early in startup. */
4424 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4425 rsz, (unsigned long) jpilist[1].buflen,
4426 "Check your rights database for corruption.\n");
4429 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4430 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4431 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4432 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4433 _ckvmssts_noperl(iosb[0]);
4435 mask = jpilist[1].bufadr;
4436 /* Check attribute flags for each identifier (2nd longword); protected
4437 * subsystem identifiers trigger tainting.
4439 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4440 if (mask[i] & KGB$M_SUBSYSTEM) {
4445 if (mask != rlst) Safefree(mask);
4447 /* We need to use this hack to tell Perl it should run with tainting,
4448 * since its tainting flag may be part of the PL_curinterp struct, which
4449 * hasn't been allocated when vms_image_init() is called.
4453 New(1320,newap,*argcp+2,char **);
4454 newap[0] = argvp[0];
4456 Copy(argvp[1],newap[2],*argcp-1,char **);
4457 /* We orphan the old argv, since we don't know where it's come from,
4458 * so we don't know how to free it.
4460 *argcp++; argvp = newap;
4462 else { /* Did user explicitly request tainting? */
4464 char *cp, **av = *argvp;
4465 for (i = 1; i < *argcp; i++) {
4466 if (*av[i] != '-') break;
4467 for (cp = av[i]+1; *cp; cp++) {
4468 if (*cp == 'T') { will_taint = 1; break; }
4469 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4470 strchr("DFIiMmx",*cp)) break;
4472 if (will_taint) break;
4477 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4479 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4480 else if (tabidx >= tabct) {
4482 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4484 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4485 tabvec[tabidx]->dsc$w_length = 0;
4486 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4487 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4488 tabvec[tabidx]->dsc$a_pointer = NULL;
4489 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4491 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4493 getredirection(argcp,argvp);
4500 * Trim Unix-style prefix off filespec, so it looks like what a shell
4501 * glob expansion would return (i.e. from specified prefix on, not
4502 * full path). Note that returned filespec is Unix-style, regardless
4503 * of whether input filespec was VMS-style or Unix-style.
4505 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4506 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4507 * vector of options; at present, only bit 0 is used, and if set tells
4508 * trim unixpath to try the current default directory as a prefix when
4509 * presented with a possibly ambiguous ... wildcard.
4511 * Returns !=0 on success, with trimmed filespec replacing contents of
4512 * fspec, and 0 on failure, with contents of fpsec unchanged.
4514 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4516 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4518 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4519 *template, *base, *end, *cp1, *cp2;
4520 register int tmplen, reslen = 0, dirs = 0;
4522 if (!wildspec || !fspec) return 0;
4523 if (strpbrk(wildspec,"]>:") != NULL) {
4524 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4525 else template = unixwild;
4527 else template = wildspec;
4528 if (strpbrk(fspec,"]>:") != NULL) {
4529 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4530 else base = unixified;
4531 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4532 * check to see that final result fits into (isn't longer than) fspec */
4533 reslen = strlen(fspec);
4537 /* No prefix or absolute path on wildcard, so nothing to remove */
4538 if (!*template || *template == '/') {
4539 if (base == fspec) return 1;
4540 tmplen = strlen(unixified);
4541 if (tmplen > reslen) return 0; /* not enough space */
4542 /* Copy unixified resultant, including trailing NUL */
4543 memmove(fspec,unixified,tmplen+1);
4547 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4548 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4549 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4550 for (cp1 = end ;cp1 >= base; cp1--)
4551 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4553 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4557 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4558 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4559 int ells = 1, totells, segdirs, match;
4560 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4561 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4563 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4565 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4566 if (ellipsis == template && opts & 1) {
4567 /* Template begins with an ellipsis. Since we can't tell how many
4568 * directory names at the front of the resultant to keep for an
4569 * arbitrary starting point, we arbitrarily choose the current
4570 * default directory as a starting point. If it's there as a prefix,
4571 * clip it off. If not, fall through and act as if the leading
4572 * ellipsis weren't there (i.e. return shortest possible path that
4573 * could match template).
4575 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4576 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4577 if (_tolower(*cp1) != _tolower(*cp2)) break;
4578 segdirs = dirs - totells; /* Min # of dirs we must have left */
4579 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4580 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4581 memcpy(fspec,cp2+1,end - cp2);
4585 /* First off, back up over constant elements at end of path */
4587 for (front = end ; front >= base; front--)
4588 if (*front == '/' && !dirs--) { front++; break; }
4590 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4591 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4592 if (cp1 != '\0') return 0; /* Path too long. */
4594 *cp2 = '\0'; /* Pick up with memcpy later */
4595 lcfront = lcres + (front - base);
4596 /* Now skip over each ellipsis and try to match the path in front of it. */
4598 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4599 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4600 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4601 if (cp1 < template) break; /* template started with an ellipsis */
4602 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4603 ellipsis = cp1; continue;
4605 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4607 for (segdirs = 0, cp2 = tpl;
4608 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4610 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4611 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4612 if (*cp2 == '/') segdirs++;
4614 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4615 /* Back up at least as many dirs as in template before matching */
4616 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4617 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4618 for (match = 0; cp1 > lcres;) {
4619 resdsc.dsc$a_pointer = cp1;
4620 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4622 if (match == 1) lcfront = cp1;
4624 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4626 if (!match) return 0; /* Can't find prefix ??? */
4627 if (match > 1 && opts & 1) {
4628 /* This ... wildcard could cover more than one set of dirs (i.e.
4629 * a set of similar dir names is repeated). If the template
4630 * contains more than 1 ..., upstream elements could resolve the
4631 * ambiguity, but it's not worth a full backtracking setup here.
4632 * As a quick heuristic, clip off the current default directory
4633 * if it's present to find the trimmed spec, else use the
4634 * shortest string that this ... could cover.
4636 char def[NAM$C_MAXRSS+1], *st;
4638 if (getcwd(def, sizeof def,0) == NULL) return 0;
4639 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4640 if (_tolower(*cp1) != _tolower(*cp2)) break;
4641 segdirs = dirs - totells; /* Min # of dirs we must have left */
4642 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4643 if (*cp1 == '\0' && *cp2 == '/') {
4644 memcpy(fspec,cp2+1,end - cp2);
4647 /* Nope -- stick with lcfront from above and keep going. */
4650 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4655 } /* end of trim_unixpath() */
4660 * VMS readdir() routines.
4661 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4663 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4664 * Minor modifications to original routines.
4667 /* Number of elements in vms_versions array */
4668 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4671 * Open a directory, return a handle for later use.
4673 /*{{{ DIR *opendir(char*name) */
4675 Perl_opendir(pTHX_ char *name)
4678 char dir[NAM$C_MAXRSS+1];
4681 if (do_tovmspath(name,dir,0) == NULL) {
4684 /* Check access before stat; otherwise stat does not
4685 * accurately report whether it's a directory.
4687 if (!cando_by_name(S_IRUSR,0,dir)) {
4688 /* cando_by_name has already set errno */
4691 if (flex_stat(dir,&sb) == -1) return NULL;
4692 if (!S_ISDIR(sb.st_mode)) {
4693 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4696 /* Get memory for the handle, and the pattern. */
4698 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4700 /* Fill in the fields; mainly playing with the descriptor. */
4701 (void)sprintf(dd->pattern, "%s*.*",dir);
4704 dd->vms_wantversions = 0;
4705 dd->pat.dsc$a_pointer = dd->pattern;
4706 dd->pat.dsc$w_length = strlen(dd->pattern);
4707 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4708 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4711 } /* end of opendir() */
4715 * Set the flag to indicate we want versions or not.
4717 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4719 vmsreaddirversions(DIR *dd, int flag)
4721 dd->vms_wantversions = flag;
4726 * Free up an opened directory.
4728 /*{{{ void closedir(DIR *dd)*/
4732 (void)lib$find_file_end(&dd->context);
4733 Safefree(dd->pattern);
4734 Safefree((char *)dd);
4739 * Collect all the version numbers for the current file.
4742 collectversions(pTHX_ DIR *dd)
4744 struct dsc$descriptor_s pat;
4745 struct dsc$descriptor_s res;
4747 char *p, *text, buff[sizeof dd->entry.d_name];
4749 unsigned long context, tmpsts;
4751 /* Convenient shorthand. */
4754 /* Add the version wildcard, ignoring the "*.*" put on before */
4755 i = strlen(dd->pattern);
4756 New(1308,text,i + e->d_namlen + 3,char);
4757 (void)strcpy(text, dd->pattern);
4758 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4760 /* Set up the pattern descriptor. */
4761 pat.dsc$a_pointer = text;
4762 pat.dsc$w_length = i + e->d_namlen - 1;
4763 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4764 pat.dsc$b_class = DSC$K_CLASS_S;
4766 /* Set up result descriptor. */
4767 res.dsc$a_pointer = buff;
4768 res.dsc$w_length = sizeof buff - 2;
4769 res.dsc$b_dtype = DSC$K_DTYPE_T;
4770 res.dsc$b_class = DSC$K_CLASS_S;
4772 /* Read files, collecting versions. */
4773 for (context = 0, e->vms_verscount = 0;
4774 e->vms_verscount < VERSIZE(e);
4775 e->vms_verscount++) {
4776 tmpsts = lib$find_file(&pat, &res, &context);
4777 if (tmpsts == RMS$_NMF || context == 0) break;
4779 buff[sizeof buff - 1] = '\0';
4780 if ((p = strchr(buff, ';')))
4781 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4783 e->vms_versions[e->vms_verscount] = -1;
4786 _ckvmssts(lib$find_file_end(&context));
4789 } /* end of collectversions() */
4792 * Read the next entry from the directory.
4794 /*{{{ struct dirent *readdir(DIR *dd)*/
4796 Perl_readdir(pTHX_ DIR *dd)
4798 struct dsc$descriptor_s res;
4799 char *p, buff[sizeof dd->entry.d_name];
4800 unsigned long int tmpsts;
4802 /* Set up result descriptor, and get next file. */
4803 res.dsc$a_pointer = buff;
4804 res.dsc$w_length = sizeof buff - 2;
4805 res.dsc$b_dtype = DSC$K_DTYPE_T;
4806 res.dsc$b_class = DSC$K_CLASS_S;
4807 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4808 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4809 if (!(tmpsts & 1)) {
4810 set_vaxc_errno(tmpsts);
4813 set_errno(EACCES); break;
4815 set_errno(ENODEV); break;
4817 set_errno(ENOTDIR); break;
4818 case RMS$_FNF: case RMS$_DNF:
4819 set_errno(ENOENT); break;
4826 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4827 buff[sizeof buff - 1] = '\0';
4828 for (p = buff; *p; p++) *p = _tolower(*p);
4829 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4832 /* Skip any directory component and just copy the name. */
4833 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4834 else (void)strcpy(dd->entry.d_name, buff);
4836 /* Clobber the version. */
4837 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4839 dd->entry.d_namlen = strlen(dd->entry.d_name);
4840 dd->entry.vms_verscount = 0;
4841 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4844 } /* end of readdir() */
4848 * Return something that can be used in a seekdir later.
4850 /*{{{ long telldir(DIR *dd)*/
4859 * Return to a spot where we used to be. Brute force.
4861 /*{{{ void seekdir(DIR *dd,long count)*/
4863 Perl_seekdir(pTHX_ DIR *dd, long count)
4865 int vms_wantversions;
4867 /* If we haven't done anything yet... */
4871 /* Remember some state, and clear it. */
4872 vms_wantversions = dd->vms_wantversions;
4873 dd->vms_wantversions = 0;
4874 _ckvmssts(lib$find_file_end(&dd->context));
4877 /* The increment is in readdir(). */
4878 for (dd->count = 0; dd->count < count; )
4881 dd->vms_wantversions = vms_wantversions;
4883 } /* end of seekdir() */
4886 /* VMS subprocess management
4888 * my_vfork() - just a vfork(), after setting a flag to record that
4889 * the current script is trying a Unix-style fork/exec.
4891 * vms_do_aexec() and vms_do_exec() are called in response to the
4892 * perl 'exec' function. If this follows a vfork call, then they
4893 * call out the the regular perl routines in doio.c which do an
4894 * execvp (for those who really want to try this under VMS).
4895 * Otherwise, they do exactly what the perl docs say exec should
4896 * do - terminate the current script and invoke a new command
4897 * (See below for notes on command syntax.)
4899 * do_aspawn() and do_spawn() implement the VMS side of the perl
4900 * 'system' function.
4902 * Note on command arguments to perl 'exec' and 'system': When handled
4903 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4904 * are concatenated to form a DCL command string. If the first arg
4905 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4906 * the the command string is handed off to DCL directly. Otherwise,
4907 * the first token of the command is taken as the filespec of an image
4908 * to run. The filespec is expanded using a default type of '.EXE' and
4909 * the process defaults for device, directory, etc., and if found, the resultant
4910 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4911 * the command string as parameters. This is perhaps a bit complicated,
4912 * but I hope it will form a happy medium between what VMS folks expect
4913 * from lib$spawn and what Unix folks expect from exec.
4916 static int vfork_called;
4918 /*{{{int my_vfork()*/
4929 vms_execfree(struct dsc$descriptor_s *vmscmd)
4932 if (vmscmd->dsc$a_pointer) {
4933 Safefree(vmscmd->dsc$a_pointer);
4940 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4942 char *junk, *tmps = Nullch;
4943 register size_t cmdlen = 0;
4950 tmps = SvPV(really,rlen);
4957 for (idx++; idx <= sp; idx++) {
4959 junk = SvPVx(*idx,rlen);
4960 cmdlen += rlen ? rlen + 1 : 0;
4963 New(401,PL_Cmd,cmdlen+1,char);
4965 if (tmps && *tmps) {
4966 strcpy(PL_Cmd,tmps);
4969 else *PL_Cmd = '\0';
4970 while (++mark <= sp) {
4972 char *s = SvPVx(*mark,n_a);
4974 if (*PL_Cmd) strcat(PL_Cmd," ");
4980 } /* end of setup_argstr() */
4983 static unsigned long int
4984 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
4985 struct dsc$descriptor_s **pvmscmd)
4987 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4988 $DESCRIPTOR(defdsc,".EXE");
4989 $DESCRIPTOR(defdsc2,".");
4990 $DESCRIPTOR(resdsc,resspec);
4991 struct dsc$descriptor_s *vmscmd;
4992 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4993 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4994 register char *s, *rest, *cp, *wordbreak;
4997 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
4998 vmscmd->dsc$a_pointer = NULL;
4999 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5000 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5001 vmscmd->dsc$w_length = 0;
5002 if (pvmscmd) *pvmscmd = vmscmd;
5004 if (suggest_quote) *suggest_quote = 0;
5006 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5007 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5009 while (*s && isspace(*s)) s++;
5011 if (*s == '@' || *s == '$') {
5012 vmsspec[0] = *s; rest = s + 1;
5013 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5015 else { cp = vmsspec; rest = s; }
5016 if (*rest == '.' || *rest == '/') {
5019 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5020 rest++, cp2++) *cp2 = *rest;
5022 if (do_tovmsspec(resspec,cp,0)) {
5025 for (cp2 = vmsspec + strlen(vmsspec);
5026 *rest && cp2 - vmsspec < sizeof vmsspec;
5027 rest++, cp2++) *cp2 = *rest;
5032 /* Intuit whether verb (first word of cmd) is a DCL command:
5033 * - if first nonspace char is '@', it's a DCL indirection
5035 * - if verb contains a filespec separator, it's not a DCL command
5036 * - if it doesn't, caller tells us whether to default to a DCL
5037 * command, or to a local image unless told it's DCL (by leading '$')
5041 if (suggest_quote) *suggest_quote = 1;
5043 register char *filespec = strpbrk(s,":<[.;");
5044 rest = wordbreak = strpbrk(s," \"\t/");
5045 if (!wordbreak) wordbreak = s + strlen(s);
5046 if (*s == '$') check_img = 0;
5047 if (filespec && (filespec < wordbreak)) isdcl = 0;
5048 else isdcl = !check_img;
5052 imgdsc.dsc$a_pointer = s;
5053 imgdsc.dsc$w_length = wordbreak - s;
5054 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5056 _ckvmssts(lib$find_file_end(&cxt));
5057 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5058 if (!(retsts & 1) && *s == '$') {
5059 _ckvmssts(lib$find_file_end(&cxt));
5060 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5061 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5063 _ckvmssts(lib$find_file_end(&cxt));
5064 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5068 _ckvmssts(lib$find_file_end(&cxt));
5073 while (*s && !isspace(*s)) s++;
5076 /* check that it's really not DCL with no file extension */
5077 fp = fopen(resspec,"r","ctx=bin,shr=get");
5079 char b[4] = {0,0,0,0};
5080 read(fileno(fp),b,4);
5081 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5084 if (check_img && isdcl) return RMS$_FNF;
5086 if (cando_by_name(S_IXUSR,0,resspec)) {
5087 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5089 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5090 if (suggest_quote) *suggest_quote = 1;
5092 strcpy(vmscmd->dsc$a_pointer,"@");
5093 if (suggest_quote) *suggest_quote = 1;
5095 strcat(vmscmd->dsc$a_pointer,resspec);
5096 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5097 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5098 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5100 else retsts = RMS$_PRV;
5103 /* It's either a DCL command or we couldn't find a suitable image */
5104 vmscmd->dsc$w_length = strlen(cmd);
5105 /* if (cmd == PL_Cmd) {
5106 vmscmd->dsc$a_pointer = PL_Cmd;
5107 if (suggest_quote) *suggest_quote = 1;
5110 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5112 /* check if it's a symbol (for quoting purposes) */
5113 if (suggest_quote && !*suggest_quote) {
5115 char equiv[LNM$C_NAMLENGTH];
5116 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5117 eqvdsc.dsc$a_pointer = equiv;
5119 iss = lib$get_symbol(vmscmd,&eqvdsc);
5120 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5122 if (!(retsts & 1)) {
5123 /* just hand off status values likely to be due to user error */
5124 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5125 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5126 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5127 else { _ckvmssts(retsts); }
5130 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5132 } /* end of setup_cmddsc() */
5135 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5137 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5140 if (vfork_called) { /* this follows a vfork - act Unixish */
5142 if (vfork_called < 0) {
5143 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5146 else return do_aexec(really,mark,sp);
5148 /* no vfork - act VMSish */
5149 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5154 } /* end of vms_do_aexec() */
5157 /* {{{bool vms_do_exec(char *cmd) */
5159 Perl_vms_do_exec(pTHX_ char *cmd)
5161 struct dsc$descriptor_s *vmscmd;
5163 if (vfork_called) { /* this follows a vfork - act Unixish */
5165 if (vfork_called < 0) {
5166 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5169 else return do_exec(cmd);
5172 { /* no vfork - act VMSish */
5173 unsigned long int retsts;
5176 TAINT_PROPER("exec");
5177 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5178 retsts = lib$do_command(vmscmd);
5181 case RMS$_FNF: case RMS$_DNF:
5182 set_errno(ENOENT); break;
5184 set_errno(ENOTDIR); break;
5186 set_errno(ENODEV); break;
5188 set_errno(EACCES); break;
5190 set_errno(EINVAL); break;
5191 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5192 set_errno(E2BIG); break;
5193 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5194 _ckvmssts(retsts); /* fall through */
5195 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5198 set_vaxc_errno(retsts);
5199 if (ckWARN(WARN_EXEC)) {
5200 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5201 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5203 vms_execfree(vmscmd);
5208 } /* end of vms_do_exec() */
5211 unsigned long int Perl_do_spawn(pTHX_ char *);
5213 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5215 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5217 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5220 } /* end of do_aspawn() */
5223 /* {{{unsigned long int do_spawn(char *cmd) */
5225 Perl_do_spawn(pTHX_ char *cmd)
5227 unsigned long int sts, substs;
5230 TAINT_PROPER("spawn");
5231 if (!cmd || !*cmd) {
5232 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5235 case RMS$_FNF: case RMS$_DNF:
5236 set_errno(ENOENT); break;
5238 set_errno(ENOTDIR); break;
5240 set_errno(ENODEV); break;
5242 set_errno(EACCES); break;
5244 set_errno(EINVAL); break;
5245 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5246 set_errno(E2BIG); break;
5247 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5248 _ckvmssts(sts); /* fall through */
5249 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5252 set_vaxc_errno(sts);
5253 if (ckWARN(WARN_EXEC)) {
5254 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5261 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5264 } /* end of do_spawn() */
5268 static unsigned int *sockflags, sockflagsize;
5271 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5272 * routines found in some versions of the CRTL can't deal with sockets.
5273 * We don't shim the other file open routines since a socket isn't
5274 * likely to be opened by a name.
5276 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5277 FILE *my_fdopen(int fd, const char *mode)
5279 FILE *fp = fdopen(fd, (char *) mode);
5282 unsigned int fdoff = fd / sizeof(unsigned int);
5283 struct stat sbuf; /* native stat; we don't need flex_stat */
5284 if (!sockflagsize || fdoff > sockflagsize) {
5285 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5286 else New (1324,sockflags,fdoff+2,unsigned int);
5287 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5288 sockflagsize = fdoff + 2;
5290 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5291 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5300 * Clear the corresponding bit when the (possibly) socket stream is closed.
5301 * There still a small hole: we miss an implicit close which might occur
5302 * via freopen(). >> Todo
5304 /*{{{ int my_fclose(FILE *fp)*/
5305 int my_fclose(FILE *fp) {
5307 unsigned int fd = fileno(fp);
5308 unsigned int fdoff = fd / sizeof(unsigned int);
5310 if (sockflagsize && fdoff <= sockflagsize)
5311 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5319 * A simple fwrite replacement which outputs itmsz*nitm chars without
5320 * introducing record boundaries every itmsz chars.
5321 * We are using fputs, which depends on a terminating null. We may
5322 * well be writing binary data, so we need to accommodate not only
5323 * data with nulls sprinkled in the middle but also data with no null
5326 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5328 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5330 register char *cp, *end, *cpd, *data;
5331 register unsigned int fd = fileno(dest);
5332 register unsigned int fdoff = fd / sizeof(unsigned int);
5334 int bufsize = itmsz * nitm + 1;
5336 if (fdoff < sockflagsize &&
5337 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5338 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5342 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5343 memcpy( data, src, itmsz*nitm );
5344 data[itmsz*nitm] = '\0';
5346 end = data + itmsz * nitm;
5347 retval = (int) nitm; /* on success return # items written */
5350 while (cpd <= end) {
5351 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5352 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5354 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5358 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5361 } /* end of my_fwrite() */
5364 /*{{{ int my_flush(FILE *fp)*/
5366 Perl_my_flush(pTHX_ FILE *fp)
5369 if ((res = fflush(fp)) == 0 && fp) {
5370 #ifdef VMS_DO_SOCKETS
5372 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5374 res = fsync(fileno(fp));
5377 * If the flush succeeded but set end-of-file, we need to clear
5378 * the error because our caller may check ferror(). BTW, this
5379 * probably means we just flushed an empty file.
5381 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5388 * Here are replacements for the following Unix routines in the VMS environment:
5389 * getpwuid Get information for a particular UIC or UID
5390 * getpwnam Get information for a named user
5391 * getpwent Get information for each user in the rights database
5392 * setpwent Reset search to the start of the rights database
5393 * endpwent Finish searching for users in the rights database
5395 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5396 * (defined in pwd.h), which contains the following fields:-
5398 * char *pw_name; Username (in lower case)
5399 * char *pw_passwd; Hashed password
5400 * unsigned int pw_uid; UIC
5401 * unsigned int pw_gid; UIC group number
5402 * char *pw_unixdir; Default device/directory (VMS-style)
5403 * char *pw_gecos; Owner name
5404 * char *pw_dir; Default device/directory (Unix-style)
5405 * char *pw_shell; Default CLI name (eg. DCL)
5407 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5409 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5410 * not the UIC member number (eg. what's returned by getuid()),
5411 * getpwuid() can accept either as input (if uid is specified, the caller's
5412 * UIC group is used), though it won't recognise gid=0.
5414 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5415 * information about other users in your group or in other groups, respectively.
5416 * If the required privilege is not available, then these routines fill only
5417 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5420 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5423 /* sizes of various UAF record fields */
5424 #define UAI$S_USERNAME 12
5425 #define UAI$S_IDENT 31
5426 #define UAI$S_OWNER 31
5427 #define UAI$S_DEFDEV 31
5428 #define UAI$S_DEFDIR 63
5429 #define UAI$S_DEFCLI 31
5432 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5433 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5434 (uic).uic$v_group != UIC$K_WILD_GROUP)
5436 static char __empty[]= "";
5437 static struct passwd __passwd_empty=
5438 {(char *) __empty, (char *) __empty, 0, 0,
5439 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5440 static int contxt= 0;
5441 static struct passwd __pwdcache;
5442 static char __pw_namecache[UAI$S_IDENT+1];
5445 * This routine does most of the work extracting the user information.
5447 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5450 unsigned char length;
5451 char pw_gecos[UAI$S_OWNER+1];
5453 static union uicdef uic;
5455 unsigned char length;
5456 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5459 unsigned char length;
5460 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5463 unsigned char length;
5464 char pw_shell[UAI$S_DEFCLI+1];
5466 static char pw_passwd[UAI$S_PWD+1];
5468 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5469 struct dsc$descriptor_s name_desc;
5470 unsigned long int sts;
5472 static struct itmlst_3 itmlst[]= {
5473 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5474 {sizeof(uic), UAI$_UIC, &uic, &luic},
5475 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5476 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5477 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5478 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5479 {0, 0, NULL, NULL}};
5481 name_desc.dsc$w_length= strlen(name);
5482 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5483 name_desc.dsc$b_class= DSC$K_CLASS_S;
5484 name_desc.dsc$a_pointer= (char *) name;
5486 /* Note that sys$getuai returns many fields as counted strings. */
5487 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5488 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5489 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5491 else { _ckvmssts(sts); }
5492 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5494 if ((int) owner.length < lowner) lowner= (int) owner.length;
5495 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5496 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5497 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5498 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5499 owner.pw_gecos[lowner]= '\0';
5500 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5501 defcli.pw_shell[ldefcli]= '\0';
5502 if (valid_uic(uic)) {
5503 pwd->pw_uid= uic.uic$l_uic;
5504 pwd->pw_gid= uic.uic$v_group;
5507 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5508 pwd->pw_passwd= pw_passwd;
5509 pwd->pw_gecos= owner.pw_gecos;
5510 pwd->pw_dir= defdev.pw_dir;
5511 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5512 pwd->pw_shell= defcli.pw_shell;
5513 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5515 ldir= strlen(pwd->pw_unixdir) - 1;
5516 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5519 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5520 __mystrtolower(pwd->pw_unixdir);
5525 * Get information for a named user.
5527 /*{{{struct passwd *getpwnam(char *name)*/
5528 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5530 struct dsc$descriptor_s name_desc;
5532 unsigned long int status, sts;
5534 __pwdcache = __passwd_empty;
5535 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5536 /* We still may be able to determine pw_uid and pw_gid */
5537 name_desc.dsc$w_length= strlen(name);
5538 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5539 name_desc.dsc$b_class= DSC$K_CLASS_S;
5540 name_desc.dsc$a_pointer= (char *) name;
5541 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5542 __pwdcache.pw_uid= uic.uic$l_uic;
5543 __pwdcache.pw_gid= uic.uic$v_group;
5546 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5547 set_vaxc_errno(sts);
5548 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5551 else { _ckvmssts(sts); }
5554 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5555 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5556 __pwdcache.pw_name= __pw_namecache;
5558 } /* end of my_getpwnam() */
5562 * Get information for a particular UIC or UID.
5563 * Called by my_getpwent with uid=-1 to list all users.
5565 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5566 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5568 const $DESCRIPTOR(name_desc,__pw_namecache);
5569 unsigned short lname;
5571 unsigned long int status;
5573 if (uid == (unsigned int) -1) {
5575 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5576 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5577 set_vaxc_errno(status);
5578 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5582 else { _ckvmssts(status); }
5583 } while (!valid_uic (uic));
5587 if (!uic.uic$v_group)
5588 uic.uic$v_group= PerlProc_getgid();
5590 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5591 else status = SS$_IVIDENT;
5592 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5593 status == RMS$_PRV) {
5594 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5597 else { _ckvmssts(status); }
5599 __pw_namecache[lname]= '\0';
5600 __mystrtolower(__pw_namecache);
5602 __pwdcache = __passwd_empty;
5603 __pwdcache.pw_name = __pw_namecache;
5605 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5606 The identifier's value is usually the UIC, but it doesn't have to be,
5607 so if we can, we let fillpasswd update this. */
5608 __pwdcache.pw_uid = uic.uic$l_uic;
5609 __pwdcache.pw_gid = uic.uic$v_group;
5611 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5614 } /* end of my_getpwuid() */
5618 * Get information for next user.
5620 /*{{{struct passwd *my_getpwent()*/
5621 struct passwd *Perl_my_getpwent(pTHX)
5623 return (my_getpwuid((unsigned int) -1));
5628 * Finish searching rights database for users.
5630 /*{{{void my_endpwent()*/
5631 void Perl_my_endpwent(pTHX)
5634 _ckvmssts(sys$finish_rdb(&contxt));
5640 #ifdef HOMEGROWN_POSIX_SIGNALS
5641 /* Signal handling routines, pulled into the core from POSIX.xs.
5643 * We need these for threads, so they've been rolled into the core,
5644 * rather than left in POSIX.xs.
5646 * (DRS, Oct 23, 1997)
5649 /* sigset_t is atomic under VMS, so these routines are easy */
5650 /*{{{int my_sigemptyset(sigset_t *) */
5651 int my_sigemptyset(sigset_t *set) {
5652 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5658 /*{{{int my_sigfillset(sigset_t *)*/
5659 int my_sigfillset(sigset_t *set) {
5661 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5662 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5668 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5669 int my_sigaddset(sigset_t *set, int sig) {
5670 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5671 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5672 *set |= (1 << (sig - 1));
5678 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5679 int my_sigdelset(sigset_t *set, int sig) {
5680 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5681 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5682 *set &= ~(1 << (sig - 1));
5688 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5689 int my_sigismember(sigset_t *set, int sig) {
5690 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5691 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5692 return *set & (1 << (sig - 1));
5697 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5698 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5701 /* If set and oset are both null, then things are badly wrong. Bail out. */
5702 if ((oset == NULL) && (set == NULL)) {
5703 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5707 /* If set's null, then we're just handling a fetch. */
5709 tempmask = sigblock(0);
5714 tempmask = sigsetmask(*set);
5717 tempmask = sigblock(*set);
5720 tempmask = sigblock(0);
5721 sigsetmask(*oset & ~tempmask);
5724 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5729 /* Did they pass us an oset? If so, stick our holding mask into it */
5736 #endif /* HOMEGROWN_POSIX_SIGNALS */
5739 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5740 * my_utime(), and flex_stat(), all of which operate on UTC unless
5741 * VMSISH_TIMES is true.
5743 /* method used to handle UTC conversions:
5744 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5746 static int gmtime_emulation_type;
5747 /* number of secs to add to UTC POSIX-style time to get local time */
5748 static long int utc_offset_secs;
5750 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5751 * in vmsish.h. #undef them here so we can call the CRTL routines
5760 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5761 * qualifier with the extern prefix pragma. This provisional
5762 * hack circumvents this prefix pragma problem in previous
5765 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5766 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5767 # pragma __extern_prefix save
5768 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5769 # define gmtime decc$__utctz_gmtime
5770 # define localtime decc$__utctz_localtime
5771 # define time decc$__utc_time
5772 # pragma __extern_prefix restore
5774 struct tm *gmtime(), *localtime();
5780 static time_t toutc_dst(time_t loc) {
5783 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5784 loc -= utc_offset_secs;
5785 if (rsltmp->tm_isdst) loc -= 3600;
5788 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5789 ((gmtime_emulation_type || my_time(NULL)), \
5790 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5791 ((secs) - utc_offset_secs))))
5793 static time_t toloc_dst(time_t utc) {
5796 utc += utc_offset_secs;
5797 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5798 if (rsltmp->tm_isdst) utc += 3600;
5801 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5802 ((gmtime_emulation_type || my_time(NULL)), \
5803 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5804 ((secs) + utc_offset_secs))))
5806 #ifndef RTL_USES_UTC
5809 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5810 DST starts on 1st sun of april at 02:00 std time
5811 ends on last sun of october at 02:00 dst time
5812 see the UCX management command reference, SET CONFIG TIMEZONE
5813 for formatting info.
5815 No, it's not as general as it should be, but then again, NOTHING
5816 will handle UK times in a sensible way.
5821 parse the DST start/end info:
5822 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5826 tz_parse_startend(char *s, struct tm *w, int *past)
5828 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5829 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5834 if (!past) return 0;
5837 if (w->tm_year % 4 == 0) ly = 1;
5838 if (w->tm_year % 100 == 0) ly = 0;
5839 if (w->tm_year+1900 % 400 == 0) ly = 1;
5842 dozjd = isdigit(*s);
5843 if (*s == 'J' || *s == 'j' || dozjd) {
5844 if (!dozjd && !isdigit(*++s)) return 0;
5847 d = d*10 + *s++ - '0';
5849 d = d*10 + *s++ - '0';
5852 if (d == 0) return 0;
5853 if (d > 366) return 0;
5855 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5858 } else if (*s == 'M' || *s == 'm') {
5859 if (!isdigit(*++s)) return 0;
5861 if (isdigit(*s)) m = 10*m + *s++ - '0';
5862 if (*s != '.') return 0;
5863 if (!isdigit(*++s)) return 0;
5865 if (n < 1 || n > 5) return 0;
5866 if (*s != '.') return 0;
5867 if (!isdigit(*++s)) return 0;
5869 if (d > 6) return 0;
5873 if (!isdigit(*++s)) return 0;
5875 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5877 if (!isdigit(*++s)) return 0;
5879 if (isdigit(*s)) min = 10*min + *s++ - '0';
5881 if (!isdigit(*++s)) return 0;
5883 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5893 if (w->tm_yday < d) goto before;
5894 if (w->tm_yday > d) goto after;
5896 if (w->tm_mon+1 < m) goto before;
5897 if (w->tm_mon+1 > m) goto after;
5899 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5900 k = d - j; /* mday of first d */
5902 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5903 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5904 if (w->tm_mday < k) goto before;
5905 if (w->tm_mday > k) goto after;
5908 if (w->tm_hour < hour) goto before;
5909 if (w->tm_hour > hour) goto after;
5910 if (w->tm_min < min) goto before;
5911 if (w->tm_min > min) goto after;
5912 if (w->tm_sec < sec) goto before;
5926 /* parse the offset: (+|-)hh[:mm[:ss]] */
5929 tz_parse_offset(char *s, int *offset)
5931 int hour = 0, min = 0, sec = 0;
5934 if (!offset) return 0;
5936 if (*s == '-') {neg++; s++;}
5938 if (!isdigit(*s)) return 0;
5940 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5941 if (hour > 24) return 0;
5943 if (!isdigit(*++s)) return 0;
5945 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5946 if (min > 59) return 0;
5948 if (!isdigit(*++s)) return 0;
5950 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5951 if (sec > 59) return 0;
5955 *offset = (hour*60+min)*60 + sec;
5956 if (neg) *offset = -*offset;
5961 input time is w, whatever type of time the CRTL localtime() uses.
5962 sets dst, the zone, and the gmtoff (seconds)
5964 caches the value of TZ and UCX$TZ env variables; note that
5965 my_setenv looks for these and sets a flag if they're changed
5968 We have to watch out for the "australian" case (dst starts in
5969 october, ends in april)...flagged by "reverse" and checked by
5970 scanning through the months of the previous year.
5975 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5980 char *dstzone, *tz, *s_start, *s_end;
5981 int std_off, dst_off, isdst;
5982 int y, dststart, dstend;
5983 static char envtz[1025]; /* longer than any logical, symbol, ... */
5984 static char ucxtz[1025];
5985 static char reversed = 0;
5991 reversed = -1; /* flag need to check */
5992 envtz[0] = ucxtz[0] = '\0';
5993 tz = my_getenv("TZ",0);
5994 if (tz) strcpy(envtz, tz);
5995 tz = my_getenv("UCX$TZ",0);
5996 if (tz) strcpy(ucxtz, tz);
5997 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6000 if (!*tz) tz = ucxtz;
6003 while (isalpha(*s)) s++;
6004 s = tz_parse_offset(s, &std_off);
6006 if (!*s) { /* no DST, hurray we're done! */
6012 while (isalpha(*s)) s++;
6013 s2 = tz_parse_offset(s, &dst_off);
6017 dst_off = std_off - 3600;
6020 if (!*s) { /* default dst start/end?? */
6021 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6022 s = strchr(ucxtz,',');
6024 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6026 if (*s != ',') return 0;
6029 when = _toutc(when); /* convert to utc */
6030 when = when - std_off; /* convert to pseudolocal time*/
6032 w2 = localtime(&when);
6035 s = tz_parse_startend(s_start,w2,&dststart);
6037 if (*s != ',') return 0;
6040 when = _toutc(when); /* convert to utc */
6041 when = when - dst_off; /* convert to pseudolocal time*/
6042 w2 = localtime(&when);
6043 if (w2->tm_year != y) { /* spans a year, just check one time */
6044 when += dst_off - std_off;
6045 w2 = localtime(&when);
6048 s = tz_parse_startend(s_end,w2,&dstend);
6051 if (reversed == -1) { /* need to check if start later than end */
6055 if (when < 2*365*86400) {
6056 when += 2*365*86400;
6060 w2 =localtime(&when);
6061 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6063 for (j = 0; j < 12; j++) {
6064 w2 =localtime(&when);
6065 (void) tz_parse_startend(s_start,w2,&ds);
6066 (void) tz_parse_startend(s_end,w2,&de);
6067 if (ds != de) break;
6071 if (de && !ds) reversed = 1;
6074 isdst = dststart && !dstend;
6075 if (reversed) isdst = dststart || !dstend;
6078 if (dst) *dst = isdst;
6079 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6080 if (isdst) tz = dstzone;
6082 while(isalpha(*tz)) *zone++ = *tz++;
6088 #endif /* !RTL_USES_UTC */
6090 /* my_time(), my_localtime(), my_gmtime()
6091 * By default traffic in UTC time values, using CRTL gmtime() or
6092 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6093 * Note: We need to use these functions even when the CRTL has working
6094 * UTC support, since they also handle C<use vmsish qw(times);>
6096 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6097 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6100 /*{{{time_t my_time(time_t *timep)*/
6101 time_t Perl_my_time(pTHX_ time_t *timep)
6106 if (gmtime_emulation_type == 0) {
6108 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6109 /* results of calls to gmtime() and localtime() */
6110 /* for same &base */
6112 gmtime_emulation_type++;
6113 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6114 char off[LNM$C_NAMLENGTH+1];;
6116 gmtime_emulation_type++;
6117 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6118 gmtime_emulation_type++;
6119 utc_offset_secs = 0;
6120 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6122 else { utc_offset_secs = atol(off); }
6124 else { /* We've got a working gmtime() */
6125 struct tm gmt, local;
6128 tm_p = localtime(&base);
6130 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6131 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6132 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6133 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6139 # ifdef RTL_USES_UTC
6140 if (VMSISH_TIME) when = _toloc(when);
6142 if (!VMSISH_TIME) when = _toutc(when);
6145 if (timep != NULL) *timep = when;
6148 } /* end of my_time() */
6152 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6154 Perl_my_gmtime(pTHX_ const time_t *timep)
6160 if (timep == NULL) {
6161 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6164 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6168 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6170 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6171 return gmtime(&when);
6173 /* CRTL localtime() wants local time as input, so does no tz correction */
6174 rsltmp = localtime(&when);
6175 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6178 } /* end of my_gmtime() */
6182 /*{{{struct tm *my_localtime(const time_t *timep)*/
6184 Perl_my_localtime(pTHX_ const time_t *timep)
6186 time_t when, whenutc;
6190 if (timep == NULL) {
6191 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6194 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6195 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6198 # ifdef RTL_USES_UTC
6200 if (VMSISH_TIME) when = _toutc(when);
6202 /* CRTL localtime() wants UTC as input, does tz correction itself */
6203 return localtime(&when);
6205 # else /* !RTL_USES_UTC */
6208 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6209 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6212 #ifndef RTL_USES_UTC
6213 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6214 when = whenutc - offset; /* pseudolocal time*/
6217 /* CRTL localtime() wants local time as input, so does no tz correction */
6218 rsltmp = localtime(&when);
6219 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6223 } /* end of my_localtime() */
6226 /* Reset definitions for later calls */
6227 #define gmtime(t) my_gmtime(t)
6228 #define localtime(t) my_localtime(t)
6229 #define time(t) my_time(t)
6232 /* my_utime - update modification time of a file
6233 * calling sequence is identical to POSIX utime(), but under
6234 * VMS only the modification time is changed; ODS-2 does not
6235 * maintain access times. Restrictions differ from the POSIX
6236 * definition in that the time can be changed as long as the
6237 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6238 * no separate checks are made to insure that the caller is the
6239 * owner of the file or has special privs enabled.
6240 * Code here is based on Joe Meadows' FILE utility.
6243 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6244 * to VMS epoch (01-JAN-1858 00:00:00.00)
6245 * in 100 ns intervals.
6247 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6249 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6250 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6253 long int bintime[2], len = 2, lowbit, unixtime,
6254 secscale = 10000000; /* seconds --> 100 ns intervals */
6255 unsigned long int chan, iosb[2], retsts;
6256 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6257 struct FAB myfab = cc$rms_fab;
6258 struct NAM mynam = cc$rms_nam;
6259 #if defined (__DECC) && defined (__VAX)
6260 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6261 * at least through VMS V6.1, which causes a type-conversion warning.
6263 # pragma message save
6264 # pragma message disable cvtdiftypes
6266 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6267 struct fibdef myfib;
6268 #if defined (__DECC) && defined (__VAX)
6269 /* This should be right after the declaration of myatr, but due
6270 * to a bug in VAX DEC C, this takes effect a statement early.
6272 # pragma message restore
6274 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6275 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6276 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6278 if (file == NULL || *file == '\0') {
6280 set_vaxc_errno(LIB$_INVARG);
6283 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6285 if (utimes != NULL) {
6286 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6287 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6288 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6289 * as input, we force the sign bit to be clear by shifting unixtime right
6290 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6292 lowbit = (utimes->modtime & 1) ? secscale : 0;
6293 unixtime = (long int) utimes->modtime;
6295 /* If input was UTC; convert to local for sys svc */
6296 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6298 unixtime >>= 1; secscale <<= 1;
6299 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6300 if (!(retsts & 1)) {
6302 set_vaxc_errno(retsts);
6305 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6306 if (!(retsts & 1)) {
6308 set_vaxc_errno(retsts);
6313 /* Just get the current time in VMS format directly */
6314 retsts = sys$gettim(bintime);
6315 if (!(retsts & 1)) {
6317 set_vaxc_errno(retsts);
6322 myfab.fab$l_fna = vmsspec;
6323 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6324 myfab.fab$l_nam = &mynam;
6325 mynam.nam$l_esa = esa;
6326 mynam.nam$b_ess = (unsigned char) sizeof esa;
6327 mynam.nam$l_rsa = rsa;
6328 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6330 /* Look for the file to be affected, letting RMS parse the file
6331 * specification for us as well. I have set errno using only
6332 * values documented in the utime() man page for VMS POSIX.
6334 retsts = sys$parse(&myfab,0,0);
6335 if (!(retsts & 1)) {
6336 set_vaxc_errno(retsts);
6337 if (retsts == RMS$_PRV) set_errno(EACCES);
6338 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6339 else set_errno(EVMSERR);
6342 retsts = sys$search(&myfab,0,0);
6343 if (!(retsts & 1)) {
6344 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6345 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6346 set_vaxc_errno(retsts);
6347 if (retsts == RMS$_PRV) set_errno(EACCES);
6348 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6349 else set_errno(EVMSERR);
6353 devdsc.dsc$w_length = mynam.nam$b_dev;
6354 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6356 retsts = sys$assign(&devdsc,&chan,0,0);
6357 if (!(retsts & 1)) {
6358 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6359 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6360 set_vaxc_errno(retsts);
6361 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6362 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6363 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6364 else set_errno(EVMSERR);
6368 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6369 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6371 memset((void *) &myfib, 0, sizeof myfib);
6372 #if defined(__DECC) || defined(__DECCXX)
6373 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6374 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6375 /* This prevents the revision time of the file being reset to the current
6376 * time as a result of our IO$_MODIFY $QIO. */
6377 myfib.fib$l_acctl = FIB$M_NORECORD;
6379 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6380 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6381 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6383 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6384 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6385 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6386 _ckvmssts(sys$dassgn(chan));
6387 if (retsts & 1) retsts = iosb[0];
6388 if (!(retsts & 1)) {
6389 set_vaxc_errno(retsts);
6390 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6391 else set_errno(EVMSERR);
6396 } /* end of my_utime() */
6400 * flex_stat, flex_fstat
6401 * basic stat, but gets it right when asked to stat
6402 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6405 /* encode_dev packs a VMS device name string into an integer to allow
6406 * simple comparisons. This can be used, for example, to check whether two
6407 * files are located on the same device, by comparing their encoded device
6408 * names. Even a string comparison would not do, because stat() reuses the
6409 * device name buffer for each call; so without encode_dev, it would be
6410 * necessary to save the buffer and use strcmp (this would mean a number of
6411 * changes to the standard Perl code, to say nothing of what a Perl script
6414 * The device lock id, if it exists, should be unique (unless perhaps compared
6415 * with lock ids transferred from other nodes). We have a lock id if the disk is
6416 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6417 * device names. Thus we use the lock id in preference, and only if that isn't
6418 * available, do we try to pack the device name into an integer (flagged by
6419 * the sign bit (LOCKID_MASK) being set).
6421 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6422 * name and its encoded form, but it seems very unlikely that we will find
6423 * two files on different disks that share the same encoded device names,
6424 * and even more remote that they will share the same file id (if the test
6425 * is to check for the same file).
6427 * A better method might be to use sys$device_scan on the first call, and to
6428 * search for the device, returning an index into the cached array.
6429 * The number returned would be more intelligable.
6430 * This is probably not worth it, and anyway would take quite a bit longer
6431 * on the first call.
6433 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6434 static mydev_t encode_dev (pTHX_ const char *dev)
6437 unsigned long int f;
6442 if (!dev || !dev[0]) return 0;
6446 struct dsc$descriptor_s dev_desc;
6447 unsigned long int status, lockid, item = DVI$_LOCKID;
6449 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6450 can try that first. */
6451 dev_desc.dsc$w_length = strlen (dev);
6452 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6453 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6454 dev_desc.dsc$a_pointer = (char *) dev;
6455 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6456 if (lockid) return (lockid & ~LOCKID_MASK);
6460 /* Otherwise we try to encode the device name */
6464 for (q = dev + strlen(dev); q--; q >= dev) {
6467 else if (isalpha (toupper (*q)))
6468 c= toupper (*q) - 'A' + (char)10;
6470 continue; /* Skip '$'s */
6472 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6474 enc += f * (unsigned long int) c;
6476 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6478 } /* end of encode_dev() */
6480 static char namecache[NAM$C_MAXRSS+1];
6483 is_null_device(name)
6486 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6487 The underscore prefix, controller letter, and unit number are
6488 independently optional; for our purposes, the colon punctuation
6489 is not. The colon can be trailed by optional directory and/or
6490 filename, but two consecutive colons indicates a nodename rather
6491 than a device. [pr] */
6492 if (*name == '_') ++name;
6493 if (tolower(*name++) != 'n') return 0;
6494 if (tolower(*name++) != 'l') return 0;
6495 if (tolower(*name) == 'a') ++name;
6496 if (*name == '0') ++name;
6497 return (*name++ == ':') && (*name != ':');
6500 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6501 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6502 * subset of the applicable information.
6505 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6507 char fname_phdev[NAM$C_MAXRSS+1];
6508 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6510 char fname[NAM$C_MAXRSS+1];
6511 unsigned long int retsts;
6512 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6513 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6515 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6516 device name on successive calls */
6517 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6518 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6519 namdsc.dsc$a_pointer = fname;
6520 namdsc.dsc$w_length = sizeof fname - 1;
6522 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6523 &namdsc,&namdsc.dsc$w_length,0,0);
6525 fname[namdsc.dsc$w_length] = '\0';
6527 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6528 * but if someone has redefined that logical, Perl gets very lost. Since
6529 * we have the physical device name from the stat buffer, just paste it on.
6531 strcpy( fname_phdev, statbufp->st_devnam );
6532 strcat( fname_phdev, strrchr(fname, ':') );
6534 return cando_by_name(bit,effective,fname_phdev);
6536 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6537 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6541 return FALSE; /* Should never get to here */
6543 } /* end of cando() */
6547 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6549 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6551 static char usrname[L_cuserid];
6552 static struct dsc$descriptor_s usrdsc =
6553 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6554 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6555 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6556 unsigned short int retlen, trnlnm_iter_count;
6557 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6558 union prvdef curprv;
6559 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6560 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6561 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6562 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6564 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6566 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6568 if (!fname || !*fname) return FALSE;
6569 /* Make sure we expand logical names, since sys$check_access doesn't */
6570 if (!strpbrk(fname,"/]>:")) {
6571 strcpy(fileified,fname);
6572 trnlnm_iter_count = 0;
6573 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6574 trnlnm_iter_count++;
6575 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6579 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6580 retlen = namdsc.dsc$w_length = strlen(vmsname);
6581 namdsc.dsc$a_pointer = vmsname;
6582 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6583 vmsname[retlen-1] == ':') {
6584 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6585 namdsc.dsc$w_length = strlen(fileified);
6586 namdsc.dsc$a_pointer = fileified;
6590 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6591 access = ARM$M_EXECUTE; break;
6592 case S_IRUSR: case S_IRGRP: case S_IROTH:
6593 access = ARM$M_READ; break;
6594 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6595 access = ARM$M_WRITE; break;
6596 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6597 access = ARM$M_DELETE; break;
6602 /* Before we call $check_access, create a user profile with the current
6603 * process privs since otherwise it just uses the default privs from the
6604 * UAF and might give false positives or negatives. This only works on
6605 * VMS versions v6.0 and later since that's when sys$create_user_profile
6609 /* get current process privs and username */
6610 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6613 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6615 /* find out the space required for the profile */
6616 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6617 &usrprodsc.dsc$w_length,0));
6619 /* allocate space for the profile and get it filled in */
6620 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6621 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6622 &usrprodsc.dsc$w_length,0));
6624 /* use the profile to check access to the file; free profile & analyze results */
6625 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6626 Safefree(usrprodsc.dsc$a_pointer);
6627 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6631 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6635 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6636 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6637 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6638 set_vaxc_errno(retsts);
6639 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6640 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6641 else set_errno(ENOENT);
6644 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6649 return FALSE; /* Should never get here */
6651 } /* end of cando_by_name() */
6655 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6657 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6659 if (!fstat(fd,(stat_t *) statbufp)) {
6660 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6661 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6662 # ifdef RTL_USES_UTC
6665 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6666 statbufp->st_atime = _toloc(statbufp->st_atime);
6667 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6672 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6676 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6677 statbufp->st_atime = _toutc(statbufp->st_atime);
6678 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6685 } /* end of flex_fstat() */
6688 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6690 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6692 char fileified[NAM$C_MAXRSS+1];
6693 char temp_fspec[NAM$C_MAXRSS+300];
6695 int saved_errno, saved_vaxc_errno;
6697 if (!fspec) return retval;
6698 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6699 strcpy(temp_fspec, fspec);
6700 if (statbufp == (Stat_t *) &PL_statcache)
6701 do_tovmsspec(temp_fspec,namecache,0);
6702 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6703 memset(statbufp,0,sizeof *statbufp);
6704 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6705 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6706 statbufp->st_uid = 0x00010001;
6707 statbufp->st_gid = 0x0001;
6708 time((time_t *)&statbufp->st_mtime);
6709 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6713 /* Try for a directory name first. If fspec contains a filename without
6714 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6715 * and sea:[wine.dark]water. exist, we prefer the directory here.
6716 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6717 * not sea:[wine.dark]., if the latter exists. If the intended target is
6718 * the file with null type, specify this by calling flex_stat() with
6719 * a '.' at the end of fspec.
6721 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6722 retval = stat(fileified,(stat_t *) statbufp);
6723 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6724 strcpy(namecache,fileified);
6726 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6728 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6729 # ifdef RTL_USES_UTC
6732 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6733 statbufp->st_atime = _toloc(statbufp->st_atime);
6734 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6739 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6743 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6744 statbufp->st_atime = _toutc(statbufp->st_atime);
6745 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6749 /* If we were successful, leave errno where we found it */
6750 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6753 } /* end of flex_stat() */
6757 /*{{{char *my_getlogin()*/
6758 /* VMS cuserid == Unix getlogin, except calling sequence */
6762 static char user[L_cuserid];
6763 return cuserid(user);
6768 /* rmscopy - copy a file using VMS RMS routines
6770 * Copies contents and attributes of spec_in to spec_out, except owner
6771 * and protection information. Name and type of spec_in are used as
6772 * defaults for spec_out. The third parameter specifies whether rmscopy()
6773 * should try to propagate timestamps from the input file to the output file.
6774 * If it is less than 0, no timestamps are preserved. If it is 0, then
6775 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6776 * propagated to the output file at creation iff the output file specification
6777 * did not contain an explicit name or type, and the revision date is always
6778 * updated at the end of the copy operation. If it is greater than 0, then
6779 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6780 * other than the revision date should be propagated, and bit 1 indicates
6781 * that the revision date should be propagated.
6783 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6785 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6786 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6787 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6788 * as part of the Perl standard distribution under the terms of the
6789 * GNU General Public License or the Perl Artistic License. Copies
6790 * of each may be found in the Perl standard distribution.
6792 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6794 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6796 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6797 rsa[NAM$C_MAXRSS], ubf[32256];
6798 unsigned long int i, sts, sts2;
6799 struct FAB fab_in, fab_out;
6800 struct RAB rab_in, rab_out;
6802 struct XABDAT xabdat;
6803 struct XABFHC xabfhc;
6804 struct XABRDT xabrdt;
6805 struct XABSUM xabsum;
6807 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6808 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6809 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6813 fab_in = cc$rms_fab;
6814 fab_in.fab$l_fna = vmsin;
6815 fab_in.fab$b_fns = strlen(vmsin);
6816 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6817 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6818 fab_in.fab$l_fop = FAB$M_SQO;
6819 fab_in.fab$l_nam = &nam;
6820 fab_in.fab$l_xab = (void *) &xabdat;
6823 nam.nam$l_rsa = rsa;
6824 nam.nam$b_rss = sizeof(rsa);
6825 nam.nam$l_esa = esa;
6826 nam.nam$b_ess = sizeof (esa);
6827 nam.nam$b_esl = nam.nam$b_rsl = 0;
6829 xabdat = cc$rms_xabdat; /* To get creation date */
6830 xabdat.xab$l_nxt = (void *) &xabfhc;
6832 xabfhc = cc$rms_xabfhc; /* To get record length */
6833 xabfhc.xab$l_nxt = (void *) &xabsum;
6835 xabsum = cc$rms_xabsum; /* To get key and area information */
6837 if (!((sts = sys$open(&fab_in)) & 1)) {
6838 set_vaxc_errno(sts);
6840 case RMS$_FNF: case RMS$_DNF:
6841 set_errno(ENOENT); break;
6843 set_errno(ENOTDIR); break;
6845 set_errno(ENODEV); break;
6847 set_errno(EINVAL); break;
6849 set_errno(EACCES); break;
6857 fab_out.fab$w_ifi = 0;
6858 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6859 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6860 fab_out.fab$l_fop = FAB$M_SQO;
6861 fab_out.fab$l_fna = vmsout;
6862 fab_out.fab$b_fns = strlen(vmsout);
6863 fab_out.fab$l_dna = nam.nam$l_name;
6864 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6866 if (preserve_dates == 0) { /* Act like DCL COPY */
6867 nam.nam$b_nop = NAM$M_SYNCHK;
6868 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6869 if (!((sts = sys$parse(&fab_out)) & 1)) {
6870 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6871 set_vaxc_errno(sts);
6874 fab_out.fab$l_xab = (void *) &xabdat;
6875 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6877 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6878 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6879 preserve_dates =0; /* bitmask from this point forward */
6881 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6882 if (!((sts = sys$create(&fab_out)) & 1)) {
6883 set_vaxc_errno(sts);
6886 set_errno(ENOENT); break;
6888 set_errno(ENOTDIR); break;
6890 set_errno(ENODEV); break;
6892 set_errno(EINVAL); break;
6894 set_errno(EACCES); break;
6900 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6901 if (preserve_dates & 2) {
6902 /* sys$close() will process xabrdt, not xabdat */
6903 xabrdt = cc$rms_xabrdt;
6905 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6907 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6908 * is unsigned long[2], while DECC & VAXC use a struct */
6909 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6911 fab_out.fab$l_xab = (void *) &xabrdt;
6914 rab_in = cc$rms_rab;
6915 rab_in.rab$l_fab = &fab_in;
6916 rab_in.rab$l_rop = RAB$M_BIO;
6917 rab_in.rab$l_ubf = ubf;
6918 rab_in.rab$w_usz = sizeof ubf;
6919 if (!((sts = sys$connect(&rab_in)) & 1)) {
6920 sys$close(&fab_in); sys$close(&fab_out);
6921 set_errno(EVMSERR); set_vaxc_errno(sts);
6925 rab_out = cc$rms_rab;
6926 rab_out.rab$l_fab = &fab_out;
6927 rab_out.rab$l_rbf = ubf;
6928 if (!((sts = sys$connect(&rab_out)) & 1)) {
6929 sys$close(&fab_in); sys$close(&fab_out);
6930 set_errno(EVMSERR); set_vaxc_errno(sts);
6934 while ((sts = sys$read(&rab_in))) { /* always true */
6935 if (sts == RMS$_EOF) break;
6936 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6937 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6938 sys$close(&fab_in); sys$close(&fab_out);
6939 set_errno(EVMSERR); set_vaxc_errno(sts);
6944 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6945 sys$close(&fab_in); sys$close(&fab_out);
6946 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6948 set_errno(EVMSERR); set_vaxc_errno(sts);
6954 } /* end of rmscopy() */
6958 /*** The following glue provides 'hooks' to make some of the routines
6959 * from this file available from Perl. These routines are sufficiently
6960 * basic, and are required sufficiently early in the build process,
6961 * that's it's nice to have them available to miniperl as well as the
6962 * full Perl, so they're set up here instead of in an extension. The
6963 * Perl code which handles importation of these names into a given
6964 * package lives in [.VMS]Filespec.pm in @INC.
6968 rmsexpand_fromperl(pTHX_ CV *cv)
6971 char *fspec, *defspec = NULL, *rslt;
6974 if (!items || items > 2)
6975 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6976 fspec = SvPV(ST(0),n_a);
6977 if (!fspec || !*fspec) XSRETURN_UNDEF;
6978 if (items == 2) defspec = SvPV(ST(1),n_a);
6980 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6981 ST(0) = sv_newmortal();
6982 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6987 vmsify_fromperl(pTHX_ CV *cv)
6993 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6994 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6995 ST(0) = sv_newmortal();
6996 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7001 unixify_fromperl(pTHX_ CV *cv)
7007 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7008 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7009 ST(0) = sv_newmortal();
7010 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7015 fileify_fromperl(pTHX_ CV *cv)
7021 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7022 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7023 ST(0) = sv_newmortal();
7024 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7029 pathify_fromperl(pTHX_ CV *cv)
7035 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7036 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7037 ST(0) = sv_newmortal();
7038 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7043 vmspath_fromperl(pTHX_ CV *cv)
7049 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7050 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7051 ST(0) = sv_newmortal();
7052 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7057 unixpath_fromperl(pTHX_ CV *cv)
7063 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7064 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7065 ST(0) = sv_newmortal();
7066 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7071 candelete_fromperl(pTHX_ CV *cv)
7074 char fspec[NAM$C_MAXRSS+1], *fsp;
7079 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7081 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7082 if (SvTYPE(mysv) == SVt_PVGV) {
7083 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7084 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7091 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7092 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7098 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7103 rmscopy_fromperl(pTHX_ CV *cv)
7106 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7108 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7109 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7110 unsigned long int sts;
7115 if (items < 2 || items > 3)
7116 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7118 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7119 if (SvTYPE(mysv) == SVt_PVGV) {
7120 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7121 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7128 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7129 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7134 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7135 if (SvTYPE(mysv) == SVt_PVGV) {
7136 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7137 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7144 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7145 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7150 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7152 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7158 mod2fname(pTHX_ CV *cv)
7161 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7162 workbuff[NAM$C_MAXRSS*1 + 1];
7163 int total_namelen = 3, counter, num_entries;
7164 /* ODS-5 ups this, but we want to be consistent, so... */
7165 int max_name_len = 39;
7166 AV *in_array = (AV *)SvRV(ST(0));
7168 num_entries = av_len(in_array);
7170 /* All the names start with PL_. */
7171 strcpy(ultimate_name, "PL_");
7173 /* Clean up our working buffer */
7174 Zero(work_name, sizeof(work_name), char);
7176 /* Run through the entries and build up a working name */
7177 for(counter = 0; counter <= num_entries; counter++) {
7178 /* If it's not the first name then tack on a __ */
7180 strcat(work_name, "__");
7182 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7186 /* Check to see if we actually have to bother...*/
7187 if (strlen(work_name) + 3 <= max_name_len) {
7188 strcat(ultimate_name, work_name);
7190 /* It's too darned big, so we need to go strip. We use the same */
7191 /* algorithm as xsubpp does. First, strip out doubled __ */
7192 char *source, *dest, last;
7195 for (source = work_name; *source; source++) {
7196 if (last == *source && last == '_') {
7202 /* Go put it back */
7203 strcpy(work_name, workbuff);
7204 /* Is it still too big? */
7205 if (strlen(work_name) + 3 > max_name_len) {
7206 /* Strip duplicate letters */
7209 for (source = work_name; *source; source++) {
7210 if (last == toupper(*source)) {
7214 last = toupper(*source);
7216 strcpy(work_name, workbuff);
7219 /* Is it *still* too big? */
7220 if (strlen(work_name) + 3 > max_name_len) {
7221 /* Too bad, we truncate */
7222 work_name[max_name_len - 2] = 0;
7224 strcat(ultimate_name, work_name);
7227 /* Okay, return it */
7228 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7233 hushexit_fromperl(pTHX_ CV *cv)
7238 VMSISH_HUSHED = SvTRUE(ST(0));
7240 ST(0) = boolSV(VMSISH_HUSHED);
7245 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7246 struct interp_intern *dst)
7248 memcpy(dst,src,sizeof(struct interp_intern));
7252 Perl_sys_intern_clear(pTHX)
7257 Perl_sys_intern_init(pTHX)
7259 unsigned int ix = RAND_MAX;
7265 MY_INV_RAND_MAX = 1./x;
7272 char* file = __FILE__;
7273 char temp_buff[512];
7274 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7275 no_translate_barewords = TRUE;
7277 no_translate_barewords = FALSE;
7280 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7281 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7282 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7283 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7284 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7285 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7286 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7287 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7288 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7289 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7290 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7292 store_pipelocs(aTHX); /* will redo any earlier attempts */