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.
4452 char **newargv, **oldargv;
4454 New(1320,newargv,(*argcp)+2,char *);
4455 newargv[0] = oldargv[0];
4456 New(1320,newargv[1],3,char);
4457 strcpy(newargv[1], "-T");
4458 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
4460 newargv[*argcp] = NULL;
4461 /* We orphan the old argv, since we don't know where it's come from,
4462 * so we don't know how to free it.
4466 else { /* Did user explicitly request tainting? */
4468 char *cp, **av = *argvp;
4469 for (i = 1; i < *argcp; i++) {
4470 if (*av[i] != '-') break;
4471 for (cp = av[i]+1; *cp; cp++) {
4472 if (*cp == 'T') { will_taint = 1; break; }
4473 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4474 strchr("DFIiMmx",*cp)) break;
4476 if (will_taint) break;
4481 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4483 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4484 else if (tabidx >= tabct) {
4486 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4488 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4489 tabvec[tabidx]->dsc$w_length = 0;
4490 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4491 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4492 tabvec[tabidx]->dsc$a_pointer = NULL;
4493 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4495 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4497 getredirection(argcp,argvp);
4504 * Trim Unix-style prefix off filespec, so it looks like what a shell
4505 * glob expansion would return (i.e. from specified prefix on, not
4506 * full path). Note that returned filespec is Unix-style, regardless
4507 * of whether input filespec was VMS-style or Unix-style.
4509 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4510 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4511 * vector of options; at present, only bit 0 is used, and if set tells
4512 * trim unixpath to try the current default directory as a prefix when
4513 * presented with a possibly ambiguous ... wildcard.
4515 * Returns !=0 on success, with trimmed filespec replacing contents of
4516 * fspec, and 0 on failure, with contents of fpsec unchanged.
4518 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4520 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4522 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4523 *template, *base, *end, *cp1, *cp2;
4524 register int tmplen, reslen = 0, dirs = 0;
4526 if (!wildspec || !fspec) return 0;
4527 if (strpbrk(wildspec,"]>:") != NULL) {
4528 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4529 else template = unixwild;
4531 else template = wildspec;
4532 if (strpbrk(fspec,"]>:") != NULL) {
4533 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4534 else base = unixified;
4535 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4536 * check to see that final result fits into (isn't longer than) fspec */
4537 reslen = strlen(fspec);
4541 /* No prefix or absolute path on wildcard, so nothing to remove */
4542 if (!*template || *template == '/') {
4543 if (base == fspec) return 1;
4544 tmplen = strlen(unixified);
4545 if (tmplen > reslen) return 0; /* not enough space */
4546 /* Copy unixified resultant, including trailing NUL */
4547 memmove(fspec,unixified,tmplen+1);
4551 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4552 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4553 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4554 for (cp1 = end ;cp1 >= base; cp1--)
4555 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4557 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4561 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4562 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4563 int ells = 1, totells, segdirs, match;
4564 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4565 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4567 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4569 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4570 if (ellipsis == template && opts & 1) {
4571 /* Template begins with an ellipsis. Since we can't tell how many
4572 * directory names at the front of the resultant to keep for an
4573 * arbitrary starting point, we arbitrarily choose the current
4574 * default directory as a starting point. If it's there as a prefix,
4575 * clip it off. If not, fall through and act as if the leading
4576 * ellipsis weren't there (i.e. return shortest possible path that
4577 * could match template).
4579 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4580 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4581 if (_tolower(*cp1) != _tolower(*cp2)) break;
4582 segdirs = dirs - totells; /* Min # of dirs we must have left */
4583 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4584 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4585 memcpy(fspec,cp2+1,end - cp2);
4589 /* First off, back up over constant elements at end of path */
4591 for (front = end ; front >= base; front--)
4592 if (*front == '/' && !dirs--) { front++; break; }
4594 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4595 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4596 if (cp1 != '\0') return 0; /* Path too long. */
4598 *cp2 = '\0'; /* Pick up with memcpy later */
4599 lcfront = lcres + (front - base);
4600 /* Now skip over each ellipsis and try to match the path in front of it. */
4602 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4603 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4604 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4605 if (cp1 < template) break; /* template started with an ellipsis */
4606 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4607 ellipsis = cp1; continue;
4609 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4611 for (segdirs = 0, cp2 = tpl;
4612 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4614 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4615 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4616 if (*cp2 == '/') segdirs++;
4618 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4619 /* Back up at least as many dirs as in template before matching */
4620 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4621 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4622 for (match = 0; cp1 > lcres;) {
4623 resdsc.dsc$a_pointer = cp1;
4624 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4626 if (match == 1) lcfront = cp1;
4628 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4630 if (!match) return 0; /* Can't find prefix ??? */
4631 if (match > 1 && opts & 1) {
4632 /* This ... wildcard could cover more than one set of dirs (i.e.
4633 * a set of similar dir names is repeated). If the template
4634 * contains more than 1 ..., upstream elements could resolve the
4635 * ambiguity, but it's not worth a full backtracking setup here.
4636 * As a quick heuristic, clip off the current default directory
4637 * if it's present to find the trimmed spec, else use the
4638 * shortest string that this ... could cover.
4640 char def[NAM$C_MAXRSS+1], *st;
4642 if (getcwd(def, sizeof def,0) == NULL) return 0;
4643 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4644 if (_tolower(*cp1) != _tolower(*cp2)) break;
4645 segdirs = dirs - totells; /* Min # of dirs we must have left */
4646 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4647 if (*cp1 == '\0' && *cp2 == '/') {
4648 memcpy(fspec,cp2+1,end - cp2);
4651 /* Nope -- stick with lcfront from above and keep going. */
4654 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4659 } /* end of trim_unixpath() */
4664 * VMS readdir() routines.
4665 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4667 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4668 * Minor modifications to original routines.
4671 /* Number of elements in vms_versions array */
4672 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4675 * Open a directory, return a handle for later use.
4677 /*{{{ DIR *opendir(char*name) */
4679 Perl_opendir(pTHX_ char *name)
4682 char dir[NAM$C_MAXRSS+1];
4685 if (do_tovmspath(name,dir,0) == NULL) {
4688 /* Check access before stat; otherwise stat does not
4689 * accurately report whether it's a directory.
4691 if (!cando_by_name(S_IRUSR,0,dir)) {
4692 /* cando_by_name has already set errno */
4695 if (flex_stat(dir,&sb) == -1) return NULL;
4696 if (!S_ISDIR(sb.st_mode)) {
4697 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4700 /* Get memory for the handle, and the pattern. */
4702 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4704 /* Fill in the fields; mainly playing with the descriptor. */
4705 (void)sprintf(dd->pattern, "%s*.*",dir);
4708 dd->vms_wantversions = 0;
4709 dd->pat.dsc$a_pointer = dd->pattern;
4710 dd->pat.dsc$w_length = strlen(dd->pattern);
4711 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4712 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4715 } /* end of opendir() */
4719 * Set the flag to indicate we want versions or not.
4721 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4723 vmsreaddirversions(DIR *dd, int flag)
4725 dd->vms_wantversions = flag;
4730 * Free up an opened directory.
4732 /*{{{ void closedir(DIR *dd)*/
4736 (void)lib$find_file_end(&dd->context);
4737 Safefree(dd->pattern);
4738 Safefree((char *)dd);
4743 * Collect all the version numbers for the current file.
4746 collectversions(pTHX_ DIR *dd)
4748 struct dsc$descriptor_s pat;
4749 struct dsc$descriptor_s res;
4751 char *p, *text, buff[sizeof dd->entry.d_name];
4753 unsigned long context, tmpsts;
4755 /* Convenient shorthand. */
4758 /* Add the version wildcard, ignoring the "*.*" put on before */
4759 i = strlen(dd->pattern);
4760 New(1308,text,i + e->d_namlen + 3,char);
4761 (void)strcpy(text, dd->pattern);
4762 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4764 /* Set up the pattern descriptor. */
4765 pat.dsc$a_pointer = text;
4766 pat.dsc$w_length = i + e->d_namlen - 1;
4767 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4768 pat.dsc$b_class = DSC$K_CLASS_S;
4770 /* Set up result descriptor. */
4771 res.dsc$a_pointer = buff;
4772 res.dsc$w_length = sizeof buff - 2;
4773 res.dsc$b_dtype = DSC$K_DTYPE_T;
4774 res.dsc$b_class = DSC$K_CLASS_S;
4776 /* Read files, collecting versions. */
4777 for (context = 0, e->vms_verscount = 0;
4778 e->vms_verscount < VERSIZE(e);
4779 e->vms_verscount++) {
4780 tmpsts = lib$find_file(&pat, &res, &context);
4781 if (tmpsts == RMS$_NMF || context == 0) break;
4783 buff[sizeof buff - 1] = '\0';
4784 if ((p = strchr(buff, ';')))
4785 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4787 e->vms_versions[e->vms_verscount] = -1;
4790 _ckvmssts(lib$find_file_end(&context));
4793 } /* end of collectversions() */
4796 * Read the next entry from the directory.
4798 /*{{{ struct dirent *readdir(DIR *dd)*/
4800 Perl_readdir(pTHX_ DIR *dd)
4802 struct dsc$descriptor_s res;
4803 char *p, buff[sizeof dd->entry.d_name];
4804 unsigned long int tmpsts;
4806 /* Set up result descriptor, and get next file. */
4807 res.dsc$a_pointer = buff;
4808 res.dsc$w_length = sizeof buff - 2;
4809 res.dsc$b_dtype = DSC$K_DTYPE_T;
4810 res.dsc$b_class = DSC$K_CLASS_S;
4811 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4812 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4813 if (!(tmpsts & 1)) {
4814 set_vaxc_errno(tmpsts);
4817 set_errno(EACCES); break;
4819 set_errno(ENODEV); break;
4821 set_errno(ENOTDIR); break;
4822 case RMS$_FNF: case RMS$_DNF:
4823 set_errno(ENOENT); break;
4830 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4831 buff[sizeof buff - 1] = '\0';
4832 for (p = buff; *p; p++) *p = _tolower(*p);
4833 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4836 /* Skip any directory component and just copy the name. */
4837 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4838 else (void)strcpy(dd->entry.d_name, buff);
4840 /* Clobber the version. */
4841 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4843 dd->entry.d_namlen = strlen(dd->entry.d_name);
4844 dd->entry.vms_verscount = 0;
4845 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4848 } /* end of readdir() */
4852 * Return something that can be used in a seekdir later.
4854 /*{{{ long telldir(DIR *dd)*/
4863 * Return to a spot where we used to be. Brute force.
4865 /*{{{ void seekdir(DIR *dd,long count)*/
4867 Perl_seekdir(pTHX_ DIR *dd, long count)
4869 int vms_wantversions;
4871 /* If we haven't done anything yet... */
4875 /* Remember some state, and clear it. */
4876 vms_wantversions = dd->vms_wantversions;
4877 dd->vms_wantversions = 0;
4878 _ckvmssts(lib$find_file_end(&dd->context));
4881 /* The increment is in readdir(). */
4882 for (dd->count = 0; dd->count < count; )
4885 dd->vms_wantversions = vms_wantversions;
4887 } /* end of seekdir() */
4890 /* VMS subprocess management
4892 * my_vfork() - just a vfork(), after setting a flag to record that
4893 * the current script is trying a Unix-style fork/exec.
4895 * vms_do_aexec() and vms_do_exec() are called in response to the
4896 * perl 'exec' function. If this follows a vfork call, then they
4897 * call out the the regular perl routines in doio.c which do an
4898 * execvp (for those who really want to try this under VMS).
4899 * Otherwise, they do exactly what the perl docs say exec should
4900 * do - terminate the current script and invoke a new command
4901 * (See below for notes on command syntax.)
4903 * do_aspawn() and do_spawn() implement the VMS side of the perl
4904 * 'system' function.
4906 * Note on command arguments to perl 'exec' and 'system': When handled
4907 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4908 * are concatenated to form a DCL command string. If the first arg
4909 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4910 * the the command string is handed off to DCL directly. Otherwise,
4911 * the first token of the command is taken as the filespec of an image
4912 * to run. The filespec is expanded using a default type of '.EXE' and
4913 * the process defaults for device, directory, etc., and if found, the resultant
4914 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4915 * the command string as parameters. This is perhaps a bit complicated,
4916 * but I hope it will form a happy medium between what VMS folks expect
4917 * from lib$spawn and what Unix folks expect from exec.
4920 static int vfork_called;
4922 /*{{{int my_vfork()*/
4933 vms_execfree(struct dsc$descriptor_s *vmscmd)
4936 if (vmscmd->dsc$a_pointer) {
4937 Safefree(vmscmd->dsc$a_pointer);
4944 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4946 char *junk, *tmps = Nullch;
4947 register size_t cmdlen = 0;
4954 tmps = SvPV(really,rlen);
4961 for (idx++; idx <= sp; idx++) {
4963 junk = SvPVx(*idx,rlen);
4964 cmdlen += rlen ? rlen + 1 : 0;
4967 New(401,PL_Cmd,cmdlen+1,char);
4969 if (tmps && *tmps) {
4970 strcpy(PL_Cmd,tmps);
4973 else *PL_Cmd = '\0';
4974 while (++mark <= sp) {
4976 char *s = SvPVx(*mark,n_a);
4978 if (*PL_Cmd) strcat(PL_Cmd," ");
4984 } /* end of setup_argstr() */
4987 static unsigned long int
4988 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
4989 struct dsc$descriptor_s **pvmscmd)
4991 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4992 $DESCRIPTOR(defdsc,".EXE");
4993 $DESCRIPTOR(defdsc2,".");
4994 $DESCRIPTOR(resdsc,resspec);
4995 struct dsc$descriptor_s *vmscmd;
4996 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4997 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4998 register char *s, *rest, *cp, *wordbreak;
5001 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5002 vmscmd->dsc$a_pointer = NULL;
5003 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5004 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5005 vmscmd->dsc$w_length = 0;
5006 if (pvmscmd) *pvmscmd = vmscmd;
5008 if (suggest_quote) *suggest_quote = 0;
5010 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5011 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5013 while (*s && isspace(*s)) s++;
5015 if (*s == '@' || *s == '$') {
5016 vmsspec[0] = *s; rest = s + 1;
5017 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5019 else { cp = vmsspec; rest = s; }
5020 if (*rest == '.' || *rest == '/') {
5023 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5024 rest++, cp2++) *cp2 = *rest;
5026 if (do_tovmsspec(resspec,cp,0)) {
5029 for (cp2 = vmsspec + strlen(vmsspec);
5030 *rest && cp2 - vmsspec < sizeof vmsspec;
5031 rest++, cp2++) *cp2 = *rest;
5036 /* Intuit whether verb (first word of cmd) is a DCL command:
5037 * - if first nonspace char is '@', it's a DCL indirection
5039 * - if verb contains a filespec separator, it's not a DCL command
5040 * - if it doesn't, caller tells us whether to default to a DCL
5041 * command, or to a local image unless told it's DCL (by leading '$')
5045 if (suggest_quote) *suggest_quote = 1;
5047 register char *filespec = strpbrk(s,":<[.;");
5048 rest = wordbreak = strpbrk(s," \"\t/");
5049 if (!wordbreak) wordbreak = s + strlen(s);
5050 if (*s == '$') check_img = 0;
5051 if (filespec && (filespec < wordbreak)) isdcl = 0;
5052 else isdcl = !check_img;
5056 imgdsc.dsc$a_pointer = s;
5057 imgdsc.dsc$w_length = wordbreak - s;
5058 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5060 _ckvmssts(lib$find_file_end(&cxt));
5061 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5062 if (!(retsts & 1) && *s == '$') {
5063 _ckvmssts(lib$find_file_end(&cxt));
5064 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5065 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5067 _ckvmssts(lib$find_file_end(&cxt));
5068 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5072 _ckvmssts(lib$find_file_end(&cxt));
5077 while (*s && !isspace(*s)) s++;
5080 /* check that it's really not DCL with no file extension */
5081 fp = fopen(resspec,"r","ctx=bin,shr=get");
5083 char b[4] = {0,0,0,0};
5084 read(fileno(fp),b,4);
5085 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5088 if (check_img && isdcl) return RMS$_FNF;
5090 if (cando_by_name(S_IXUSR,0,resspec)) {
5091 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5093 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5094 if (suggest_quote) *suggest_quote = 1;
5096 strcpy(vmscmd->dsc$a_pointer,"@");
5097 if (suggest_quote) *suggest_quote = 1;
5099 strcat(vmscmd->dsc$a_pointer,resspec);
5100 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5101 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5102 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5104 else retsts = RMS$_PRV;
5107 /* It's either a DCL command or we couldn't find a suitable image */
5108 vmscmd->dsc$w_length = strlen(cmd);
5109 /* if (cmd == PL_Cmd) {
5110 vmscmd->dsc$a_pointer = PL_Cmd;
5111 if (suggest_quote) *suggest_quote = 1;
5114 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5116 /* check if it's a symbol (for quoting purposes) */
5117 if (suggest_quote && !*suggest_quote) {
5119 char equiv[LNM$C_NAMLENGTH];
5120 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5121 eqvdsc.dsc$a_pointer = equiv;
5123 iss = lib$get_symbol(vmscmd,&eqvdsc);
5124 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5126 if (!(retsts & 1)) {
5127 /* just hand off status values likely to be due to user error */
5128 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5129 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5130 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5131 else { _ckvmssts(retsts); }
5134 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5136 } /* end of setup_cmddsc() */
5139 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5141 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5144 if (vfork_called) { /* this follows a vfork - act Unixish */
5146 if (vfork_called < 0) {
5147 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5150 else return do_aexec(really,mark,sp);
5152 /* no vfork - act VMSish */
5153 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5158 } /* end of vms_do_aexec() */
5161 /* {{{bool vms_do_exec(char *cmd) */
5163 Perl_vms_do_exec(pTHX_ char *cmd)
5165 struct dsc$descriptor_s *vmscmd;
5167 if (vfork_called) { /* this follows a vfork - act Unixish */
5169 if (vfork_called < 0) {
5170 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5173 else return do_exec(cmd);
5176 { /* no vfork - act VMSish */
5177 unsigned long int retsts;
5180 TAINT_PROPER("exec");
5181 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5182 retsts = lib$do_command(vmscmd);
5185 case RMS$_FNF: case RMS$_DNF:
5186 set_errno(ENOENT); break;
5188 set_errno(ENOTDIR); break;
5190 set_errno(ENODEV); break;
5192 set_errno(EACCES); break;
5194 set_errno(EINVAL); break;
5195 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5196 set_errno(E2BIG); break;
5197 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5198 _ckvmssts(retsts); /* fall through */
5199 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5202 set_vaxc_errno(retsts);
5203 if (ckWARN(WARN_EXEC)) {
5204 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5205 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5207 vms_execfree(vmscmd);
5212 } /* end of vms_do_exec() */
5215 unsigned long int Perl_do_spawn(pTHX_ char *);
5217 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5219 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5221 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5224 } /* end of do_aspawn() */
5227 /* {{{unsigned long int do_spawn(char *cmd) */
5229 Perl_do_spawn(pTHX_ char *cmd)
5231 unsigned long int sts, substs;
5234 TAINT_PROPER("spawn");
5235 if (!cmd || !*cmd) {
5236 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5239 case RMS$_FNF: case RMS$_DNF:
5240 set_errno(ENOENT); break;
5242 set_errno(ENOTDIR); break;
5244 set_errno(ENODEV); break;
5246 set_errno(EACCES); break;
5248 set_errno(EINVAL); break;
5249 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5250 set_errno(E2BIG); break;
5251 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5252 _ckvmssts(sts); /* fall through */
5253 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5256 set_vaxc_errno(sts);
5257 if (ckWARN(WARN_EXEC)) {
5258 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5265 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5268 } /* end of do_spawn() */
5272 static unsigned int *sockflags, sockflagsize;
5275 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5276 * routines found in some versions of the CRTL can't deal with sockets.
5277 * We don't shim the other file open routines since a socket isn't
5278 * likely to be opened by a name.
5280 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5281 FILE *my_fdopen(int fd, const char *mode)
5283 FILE *fp = fdopen(fd, (char *) mode);
5286 unsigned int fdoff = fd / sizeof(unsigned int);
5287 struct stat sbuf; /* native stat; we don't need flex_stat */
5288 if (!sockflagsize || fdoff > sockflagsize) {
5289 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5290 else New (1324,sockflags,fdoff+2,unsigned int);
5291 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5292 sockflagsize = fdoff + 2;
5294 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5295 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5304 * Clear the corresponding bit when the (possibly) socket stream is closed.
5305 * There still a small hole: we miss an implicit close which might occur
5306 * via freopen(). >> Todo
5308 /*{{{ int my_fclose(FILE *fp)*/
5309 int my_fclose(FILE *fp) {
5311 unsigned int fd = fileno(fp);
5312 unsigned int fdoff = fd / sizeof(unsigned int);
5314 if (sockflagsize && fdoff <= sockflagsize)
5315 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5323 * A simple fwrite replacement which outputs itmsz*nitm chars without
5324 * introducing record boundaries every itmsz chars.
5325 * We are using fputs, which depends on a terminating null. We may
5326 * well be writing binary data, so we need to accommodate not only
5327 * data with nulls sprinkled in the middle but also data with no null
5330 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5332 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5334 register char *cp, *end, *cpd, *data;
5335 register unsigned int fd = fileno(dest);
5336 register unsigned int fdoff = fd / sizeof(unsigned int);
5338 int bufsize = itmsz * nitm + 1;
5340 if (fdoff < sockflagsize &&
5341 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5342 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5346 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5347 memcpy( data, src, itmsz*nitm );
5348 data[itmsz*nitm] = '\0';
5350 end = data + itmsz * nitm;
5351 retval = (int) nitm; /* on success return # items written */
5354 while (cpd <= end) {
5355 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5356 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5358 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5362 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5365 } /* end of my_fwrite() */
5368 /*{{{ int my_flush(FILE *fp)*/
5370 Perl_my_flush(pTHX_ FILE *fp)
5373 if ((res = fflush(fp)) == 0 && fp) {
5374 #ifdef VMS_DO_SOCKETS
5376 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5378 res = fsync(fileno(fp));
5381 * If the flush succeeded but set end-of-file, we need to clear
5382 * the error because our caller may check ferror(). BTW, this
5383 * probably means we just flushed an empty file.
5385 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5392 * Here are replacements for the following Unix routines in the VMS environment:
5393 * getpwuid Get information for a particular UIC or UID
5394 * getpwnam Get information for a named user
5395 * getpwent Get information for each user in the rights database
5396 * setpwent Reset search to the start of the rights database
5397 * endpwent Finish searching for users in the rights database
5399 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5400 * (defined in pwd.h), which contains the following fields:-
5402 * char *pw_name; Username (in lower case)
5403 * char *pw_passwd; Hashed password
5404 * unsigned int pw_uid; UIC
5405 * unsigned int pw_gid; UIC group number
5406 * char *pw_unixdir; Default device/directory (VMS-style)
5407 * char *pw_gecos; Owner name
5408 * char *pw_dir; Default device/directory (Unix-style)
5409 * char *pw_shell; Default CLI name (eg. DCL)
5411 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5413 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5414 * not the UIC member number (eg. what's returned by getuid()),
5415 * getpwuid() can accept either as input (if uid is specified, the caller's
5416 * UIC group is used), though it won't recognise gid=0.
5418 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5419 * information about other users in your group or in other groups, respectively.
5420 * If the required privilege is not available, then these routines fill only
5421 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5424 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5427 /* sizes of various UAF record fields */
5428 #define UAI$S_USERNAME 12
5429 #define UAI$S_IDENT 31
5430 #define UAI$S_OWNER 31
5431 #define UAI$S_DEFDEV 31
5432 #define UAI$S_DEFDIR 63
5433 #define UAI$S_DEFCLI 31
5436 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5437 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5438 (uic).uic$v_group != UIC$K_WILD_GROUP)
5440 static char __empty[]= "";
5441 static struct passwd __passwd_empty=
5442 {(char *) __empty, (char *) __empty, 0, 0,
5443 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5444 static int contxt= 0;
5445 static struct passwd __pwdcache;
5446 static char __pw_namecache[UAI$S_IDENT+1];
5449 * This routine does most of the work extracting the user information.
5451 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5454 unsigned char length;
5455 char pw_gecos[UAI$S_OWNER+1];
5457 static union uicdef uic;
5459 unsigned char length;
5460 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5463 unsigned char length;
5464 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5467 unsigned char length;
5468 char pw_shell[UAI$S_DEFCLI+1];
5470 static char pw_passwd[UAI$S_PWD+1];
5472 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5473 struct dsc$descriptor_s name_desc;
5474 unsigned long int sts;
5476 static struct itmlst_3 itmlst[]= {
5477 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5478 {sizeof(uic), UAI$_UIC, &uic, &luic},
5479 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5480 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5481 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5482 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5483 {0, 0, NULL, NULL}};
5485 name_desc.dsc$w_length= strlen(name);
5486 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5487 name_desc.dsc$b_class= DSC$K_CLASS_S;
5488 name_desc.dsc$a_pointer= (char *) name;
5490 /* Note that sys$getuai returns many fields as counted strings. */
5491 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5492 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5493 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5495 else { _ckvmssts(sts); }
5496 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5498 if ((int) owner.length < lowner) lowner= (int) owner.length;
5499 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5500 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5501 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5502 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5503 owner.pw_gecos[lowner]= '\0';
5504 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5505 defcli.pw_shell[ldefcli]= '\0';
5506 if (valid_uic(uic)) {
5507 pwd->pw_uid= uic.uic$l_uic;
5508 pwd->pw_gid= uic.uic$v_group;
5511 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5512 pwd->pw_passwd= pw_passwd;
5513 pwd->pw_gecos= owner.pw_gecos;
5514 pwd->pw_dir= defdev.pw_dir;
5515 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5516 pwd->pw_shell= defcli.pw_shell;
5517 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5519 ldir= strlen(pwd->pw_unixdir) - 1;
5520 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5523 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5524 __mystrtolower(pwd->pw_unixdir);
5529 * Get information for a named user.
5531 /*{{{struct passwd *getpwnam(char *name)*/
5532 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5534 struct dsc$descriptor_s name_desc;
5536 unsigned long int status, sts;
5538 __pwdcache = __passwd_empty;
5539 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5540 /* We still may be able to determine pw_uid and pw_gid */
5541 name_desc.dsc$w_length= strlen(name);
5542 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5543 name_desc.dsc$b_class= DSC$K_CLASS_S;
5544 name_desc.dsc$a_pointer= (char *) name;
5545 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5546 __pwdcache.pw_uid= uic.uic$l_uic;
5547 __pwdcache.pw_gid= uic.uic$v_group;
5550 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5551 set_vaxc_errno(sts);
5552 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5555 else { _ckvmssts(sts); }
5558 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5559 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5560 __pwdcache.pw_name= __pw_namecache;
5562 } /* end of my_getpwnam() */
5566 * Get information for a particular UIC or UID.
5567 * Called by my_getpwent with uid=-1 to list all users.
5569 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5570 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5572 const $DESCRIPTOR(name_desc,__pw_namecache);
5573 unsigned short lname;
5575 unsigned long int status;
5577 if (uid == (unsigned int) -1) {
5579 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5580 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5581 set_vaxc_errno(status);
5582 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5586 else { _ckvmssts(status); }
5587 } while (!valid_uic (uic));
5591 if (!uic.uic$v_group)
5592 uic.uic$v_group= PerlProc_getgid();
5594 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5595 else status = SS$_IVIDENT;
5596 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5597 status == RMS$_PRV) {
5598 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5601 else { _ckvmssts(status); }
5603 __pw_namecache[lname]= '\0';
5604 __mystrtolower(__pw_namecache);
5606 __pwdcache = __passwd_empty;
5607 __pwdcache.pw_name = __pw_namecache;
5609 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5610 The identifier's value is usually the UIC, but it doesn't have to be,
5611 so if we can, we let fillpasswd update this. */
5612 __pwdcache.pw_uid = uic.uic$l_uic;
5613 __pwdcache.pw_gid = uic.uic$v_group;
5615 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5618 } /* end of my_getpwuid() */
5622 * Get information for next user.
5624 /*{{{struct passwd *my_getpwent()*/
5625 struct passwd *Perl_my_getpwent(pTHX)
5627 return (my_getpwuid((unsigned int) -1));
5632 * Finish searching rights database for users.
5634 /*{{{void my_endpwent()*/
5635 void Perl_my_endpwent(pTHX)
5638 _ckvmssts(sys$finish_rdb(&contxt));
5644 #ifdef HOMEGROWN_POSIX_SIGNALS
5645 /* Signal handling routines, pulled into the core from POSIX.xs.
5647 * We need these for threads, so they've been rolled into the core,
5648 * rather than left in POSIX.xs.
5650 * (DRS, Oct 23, 1997)
5653 /* sigset_t is atomic under VMS, so these routines are easy */
5654 /*{{{int my_sigemptyset(sigset_t *) */
5655 int my_sigemptyset(sigset_t *set) {
5656 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5662 /*{{{int my_sigfillset(sigset_t *)*/
5663 int my_sigfillset(sigset_t *set) {
5665 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5666 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5672 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5673 int my_sigaddset(sigset_t *set, int sig) {
5674 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5675 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5676 *set |= (1 << (sig - 1));
5682 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5683 int my_sigdelset(sigset_t *set, int sig) {
5684 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5685 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5686 *set &= ~(1 << (sig - 1));
5692 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5693 int my_sigismember(sigset_t *set, int sig) {
5694 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5695 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5696 return *set & (1 << (sig - 1));
5701 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5702 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5705 /* If set and oset are both null, then things are badly wrong. Bail out. */
5706 if ((oset == NULL) && (set == NULL)) {
5707 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5711 /* If set's null, then we're just handling a fetch. */
5713 tempmask = sigblock(0);
5718 tempmask = sigsetmask(*set);
5721 tempmask = sigblock(*set);
5724 tempmask = sigblock(0);
5725 sigsetmask(*oset & ~tempmask);
5728 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5733 /* Did they pass us an oset? If so, stick our holding mask into it */
5740 #endif /* HOMEGROWN_POSIX_SIGNALS */
5743 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5744 * my_utime(), and flex_stat(), all of which operate on UTC unless
5745 * VMSISH_TIMES is true.
5747 /* method used to handle UTC conversions:
5748 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5750 static int gmtime_emulation_type;
5751 /* number of secs to add to UTC POSIX-style time to get local time */
5752 static long int utc_offset_secs;
5754 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5755 * in vmsish.h. #undef them here so we can call the CRTL routines
5764 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5765 * qualifier with the extern prefix pragma. This provisional
5766 * hack circumvents this prefix pragma problem in previous
5769 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5770 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5771 # pragma __extern_prefix save
5772 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5773 # define gmtime decc$__utctz_gmtime
5774 # define localtime decc$__utctz_localtime
5775 # define time decc$__utc_time
5776 # pragma __extern_prefix restore
5778 struct tm *gmtime(), *localtime();
5784 static time_t toutc_dst(time_t loc) {
5787 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5788 loc -= utc_offset_secs;
5789 if (rsltmp->tm_isdst) loc -= 3600;
5792 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5793 ((gmtime_emulation_type || my_time(NULL)), \
5794 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5795 ((secs) - utc_offset_secs))))
5797 static time_t toloc_dst(time_t utc) {
5800 utc += utc_offset_secs;
5801 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5802 if (rsltmp->tm_isdst) utc += 3600;
5805 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5806 ((gmtime_emulation_type || my_time(NULL)), \
5807 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5808 ((secs) + utc_offset_secs))))
5810 #ifndef RTL_USES_UTC
5813 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5814 DST starts on 1st sun of april at 02:00 std time
5815 ends on last sun of october at 02:00 dst time
5816 see the UCX management command reference, SET CONFIG TIMEZONE
5817 for formatting info.
5819 No, it's not as general as it should be, but then again, NOTHING
5820 will handle UK times in a sensible way.
5825 parse the DST start/end info:
5826 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5830 tz_parse_startend(char *s, struct tm *w, int *past)
5832 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5833 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5838 if (!past) return 0;
5841 if (w->tm_year % 4 == 0) ly = 1;
5842 if (w->tm_year % 100 == 0) ly = 0;
5843 if (w->tm_year+1900 % 400 == 0) ly = 1;
5846 dozjd = isdigit(*s);
5847 if (*s == 'J' || *s == 'j' || dozjd) {
5848 if (!dozjd && !isdigit(*++s)) return 0;
5851 d = d*10 + *s++ - '0';
5853 d = d*10 + *s++ - '0';
5856 if (d == 0) return 0;
5857 if (d > 366) return 0;
5859 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5862 } else if (*s == 'M' || *s == 'm') {
5863 if (!isdigit(*++s)) return 0;
5865 if (isdigit(*s)) m = 10*m + *s++ - '0';
5866 if (*s != '.') return 0;
5867 if (!isdigit(*++s)) return 0;
5869 if (n < 1 || n > 5) return 0;
5870 if (*s != '.') return 0;
5871 if (!isdigit(*++s)) return 0;
5873 if (d > 6) return 0;
5877 if (!isdigit(*++s)) return 0;
5879 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5881 if (!isdigit(*++s)) return 0;
5883 if (isdigit(*s)) min = 10*min + *s++ - '0';
5885 if (!isdigit(*++s)) return 0;
5887 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5897 if (w->tm_yday < d) goto before;
5898 if (w->tm_yday > d) goto after;
5900 if (w->tm_mon+1 < m) goto before;
5901 if (w->tm_mon+1 > m) goto after;
5903 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5904 k = d - j; /* mday of first d */
5906 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5907 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5908 if (w->tm_mday < k) goto before;
5909 if (w->tm_mday > k) goto after;
5912 if (w->tm_hour < hour) goto before;
5913 if (w->tm_hour > hour) goto after;
5914 if (w->tm_min < min) goto before;
5915 if (w->tm_min > min) goto after;
5916 if (w->tm_sec < sec) goto before;
5930 /* parse the offset: (+|-)hh[:mm[:ss]] */
5933 tz_parse_offset(char *s, int *offset)
5935 int hour = 0, min = 0, sec = 0;
5938 if (!offset) return 0;
5940 if (*s == '-') {neg++; s++;}
5942 if (!isdigit(*s)) return 0;
5944 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5945 if (hour > 24) return 0;
5947 if (!isdigit(*++s)) return 0;
5949 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5950 if (min > 59) return 0;
5952 if (!isdigit(*++s)) return 0;
5954 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5955 if (sec > 59) return 0;
5959 *offset = (hour*60+min)*60 + sec;
5960 if (neg) *offset = -*offset;
5965 input time is w, whatever type of time the CRTL localtime() uses.
5966 sets dst, the zone, and the gmtoff (seconds)
5968 caches the value of TZ and UCX$TZ env variables; note that
5969 my_setenv looks for these and sets a flag if they're changed
5972 We have to watch out for the "australian" case (dst starts in
5973 october, ends in april)...flagged by "reverse" and checked by
5974 scanning through the months of the previous year.
5979 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5984 char *dstzone, *tz, *s_start, *s_end;
5985 int std_off, dst_off, isdst;
5986 int y, dststart, dstend;
5987 static char envtz[1025]; /* longer than any logical, symbol, ... */
5988 static char ucxtz[1025];
5989 static char reversed = 0;
5995 reversed = -1; /* flag need to check */
5996 envtz[0] = ucxtz[0] = '\0';
5997 tz = my_getenv("TZ",0);
5998 if (tz) strcpy(envtz, tz);
5999 tz = my_getenv("UCX$TZ",0);
6000 if (tz) strcpy(ucxtz, tz);
6001 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6004 if (!*tz) tz = ucxtz;
6007 while (isalpha(*s)) s++;
6008 s = tz_parse_offset(s, &std_off);
6010 if (!*s) { /* no DST, hurray we're done! */
6016 while (isalpha(*s)) s++;
6017 s2 = tz_parse_offset(s, &dst_off);
6021 dst_off = std_off - 3600;
6024 if (!*s) { /* default dst start/end?? */
6025 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6026 s = strchr(ucxtz,',');
6028 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6030 if (*s != ',') return 0;
6033 when = _toutc(when); /* convert to utc */
6034 when = when - std_off; /* convert to pseudolocal time*/
6036 w2 = localtime(&when);
6039 s = tz_parse_startend(s_start,w2,&dststart);
6041 if (*s != ',') return 0;
6044 when = _toutc(when); /* convert to utc */
6045 when = when - dst_off; /* convert to pseudolocal time*/
6046 w2 = localtime(&when);
6047 if (w2->tm_year != y) { /* spans a year, just check one time */
6048 when += dst_off - std_off;
6049 w2 = localtime(&when);
6052 s = tz_parse_startend(s_end,w2,&dstend);
6055 if (reversed == -1) { /* need to check if start later than end */
6059 if (when < 2*365*86400) {
6060 when += 2*365*86400;
6064 w2 =localtime(&when);
6065 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6067 for (j = 0; j < 12; j++) {
6068 w2 =localtime(&when);
6069 (void) tz_parse_startend(s_start,w2,&ds);
6070 (void) tz_parse_startend(s_end,w2,&de);
6071 if (ds != de) break;
6075 if (de && !ds) reversed = 1;
6078 isdst = dststart && !dstend;
6079 if (reversed) isdst = dststart || !dstend;
6082 if (dst) *dst = isdst;
6083 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6084 if (isdst) tz = dstzone;
6086 while(isalpha(*tz)) *zone++ = *tz++;
6092 #endif /* !RTL_USES_UTC */
6094 /* my_time(), my_localtime(), my_gmtime()
6095 * By default traffic in UTC time values, using CRTL gmtime() or
6096 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6097 * Note: We need to use these functions even when the CRTL has working
6098 * UTC support, since they also handle C<use vmsish qw(times);>
6100 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6101 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6104 /*{{{time_t my_time(time_t *timep)*/
6105 time_t Perl_my_time(pTHX_ time_t *timep)
6110 if (gmtime_emulation_type == 0) {
6112 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6113 /* results of calls to gmtime() and localtime() */
6114 /* for same &base */
6116 gmtime_emulation_type++;
6117 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6118 char off[LNM$C_NAMLENGTH+1];;
6120 gmtime_emulation_type++;
6121 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6122 gmtime_emulation_type++;
6123 utc_offset_secs = 0;
6124 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6126 else { utc_offset_secs = atol(off); }
6128 else { /* We've got a working gmtime() */
6129 struct tm gmt, local;
6132 tm_p = localtime(&base);
6134 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6135 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6136 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6137 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6143 # ifdef RTL_USES_UTC
6144 if (VMSISH_TIME) when = _toloc(when);
6146 if (!VMSISH_TIME) when = _toutc(when);
6149 if (timep != NULL) *timep = when;
6152 } /* end of my_time() */
6156 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6158 Perl_my_gmtime(pTHX_ const time_t *timep)
6164 if (timep == NULL) {
6165 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6168 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6172 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6174 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6175 return gmtime(&when);
6177 /* CRTL localtime() wants local time as input, so does no tz correction */
6178 rsltmp = localtime(&when);
6179 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6182 } /* end of my_gmtime() */
6186 /*{{{struct tm *my_localtime(const time_t *timep)*/
6188 Perl_my_localtime(pTHX_ const time_t *timep)
6190 time_t when, whenutc;
6194 if (timep == NULL) {
6195 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6198 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6199 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6202 # ifdef RTL_USES_UTC
6204 if (VMSISH_TIME) when = _toutc(when);
6206 /* CRTL localtime() wants UTC as input, does tz correction itself */
6207 return localtime(&when);
6209 # else /* !RTL_USES_UTC */
6212 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6213 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6216 #ifndef RTL_USES_UTC
6217 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6218 when = whenutc - offset; /* pseudolocal time*/
6221 /* CRTL localtime() wants local time as input, so does no tz correction */
6222 rsltmp = localtime(&when);
6223 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6227 } /* end of my_localtime() */
6230 /* Reset definitions for later calls */
6231 #define gmtime(t) my_gmtime(t)
6232 #define localtime(t) my_localtime(t)
6233 #define time(t) my_time(t)
6236 /* my_utime - update modification time of a file
6237 * calling sequence is identical to POSIX utime(), but under
6238 * VMS only the modification time is changed; ODS-2 does not
6239 * maintain access times. Restrictions differ from the POSIX
6240 * definition in that the time can be changed as long as the
6241 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6242 * no separate checks are made to insure that the caller is the
6243 * owner of the file or has special privs enabled.
6244 * Code here is based on Joe Meadows' FILE utility.
6247 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6248 * to VMS epoch (01-JAN-1858 00:00:00.00)
6249 * in 100 ns intervals.
6251 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6253 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6254 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6257 long int bintime[2], len = 2, lowbit, unixtime,
6258 secscale = 10000000; /* seconds --> 100 ns intervals */
6259 unsigned long int chan, iosb[2], retsts;
6260 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6261 struct FAB myfab = cc$rms_fab;
6262 struct NAM mynam = cc$rms_nam;
6263 #if defined (__DECC) && defined (__VAX)
6264 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6265 * at least through VMS V6.1, which causes a type-conversion warning.
6267 # pragma message save
6268 # pragma message disable cvtdiftypes
6270 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6271 struct fibdef myfib;
6272 #if defined (__DECC) && defined (__VAX)
6273 /* This should be right after the declaration of myatr, but due
6274 * to a bug in VAX DEC C, this takes effect a statement early.
6276 # pragma message restore
6278 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6279 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6280 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6282 if (file == NULL || *file == '\0') {
6284 set_vaxc_errno(LIB$_INVARG);
6287 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6289 if (utimes != NULL) {
6290 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6291 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6292 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6293 * as input, we force the sign bit to be clear by shifting unixtime right
6294 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6296 lowbit = (utimes->modtime & 1) ? secscale : 0;
6297 unixtime = (long int) utimes->modtime;
6299 /* If input was UTC; convert to local for sys svc */
6300 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6302 unixtime >>= 1; secscale <<= 1;
6303 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6304 if (!(retsts & 1)) {
6306 set_vaxc_errno(retsts);
6309 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6310 if (!(retsts & 1)) {
6312 set_vaxc_errno(retsts);
6317 /* Just get the current time in VMS format directly */
6318 retsts = sys$gettim(bintime);
6319 if (!(retsts & 1)) {
6321 set_vaxc_errno(retsts);
6326 myfab.fab$l_fna = vmsspec;
6327 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6328 myfab.fab$l_nam = &mynam;
6329 mynam.nam$l_esa = esa;
6330 mynam.nam$b_ess = (unsigned char) sizeof esa;
6331 mynam.nam$l_rsa = rsa;
6332 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6334 /* Look for the file to be affected, letting RMS parse the file
6335 * specification for us as well. I have set errno using only
6336 * values documented in the utime() man page for VMS POSIX.
6338 retsts = sys$parse(&myfab,0,0);
6339 if (!(retsts & 1)) {
6340 set_vaxc_errno(retsts);
6341 if (retsts == RMS$_PRV) set_errno(EACCES);
6342 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6343 else set_errno(EVMSERR);
6346 retsts = sys$search(&myfab,0,0);
6347 if (!(retsts & 1)) {
6348 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6349 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6350 set_vaxc_errno(retsts);
6351 if (retsts == RMS$_PRV) set_errno(EACCES);
6352 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6353 else set_errno(EVMSERR);
6357 devdsc.dsc$w_length = mynam.nam$b_dev;
6358 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6360 retsts = sys$assign(&devdsc,&chan,0,0);
6361 if (!(retsts & 1)) {
6362 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6363 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6364 set_vaxc_errno(retsts);
6365 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6366 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6367 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6368 else set_errno(EVMSERR);
6372 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6373 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6375 memset((void *) &myfib, 0, sizeof myfib);
6376 #if defined(__DECC) || defined(__DECCXX)
6377 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6378 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6379 /* This prevents the revision time of the file being reset to the current
6380 * time as a result of our IO$_MODIFY $QIO. */
6381 myfib.fib$l_acctl = FIB$M_NORECORD;
6383 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6384 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6385 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6387 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6388 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6389 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6390 _ckvmssts(sys$dassgn(chan));
6391 if (retsts & 1) retsts = iosb[0];
6392 if (!(retsts & 1)) {
6393 set_vaxc_errno(retsts);
6394 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6395 else set_errno(EVMSERR);
6400 } /* end of my_utime() */
6404 * flex_stat, flex_fstat
6405 * basic stat, but gets it right when asked to stat
6406 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6409 /* encode_dev packs a VMS device name string into an integer to allow
6410 * simple comparisons. This can be used, for example, to check whether two
6411 * files are located on the same device, by comparing their encoded device
6412 * names. Even a string comparison would not do, because stat() reuses the
6413 * device name buffer for each call; so without encode_dev, it would be
6414 * necessary to save the buffer and use strcmp (this would mean a number of
6415 * changes to the standard Perl code, to say nothing of what a Perl script
6418 * The device lock id, if it exists, should be unique (unless perhaps compared
6419 * with lock ids transferred from other nodes). We have a lock id if the disk is
6420 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6421 * device names. Thus we use the lock id in preference, and only if that isn't
6422 * available, do we try to pack the device name into an integer (flagged by
6423 * the sign bit (LOCKID_MASK) being set).
6425 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6426 * name and its encoded form, but it seems very unlikely that we will find
6427 * two files on different disks that share the same encoded device names,
6428 * and even more remote that they will share the same file id (if the test
6429 * is to check for the same file).
6431 * A better method might be to use sys$device_scan on the first call, and to
6432 * search for the device, returning an index into the cached array.
6433 * The number returned would be more intelligable.
6434 * This is probably not worth it, and anyway would take quite a bit longer
6435 * on the first call.
6437 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6438 static mydev_t encode_dev (pTHX_ const char *dev)
6441 unsigned long int f;
6446 if (!dev || !dev[0]) return 0;
6450 struct dsc$descriptor_s dev_desc;
6451 unsigned long int status, lockid, item = DVI$_LOCKID;
6453 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6454 can try that first. */
6455 dev_desc.dsc$w_length = strlen (dev);
6456 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6457 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6458 dev_desc.dsc$a_pointer = (char *) dev;
6459 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6460 if (lockid) return (lockid & ~LOCKID_MASK);
6464 /* Otherwise we try to encode the device name */
6468 for (q = dev + strlen(dev); q--; q >= dev) {
6471 else if (isalpha (toupper (*q)))
6472 c= toupper (*q) - 'A' + (char)10;
6474 continue; /* Skip '$'s */
6476 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6478 enc += f * (unsigned long int) c;
6480 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6482 } /* end of encode_dev() */
6484 static char namecache[NAM$C_MAXRSS+1];
6487 is_null_device(name)
6490 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6491 The underscore prefix, controller letter, and unit number are
6492 independently optional; for our purposes, the colon punctuation
6493 is not. The colon can be trailed by optional directory and/or
6494 filename, but two consecutive colons indicates a nodename rather
6495 than a device. [pr] */
6496 if (*name == '_') ++name;
6497 if (tolower(*name++) != 'n') return 0;
6498 if (tolower(*name++) != 'l') return 0;
6499 if (tolower(*name) == 'a') ++name;
6500 if (*name == '0') ++name;
6501 return (*name++ == ':') && (*name != ':');
6504 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6505 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6506 * subset of the applicable information.
6509 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6511 char fname_phdev[NAM$C_MAXRSS+1];
6512 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6514 char fname[NAM$C_MAXRSS+1];
6515 unsigned long int retsts;
6516 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6517 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6519 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6520 device name on successive calls */
6521 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6522 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6523 namdsc.dsc$a_pointer = fname;
6524 namdsc.dsc$w_length = sizeof fname - 1;
6526 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6527 &namdsc,&namdsc.dsc$w_length,0,0);
6529 fname[namdsc.dsc$w_length] = '\0';
6531 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6532 * but if someone has redefined that logical, Perl gets very lost. Since
6533 * we have the physical device name from the stat buffer, just paste it on.
6535 strcpy( fname_phdev, statbufp->st_devnam );
6536 strcat( fname_phdev, strrchr(fname, ':') );
6538 return cando_by_name(bit,effective,fname_phdev);
6540 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6541 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6545 return FALSE; /* Should never get to here */
6547 } /* end of cando() */
6551 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6553 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6555 static char usrname[L_cuserid];
6556 static struct dsc$descriptor_s usrdsc =
6557 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6558 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6559 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6560 unsigned short int retlen, trnlnm_iter_count;
6561 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6562 union prvdef curprv;
6563 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6564 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6565 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6566 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6568 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6570 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6572 if (!fname || !*fname) return FALSE;
6573 /* Make sure we expand logical names, since sys$check_access doesn't */
6574 if (!strpbrk(fname,"/]>:")) {
6575 strcpy(fileified,fname);
6576 trnlnm_iter_count = 0;
6577 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
6578 trnlnm_iter_count++;
6579 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6583 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6584 retlen = namdsc.dsc$w_length = strlen(vmsname);
6585 namdsc.dsc$a_pointer = vmsname;
6586 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6587 vmsname[retlen-1] == ':') {
6588 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6589 namdsc.dsc$w_length = strlen(fileified);
6590 namdsc.dsc$a_pointer = fileified;
6594 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6595 access = ARM$M_EXECUTE; break;
6596 case S_IRUSR: case S_IRGRP: case S_IROTH:
6597 access = ARM$M_READ; break;
6598 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6599 access = ARM$M_WRITE; break;
6600 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6601 access = ARM$M_DELETE; break;
6606 /* Before we call $check_access, create a user profile with the current
6607 * process privs since otherwise it just uses the default privs from the
6608 * UAF and might give false positives or negatives. This only works on
6609 * VMS versions v6.0 and later since that's when sys$create_user_profile
6613 /* get current process privs and username */
6614 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6617 #if defined(__VMS_VER) && __VMS_VER >= 60000000
6619 /* find out the space required for the profile */
6620 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6621 &usrprodsc.dsc$w_length,0));
6623 /* allocate space for the profile and get it filled in */
6624 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6625 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6626 &usrprodsc.dsc$w_length,0));
6628 /* use the profile to check access to the file; free profile & analyze results */
6629 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6630 Safefree(usrprodsc.dsc$a_pointer);
6631 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6635 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6639 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6640 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6641 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6642 set_vaxc_errno(retsts);
6643 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6644 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6645 else set_errno(ENOENT);
6648 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6653 return FALSE; /* Should never get here */
6655 } /* end of cando_by_name() */
6659 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6661 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6663 if (!fstat(fd,(stat_t *) statbufp)) {
6664 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6665 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6666 # ifdef RTL_USES_UTC
6669 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6670 statbufp->st_atime = _toloc(statbufp->st_atime);
6671 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6676 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6680 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6681 statbufp->st_atime = _toutc(statbufp->st_atime);
6682 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6689 } /* end of flex_fstat() */
6692 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6694 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6696 char fileified[NAM$C_MAXRSS+1];
6697 char temp_fspec[NAM$C_MAXRSS+300];
6699 int saved_errno, saved_vaxc_errno;
6701 if (!fspec) return retval;
6702 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6703 strcpy(temp_fspec, fspec);
6704 if (statbufp == (Stat_t *) &PL_statcache)
6705 do_tovmsspec(temp_fspec,namecache,0);
6706 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6707 memset(statbufp,0,sizeof *statbufp);
6708 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6709 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6710 statbufp->st_uid = 0x00010001;
6711 statbufp->st_gid = 0x0001;
6712 time((time_t *)&statbufp->st_mtime);
6713 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6717 /* Try for a directory name first. If fspec contains a filename without
6718 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6719 * and sea:[wine.dark]water. exist, we prefer the directory here.
6720 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6721 * not sea:[wine.dark]., if the latter exists. If the intended target is
6722 * the file with null type, specify this by calling flex_stat() with
6723 * a '.' at the end of fspec.
6725 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6726 retval = stat(fileified,(stat_t *) statbufp);
6727 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6728 strcpy(namecache,fileified);
6730 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6732 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6733 # ifdef RTL_USES_UTC
6736 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6737 statbufp->st_atime = _toloc(statbufp->st_atime);
6738 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6743 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6747 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6748 statbufp->st_atime = _toutc(statbufp->st_atime);
6749 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6753 /* If we were successful, leave errno where we found it */
6754 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6757 } /* end of flex_stat() */
6761 /*{{{char *my_getlogin()*/
6762 /* VMS cuserid == Unix getlogin, except calling sequence */
6766 static char user[L_cuserid];
6767 return cuserid(user);
6772 /* rmscopy - copy a file using VMS RMS routines
6774 * Copies contents and attributes of spec_in to spec_out, except owner
6775 * and protection information. Name and type of spec_in are used as
6776 * defaults for spec_out. The third parameter specifies whether rmscopy()
6777 * should try to propagate timestamps from the input file to the output file.
6778 * If it is less than 0, no timestamps are preserved. If it is 0, then
6779 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6780 * propagated to the output file at creation iff the output file specification
6781 * did not contain an explicit name or type, and the revision date is always
6782 * updated at the end of the copy operation. If it is greater than 0, then
6783 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6784 * other than the revision date should be propagated, and bit 1 indicates
6785 * that the revision date should be propagated.
6787 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6789 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6790 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6791 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6792 * as part of the Perl standard distribution under the terms of the
6793 * GNU General Public License or the Perl Artistic License. Copies
6794 * of each may be found in the Perl standard distribution.
6796 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6798 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6800 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6801 rsa[NAM$C_MAXRSS], ubf[32256];
6802 unsigned long int i, sts, sts2;
6803 struct FAB fab_in, fab_out;
6804 struct RAB rab_in, rab_out;
6806 struct XABDAT xabdat;
6807 struct XABFHC xabfhc;
6808 struct XABRDT xabrdt;
6809 struct XABSUM xabsum;
6811 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6812 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6813 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6817 fab_in = cc$rms_fab;
6818 fab_in.fab$l_fna = vmsin;
6819 fab_in.fab$b_fns = strlen(vmsin);
6820 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6821 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6822 fab_in.fab$l_fop = FAB$M_SQO;
6823 fab_in.fab$l_nam = &nam;
6824 fab_in.fab$l_xab = (void *) &xabdat;
6827 nam.nam$l_rsa = rsa;
6828 nam.nam$b_rss = sizeof(rsa);
6829 nam.nam$l_esa = esa;
6830 nam.nam$b_ess = sizeof (esa);
6831 nam.nam$b_esl = nam.nam$b_rsl = 0;
6833 xabdat = cc$rms_xabdat; /* To get creation date */
6834 xabdat.xab$l_nxt = (void *) &xabfhc;
6836 xabfhc = cc$rms_xabfhc; /* To get record length */
6837 xabfhc.xab$l_nxt = (void *) &xabsum;
6839 xabsum = cc$rms_xabsum; /* To get key and area information */
6841 if (!((sts = sys$open(&fab_in)) & 1)) {
6842 set_vaxc_errno(sts);
6844 case RMS$_FNF: case RMS$_DNF:
6845 set_errno(ENOENT); break;
6847 set_errno(ENOTDIR); break;
6849 set_errno(ENODEV); break;
6851 set_errno(EINVAL); break;
6853 set_errno(EACCES); break;
6861 fab_out.fab$w_ifi = 0;
6862 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6863 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6864 fab_out.fab$l_fop = FAB$M_SQO;
6865 fab_out.fab$l_fna = vmsout;
6866 fab_out.fab$b_fns = strlen(vmsout);
6867 fab_out.fab$l_dna = nam.nam$l_name;
6868 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6870 if (preserve_dates == 0) { /* Act like DCL COPY */
6871 nam.nam$b_nop = NAM$M_SYNCHK;
6872 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6873 if (!((sts = sys$parse(&fab_out)) & 1)) {
6874 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6875 set_vaxc_errno(sts);
6878 fab_out.fab$l_xab = (void *) &xabdat;
6879 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6881 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6882 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6883 preserve_dates =0; /* bitmask from this point forward */
6885 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6886 if (!((sts = sys$create(&fab_out)) & 1)) {
6887 set_vaxc_errno(sts);
6890 set_errno(ENOENT); break;
6892 set_errno(ENOTDIR); break;
6894 set_errno(ENODEV); break;
6896 set_errno(EINVAL); break;
6898 set_errno(EACCES); break;
6904 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6905 if (preserve_dates & 2) {
6906 /* sys$close() will process xabrdt, not xabdat */
6907 xabrdt = cc$rms_xabrdt;
6909 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6911 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6912 * is unsigned long[2], while DECC & VAXC use a struct */
6913 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6915 fab_out.fab$l_xab = (void *) &xabrdt;
6918 rab_in = cc$rms_rab;
6919 rab_in.rab$l_fab = &fab_in;
6920 rab_in.rab$l_rop = RAB$M_BIO;
6921 rab_in.rab$l_ubf = ubf;
6922 rab_in.rab$w_usz = sizeof ubf;
6923 if (!((sts = sys$connect(&rab_in)) & 1)) {
6924 sys$close(&fab_in); sys$close(&fab_out);
6925 set_errno(EVMSERR); set_vaxc_errno(sts);
6929 rab_out = cc$rms_rab;
6930 rab_out.rab$l_fab = &fab_out;
6931 rab_out.rab$l_rbf = ubf;
6932 if (!((sts = sys$connect(&rab_out)) & 1)) {
6933 sys$close(&fab_in); sys$close(&fab_out);
6934 set_errno(EVMSERR); set_vaxc_errno(sts);
6938 while ((sts = sys$read(&rab_in))) { /* always true */
6939 if (sts == RMS$_EOF) break;
6940 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6941 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6942 sys$close(&fab_in); sys$close(&fab_out);
6943 set_errno(EVMSERR); set_vaxc_errno(sts);
6948 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6949 sys$close(&fab_in); sys$close(&fab_out);
6950 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6952 set_errno(EVMSERR); set_vaxc_errno(sts);
6958 } /* end of rmscopy() */
6962 /*** The following glue provides 'hooks' to make some of the routines
6963 * from this file available from Perl. These routines are sufficiently
6964 * basic, and are required sufficiently early in the build process,
6965 * that's it's nice to have them available to miniperl as well as the
6966 * full Perl, so they're set up here instead of in an extension. The
6967 * Perl code which handles importation of these names into a given
6968 * package lives in [.VMS]Filespec.pm in @INC.
6972 rmsexpand_fromperl(pTHX_ CV *cv)
6975 char *fspec, *defspec = NULL, *rslt;
6978 if (!items || items > 2)
6979 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6980 fspec = SvPV(ST(0),n_a);
6981 if (!fspec || !*fspec) XSRETURN_UNDEF;
6982 if (items == 2) defspec = SvPV(ST(1),n_a);
6984 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6985 ST(0) = sv_newmortal();
6986 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6991 vmsify_fromperl(pTHX_ CV *cv)
6997 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6998 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6999 ST(0) = sv_newmortal();
7000 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7005 unixify_fromperl(pTHX_ CV *cv)
7011 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7012 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7013 ST(0) = sv_newmortal();
7014 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7019 fileify_fromperl(pTHX_ CV *cv)
7025 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7026 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7027 ST(0) = sv_newmortal();
7028 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7033 pathify_fromperl(pTHX_ CV *cv)
7039 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7040 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7041 ST(0) = sv_newmortal();
7042 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7047 vmspath_fromperl(pTHX_ CV *cv)
7053 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7054 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7055 ST(0) = sv_newmortal();
7056 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7061 unixpath_fromperl(pTHX_ CV *cv)
7067 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7068 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7069 ST(0) = sv_newmortal();
7070 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7075 candelete_fromperl(pTHX_ CV *cv)
7078 char fspec[NAM$C_MAXRSS+1], *fsp;
7083 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7085 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7086 if (SvTYPE(mysv) == SVt_PVGV) {
7087 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7088 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7095 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7096 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7102 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7107 rmscopy_fromperl(pTHX_ CV *cv)
7110 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7112 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7113 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7114 unsigned long int sts;
7119 if (items < 2 || items > 3)
7120 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7122 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7123 if (SvTYPE(mysv) == SVt_PVGV) {
7124 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7125 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7132 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7133 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7138 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7139 if (SvTYPE(mysv) == SVt_PVGV) {
7140 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7141 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7148 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7149 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7154 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7156 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7162 mod2fname(pTHX_ CV *cv)
7165 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7166 workbuff[NAM$C_MAXRSS*1 + 1];
7167 int total_namelen = 3, counter, num_entries;
7168 /* ODS-5 ups this, but we want to be consistent, so... */
7169 int max_name_len = 39;
7170 AV *in_array = (AV *)SvRV(ST(0));
7172 num_entries = av_len(in_array);
7174 /* All the names start with PL_. */
7175 strcpy(ultimate_name, "PL_");
7177 /* Clean up our working buffer */
7178 Zero(work_name, sizeof(work_name), char);
7180 /* Run through the entries and build up a working name */
7181 for(counter = 0; counter <= num_entries; counter++) {
7182 /* If it's not the first name then tack on a __ */
7184 strcat(work_name, "__");
7186 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7190 /* Check to see if we actually have to bother...*/
7191 if (strlen(work_name) + 3 <= max_name_len) {
7192 strcat(ultimate_name, work_name);
7194 /* It's too darned big, so we need to go strip. We use the same */
7195 /* algorithm as xsubpp does. First, strip out doubled __ */
7196 char *source, *dest, last;
7199 for (source = work_name; *source; source++) {
7200 if (last == *source && last == '_') {
7206 /* Go put it back */
7207 strcpy(work_name, workbuff);
7208 /* Is it still too big? */
7209 if (strlen(work_name) + 3 > max_name_len) {
7210 /* Strip duplicate letters */
7213 for (source = work_name; *source; source++) {
7214 if (last == toupper(*source)) {
7218 last = toupper(*source);
7220 strcpy(work_name, workbuff);
7223 /* Is it *still* too big? */
7224 if (strlen(work_name) + 3 > max_name_len) {
7225 /* Too bad, we truncate */
7226 work_name[max_name_len - 2] = 0;
7228 strcat(ultimate_name, work_name);
7231 /* Okay, return it */
7232 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7237 hushexit_fromperl(pTHX_ CV *cv)
7242 VMSISH_HUSHED = SvTRUE(ST(0));
7244 ST(0) = boolSV(VMSISH_HUSHED);
7249 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7250 struct interp_intern *dst)
7252 memcpy(dst,src,sizeof(struct interp_intern));
7256 Perl_sys_intern_clear(pTHX)
7261 Perl_sys_intern_init(pTHX)
7263 unsigned int ix = RAND_MAX;
7269 MY_INV_RAND_MAX = 1./x;
7276 char* file = __FILE__;
7277 char temp_buff[512];
7278 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7279 no_translate_barewords = TRUE;
7281 no_translate_barewords = FALSE;
7284 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7285 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7286 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7287 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7288 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7289 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7290 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7291 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7292 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7293 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7294 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7296 store_pipelocs(aTHX); /* will redo any earlier attempts */