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>
39 #include <str$routines.h>
44 /* Older versions of ssdef.h don't have these */
45 #ifndef SS$_INVFILFOROP
46 # define SS$_INVFILFOROP 3930
48 #ifndef SS$_NOSUCHOBJECT
49 # define SS$_NOSUCHOBJECT 2696
52 /* Don't replace system definitions of vfork, getenv, and stat,
53 * code below needs to get to the underlying CRTL routines. */
54 #define DONT_MASK_RTL_CALLS
58 /* Anticipating future expansion in lexical warnings . . . */
60 # define WARN_INTERNAL WARN_MISC
63 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
64 # define RTL_USES_UTC 1
68 /* gcc's header files don't #define direct access macros
69 * corresponding to VAXC's variant structs */
71 # define uic$v_format uic$r_uic_form.uic$v_format
72 # define uic$v_group uic$r_uic_form.uic$v_group
73 # define uic$v_member uic$r_uic_form.uic$v_member
74 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
75 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
76 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
77 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
80 #if defined(NEED_AN_H_ERRNO)
85 unsigned short int buflen;
86 unsigned short int itmcode;
88 unsigned short int *retlen;
91 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
92 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
93 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
94 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
95 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
96 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
97 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
98 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
99 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
101 static char *__mystrtolower(char *str)
103 if (str) for (; *str; ++str) *str= tolower(*str);
107 static struct dsc$descriptor_s fildevdsc =
108 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
109 static struct dsc$descriptor_s crtlenvdsc =
110 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
111 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
112 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
113 static struct dsc$descriptor_s **env_tables = defenv;
114 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
116 /* True if we shouldn't treat barewords as logicals during directory */
118 static int no_translate_barewords;
120 /* Temp for subprocess commands */
121 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
124 static int tz_updated = 1;
127 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
129 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
130 struct dsc$descriptor_s **tabvec, unsigned long int flags)
132 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
133 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
134 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
135 unsigned char acmode;
136 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
137 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
138 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
139 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
141 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
142 #if defined(USE_THREADS)
143 /* We jump through these hoops because we can be called at */
144 /* platform-specific initialization time, which is before anything is */
145 /* set up--we can't even do a plain dTHX since that relies on the */
146 /* interpreter structure to be initialized */
147 struct perl_thread *thr;
149 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
155 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
156 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
158 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
159 *cp2 = _toupper(*cp1);
160 if (cp1 - lnm > LNM$C_NAMLENGTH) {
161 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
165 lnmdsc.dsc$w_length = cp1 - lnm;
166 lnmdsc.dsc$a_pointer = uplnm;
167 uplnm[lnmdsc.dsc$w_length] = '\0';
168 secure = flags & PERL__TRNENV_SECURE;
169 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
170 if (!tabvec || !*tabvec) tabvec = env_tables;
172 for (curtab = 0; tabvec[curtab]; curtab++) {
173 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
174 if (!ivenv && !secure) {
179 Perl_warn(aTHX_ "Can't read CRTL environ\n");
182 retsts = SS$_NOLOGNAM;
183 for (i = 0; environ[i]; i++) {
184 if ((eq = strchr(environ[i],'=')) &&
185 !strncmp(environ[i],uplnm,eq - environ[i])) {
187 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
188 if (!eqvlen) continue;
193 if (retsts != SS$_NOLOGNAM) break;
196 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
197 !str$case_blind_compare(&tmpdsc,&clisym)) {
198 if (!ivsym && !secure) {
199 unsigned short int deflen = LNM$C_NAMLENGTH;
200 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
201 /* dynamic dsc to accomodate possible long value */
202 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
203 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
206 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
208 /* Special hack--we might be called before the interpreter's */
209 /* fully initialized, in which case either thr or PL_curcop */
210 /* might be bogus. We have to check, since ckWARN needs them */
211 /* both to be valid if running threaded */
212 #if defined(USE_THREADS)
213 if (thr && PL_curcop) {
215 if (ckWARN(WARN_MISC)) {
216 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
218 #if defined(USE_THREADS)
220 Perl_warner(aTHX_ 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;
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 */
317 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
318 if (vmstrnenv(lnm,eqv,idx,
320 #ifdef SECURE_INTERNAL_GETENV
321 sys ? PERL__TRNENV_SECURE : 0
329 } /* end of my_getenv() */
333 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
335 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
338 char *buf, *cp1, *cp2;
339 unsigned long idx = 0;
340 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
343 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
344 /* Set up a temporary buffer for the return value; Perl will
345 * clean it up at the next statement transition */
346 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
347 if (!tmpsv) return NULL;
350 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
351 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
352 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
353 getcwd(buf,LNM$C_NAMLENGTH);
358 if ((cp2 = strchr(lnm,';')) != NULL) {
361 idx = strtoul(cp2+1,NULL,0);
364 /* Impose security constraints only if tainting */
365 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
366 if ((*len = vmstrnenv(lnm,buf,idx,
368 #ifdef SECURE_INTERNAL_GETENV
369 sys ? PERL__TRNENV_SECURE : 0
379 } /* end of my_getenv_len() */
382 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
384 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
386 /*{{{ void prime_env_iter() */
389 /* Fill the %ENV associative array with all logical names we can
390 * find, in preparation for iterating over it.
394 static int primed = 0;
395 HV *seenhv = NULL, *envhv;
396 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
397 unsigned short int chan;
398 #ifndef CLI$M_TRUSTED
399 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
401 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
402 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
404 bool have_sym = FALSE, have_lnm = FALSE;
405 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
406 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
407 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
408 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
409 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
410 #if defined(USE_THREADS) || defined(USE_ITHREADS)
411 static perl_mutex primenv_mutex;
412 MUTEX_INIT(&primenv_mutex);
415 if (primed || !PL_envgv) return;
416 MUTEX_LOCK(&primenv_mutex);
417 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
418 envhv = GvHVn(PL_envgv);
419 /* Perform a dummy fetch as an lval to insure that the hash table is
420 * set up. Otherwise, the hv_store() will turn into a nullop. */
421 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
423 for (i = 0; env_tables[i]; i++) {
424 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
425 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
426 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
428 if (have_sym || have_lnm) {
429 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
430 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
431 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
432 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
435 for (i--; i >= 0; i--) {
436 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
439 for (j = 0; environ[j]; j++) {
440 if (!(start = strchr(environ[j],'='))) {
441 if (ckWARN(WARN_INTERNAL))
442 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
446 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
452 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
453 !str$case_blind_compare(&tmpdsc,&clisym)) {
454 strcpy(cmd,"Show Symbol/Global *");
455 cmddsc.dsc$w_length = 20;
456 if (env_tables[i]->dsc$w_length == 12 &&
457 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
458 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
459 flags = defflags | CLI$M_NOLOGNAM;
462 strcpy(cmd,"Show Logical *");
463 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
464 strcat(cmd," /Table=");
465 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
466 cmddsc.dsc$w_length = strlen(cmd);
468 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
469 flags = defflags | CLI$M_NOCLISYM;
472 /* Create a new subprocess to execute each command, to exclude the
473 * remote possibility that someone could subvert a mbx or file used
474 * to write multiple commands to a single subprocess.
477 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
478 0,&riseandshine,0,0,&clidsc,&clitabdsc);
479 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
480 defflags &= ~CLI$M_TRUSTED;
481 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
483 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
484 if (seenhv) SvREFCNT_dec(seenhv);
487 char *cp1, *cp2, *key;
488 unsigned long int sts, iosb[2], retlen, keylen;
491 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
492 if (sts & 1) sts = iosb[0] & 0xffff;
493 if (sts == SS$_ENDOFFILE) {
495 while (substs == 0) { sys$hiber(); wakect++;}
496 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
501 retlen = iosb[0] >> 16;
502 if (!retlen) continue; /* blank line */
504 if (iosb[1] != subpid) {
506 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
510 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
511 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
513 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
514 if (*cp1 == '(' || /* Logical name table name */
515 *cp1 == '=' /* Next eqv of searchlist */) continue;
516 if (*cp1 == '"') cp1++;
517 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
518 key = cp1; keylen = cp2 - cp1;
519 if (keylen && hv_exists(seenhv,key,keylen)) continue;
520 while (*cp2 && *cp2 != '=') cp2++;
521 while (*cp2 && *cp2 == '=') cp2++;
522 while (*cp2 && *cp2 == ' ') cp2++;
523 if (*cp2 == '"') { /* String translation; may embed "" */
524 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
525 cp2++; cp1--; /* Skip "" surrounding translation */
527 else { /* Numeric translation */
528 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
529 cp1--; /* stop on last non-space char */
531 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
532 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
535 PERL_HASH(hash,key,keylen);
536 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
537 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
539 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
540 /* get the PPFs for this process, not the subprocess */
541 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
542 char eqv[LNM$C_NAMLENGTH+1];
544 for (i = 0; ppfs[i]; i++) {
545 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
546 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
551 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
552 if (buf) Safefree(buf);
553 if (seenhv) SvREFCNT_dec(seenhv);
554 MUTEX_UNLOCK(&primenv_mutex);
557 } /* end of prime_env_iter */
561 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
562 /* Define or delete an element in the same "environment" as
563 * vmstrnenv(). If an element is to be deleted, it's removed from
564 * the first place it's found. If it's to be set, it's set in the
565 * place designated by the first element of the table vector.
566 * Like setenv() returns 0 for success, non-zero on error.
569 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
571 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
572 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
573 unsigned long int retsts, usermode = PSL$C_USER;
574 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
575 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
576 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
577 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
578 $DESCRIPTOR(local,"_LOCAL");
581 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
582 *cp2 = _toupper(*cp1);
583 if (cp1 - lnm > LNM$C_NAMLENGTH) {
584 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
588 lnmdsc.dsc$w_length = cp1 - lnm;
589 if (!tabvec || !*tabvec) tabvec = env_tables;
591 if (!eqv) { /* we're deleting n element */
592 for (curtab = 0; tabvec[curtab]; curtab++) {
593 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
595 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
596 if ((cp1 = strchr(environ[i],'=')) &&
597 !strncmp(environ[i],lnm,cp1 - environ[i])) {
599 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
602 ivenv = 1; retsts = SS$_NOLOGNAM;
604 if (ckWARN(WARN_INTERNAL))
605 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
606 ivenv = 1; retsts = SS$_NOSUCHPGM;
612 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
613 !str$case_blind_compare(&tmpdsc,&clisym)) {
614 unsigned int symtype;
615 if (tabvec[curtab]->dsc$w_length == 12 &&
616 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
617 !str$case_blind_compare(&tmpdsc,&local))
618 symtype = LIB$K_CLI_LOCAL_SYM;
619 else symtype = LIB$K_CLI_GLOBAL_SYM;
620 retsts = lib$delete_symbol(&lnmdsc,&symtype);
621 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
622 if (retsts == LIB$_NOSUCHSYM) continue;
626 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
627 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
628 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
629 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
630 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
634 else { /* we're defining a value */
635 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
637 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
639 if (ckWARN(WARN_INTERNAL))
640 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
641 retsts = SS$_NOSUCHPGM;
645 eqvdsc.dsc$a_pointer = eqv;
646 eqvdsc.dsc$w_length = strlen(eqv);
647 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
648 !str$case_blind_compare(&tmpdsc,&clisym)) {
649 unsigned int symtype;
650 if (tabvec[0]->dsc$w_length == 12 &&
651 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
652 !str$case_blind_compare(&tmpdsc,&local))
653 symtype = LIB$K_CLI_LOCAL_SYM;
654 else symtype = LIB$K_CLI_GLOBAL_SYM;
655 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
658 if (!*eqv) eqvdsc.dsc$w_length = 1;
659 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
660 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
661 if (ckWARN(WARN_MISC)) {
662 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
665 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
671 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
672 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
673 set_errno(EVMSERR); break;
674 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
675 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
676 set_errno(EINVAL); break;
683 set_vaxc_errno(retsts);
684 return (int) retsts || 44; /* retsts should never be 0, but just in case */
687 /* We reset error values on success because Perl does an hv_fetch()
688 * before each hv_store(), and if the thing we're setting didn't
689 * previously exist, we've got a leftover error message. (Of course,
690 * this fails in the face of
691 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
692 * in that the error reported in $! isn't spurious,
693 * but it's right more often than not.)
695 set_errno(0); set_vaxc_errno(retsts);
699 } /* end of vmssetenv() */
702 /*{{{ void my_setenv(char *lnm, char *eqv)*/
703 /* This has to be a function since there's a prototype for it in proto.h */
705 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
708 int len = strlen(lnm);
712 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
713 if (!strcmp(uplnm,"DEFAULT")) {
714 if (eqv && *eqv) chdir(eqv);
719 if (len == 6 || len == 2) {
722 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
724 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
725 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
729 (void) vmssetenv(lnm,eqv,NULL);
735 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
736 /* my_crypt - VMS password hashing
737 * my_crypt() provides an interface compatible with the Unix crypt()
738 * C library function, and uses sys$hash_password() to perform VMS
739 * password hashing. The quadword hashed password value is returned
740 * as a NUL-terminated 8 character string. my_crypt() does not change
741 * the case of its string arguments; in order to match the behavior
742 * of LOGINOUT et al., alphabetic characters in both arguments must
743 * be upcased by the caller.
746 my_crypt(const char *textpasswd, const char *usrname)
748 # ifndef UAI$C_PREFERRED_ALGORITHM
749 # define UAI$C_PREFERRED_ALGORITHM 127
751 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
752 unsigned short int salt = 0;
753 unsigned long int sts;
755 unsigned short int dsc$w_length;
756 unsigned char dsc$b_type;
757 unsigned char dsc$b_class;
758 const char * dsc$a_pointer;
759 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
760 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
761 struct itmlst_3 uailst[3] = {
762 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
763 { sizeof salt, UAI$_SALT, &salt, 0},
764 { 0, 0, NULL, NULL}};
767 usrdsc.dsc$w_length = strlen(usrname);
768 usrdsc.dsc$a_pointer = usrname;
769 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
771 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
775 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
781 if (sts != RMS$_RNF) return NULL;
784 txtdsc.dsc$w_length = strlen(textpasswd);
785 txtdsc.dsc$a_pointer = textpasswd;
786 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
787 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
790 return (char *) hash;
792 } /* end of my_crypt() */
796 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
797 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
798 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
800 /*{{{int do_rmdir(char *name)*/
802 Perl_do_rmdir(pTHX_ char *name)
804 char dirfile[NAM$C_MAXRSS+1];
808 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
809 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
810 else retval = kill_file(dirfile);
813 } /* end of do_rmdir */
817 * Delete any file to which user has control access, regardless of whether
818 * delete access is explicitly allowed.
819 * Limitations: User must have write access to parent directory.
820 * Does not block signals or ASTs; if interrupted in midstream
821 * may leave file with an altered ACL.
824 /*{{{int kill_file(char *name)*/
826 kill_file(char *name)
828 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
829 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
830 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
832 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
834 unsigned char myace$b_length;
835 unsigned char myace$b_type;
836 unsigned short int myace$w_flags;
837 unsigned long int myace$l_access;
838 unsigned long int myace$l_ident;
839 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
840 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
841 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
843 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
844 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
845 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
846 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
847 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
848 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
850 /* Expand the input spec using RMS, since the CRTL remove() and
851 * system services won't do this by themselves, so we may miss
852 * a file "hiding" behind a logical name or search list. */
853 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
854 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
855 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
856 /* If not, can changing protections help? */
857 if (vaxc$errno != RMS$_PRV) return -1;
859 /* No, so we get our own UIC to use as a rights identifier,
860 * and the insert an ACE at the head of the ACL which allows us
861 * to delete the file.
863 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
864 fildsc.dsc$w_length = strlen(rspec);
865 fildsc.dsc$a_pointer = rspec;
867 newace.myace$l_ident = oldace.myace$l_ident;
868 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
870 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
871 set_errno(ENOENT); break;
873 set_errno(ENOTDIR); break;
875 set_errno(ENODEV); break;
876 case RMS$_SYN: case SS$_INVFILFOROP:
877 set_errno(EINVAL); break;
879 set_errno(EACCES); break;
883 set_vaxc_errno(aclsts);
886 /* Grab any existing ACEs with this identifier in case we fail */
887 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
888 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
889 || fndsts == SS$_NOMOREACE ) {
890 /* Add the new ACE . . . */
891 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
893 if ((rmsts = remove(name))) {
894 /* We blew it - dir with files in it, no write priv for
895 * parent directory, etc. Put things back the way they were. */
896 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
899 addlst[0].bufadr = &oldace;
900 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
907 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
908 /* We just deleted it, so of course it's not there. Some versions of
909 * VMS seem to return success on the unlock operation anyhow (after all
910 * the unlock is successful), but others don't.
912 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
913 if (aclsts & 1) aclsts = fndsts;
916 set_vaxc_errno(aclsts);
922 } /* end of kill_file() */
926 /*{{{int my_mkdir(char *,Mode_t)*/
928 my_mkdir(char *dir, Mode_t mode)
930 STRLEN dirlen = strlen(dir);
933 /* zero length string sometimes gives ACCVIO */
934 if (dirlen == 0) return -1;
936 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
937 * null file name/type. However, it's commonplace under Unix,
938 * so we'll allow it for a gain in portability.
940 if (dir[dirlen-1] == '/') {
941 char *newdir = savepvn(dir,dirlen-1);
942 int ret = mkdir(newdir,mode);
946 else return mkdir(dir,mode);
947 } /* end of my_mkdir */
950 /*{{{int my_chdir(char *)*/
954 STRLEN dirlen = strlen(dir);
957 /* zero length string sometimes gives ACCVIO */
958 if (dirlen == 0) return -1;
960 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
962 * null file name/type. However, it's commonplace under Unix,
963 * so we'll allow it for a gain in portability.
965 if (dir[dirlen-1] == '/') {
966 char *newdir = savepvn(dir,dirlen-1);
967 int ret = chdir(newdir);
971 else return chdir(dir);
972 } /* end of my_chdir */
976 /*{{{FILE *my_tmpfile()*/
984 if ((fp = tmpfile())) return fp;
986 New(1323,cp,L_tmpnam+24,char);
987 strcpy(cp,"Sys$Scratch:");
988 tmpnam(cp+strlen(cp));
989 strcat(cp,".Perltmp");
990 fp = fopen(cp,"w+","fop=dlt");
996 /* default piping mailbox size */
997 #define PERL_BUFSIZ 512
1001 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1003 unsigned long int mbxbufsiz;
1004 static unsigned long int syssize = 0;
1005 unsigned long int dviitm = DVI$_DEVNAM;
1007 char csize[LNM$C_NAMLENGTH+1];
1010 unsigned long syiitm = SYI$_MAXBUF;
1012 * Get the SYSGEN parameter MAXBUF
1014 * If the logical 'PERL_MBX_SIZE' is defined
1015 * use the value of the logical instead of PERL_BUFSIZ, but
1016 * keep the size between 128 and MAXBUF.
1019 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1022 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1023 mbxbufsiz = atoi(csize);
1025 mbxbufsiz = PERL_BUFSIZ;
1027 if (mbxbufsiz < 128) mbxbufsiz = 128;
1028 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1030 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1032 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1033 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1035 } /* end of create_mbx() */
1038 /*{{{ my_popen and my_pclose*/
1040 typedef struct _iosb IOSB;
1041 typedef struct _iosb* pIOSB;
1042 typedef struct _pipe Pipe;
1043 typedef struct _pipe* pPipe;
1044 typedef struct pipe_details Info;
1045 typedef struct pipe_details* pInfo;
1046 typedef struct _srqp RQE;
1047 typedef struct _srqp* pRQE;
1048 typedef struct _tochildbuf CBuf;
1049 typedef struct _tochildbuf* pCBuf;
1052 unsigned short status;
1053 unsigned short count;
1054 unsigned long dvispec;
1057 #pragma member_alignment save
1058 #pragma nomember_alignment quadword
1059 struct _srqp { /* VMS self-relative queue entry */
1060 unsigned long qptr[2];
1062 #pragma member_alignment restore
1063 static RQE RQE_ZERO = {0,0};
1065 struct _tochildbuf {
1068 unsigned short size;
1076 unsigned short chan_in;
1077 unsigned short chan_out;
1079 unsigned int bufsize;
1097 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1098 int pid; /* PID of subprocess */
1099 int mode; /* == 'r' if pipe open for reading */
1100 int done; /* subprocess has completed */
1101 int closing; /* my_pclose is closing this pipe */
1102 unsigned long completion; /* termination status of subprocess */
1103 pPipe in; /* pipe in to sub */
1104 pPipe out; /* pipe out of sub */
1105 pPipe err; /* pipe of sub's sys$error */
1106 int in_done; /* true when in pipe finished */
1111 struct exit_control_block
1113 struct exit_control_block *flink;
1114 unsigned long int (*exit_routine)();
1115 unsigned long int arg_count;
1116 unsigned long int *status_address;
1117 unsigned long int exit_status;
1120 #define RETRY_DELAY "0 ::0.20"
1121 #define MAX_RETRY 50
1123 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1124 static unsigned long mypid;
1125 static unsigned long delaytime[2];
1127 static pInfo open_pipes = NULL;
1128 static $DESCRIPTOR(nl_desc, "NL:");
1131 static unsigned long int
1135 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1136 int sts, did_stuff, need_eof;
1140 first we try sending an EOF...ignore if doesn't work, make sure we
1148 _ckvmssts(sys$setast(0));
1149 if (info->in && !info->in->shut_on_empty) {
1150 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1154 _ckvmssts(sys$setast(1));
1157 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1162 _ckvmssts(sys$setast(0));
1163 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1164 sts = sys$forcex(&info->pid,0,&abort);
1165 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1168 _ckvmssts(sys$setast(1));
1171 if (did_stuff) sleep(1); /* wait for them to respond */
1175 _ckvmssts(sys$setast(0));
1176 if (!info->done) { /* We tried to be nice . . . */
1177 sts = sys$delprc(&info->pid,0);
1178 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1180 _ckvmssts(sys$setast(1));
1185 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1186 else if (!(sts & 1)) retsts = sts;
1191 static struct exit_control_block pipe_exitblock =
1192 {(struct exit_control_block *) 0,
1193 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1195 static void pipe_mbxtofd_ast(pPipe p);
1196 static void pipe_tochild1_ast(pPipe p);
1197 static void pipe_tochild2_ast(pPipe p);
1200 popen_completion_ast(pInfo info)
1203 pInfo i = open_pipes;
1207 if (i == info) break;
1210 if (!i) return; /* unlinked, probably freed too */
1212 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1216 Writing to subprocess ...
1217 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1219 chan_out may be waiting for "done" flag, or hung waiting
1220 for i/o completion to child...cancel the i/o. This will
1221 put it into "snarf mode" (done but no EOF yet) that discards
1224 Output from subprocess (stdout, stderr) needs to be flushed and
1225 shut down. We try sending an EOF, but if the mbx is full the pipe
1226 routine should still catch the "shut_on_empty" flag, telling it to
1227 use immediate-style reads so that "mbx empty" -> EOF.
1231 if (info->in && !info->in_done) { /* only for mode=w */
1232 if (info->in->shut_on_empty && info->in->need_wake) {
1233 info->in->need_wake = FALSE;
1234 _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1236 _ckvmssts(sys$cancel(info->in->chan_out));
1240 if (info->out && !info->out_done) { /* were we also piping output? */
1241 info->out->shut_on_empty = TRUE;
1242 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1243 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1247 if (info->err && !info->err_done) { /* we were piping stderr */
1248 info->err->shut_on_empty = TRUE;
1249 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1250 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1253 _ckvmssts(sys$setef(pipe_ef));
1257 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1258 static void vms_execfree(pTHX);
1261 we actually differ from vmstrnenv since we use this to
1262 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1263 are pointing to the same thing
1266 static unsigned short
1267 popen_translate(char *logical, char *result)
1270 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1271 $DESCRIPTOR(d_log,"");
1273 unsigned short length;
1274 unsigned short code;
1276 unsigned short *retlenaddr;
1278 unsigned short l, ifi;
1280 d_log.dsc$a_pointer = logical;
1281 d_log.dsc$w_length = strlen(logical);
1283 itmlst[0].code = LNM$_STRING;
1284 itmlst[0].length = 255;
1285 itmlst[0].buffer_addr = result;
1286 itmlst[0].retlenaddr = &l;
1289 itmlst[1].length = 0;
1290 itmlst[1].buffer_addr = 0;
1291 itmlst[1].retlenaddr = 0;
1293 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1294 if (iss == SS$_NOLOGNAM) {
1298 if (!(iss&1)) lib$signal(iss);
1301 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1302 strip it off and return the ifi, if any
1305 if (result[0] == 0x1b && result[1] == 0x00) {
1306 memcpy(&ifi,result+2,2);
1307 strcpy(result,result+4);
1309 return ifi; /* this is the RMS internal file id */
1312 #define MAX_DCL_SYMBOL 255
1313 static void pipe_infromchild_ast(pPipe p);
1316 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1317 inside an AST routine without worrying about reentrancy and which Perl
1318 memory allocator is being used.
1320 We read data and queue up the buffers, then spit them out one at a
1321 time to the output mailbox when the output mailbox is ready for one.
1324 #define INITIAL_TOCHILDQUEUE 2
1327 pipe_tochild_setup(char *rmbx, char *wmbx)
1332 char mbx1[64], mbx2[64];
1333 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1334 DSC$K_CLASS_S, mbx1},
1335 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1336 DSC$K_CLASS_S, mbx2};
1337 unsigned int dviitm = DVI$_DEVBUFSIZ;
1340 New(1368, p, 1, Pipe);
1342 create_mbx(&p->chan_in , &d_mbx1);
1343 create_mbx(&p->chan_out, &d_mbx2);
1344 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1347 p->shut_on_empty = FALSE;
1348 p->need_wake = FALSE;
1351 p->iosb.status = SS$_NORMAL;
1352 p->iosb2.status = SS$_NORMAL;
1359 n = sizeof(CBuf) + p->bufsize;
1361 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1362 _ckvmssts(lib$get_vm(&n, &b));
1363 b->buf = (char *) b + sizeof(CBuf);
1364 _ckvmssts(lib$insqhi(b, &p->free));
1367 pipe_tochild2_ast(p);
1368 pipe_tochild1_ast(p);
1374 /* reads the MBX Perl is writing, and queues */
1377 pipe_tochild1_ast(pPipe p)
1381 int iss = p->iosb.status;
1382 int eof = (iss == SS$_ENDOFFILE);
1386 p->shut_on_empty = TRUE;
1388 _ckvmssts(sys$dassgn(p->chan_in));
1394 b->size = p->iosb.count;
1395 _ckvmssts(lib$insqhi(b, &p->wait));
1397 p->need_wake = FALSE;
1398 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1401 p->retry = 1; /* initial call */
1404 if (eof) { /* flush the free queue, return when done */
1405 int n = sizeof(CBuf) + p->bufsize;
1407 iss = lib$remqti(&p->free, &b);
1408 if (iss == LIB$_QUEWASEMP) return;
1410 _ckvmssts(lib$free_vm(&n, &b));
1414 iss = lib$remqti(&p->free, &b);
1415 if (iss == LIB$_QUEWASEMP) {
1416 int n = sizeof(CBuf) + p->bufsize;
1417 _ckvmssts(lib$get_vm(&n, &b));
1418 b->buf = (char *) b + sizeof(CBuf);
1424 iss = sys$qio(0,p->chan_in,
1425 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1427 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1428 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1433 /* writes queued buffers to output, waits for each to complete before
1437 pipe_tochild2_ast(pPipe p)
1441 int iss = p->iosb2.status;
1442 int n = sizeof(CBuf) + p->bufsize;
1443 int done = (p->info && p->info->done) ||
1444 iss == SS$_CANCEL || iss == SS$_ABORT;
1447 if (p->type) { /* type=1 has old buffer, dispose */
1448 if (p->shut_on_empty) {
1449 _ckvmssts(lib$free_vm(&n, &b));
1451 _ckvmssts(lib$insqhi(b, &p->free));
1456 iss = lib$remqti(&p->wait, &b);
1457 if (iss == LIB$_QUEWASEMP) {
1458 if (p->shut_on_empty) {
1460 _ckvmssts(sys$dassgn(p->chan_out));
1461 *p->pipe_done = TRUE;
1462 _ckvmssts(sys$setef(pipe_ef));
1464 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1465 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1469 p->need_wake = TRUE;
1479 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1480 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1482 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1483 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1492 pipe_infromchild_setup(char *rmbx, char *wmbx)
1496 char mbx1[64], mbx2[64];
1497 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1498 DSC$K_CLASS_S, mbx1},
1499 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1500 DSC$K_CLASS_S, mbx2};
1501 unsigned int dviitm = DVI$_DEVBUFSIZ;
1503 New(1367, p, 1, Pipe);
1504 create_mbx(&p->chan_in , &d_mbx1);
1505 create_mbx(&p->chan_out, &d_mbx2);
1507 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1508 New(1367, p->buf, p->bufsize, char);
1509 p->shut_on_empty = FALSE;
1512 p->iosb.status = SS$_NORMAL;
1513 pipe_infromchild_ast(p);
1521 pipe_infromchild_ast(pPipe p)
1524 int iss = p->iosb.status;
1525 int eof = (iss == SS$_ENDOFFILE);
1526 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1527 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1529 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1530 _ckvmssts(sys$dassgn(p->chan_out));
1535 input shutdown if EOF from self (done or shut_on_empty)
1536 output shutdown if closing flag set (my_pclose)
1537 send data/eof from child or eof from self
1538 otherwise, re-read (snarf of data from child)
1543 if (myeof && p->chan_in) { /* input shutdown */
1544 _ckvmssts(sys$dassgn(p->chan_in));
1549 if (myeof || kideof) { /* pass EOF to parent */
1550 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1551 pipe_infromchild_ast, p,
1554 } else if (eof) { /* eat EOF --- fall through to read*/
1556 } else { /* transmit data */
1557 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1558 pipe_infromchild_ast,p,
1559 p->buf, p->iosb.count, 0, 0, 0, 0));
1565 /* everything shut? flag as done */
1567 if (!p->chan_in && !p->chan_out) {
1568 *p->pipe_done = TRUE;
1569 _ckvmssts(sys$setef(pipe_ef));
1573 /* write completed (or read, if snarfing from child)
1574 if still have input active,
1575 queue read...immediate mode if shut_on_empty so we get EOF if empty
1577 check if Perl reading, generate EOFs as needed
1583 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1584 pipe_infromchild_ast,p,
1585 p->buf, p->bufsize, 0, 0, 0, 0);
1586 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1588 } else { /* send EOFs for extra reads */
1589 p->iosb.status = SS$_ENDOFFILE;
1590 p->iosb.dvispec = 0;
1591 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1593 pipe_infromchild_ast, p, 0, 0, 0, 0));
1599 pipe_mbxtofd_setup(int fd, char *out)
1604 unsigned long dviitm = DVI$_DEVBUFSIZ;
1606 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1607 DSC$K_CLASS_S, mbx};
1609 /* things like terminals and mbx's don't need this filter */
1610 if (fd && fstat(fd,&s) == 0) {
1611 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1612 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1613 DSC$K_CLASS_S, s.st_dev};
1615 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1616 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1617 strcpy(out, s.st_dev);
1622 New(1366, p, 1, Pipe);
1623 p->fd_out = dup(fd);
1624 create_mbx(&p->chan_in, &d_mbx);
1625 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1626 New(1366, p->buf, p->bufsize+1, char);
1627 p->shut_on_empty = FALSE;
1632 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1633 pipe_mbxtofd_ast, p,
1634 p->buf, p->bufsize, 0, 0, 0, 0));
1640 pipe_mbxtofd_ast(pPipe p)
1643 int iss = p->iosb.status;
1644 int done = p->info->done;
1646 int eof = (iss == SS$_ENDOFFILE);
1647 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1648 int err = !(iss&1) && !eof;
1651 if (done && myeof) { /* end piping */
1653 sys$dassgn(p->chan_in);
1654 *p->pipe_done = TRUE;
1655 _ckvmssts(sys$setef(pipe_ef));
1659 if (!err && !eof) { /* good data to send to file */
1660 p->buf[p->iosb.count] = '\n';
1661 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1664 if (p->retry < MAX_RETRY) {
1665 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1675 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1676 pipe_mbxtofd_ast, p,
1677 p->buf, p->bufsize, 0, 0, 0, 0);
1678 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1683 typedef struct _pipeloc PLOC;
1684 typedef struct _pipeloc* pPLOC;
1688 char dir[NAM$C_MAXRSS+1];
1690 static pPLOC head_PLOC = 0;
1698 AV *av = GvAVn(PL_incgv);
1703 char temp[NAM$C_MAXRSS+1];
1706 /* the . directory from @INC comes last */
1709 p->next = head_PLOC;
1711 strcpy(p->dir,"./");
1713 /* get the directory from $^X */
1715 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1716 strcpy(temp, PL_origargv[0]);
1717 x = strrchr(temp,']');
1720 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1722 p->next = head_PLOC;
1724 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1725 p->dir[NAM$C_MAXRSS] = '\0';
1729 /* reverse order of @INC entries, skip "." since entered above */
1731 for (i = 0; i <= AvFILL(av); i++) {
1732 dirsv = *av_fetch(av,i,TRUE);
1734 if (SvROK(dirsv)) continue;
1735 dir = SvPVx(dirsv,n_a);
1736 if (strcmp(dir,".") == 0) continue;
1737 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1741 p->next = head_PLOC;
1743 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1744 p->dir[NAM$C_MAXRSS] = '\0';
1747 /* most likely spot (ARCHLIB) put first in the list */
1750 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1752 p->next = head_PLOC;
1754 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1755 p->dir[NAM$C_MAXRSS] = '\0';
1765 static int vmspipe_file_status = 0;
1766 static char vmspipe_file[NAM$C_MAXRSS+1];
1768 /* already found? Check and use ... need read+execute permission */
1770 if (vmspipe_file_status == 1) {
1771 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1772 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1773 return vmspipe_file;
1775 vmspipe_file_status = 0;
1778 /* scan through stored @INC, $^X */
1780 if (vmspipe_file_status == 0) {
1781 char file[NAM$C_MAXRSS+1];
1782 pPLOC p = head_PLOC;
1785 strcpy(file, p->dir);
1786 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1787 file[NAM$C_MAXRSS] = '\0';
1790 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1792 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1793 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1794 vmspipe_file_status = 1;
1795 return vmspipe_file;
1798 vmspipe_file_status = -1; /* failed, use tempfiles */
1805 vmspipe_tempfile(void)
1807 char file[NAM$C_MAXRSS+1];
1809 static int index = 0;
1812 /* create a tempfile */
1814 /* we can't go from W, shr=get to R, shr=get without
1815 an intermediate vulnerable state, so don't bother trying...
1817 and lib$spawn doesn't shr=put, so have to close the write
1819 So... match up the creation date/time and the FID to
1820 make sure we're dealing with the same file
1825 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1826 fp = fopen(file,"w");
1828 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1829 fp = fopen(file,"w");
1831 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1832 fp = fopen(file,"w");
1835 if (!fp) return 0; /* we're hosed */
1837 fprintf(fp,"$! 'f$verify(0)\n");
1838 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1839 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1840 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1841 fprintf(fp,"$ perl_on = \"set noon\"\n");
1842 fprintf(fp,"$ perl_exit = \"exit\"\n");
1843 fprintf(fp,"$ perl_del = \"delete\"\n");
1844 fprintf(fp,"$ pif = \"if\"\n");
1845 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1846 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n");
1847 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\n");
1848 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1849 fprintf(fp,"$! --- get rid of global symbols\n");
1850 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1851 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1852 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1853 fprintf(fp,"$ perl_on\n");
1854 fprintf(fp,"$ 'cmd\n");
1855 fprintf(fp,"$ perl_status = $STATUS\n");
1856 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1857 fprintf(fp,"$ perl_exit 'perl_status'\n");
1860 fgetname(fp, file, 1);
1861 fstat(fileno(fp), &s0);
1864 fp = fopen(file,"r","shr=get");
1866 fstat(fileno(fp), &s1);
1868 if (s0.st_ino[0] != s1.st_ino[0] ||
1869 s0.st_ino[1] != s1.st_ino[1] ||
1870 s0.st_ino[2] != s1.st_ino[2] ||
1871 s0.st_ctime != s1.st_ctime ) {
1882 safe_popen(char *cmd, char *mode)
1885 static int handler_set_up = FALSE;
1886 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1887 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1888 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1889 char in[512], out[512], err[512], mbx[512];
1891 char tfilebuf[NAM$C_MAXRSS+1];
1893 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1894 DSC$K_CLASS_S, symbol};
1895 struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
1896 DSC$K_CLASS_S, out};
1897 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1899 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1900 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1901 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1903 /* once-per-program initialization...
1904 note that the SETAST calls and the dual test of pipe_ef
1905 makes sure that only the FIRST thread through here does
1906 the initialization...all other threads wait until it's
1909 Yeah, uglier than a pthread call, it's got all the stuff inline
1910 rather than in a separate routine.
1914 _ckvmssts(sys$setast(0));
1916 unsigned long int pidcode = JPI$_PID;
1917 $DESCRIPTOR(d_delay, RETRY_DELAY);
1918 _ckvmssts(lib$get_ef(&pipe_ef));
1919 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1920 _ckvmssts(sys$bintim(&d_delay, delaytime));
1922 if (!handler_set_up) {
1923 _ckvmssts(sys$dclexh(&pipe_exitblock));
1924 handler_set_up = TRUE;
1926 _ckvmssts(sys$setast(1));
1929 /* see if we can find a VMSPIPE.COM */
1932 vmspipe = find_vmspipe();
1934 strcpy(tfilebuf+1,vmspipe);
1935 } else { /* uh, oh...we're in tempfile hell */
1936 tpipe = vmspipe_tempfile();
1937 if (!tpipe) { /* a fish popular in Boston */
1938 if (ckWARN(WARN_PIPE)) {
1939 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1943 fgetname(tpipe,tfilebuf+1,1);
1945 vmspipedsc.dsc$a_pointer = tfilebuf;
1946 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1948 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1949 New(1301,info,1,Info);
1953 info->completion = 0;
1954 info->closing = FALSE;
1958 info->in_done = TRUE;
1959 info->out_done = TRUE;
1960 info->err_done = TRUE;
1962 if (*mode == 'r') { /* piping from subroutine */
1965 info->out = pipe_infromchild_setup(mbx,out);
1967 info->out->pipe_done = &info->out_done;
1968 info->out_done = FALSE;
1969 info->out->info = info;
1971 info->fp = PerlIO_open(mbx, mode);
1972 if (!info->fp && info->out) {
1973 sys$cancel(info->out->chan_out);
1975 while (!info->out_done) {
1977 _ckvmssts(sys$setast(0));
1978 done = info->out_done;
1979 if (!done) _ckvmssts(sys$clref(pipe_ef));
1980 _ckvmssts(sys$setast(1));
1981 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1984 if (info->out->buf) Safefree(info->out->buf);
1985 Safefree(info->out);
1990 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1992 info->err->pipe_done = &info->err_done;
1993 info->err_done = FALSE;
1994 info->err->info = info;
1997 } else { /* piping to subroutine , mode=w*/
2000 info->in = pipe_tochild_setup(in,mbx);
2001 info->fp = PerlIO_open(mbx, mode);
2003 info->in->pipe_done = &info->in_done;
2004 info->in_done = FALSE;
2005 info->in->info = info;
2009 if (!info->fp && info->in) {
2011 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2012 0, 0, 0, 0, 0, 0, 0, 0));
2014 while (!info->in_done) {
2016 _ckvmssts(sys$setast(0));
2017 done = info->in_done;
2018 if (!done) _ckvmssts(sys$clref(pipe_ef));
2019 _ckvmssts(sys$setast(1));
2020 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2023 if (info->in->buf) Safefree(info->in->buf);
2029 /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
2032 fgetname(stderr, err);
2033 if (strncmp(err,"SYS$ERROR:",10) == 0) {
2034 fgetname(stdout, out);
2035 if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
2036 if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
2042 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2044 info->out->pipe_done = &info->out_done;
2045 info->out_done = FALSE;
2046 info->out->info = info;
2049 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2051 info->err->pipe_done = &info->err_done;
2052 info->err_done = FALSE;
2053 info->err->info = info;
2059 d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/
2061 symbol[MAX_DCL_SYMBOL] = '\0';
2063 strncpy(symbol, in, MAX_DCL_SYMBOL);
2064 d_symbol.dsc$w_length = strlen(symbol);
2065 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2067 strncpy(symbol, err, MAX_DCL_SYMBOL);
2068 d_symbol.dsc$w_length = strlen(symbol);
2069 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2072 p = VMScmd.dsc$a_pointer;
2073 while (*p && *p != '\n') p++;
2074 *p = '\0'; /* truncate on \n */
2075 p = VMScmd.dsc$a_pointer;
2076 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2077 if (*p == '$') p++; /* remove leading $ */
2078 while (*p == ' ' || *p == '\t') p++;
2079 strncpy(symbol, p, MAX_DCL_SYMBOL);
2080 d_symbol.dsc$w_length = strlen(symbol);
2081 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2083 _ckvmssts(sys$setast(0));
2084 info->next=open_pipes; /* prepend to list */
2086 _ckvmssts(sys$setast(1));
2087 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
2088 0, &info->pid, &info->completion,
2089 0, popen_completion_ast,info,0,0,0));
2091 /* if we were using a tempfile, close it now */
2093 if (tpipe) fclose(tpipe);
2095 /* once the subprocess is spawned, its copied the symbols and
2096 we can get rid of ours */
2098 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2099 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2100 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2104 PL_forkprocess = info->pid;
2106 } /* end of safe_popen */
2109 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2111 Perl_my_popen(pTHX_ char *cmd, char *mode)
2114 TAINT_PROPER("popen");
2115 PERL_FLUSHALL_FOR_CHILD;
2116 return safe_popen(cmd,mode);
2121 /*{{{ I32 my_pclose(FILE *fp)*/
2122 I32 Perl_my_pclose(pTHX_ FILE *fp)
2125 pInfo info, last = NULL;
2126 unsigned long int retsts;
2129 for (info = open_pipes; info != NULL; last = info, info = info->next)
2130 if (info->fp == fp) break;
2132 if (info == NULL) { /* no such pipe open */
2133 set_errno(ECHILD); /* quoth POSIX */
2134 set_vaxc_errno(SS$_NONEXPR);
2138 /* If we were writing to a subprocess, insure that someone reading from
2139 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2140 * produce an EOF record in the mailbox.
2142 * well, at least sometimes it *does*, so we have to watch out for
2143 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2146 fsync(fileno(info->fp)); /* first, flush data */
2148 _ckvmssts(sys$setast(0));
2149 info->closing = TRUE;
2150 done = info->done && info->in_done && info->out_done && info->err_done;
2151 /* hanging on write to Perl's input? cancel it */
2152 if (info->mode == 'r' && info->out && !info->out_done) {
2153 if (info->out->chan_out) {
2154 _ckvmssts(sys$cancel(info->out->chan_out));
2155 if (!info->out->chan_in) { /* EOF generation, need AST */
2156 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2160 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2161 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2163 _ckvmssts(sys$setast(1));
2164 PerlIO_close(info->fp);
2167 we have to wait until subprocess completes, but ALSO wait until all
2168 the i/o completes...otherwise we'll be freeing the "info" structure
2169 that the i/o ASTs could still be using...
2173 _ckvmssts(sys$setast(0));
2174 done = info->done && info->in_done && info->out_done && info->err_done;
2175 if (!done) _ckvmssts(sys$clref(pipe_ef));
2176 _ckvmssts(sys$setast(1));
2177 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2179 retsts = info->completion;
2181 /* remove from list of open pipes */
2182 _ckvmssts(sys$setast(0));
2183 if (last) last->next = info->next;
2184 else open_pipes = info->next;
2185 _ckvmssts(sys$setast(1));
2187 /* free buffers and structures */
2190 if (info->in->buf) Safefree(info->in->buf);
2194 if (info->out->buf) Safefree(info->out->buf);
2195 Safefree(info->out);
2198 if (info->err->buf) Safefree(info->err->buf);
2199 Safefree(info->err);
2205 } /* end of my_pclose() */
2207 /* sort-of waitpid; use only with popen() */
2208 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2210 my_waitpid(Pid_t pid, int *statusp, int flags)
2216 for (info = open_pipes; info != NULL; info = info->next)
2217 if (info->pid == pid) break;
2219 if (info != NULL) { /* we know about this child */
2220 while (!info->done) {
2221 _ckvmssts(sys$setast(0));
2223 if (!done) _ckvmssts(sys$clref(pipe_ef));
2224 _ckvmssts(sys$setast(1));
2225 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2228 *statusp = info->completion;
2231 else { /* we haven't heard of this child */
2232 $DESCRIPTOR(intdsc,"0 00:00:01");
2233 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2234 unsigned long int interval[2],sts;
2236 if (ckWARN(WARN_EXEC)) {
2237 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2238 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2239 if (ownerpid != mypid)
2240 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2243 _ckvmssts(sys$bintim(&intdsc,interval));
2244 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2245 _ckvmssts(sys$schdwk(0,0,interval,0));
2246 _ckvmssts(sys$hiber());
2248 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2251 /* There's no easy way to find the termination status a child we're
2252 * not aware of beforehand. If we're really interested in the future,
2253 * we can go looking for a termination mailbox, or chase after the
2254 * accounting record for the process.
2260 } /* end of waitpid() */
2265 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2267 my_gconvert(double val, int ndig, int trail, char *buf)
2269 static char __gcvtbuf[DBL_DIG+1];
2272 loc = buf ? buf : __gcvtbuf;
2274 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2276 sprintf(loc,"%.*g",ndig,val);
2282 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2283 return gcvt(val,ndig,loc);
2286 loc[0] = '0'; loc[1] = '\0';
2294 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2295 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2296 * to expand file specification. Allows for a single default file
2297 * specification and a simple mask of options. If outbuf is non-NULL,
2298 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2299 * the resultant file specification is placed. If outbuf is NULL, the
2300 * resultant file specification is placed into a static buffer.
2301 * The third argument, if non-NULL, is taken to be a default file
2302 * specification string. The fourth argument is unused at present.
2303 * rmesexpand() returns the address of the resultant string if
2304 * successful, and NULL on error.
2306 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2309 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2311 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2312 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2313 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2314 struct FAB myfab = cc$rms_fab;
2315 struct NAM mynam = cc$rms_nam;
2317 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2319 if (!filespec || !*filespec) {
2320 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2324 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2325 else outbuf = __rmsexpand_retbuf;
2327 if ((isunix = (strchr(filespec,'/') != NULL))) {
2328 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2329 filespec = vmsfspec;
2332 myfab.fab$l_fna = filespec;
2333 myfab.fab$b_fns = strlen(filespec);
2334 myfab.fab$l_nam = &mynam;
2336 if (defspec && *defspec) {
2337 if (strchr(defspec,'/') != NULL) {
2338 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2341 myfab.fab$l_dna = defspec;
2342 myfab.fab$b_dns = strlen(defspec);
2345 mynam.nam$l_esa = esa;
2346 mynam.nam$b_ess = sizeof esa;
2347 mynam.nam$l_rsa = outbuf;
2348 mynam.nam$b_rss = NAM$C_MAXRSS;
2350 retsts = sys$parse(&myfab,0,0);
2351 if (!(retsts & 1)) {
2352 mynam.nam$b_nop |= NAM$M_SYNCHK;
2353 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2354 retsts = sys$parse(&myfab,0,0);
2355 if (retsts & 1) goto expanded;
2357 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2358 (void) sys$parse(&myfab,0,0); /* Free search context */
2359 if (out) Safefree(out);
2360 set_vaxc_errno(retsts);
2361 if (retsts == RMS$_PRV) set_errno(EACCES);
2362 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2363 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2364 else set_errno(EVMSERR);
2367 retsts = sys$search(&myfab,0,0);
2368 if (!(retsts & 1) && retsts != RMS$_FNF) {
2369 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2370 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2371 if (out) Safefree(out);
2372 set_vaxc_errno(retsts);
2373 if (retsts == RMS$_PRV) set_errno(EACCES);
2374 else set_errno(EVMSERR);
2378 /* If the input filespec contained any lowercase characters,
2379 * downcase the result for compatibility with Unix-minded code. */
2381 for (out = myfab.fab$l_fna; *out; out++)
2382 if (islower(*out)) { haslower = 1; break; }
2383 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2384 else { out = esa; speclen = mynam.nam$b_esl; }
2385 /* Trim off null fields added by $PARSE
2386 * If type > 1 char, must have been specified in original or default spec
2387 * (not true for version; $SEARCH may have added version of existing file).
2389 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2390 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2391 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2392 if (trimver || trimtype) {
2393 if (defspec && *defspec) {
2394 char defesa[NAM$C_MAXRSS];
2395 struct FAB deffab = cc$rms_fab;
2396 struct NAM defnam = cc$rms_nam;
2398 deffab.fab$l_nam = &defnam;
2399 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2400 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2401 defnam.nam$b_nop = NAM$M_SYNCHK;
2402 if (sys$parse(&deffab,0,0) & 1) {
2403 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2404 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2407 if (trimver) speclen = mynam.nam$l_ver - out;
2409 /* If we didn't already trim version, copy down */
2410 if (speclen > mynam.nam$l_ver - out)
2411 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2412 speclen - (mynam.nam$l_ver - out));
2413 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2416 /* If we just had a directory spec on input, $PARSE "helpfully"
2417 * adds an empty name and type for us */
2418 if (mynam.nam$l_name == mynam.nam$l_type &&
2419 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2420 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2421 speclen = mynam.nam$l_name - out;
2422 out[speclen] = '\0';
2423 if (haslower) __mystrtolower(out);
2425 /* Have we been working with an expanded, but not resultant, spec? */
2426 /* Also, convert back to Unix syntax if necessary. */
2427 if (!mynam.nam$b_rsl) {
2429 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2431 else strcpy(outbuf,esa);
2434 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2435 strcpy(outbuf,tmpfspec);
2437 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2438 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2439 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2443 /* External entry points */
2444 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2445 { return do_rmsexpand(spec,buf,0,def,opt); }
2446 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2447 { return do_rmsexpand(spec,buf,1,def,opt); }
2451 ** The following routines are provided to make life easier when
2452 ** converting among VMS-style and Unix-style directory specifications.
2453 ** All will take input specifications in either VMS or Unix syntax. On
2454 ** failure, all return NULL. If successful, the routines listed below
2455 ** return a pointer to a buffer containing the appropriately
2456 ** reformatted spec (and, therefore, subsequent calls to that routine
2457 ** will clobber the result), while the routines of the same names with
2458 ** a _ts suffix appended will return a pointer to a mallocd string
2459 ** containing the appropriately reformatted spec.
2460 ** In all cases, only explicit syntax is altered; no check is made that
2461 ** the resulting string is valid or that the directory in question
2464 ** fileify_dirspec() - convert a directory spec into the name of the
2465 ** directory file (i.e. what you can stat() to see if it's a dir).
2466 ** The style (VMS or Unix) of the result is the same as the style
2467 ** of the parameter passed in.
2468 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2469 ** what you prepend to a filename to indicate what directory it's in).
2470 ** The style (VMS or Unix) of the result is the same as the style
2471 ** of the parameter passed in.
2472 ** tounixpath() - convert a directory spec into a Unix-style path.
2473 ** tovmspath() - convert a directory spec into a VMS-style path.
2474 ** tounixspec() - convert any file spec into a Unix-style file spec.
2475 ** tovmsspec() - convert any file spec into a VMS-style spec.
2477 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2478 ** Permission is given to distribute this code as part of the Perl
2479 ** standard distribution under the terms of the GNU General Public
2480 ** License or the Perl Artistic License. Copies of each may be
2481 ** found in the Perl standard distribution.
2484 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2485 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2487 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2488 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2489 char *retspec, *cp1, *cp2, *lastdir;
2490 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2492 if (!dir || !*dir) {
2493 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2495 dirlen = strlen(dir);
2496 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2497 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2498 strcpy(trndir,"/sys$disk/000000");
2502 if (dirlen > NAM$C_MAXRSS) {
2503 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2505 if (!strpbrk(dir+1,"/]>:")) {
2506 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2507 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2509 dirlen = strlen(dir);
2512 strncpy(trndir,dir,dirlen);
2513 trndir[dirlen] = '\0';
2516 /* If we were handed a rooted logical name or spec, treat it like a
2517 * simple directory, so that
2518 * $ Define myroot dev:[dir.]
2519 * ... do_fileify_dirspec("myroot",buf,1) ...
2520 * does something useful.
2522 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2523 dir[--dirlen] = '\0';
2524 dir[dirlen-1] = ']';
2527 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2528 /* If we've got an explicit filename, we can just shuffle the string. */
2529 if (*(cp1+1)) hasfilename = 1;
2530 /* Similarly, we can just back up a level if we've got multiple levels
2531 of explicit directories in a VMS spec which ends with directories. */
2533 for (cp2 = cp1; cp2 > dir; cp2--) {
2535 *cp2 = *cp1; *cp1 = '\0';
2539 if (*cp2 == '[' || *cp2 == '<') break;
2544 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2545 if (dir[0] == '.') {
2546 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2547 return do_fileify_dirspec("[]",buf,ts);
2548 else if (dir[1] == '.' &&
2549 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2550 return do_fileify_dirspec("[-]",buf,ts);
2552 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2553 dirlen -= 1; /* to last element */
2554 lastdir = strrchr(dir,'/');
2556 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2557 /* If we have "/." or "/..", VMSify it and let the VMS code
2558 * below expand it, rather than repeating the code to handle
2559 * relative components of a filespec here */
2561 if (*(cp1+2) == '.') cp1++;
2562 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2563 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2564 if (strchr(vmsdir,'/') != NULL) {
2565 /* If do_tovmsspec() returned it, it must have VMS syntax
2566 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2567 * the time to check this here only so we avoid a recursion
2568 * loop; otherwise, gigo.
2570 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2572 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2573 return do_tounixspec(trndir,buf,ts);
2576 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2577 lastdir = strrchr(dir,'/');
2579 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2580 /* Ditto for specs that end in an MFD -- let the VMS code
2581 * figure out whether it's a real device or a rooted logical. */
2582 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2583 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2584 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2585 return do_tounixspec(trndir,buf,ts);
2588 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2589 !(lastdir = cp1 = strrchr(dir,']')) &&
2590 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2591 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2593 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2594 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2595 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2596 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2597 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2598 (ver || *cp3)))))) {
2600 set_vaxc_errno(RMS$_DIR);
2606 /* If we lead off with a device or rooted logical, add the MFD
2607 if we're specifying a top-level directory. */
2608 if (lastdir && *dir == '/') {
2610 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2617 retlen = dirlen + (addmfd ? 13 : 6);
2618 if (buf) retspec = buf;
2619 else if (ts) New(1309,retspec,retlen+1,char);
2620 else retspec = __fileify_retbuf;
2622 dirlen = lastdir - dir;
2623 memcpy(retspec,dir,dirlen);
2624 strcpy(&retspec[dirlen],"/000000");
2625 strcpy(&retspec[dirlen+7],lastdir);
2628 memcpy(retspec,dir,dirlen);
2629 retspec[dirlen] = '\0';
2631 /* We've picked up everything up to the directory file name.
2632 Now just add the type and version, and we're set. */
2633 strcat(retspec,".dir;1");
2636 else { /* VMS-style directory spec */
2637 char esa[NAM$C_MAXRSS+1], term, *cp;
2638 unsigned long int sts, cmplen, haslower = 0;
2639 struct FAB dirfab = cc$rms_fab;
2640 struct NAM savnam, dirnam = cc$rms_nam;
2642 dirfab.fab$b_fns = strlen(dir);
2643 dirfab.fab$l_fna = dir;
2644 dirfab.fab$l_nam = &dirnam;
2645 dirfab.fab$l_dna = ".DIR;1";
2646 dirfab.fab$b_dns = 6;
2647 dirnam.nam$b_ess = NAM$C_MAXRSS;
2648 dirnam.nam$l_esa = esa;
2650 for (cp = dir; *cp; cp++)
2651 if (islower(*cp)) { haslower = 1; break; }
2652 if (!((sts = sys$parse(&dirfab))&1)) {
2653 if (dirfab.fab$l_sts == RMS$_DIR) {
2654 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2655 sts = sys$parse(&dirfab) & 1;
2659 set_vaxc_errno(dirfab.fab$l_sts);
2665 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2666 /* Yes; fake the fnb bits so we'll check type below */
2667 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2669 else { /* No; just work with potential name */
2670 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2672 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2673 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2674 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2679 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2680 cp1 = strchr(esa,']');
2681 if (!cp1) cp1 = strchr(esa,'>');
2682 if (cp1) { /* Should always be true */
2683 dirnam.nam$b_esl -= cp1 - esa - 1;
2684 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2687 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2688 /* Yep; check version while we're at it, if it's there. */
2689 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2690 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2691 /* Something other than .DIR[;1]. Bzzt. */
2692 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2693 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2695 set_vaxc_errno(RMS$_DIR);
2699 esa[dirnam.nam$b_esl] = '\0';
2700 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2701 /* They provided at least the name; we added the type, if necessary, */
2702 if (buf) retspec = buf; /* in sys$parse() */
2703 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2704 else retspec = __fileify_retbuf;
2705 strcpy(retspec,esa);
2706 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2707 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2710 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2711 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2713 dirnam.nam$b_esl -= 9;
2715 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2716 if (cp1 == NULL) { /* should never happen */
2717 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2718 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2723 retlen = strlen(esa);
2724 if ((cp1 = strrchr(esa,'.')) != NULL) {
2725 /* There's more than one directory in the path. Just roll back. */
2727 if (buf) retspec = buf;
2728 else if (ts) New(1311,retspec,retlen+7,char);
2729 else retspec = __fileify_retbuf;
2730 strcpy(retspec,esa);
2733 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2734 /* Go back and expand rooted logical name */
2735 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2736 if (!(sys$parse(&dirfab) & 1)) {
2737 dirnam.nam$l_rlf = NULL;
2738 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2740 set_vaxc_errno(dirfab.fab$l_sts);
2743 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2744 if (buf) retspec = buf;
2745 else if (ts) New(1312,retspec,retlen+16,char);
2746 else retspec = __fileify_retbuf;
2747 cp1 = strstr(esa,"][");
2749 memcpy(retspec,esa,dirlen);
2750 if (!strncmp(cp1+2,"000000]",7)) {
2751 retspec[dirlen-1] = '\0';
2752 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2753 if (*cp1 == '.') *cp1 = ']';
2755 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2756 memcpy(cp1+1,"000000]",7);
2760 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2761 retspec[retlen] = '\0';
2762 /* Convert last '.' to ']' */
2763 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2764 if (*cp1 == '.') *cp1 = ']';
2766 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2767 memcpy(cp1+1,"000000]",7);
2771 else { /* This is a top-level dir. Add the MFD to the path. */
2772 if (buf) retspec = buf;
2773 else if (ts) New(1312,retspec,retlen+16,char);
2774 else retspec = __fileify_retbuf;
2777 while (*cp1 != ':') *(cp2++) = *(cp1++);
2778 strcpy(cp2,":[000000]");
2783 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2784 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2785 /* We've set up the string up through the filename. Add the
2786 type and version, and we're done. */
2787 strcat(retspec,".DIR;1");
2789 /* $PARSE may have upcased filespec, so convert output to lower
2790 * case if input contained any lowercase characters. */
2791 if (haslower) __mystrtolower(retspec);
2794 } /* end of do_fileify_dirspec() */
2796 /* External entry points */
2797 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2798 { return do_fileify_dirspec(dir,buf,0); }
2799 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2800 { return do_fileify_dirspec(dir,buf,1); }
2802 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2803 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2805 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2806 unsigned long int retlen;
2807 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2809 if (!dir || !*dir) {
2810 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2813 if (*dir) strcpy(trndir,dir);
2814 else getcwd(trndir,sizeof trndir - 1);
2816 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2817 && my_trnlnm(trndir,trndir,0)) {
2818 STRLEN trnlen = strlen(trndir);
2820 /* Trap simple rooted lnms, and return lnm:[000000] */
2821 if (!strcmp(trndir+trnlen-2,".]")) {
2822 if (buf) retpath = buf;
2823 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2824 else retpath = __pathify_retbuf;
2825 strcpy(retpath,dir);
2826 strcat(retpath,":[000000]");
2832 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2833 if (*dir == '.' && (*(dir+1) == '\0' ||
2834 (*(dir+1) == '.' && *(dir+2) == '\0')))
2835 retlen = 2 + (*(dir+1) != '\0');
2837 if ( !(cp1 = strrchr(dir,'/')) &&
2838 !(cp1 = strrchr(dir,']')) &&
2839 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2840 if ((cp2 = strchr(cp1,'.')) != NULL &&
2841 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2842 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2843 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2844 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2846 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2847 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2848 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2849 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2850 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2851 (ver || *cp3)))))) {
2853 set_vaxc_errno(RMS$_DIR);
2856 retlen = cp2 - dir + 1;
2858 else { /* No file type present. Treat the filename as a directory. */
2859 retlen = strlen(dir) + 1;
2862 if (buf) retpath = buf;
2863 else if (ts) New(1313,retpath,retlen+1,char);
2864 else retpath = __pathify_retbuf;
2865 strncpy(retpath,dir,retlen-1);
2866 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2867 retpath[retlen-1] = '/'; /* with '/', add it. */
2868 retpath[retlen] = '\0';
2870 else retpath[retlen-1] = '\0';
2872 else { /* VMS-style directory spec */
2873 char esa[NAM$C_MAXRSS+1], *cp;
2874 unsigned long int sts, cmplen, haslower;
2875 struct FAB dirfab = cc$rms_fab;
2876 struct NAM savnam, dirnam = cc$rms_nam;
2878 /* If we've got an explicit filename, we can just shuffle the string. */
2879 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2880 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2881 if ((cp2 = strchr(cp1,'.')) != NULL) {
2883 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2884 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2885 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2886 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2887 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2888 (ver || *cp3)))))) {
2890 set_vaxc_errno(RMS$_DIR);
2894 else { /* No file type, so just draw name into directory part */
2895 for (cp2 = cp1; *cp2; cp2++) ;
2898 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2900 /* We've now got a VMS 'path'; fall through */
2902 dirfab.fab$b_fns = strlen(dir);
2903 dirfab.fab$l_fna = dir;
2904 if (dir[dirfab.fab$b_fns-1] == ']' ||
2905 dir[dirfab.fab$b_fns-1] == '>' ||
2906 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2907 if (buf) retpath = buf;
2908 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2909 else retpath = __pathify_retbuf;
2910 strcpy(retpath,dir);
2913 dirfab.fab$l_dna = ".DIR;1";
2914 dirfab.fab$b_dns = 6;
2915 dirfab.fab$l_nam = &dirnam;
2916 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2917 dirnam.nam$l_esa = esa;
2919 for (cp = dir; *cp; cp++)
2920 if (islower(*cp)) { haslower = 1; break; }
2922 if (!(sts = (sys$parse(&dirfab)&1))) {
2923 if (dirfab.fab$l_sts == RMS$_DIR) {
2924 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2925 sts = sys$parse(&dirfab) & 1;
2929 set_vaxc_errno(dirfab.fab$l_sts);
2935 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
2936 if (dirfab.fab$l_sts != RMS$_FNF) {
2937 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2938 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2940 set_vaxc_errno(dirfab.fab$l_sts);
2943 dirnam = savnam; /* No; just work with potential name */
2946 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2947 /* Yep; check version while we're at it, if it's there. */
2948 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2949 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2950 /* Something other than .DIR[;1]. Bzzt. */
2951 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2952 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2954 set_vaxc_errno(RMS$_DIR);
2958 /* OK, the type was fine. Now pull any file name into the
2960 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
2962 cp1 = strrchr(esa,'>');
2963 *dirnam.nam$l_type = '>';
2966 *(dirnam.nam$l_type + 1) = '\0';
2967 retlen = dirnam.nam$l_type - esa + 2;
2968 if (buf) retpath = buf;
2969 else if (ts) New(1314,retpath,retlen,char);
2970 else retpath = __pathify_retbuf;
2971 strcpy(retpath,esa);
2972 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2973 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2974 /* $PARSE may have upcased filespec, so convert output to lower
2975 * case if input contained any lowercase characters. */
2976 if (haslower) __mystrtolower(retpath);
2980 } /* end of do_pathify_dirspec() */
2982 /* External entry points */
2983 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2984 { return do_pathify_dirspec(dir,buf,0); }
2985 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
2986 { return do_pathify_dirspec(dir,buf,1); }
2988 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
2989 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
2991 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
2992 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
2993 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
2995 if (spec == NULL) return NULL;
2996 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
2997 if (buf) rslt = buf;
2999 retlen = strlen(spec);
3000 cp1 = strchr(spec,'[');
3001 if (!cp1) cp1 = strchr(spec,'<');
3003 for (cp1++; *cp1; cp1++) {
3004 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3005 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3006 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3009 New(1315,rslt,retlen+2+2*expand,char);
3011 else rslt = __tounixspec_retbuf;
3012 if (strchr(spec,'/') != NULL) {
3019 dirend = strrchr(spec,']');
3020 if (dirend == NULL) dirend = strrchr(spec,'>');
3021 if (dirend == NULL) dirend = strchr(spec,':');
3022 if (dirend == NULL) {
3026 if (*cp2 != '[' && *cp2 != '<') {
3029 else { /* the VMS spec begins with directories */
3031 if (*cp2 == ']' || *cp2 == '>') {
3032 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3035 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3036 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3037 if (ts) Safefree(rslt);
3042 while (*cp3 != ':' && *cp3) cp3++;
3044 if (strchr(cp3,']') != NULL) break;
3045 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3047 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3048 retlen = devlen + dirlen;
3049 Renew(rslt,retlen+1+2*expand,char);
3055 *(cp1++) = *(cp3++);
3056 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3060 else if ( *cp2 == '.') {
3061 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3062 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3068 for (; cp2 <= dirend; cp2++) {
3071 if (*(cp2+1) == '[') cp2++;
3073 else if (*cp2 == ']' || *cp2 == '>') {
3074 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3076 else if (*cp2 == '.') {
3078 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3079 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3080 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3081 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3082 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3084 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3085 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3089 else if (*cp2 == '-') {
3090 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3091 while (*cp2 == '-') {
3093 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3095 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3096 if (ts) Safefree(rslt); /* filespecs like */
3097 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3101 else *(cp1++) = *cp2;
3103 else *(cp1++) = *cp2;
3105 while (*cp2) *(cp1++) = *(cp2++);
3110 } /* end of do_tounixspec() */
3112 /* External entry points */
3113 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3114 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3116 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3117 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3118 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3119 char *rslt, *dirend;
3120 register char *cp1, *cp2;
3121 unsigned long int infront = 0, hasdir = 1;
3123 if (path == NULL) return NULL;
3124 if (buf) rslt = buf;
3125 else if (ts) New(1316,rslt,strlen(path)+9,char);
3126 else rslt = __tovmsspec_retbuf;
3127 if (strpbrk(path,"]:>") ||
3128 (dirend = strrchr(path,'/')) == NULL) {
3129 if (path[0] == '.') {
3130 if (path[1] == '\0') strcpy(rslt,"[]");
3131 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3132 else strcpy(rslt,path); /* probably garbage */
3134 else strcpy(rslt,path);
3137 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3138 if (!*(dirend+2)) dirend +=2;
3139 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3140 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3145 char trndev[NAM$C_MAXRSS+1];
3149 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3151 if (!buf & ts) Renew(rslt,18,char);
3152 strcpy(rslt,"sys$disk:[000000]");
3155 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3157 islnm = my_trnlnm(rslt,trndev,0);
3158 trnend = islnm ? strlen(trndev) - 1 : 0;
3159 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3160 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3161 /* If the first element of the path is a logical name, determine
3162 * whether it has to be translated so we can add more directories. */
3163 if (!islnm || rooted) {
3166 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3170 if (cp2 != dirend) {
3171 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3172 strcpy(rslt,trndev);
3173 cp1 = rslt + trnend;
3186 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3187 cp2 += 2; /* skip over "./" - it's redundant */
3188 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3190 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3191 *(cp1++) = '-'; /* "../" --> "-" */
3194 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3195 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3196 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3197 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3200 if (cp2 > dirend) cp2 = dirend;
3202 else *(cp1++) = '.';
3204 for (; cp2 < dirend; cp2++) {
3206 if (*(cp2-1) == '/') continue;
3207 if (*(cp1-1) != '.') *(cp1++) = '.';
3210 else if (!infront && *cp2 == '.') {
3211 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3212 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3213 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3214 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3215 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3216 else { /* back up over previous directory name */
3218 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3219 if (*(cp1-1) == '[') {
3220 memcpy(cp1,"000000.",7);
3225 if (cp2 == dirend) break;
3227 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3228 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3229 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3230 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3232 *(cp1++) = '.'; /* Simulate trailing '/' */
3233 cp2 += 2; /* for loop will incr this to == dirend */
3235 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3237 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3240 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3241 if (*cp2 == '.') *(cp1++) = '_';
3242 else *(cp1++) = *cp2;
3246 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3247 if (hasdir) *(cp1++) = ']';
3248 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3249 while (*cp2) *(cp1++) = *(cp2++);
3254 } /* end of do_tovmsspec() */
3256 /* External entry points */
3257 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3258 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3260 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3261 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3262 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3264 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3266 if (path == NULL) return NULL;
3267 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3268 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3269 if (buf) return buf;
3271 vmslen = strlen(vmsified);
3272 New(1317,cp,vmslen+1,char);
3273 memcpy(cp,vmsified,vmslen);
3278 strcpy(__tovmspath_retbuf,vmsified);
3279 return __tovmspath_retbuf;
3282 } /* end of do_tovmspath() */
3284 /* External entry points */
3285 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3286 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3289 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3290 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3291 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3293 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3295 if (path == NULL) return NULL;
3296 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3297 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3298 if (buf) return buf;
3300 unixlen = strlen(unixified);
3301 New(1317,cp,unixlen+1,char);
3302 memcpy(cp,unixified,unixlen);
3307 strcpy(__tounixpath_retbuf,unixified);
3308 return __tounixpath_retbuf;
3311 } /* end of do_tounixpath() */
3313 /* External entry points */
3314 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3315 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3318 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3320 *****************************************************************************
3322 * Copyright (C) 1989-1994 by *
3323 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3325 * Permission is hereby granted for the reproduction of this software, *
3326 * on condition that this copyright notice is included in the reproduction, *
3327 * and that such reproduction is not for purposes of profit or material *
3330 * 27-Aug-1994 Modified for inclusion in perl5 *
3331 * by Charles Bailey bailey@newman.upenn.edu *
3332 *****************************************************************************
3336 * getredirection() is intended to aid in porting C programs
3337 * to VMS (Vax-11 C). The native VMS environment does not support
3338 * '>' and '<' I/O redirection, or command line wild card expansion,
3339 * or a command line pipe mechanism using the '|' AND background
3340 * command execution '&'. All of these capabilities are provided to any
3341 * C program which calls this procedure as the first thing in the
3343 * The piping mechanism will probably work with almost any 'filter' type
3344 * of program. With suitable modification, it may useful for other
3345 * portability problems as well.
3347 * Author: Mark Pizzolato mark@infocomm.com
3351 struct list_item *next;
3355 static void add_item(struct list_item **head,
3356 struct list_item **tail,
3360 static void mp_expand_wild_cards(pTHX_ char *item,
3361 struct list_item **head,
3362 struct list_item **tail,
3365 static int background_process(int argc, char **argv);
3367 static void pipe_and_fork(char **cmargv);
3369 /*{{{ void getredirection(int *ac, char ***av)*/
3371 mp_getredirection(pTHX_ int *ac, char ***av)
3373 * Process vms redirection arg's. Exit if any error is seen.
3374 * If getredirection() processes an argument, it is erased
3375 * from the vector. getredirection() returns a new argc and argv value.
3376 * In the event that a background command is requested (by a trailing "&"),
3377 * this routine creates a background subprocess, and simply exits the program.
3379 * Warning: do not try to simplify the code for vms. The code
3380 * presupposes that getredirection() is called before any data is
3381 * read from stdin or written to stdout.
3383 * Normal usage is as follows:
3389 * getredirection(&argc, &argv);
3393 int argc = *ac; /* Argument Count */
3394 char **argv = *av; /* Argument Vector */
3395 char *ap; /* Argument pointer */
3396 int j; /* argv[] index */
3397 int item_count = 0; /* Count of Items in List */
3398 struct list_item *list_head = 0; /* First Item in List */
3399 struct list_item *list_tail; /* Last Item in List */
3400 char *in = NULL; /* Input File Name */
3401 char *out = NULL; /* Output File Name */
3402 char *outmode = "w"; /* Mode to Open Output File */
3403 char *err = NULL; /* Error File Name */
3404 char *errmode = "w"; /* Mode to Open Error File */
3405 int cmargc = 0; /* Piped Command Arg Count */
3406 char **cmargv = NULL;/* Piped Command Arg Vector */
3409 * First handle the case where the last thing on the line ends with
3410 * a '&'. This indicates the desire for the command to be run in a
3411 * subprocess, so we satisfy that desire.
3414 if (0 == strcmp("&", ap))
3415 exit(background_process(--argc, argv));
3416 if (*ap && '&' == ap[strlen(ap)-1])
3418 ap[strlen(ap)-1] = '\0';
3419 exit(background_process(argc, argv));
3422 * Now we handle the general redirection cases that involve '>', '>>',
3423 * '<', and pipes '|'.
3425 for (j = 0; j < argc; ++j)
3427 if (0 == strcmp("<", argv[j]))
3431 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3432 exit(LIB$_WRONUMARG);
3437 if ('<' == *(ap = argv[j]))
3442 if (0 == strcmp(">", ap))
3446 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3447 exit(LIB$_WRONUMARG);
3466 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3467 exit(LIB$_WRONUMARG);
3471 if (('2' == *ap) && ('>' == ap[1]))
3488 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3489 exit(LIB$_WRONUMARG);
3493 if (0 == strcmp("|", argv[j]))
3497 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3498 exit(LIB$_WRONUMARG);
3500 cmargc = argc-(j+1);
3501 cmargv = &argv[j+1];
3505 if ('|' == *(ap = argv[j]))
3513 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3516 * Allocate and fill in the new argument vector, Some Unix's terminate
3517 * the list with an extra null pointer.
3519 New(1302, argv, item_count+1, char *);
3521 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3522 argv[j] = list_head->value;
3528 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3529 exit(LIB$_INVARGORD);
3531 pipe_and_fork(cmargv);
3534 /* Check for input from a pipe (mailbox) */
3536 if (in == NULL && 1 == isapipe(0))
3538 char mbxname[L_tmpnam];
3540 long int dvi_item = DVI$_DEVBUFSIZ;
3541 $DESCRIPTOR(mbxnam, "");
3542 $DESCRIPTOR(mbxdevnam, "");
3544 /* Input from a pipe, reopen it in binary mode to disable */
3545 /* carriage control processing. */
3547 PerlIO_getname(stdin, mbxname);
3548 mbxnam.dsc$a_pointer = mbxname;
3549 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3550 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3551 mbxdevnam.dsc$a_pointer = mbxname;
3552 mbxdevnam.dsc$w_length = sizeof(mbxname);
3553 dvi_item = DVI$_DEVNAM;
3554 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3555 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3558 freopen(mbxname, "rb", stdin);
3561 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3565 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3567 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3570 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3572 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3576 if (strcmp(err,"&1") == 0) {
3577 dup2(fileno(stdout), fileno(Perl_debug_log));
3580 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3582 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3586 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3592 #ifdef ARGPROC_DEBUG
3593 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3594 for (j = 0; j < *ac; ++j)
3595 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3597 /* Clear errors we may have hit expanding wildcards, so they don't
3598 show up in Perl's $! later */
3599 set_errno(0); set_vaxc_errno(1);
3600 } /* end of getredirection() */
3603 static void add_item(struct list_item **head,
3604 struct list_item **tail,
3610 New(1303,*head,1,struct list_item);
3614 New(1304,(*tail)->next,1,struct list_item);
3615 *tail = (*tail)->next;
3617 (*tail)->value = value;
3621 static void mp_expand_wild_cards(pTHX_ char *item,
3622 struct list_item **head,
3623 struct list_item **tail,
3627 unsigned long int context = 0;
3633 char vmsspec[NAM$C_MAXRSS+1];
3634 $DESCRIPTOR(filespec, "");
3635 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3636 $DESCRIPTOR(resultspec, "");
3637 unsigned long int zero = 0, sts;
3639 for (cp = item; *cp; cp++) {
3640 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3641 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3643 if (!*cp || isspace(*cp))
3645 add_item(head, tail, item, count);
3648 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3649 resultspec.dsc$b_class = DSC$K_CLASS_D;
3650 resultspec.dsc$a_pointer = NULL;
3651 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3652 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3653 if (!isunix || !filespec.dsc$a_pointer)
3654 filespec.dsc$a_pointer = item;
3655 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3657 * Only return version specs, if the caller specified a version
3659 had_version = strchr(item, ';');
3661 * Only return device and directory specs, if the caller specifed either.
3663 had_device = strchr(item, ':');
3664 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3666 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3667 &defaultspec, 0, 0, &zero))))
3672 New(1305,string,resultspec.dsc$w_length+1,char);
3673 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3674 string[resultspec.dsc$w_length] = '\0';
3675 if (NULL == had_version)
3676 *((char *)strrchr(string, ';')) = '\0';
3677 if ((!had_directory) && (had_device == NULL))
3679 if (NULL == (devdir = strrchr(string, ']')))
3680 devdir = strrchr(string, '>');
3681 strcpy(string, devdir + 1);
3684 * Be consistent with what the C RTL has already done to the rest of
3685 * the argv items and lowercase all of these names.
3687 for (c = string; *c; ++c)
3690 if (isunix) trim_unixpath(string,item,1);
3691 add_item(head, tail, string, count);
3694 if (sts != RMS$_NMF)
3696 set_vaxc_errno(sts);
3699 case RMS$_FNF: case RMS$_DNF:
3700 set_errno(ENOENT); break;
3702 set_errno(ENOTDIR); break;
3704 set_errno(ENODEV); break;
3705 case RMS$_FNM: case RMS$_SYN:
3706 set_errno(EINVAL); break;
3708 set_errno(EACCES); break;
3710 _ckvmssts_noperl(sts);
3714 add_item(head, tail, item, count);
3715 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3716 _ckvmssts_noperl(lib$find_file_end(&context));
3719 static int child_st[2];/* Event Flag set when child process completes */
3721 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3723 static unsigned long int exit_handler(int *status)
3727 if (0 == child_st[0])
3729 #ifdef ARGPROC_DEBUG
3730 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3732 fflush(stdout); /* Have to flush pipe for binary data to */
3733 /* terminate properly -- <tp@mccall.com> */
3734 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3735 sys$dassgn(child_chan);
3737 sys$synch(0, child_st);
3742 static void sig_child(int chan)
3744 #ifdef ARGPROC_DEBUG
3745 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3747 if (child_st[0] == 0)
3751 static struct exit_control_block exit_block =
3756 &exit_block.exit_status,
3760 static void pipe_and_fork(char **cmargv)
3763 $DESCRIPTOR(cmddsc, "");
3764 static char mbxname[64];
3765 $DESCRIPTOR(mbxdsc, mbxname);
3767 unsigned long int zero = 0, one = 1;
3769 strcpy(subcmd, cmargv[0]);
3770 for (j = 1; NULL != cmargv[j]; ++j)
3772 strcat(subcmd, " \"");
3773 strcat(subcmd, cmargv[j]);
3774 strcat(subcmd, "\"");
3776 cmddsc.dsc$a_pointer = subcmd;
3777 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3779 create_mbx(&child_chan,&mbxdsc);
3780 #ifdef ARGPROC_DEBUG
3781 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3782 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3784 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3785 0, &pid, child_st, &zero, sig_child,
3787 #ifdef ARGPROC_DEBUG
3788 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3790 sys$dclexh(&exit_block);
3791 if (NULL == freopen(mbxname, "wb", stdout))
3793 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3797 static int background_process(int argc, char **argv)
3799 char command[2048] = "$";
3800 $DESCRIPTOR(value, "");
3801 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3802 static $DESCRIPTOR(null, "NLA0:");
3803 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3805 $DESCRIPTOR(pidstr, "");
3807 unsigned long int flags = 17, one = 1, retsts;
3809 strcat(command, argv[0]);
3812 strcat(command, " \"");
3813 strcat(command, *(++argv));
3814 strcat(command, "\"");
3816 value.dsc$a_pointer = command;
3817 value.dsc$w_length = strlen(value.dsc$a_pointer);
3818 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3819 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3820 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3821 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3824 _ckvmssts_noperl(retsts);
3826 #ifdef ARGPROC_DEBUG
3827 PerlIO_printf(Perl_debug_log, "%s\n", command);
3829 sprintf(pidstring, "%08X", pid);
3830 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3831 pidstr.dsc$a_pointer = pidstring;
3832 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3833 lib$set_symbol(&pidsymbol, &pidstr);
3837 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3840 /* OS-specific initialization at image activation (not thread startup) */
3841 /* Older VAXC header files lack these constants */
3842 #ifndef JPI$_RIGHTS_SIZE
3843 # define JPI$_RIGHTS_SIZE 817
3845 #ifndef KGB$M_SUBSYSTEM
3846 # define KGB$M_SUBSYSTEM 0x8
3849 /*{{{void vms_image_init(int *, char ***)*/
3851 vms_image_init(int *argcp, char ***argvp)
3853 char eqv[LNM$C_NAMLENGTH+1] = "";
3854 unsigned int len, tabct = 8, tabidx = 0;
3855 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3856 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3857 unsigned short int dummy, rlen;
3858 struct dsc$descriptor_s **tabvec;
3860 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3861 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3862 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3865 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3867 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3868 if (iprv[i]) { /* Running image installed with privs? */
3869 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3874 /* Rights identifiers might trigger tainting as well. */
3875 if (!will_taint && (rlen || rsz)) {
3876 while (rlen < rsz) {
3877 /* We didn't get all the identifiers on the first pass. Allocate a
3878 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3879 * were needed to hold all identifiers at time of last call; we'll
3880 * allocate that many unsigned long ints), and go back and get 'em.
3881 * If it gave us less than it wanted to despite ample buffer space,
3882 * something's broken. Is your system missing a system identifier?
3884 if (rsz <= jpilist[1].buflen) {
3885 /* Perl_croak accvios when used this early in startup. */
3886 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3887 rsz, (unsigned long) jpilist[1].buflen,
3888 "Check your rights database for corruption.\n");
3891 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3892 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3893 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3894 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3897 mask = jpilist[1].bufadr;
3898 /* Check attribute flags for each identifier (2nd longword); protected
3899 * subsystem identifiers trigger tainting.
3901 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3902 if (mask[i] & KGB$M_SUBSYSTEM) {
3907 if (mask != rlst) Safefree(mask);
3909 /* We need to use this hack to tell Perl it should run with tainting,
3910 * since its tainting flag may be part of the PL_curinterp struct, which
3911 * hasn't been allocated when vms_image_init() is called.
3915 New(1320,newap,*argcp+2,char **);
3916 newap[0] = argvp[0];
3918 Copy(argvp[1],newap[2],*argcp-1,char **);
3919 /* We orphan the old argv, since we don't know where it's come from,
3920 * so we don't know how to free it.
3922 *argcp++; argvp = newap;
3924 else { /* Did user explicitly request tainting? */
3926 char *cp, **av = *argvp;
3927 for (i = 1; i < *argcp; i++) {
3928 if (*av[i] != '-') break;
3929 for (cp = av[i]+1; *cp; cp++) {
3930 if (*cp == 'T') { will_taint = 1; break; }
3931 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3932 strchr("DFIiMmx",*cp)) break;
3934 if (will_taint) break;
3939 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3941 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3942 else if (tabidx >= tabct) {
3944 Renew(tabvec,tabct,struct dsc$descriptor_s *);
3946 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3947 tabvec[tabidx]->dsc$w_length = 0;
3948 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
3949 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
3950 tabvec[tabidx]->dsc$a_pointer = NULL;
3951 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3953 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
3955 getredirection(argcp,argvp);
3956 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
3958 # include <reentrancy.h>
3959 (void) decc$set_reentrancy(C$C_MULTITHREAD);
3968 * Trim Unix-style prefix off filespec, so it looks like what a shell
3969 * glob expansion would return (i.e. from specified prefix on, not
3970 * full path). Note that returned filespec is Unix-style, regardless
3971 * of whether input filespec was VMS-style or Unix-style.
3973 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
3974 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
3975 * vector of options; at present, only bit 0 is used, and if set tells
3976 * trim unixpath to try the current default directory as a prefix when
3977 * presented with a possibly ambiguous ... wildcard.
3979 * Returns !=0 on success, with trimmed filespec replacing contents of
3980 * fspec, and 0 on failure, with contents of fpsec unchanged.
3982 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
3984 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
3986 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3987 *template, *base, *end, *cp1, *cp2;
3988 register int tmplen, reslen = 0, dirs = 0;
3990 if (!wildspec || !fspec) return 0;
3991 if (strpbrk(wildspec,"]>:") != NULL) {
3992 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3993 else template = unixwild;
3995 else template = wildspec;
3996 if (strpbrk(fspec,"]>:") != NULL) {
3997 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3998 else base = unixified;
3999 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4000 * check to see that final result fits into (isn't longer than) fspec */
4001 reslen = strlen(fspec);
4005 /* No prefix or absolute path on wildcard, so nothing to remove */
4006 if (!*template || *template == '/') {
4007 if (base == fspec) return 1;
4008 tmplen = strlen(unixified);
4009 if (tmplen > reslen) return 0; /* not enough space */
4010 /* Copy unixified resultant, including trailing NUL */
4011 memmove(fspec,unixified,tmplen+1);
4015 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4016 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4017 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4018 for (cp1 = end ;cp1 >= base; cp1--)
4019 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4021 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4025 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4026 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4027 int ells = 1, totells, segdirs, match;
4028 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4029 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4031 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4033 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4034 if (ellipsis == template && opts & 1) {
4035 /* Template begins with an ellipsis. Since we can't tell how many
4036 * directory names at the front of the resultant to keep for an
4037 * arbitrary starting point, we arbitrarily choose the current
4038 * default directory as a starting point. If it's there as a prefix,
4039 * clip it off. If not, fall through and act as if the leading
4040 * ellipsis weren't there (i.e. return shortest possible path that
4041 * could match template).
4043 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4044 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4045 if (_tolower(*cp1) != _tolower(*cp2)) break;
4046 segdirs = dirs - totells; /* Min # of dirs we must have left */
4047 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4048 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4049 memcpy(fspec,cp2+1,end - cp2);
4053 /* First off, back up over constant elements at end of path */
4055 for (front = end ; front >= base; front--)
4056 if (*front == '/' && !dirs--) { front++; break; }
4058 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4059 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4060 if (cp1 != '\0') return 0; /* Path too long. */
4062 *cp2 = '\0'; /* Pick up with memcpy later */
4063 lcfront = lcres + (front - base);
4064 /* Now skip over each ellipsis and try to match the path in front of it. */
4066 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4067 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4068 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4069 if (cp1 < template) break; /* template started with an ellipsis */
4070 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4071 ellipsis = cp1; continue;
4073 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4075 for (segdirs = 0, cp2 = tpl;
4076 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4078 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4079 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4080 if (*cp2 == '/') segdirs++;
4082 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4083 /* Back up at least as many dirs as in template before matching */
4084 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4085 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4086 for (match = 0; cp1 > lcres;) {
4087 resdsc.dsc$a_pointer = cp1;
4088 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4090 if (match == 1) lcfront = cp1;
4092 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4094 if (!match) return 0; /* Can't find prefix ??? */
4095 if (match > 1 && opts & 1) {
4096 /* This ... wildcard could cover more than one set of dirs (i.e.
4097 * a set of similar dir names is repeated). If the template
4098 * contains more than 1 ..., upstream elements could resolve the
4099 * ambiguity, but it's not worth a full backtracking setup here.
4100 * As a quick heuristic, clip off the current default directory
4101 * if it's present to find the trimmed spec, else use the
4102 * shortest string that this ... could cover.
4104 char def[NAM$C_MAXRSS+1], *st;
4106 if (getcwd(def, sizeof def,0) == NULL) return 0;
4107 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4108 if (_tolower(*cp1) != _tolower(*cp2)) break;
4109 segdirs = dirs - totells; /* Min # of dirs we must have left */
4110 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4111 if (*cp1 == '\0' && *cp2 == '/') {
4112 memcpy(fspec,cp2+1,end - cp2);
4115 /* Nope -- stick with lcfront from above and keep going. */
4118 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4123 } /* end of trim_unixpath() */
4128 * VMS readdir() routines.
4129 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4131 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4132 * Minor modifications to original routines.
4135 /* Number of elements in vms_versions array */
4136 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4139 * Open a directory, return a handle for later use.
4141 /*{{{ DIR *opendir(char*name) */
4143 Perl_opendir(pTHX_ char *name)
4146 char dir[NAM$C_MAXRSS+1];
4149 if (do_tovmspath(name,dir,0) == NULL) {
4152 if (flex_stat(dir,&sb) == -1) return NULL;
4153 if (!S_ISDIR(sb.st_mode)) {
4154 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4157 if (!cando_by_name(S_IRUSR,0,dir)) {
4158 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4161 /* Get memory for the handle, and the pattern. */
4163 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4165 /* Fill in the fields; mainly playing with the descriptor. */
4166 (void)sprintf(dd->pattern, "%s*.*",dir);
4169 dd->vms_wantversions = 0;
4170 dd->pat.dsc$a_pointer = dd->pattern;
4171 dd->pat.dsc$w_length = strlen(dd->pattern);
4172 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4173 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4176 } /* end of opendir() */
4180 * Set the flag to indicate we want versions or not.
4182 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4184 vmsreaddirversions(DIR *dd, int flag)
4186 dd->vms_wantversions = flag;
4191 * Free up an opened directory.
4193 /*{{{ void closedir(DIR *dd)*/
4197 (void)lib$find_file_end(&dd->context);
4198 Safefree(dd->pattern);
4199 Safefree((char *)dd);
4204 * Collect all the version numbers for the current file.
4210 struct dsc$descriptor_s pat;
4211 struct dsc$descriptor_s res;
4213 char *p, *text, buff[sizeof dd->entry.d_name];
4215 unsigned long context, tmpsts;
4218 /* Convenient shorthand. */
4221 /* Add the version wildcard, ignoring the "*.*" put on before */
4222 i = strlen(dd->pattern);
4223 New(1308,text,i + e->d_namlen + 3,char);
4224 (void)strcpy(text, dd->pattern);
4225 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4227 /* Set up the pattern descriptor. */
4228 pat.dsc$a_pointer = text;
4229 pat.dsc$w_length = i + e->d_namlen - 1;
4230 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4231 pat.dsc$b_class = DSC$K_CLASS_S;
4233 /* Set up result descriptor. */
4234 res.dsc$a_pointer = buff;
4235 res.dsc$w_length = sizeof buff - 2;
4236 res.dsc$b_dtype = DSC$K_DTYPE_T;
4237 res.dsc$b_class = DSC$K_CLASS_S;
4239 /* Read files, collecting versions. */
4240 for (context = 0, e->vms_verscount = 0;
4241 e->vms_verscount < VERSIZE(e);
4242 e->vms_verscount++) {
4243 tmpsts = lib$find_file(&pat, &res, &context);
4244 if (tmpsts == RMS$_NMF || context == 0) break;
4246 buff[sizeof buff - 1] = '\0';
4247 if ((p = strchr(buff, ';')))
4248 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4250 e->vms_versions[e->vms_verscount] = -1;
4253 _ckvmssts(lib$find_file_end(&context));
4256 } /* end of collectversions() */
4259 * Read the next entry from the directory.
4261 /*{{{ struct dirent *readdir(DIR *dd)*/
4265 struct dsc$descriptor_s res;
4266 char *p, buff[sizeof dd->entry.d_name];
4267 unsigned long int tmpsts;
4269 /* Set up result descriptor, and get next file. */
4270 res.dsc$a_pointer = buff;
4271 res.dsc$w_length = sizeof buff - 2;
4272 res.dsc$b_dtype = DSC$K_DTYPE_T;
4273 res.dsc$b_class = DSC$K_CLASS_S;
4274 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4275 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4276 if (!(tmpsts & 1)) {
4277 set_vaxc_errno(tmpsts);
4280 set_errno(EACCES); break;
4282 set_errno(ENODEV); break;
4284 set_errno(ENOTDIR); break;
4285 case RMS$_FNF: case RMS$_DNF:
4286 set_errno(ENOENT); break;
4293 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4294 buff[sizeof buff - 1] = '\0';
4295 for (p = buff; *p; p++) *p = _tolower(*p);
4296 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4299 /* Skip any directory component and just copy the name. */
4300 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4301 else (void)strcpy(dd->entry.d_name, buff);
4303 /* Clobber the version. */
4304 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4306 dd->entry.d_namlen = strlen(dd->entry.d_name);
4307 dd->entry.vms_verscount = 0;
4308 if (dd->vms_wantversions) collectversions(dd);
4311 } /* end of readdir() */
4315 * Return something that can be used in a seekdir later.
4317 /*{{{ long telldir(DIR *dd)*/
4326 * Return to a spot where we used to be. Brute force.
4328 /*{{{ void seekdir(DIR *dd,long count)*/
4330 seekdir(DIR *dd, long count)
4332 int vms_wantversions;
4335 /* If we haven't done anything yet... */
4339 /* Remember some state, and clear it. */
4340 vms_wantversions = dd->vms_wantversions;
4341 dd->vms_wantversions = 0;
4342 _ckvmssts(lib$find_file_end(&dd->context));
4345 /* The increment is in readdir(). */
4346 for (dd->count = 0; dd->count < count; )
4349 dd->vms_wantversions = vms_wantversions;
4351 } /* end of seekdir() */
4354 /* VMS subprocess management
4356 * my_vfork() - just a vfork(), after setting a flag to record that
4357 * the current script is trying a Unix-style fork/exec.
4359 * vms_do_aexec() and vms_do_exec() are called in response to the
4360 * perl 'exec' function. If this follows a vfork call, then they
4361 * call out the the regular perl routines in doio.c which do an
4362 * execvp (for those who really want to try this under VMS).
4363 * Otherwise, they do exactly what the perl docs say exec should
4364 * do - terminate the current script and invoke a new command
4365 * (See below for notes on command syntax.)
4367 * do_aspawn() and do_spawn() implement the VMS side of the perl
4368 * 'system' function.
4370 * Note on command arguments to perl 'exec' and 'system': When handled
4371 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4372 * are concatenated to form a DCL command string. If the first arg
4373 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4374 * the the command string is handed off to DCL directly. Otherwise,
4375 * the first token of the command is taken as the filespec of an image
4376 * to run. The filespec is expanded using a default type of '.EXE' and
4377 * the process defaults for device, directory, etc., and if found, the resultant
4378 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4379 * the command string as parameters. This is perhaps a bit complicated,
4380 * but I hope it will form a happy medium between what VMS folks expect
4381 * from lib$spawn and what Unix folks expect from exec.
4384 static int vfork_called;
4386 /*{{{int my_vfork()*/
4397 vms_execfree(pTHX) {
4399 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4402 if (VMScmd.dsc$a_pointer) {
4403 Safefree(VMScmd.dsc$a_pointer);
4404 VMScmd.dsc$w_length = 0;
4405 VMScmd.dsc$a_pointer = Nullch;
4410 setup_argstr(SV *really, SV **mark, SV **sp)
4413 char *junk, *tmps = Nullch;
4414 register size_t cmdlen = 0;
4421 tmps = SvPV(really,rlen);
4428 for (idx++; idx <= sp; idx++) {
4430 junk = SvPVx(*idx,rlen);
4431 cmdlen += rlen ? rlen + 1 : 0;
4434 New(401,PL_Cmd,cmdlen+1,char);
4436 if (tmps && *tmps) {
4437 strcpy(PL_Cmd,tmps);
4440 else *PL_Cmd = '\0';
4441 while (++mark <= sp) {
4443 char *s = SvPVx(*mark,n_a);
4445 if (*PL_Cmd) strcat(PL_Cmd," ");
4451 } /* end of setup_argstr() */
4454 static unsigned long int
4455 setup_cmddsc(char *cmd, int check_img)
4457 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4458 $DESCRIPTOR(defdsc,".EXE");
4459 $DESCRIPTOR(defdsc2,".");
4460 $DESCRIPTOR(resdsc,resspec);
4461 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4462 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4463 register char *s, *rest, *cp, *wordbreak;
4468 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4471 while (*s && isspace(*s)) s++;
4473 if (*s == '@' || *s == '$') {
4474 vmsspec[0] = *s; rest = s + 1;
4475 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4477 else { cp = vmsspec; rest = s; }
4478 if (*rest == '.' || *rest == '/') {
4481 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4482 rest++, cp2++) *cp2 = *rest;
4484 if (do_tovmsspec(resspec,cp,0)) {
4487 for (cp2 = vmsspec + strlen(vmsspec);
4488 *rest && cp2 - vmsspec < sizeof vmsspec;
4489 rest++, cp2++) *cp2 = *rest;
4494 /* Intuit whether verb (first word of cmd) is a DCL command:
4495 * - if first nonspace char is '@', it's a DCL indirection
4497 * - if verb contains a filespec separator, it's not a DCL command
4498 * - if it doesn't, caller tells us whether to default to a DCL
4499 * command, or to a local image unless told it's DCL (by leading '$')
4501 if (*s == '@') isdcl = 1;
4503 register char *filespec = strpbrk(s,":<[.;");
4504 rest = wordbreak = strpbrk(s," \"\t/");
4505 if (!wordbreak) wordbreak = s + strlen(s);
4506 if (*s == '$') check_img = 0;
4507 if (filespec && (filespec < wordbreak)) isdcl = 0;
4508 else isdcl = !check_img;
4512 imgdsc.dsc$a_pointer = s;
4513 imgdsc.dsc$w_length = wordbreak - s;
4514 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4516 _ckvmssts(lib$find_file_end(&cxt));
4517 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4518 if (!(retsts & 1) && *s == '$') {
4519 _ckvmssts(lib$find_file_end(&cxt));
4520 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4521 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4523 _ckvmssts(lib$find_file_end(&cxt));
4524 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4528 _ckvmssts(lib$find_file_end(&cxt));
4533 while (*s && !isspace(*s)) s++;
4536 /* check that it's really not DCL with no file extension */
4537 fp = fopen(resspec,"r","ctx=bin,shr=get");
4539 char b[4] = {0,0,0,0};
4540 read(fileno(fp),b,4);
4541 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4544 if (check_img && isdcl) return RMS$_FNF;
4546 if (cando_by_name(S_IXUSR,0,resspec)) {
4547 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4549 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4551 strcpy(VMScmd.dsc$a_pointer,"@");
4553 strcat(VMScmd.dsc$a_pointer,resspec);
4554 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4555 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4558 else retsts = RMS$_PRV;
4561 /* It's either a DCL command or we couldn't find a suitable image */
4562 VMScmd.dsc$w_length = strlen(cmd);
4563 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4564 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4565 if (!(retsts & 1)) {
4566 /* just hand off status values likely to be due to user error */
4567 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4568 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4569 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4570 else { _ckvmssts(retsts); }
4573 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4575 } /* end of setup_cmddsc() */
4578 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4580 vms_do_aexec(SV *really,SV **mark,SV **sp)
4584 if (vfork_called) { /* this follows a vfork - act Unixish */
4586 if (vfork_called < 0) {
4587 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4590 else return do_aexec(really,mark,sp);
4592 /* no vfork - act VMSish */
4593 return vms_do_exec(setup_argstr(really,mark,sp));
4598 } /* end of vms_do_aexec() */
4601 /* {{{bool vms_do_exec(char *cmd) */
4603 vms_do_exec(char *cmd)
4607 if (vfork_called) { /* this follows a vfork - act Unixish */
4609 if (vfork_called < 0) {
4610 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4613 else return do_exec(cmd);
4616 { /* no vfork - act VMSish */
4617 unsigned long int retsts;
4620 TAINT_PROPER("exec");
4621 if ((retsts = setup_cmddsc(cmd,1)) & 1)
4622 retsts = lib$do_command(&VMScmd);
4625 case RMS$_FNF: case RMS$_DNF:
4626 set_errno(ENOENT); break;
4628 set_errno(ENOTDIR); break;
4630 set_errno(ENODEV); break;
4632 set_errno(EACCES); break;
4634 set_errno(EINVAL); break;
4636 set_errno(E2BIG); break;
4637 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4638 _ckvmssts(retsts); /* fall through */
4639 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4642 set_vaxc_errno(retsts);
4643 if (ckWARN(WARN_EXEC)) {
4644 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4645 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4652 } /* end of vms_do_exec() */
4655 unsigned long int do_spawn(char *);
4657 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4659 do_aspawn(void *really,void **mark,void **sp)
4662 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4665 } /* end of do_aspawn() */
4668 /* {{{unsigned long int do_spawn(char *cmd) */
4672 unsigned long int sts, substs, hadcmd = 1;
4676 TAINT_PROPER("spawn");
4677 if (!cmd || !*cmd) {
4679 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4681 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4682 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4687 case RMS$_FNF: case RMS$_DNF:
4688 set_errno(ENOENT); break;
4690 set_errno(ENOTDIR); break;
4692 set_errno(ENODEV); break;
4694 set_errno(EACCES); break;
4696 set_errno(EINVAL); break;
4698 set_errno(E2BIG); break;
4699 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4700 _ckvmssts(sts); /* fall through */
4701 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4704 set_vaxc_errno(sts);
4705 if (ckWARN(WARN_EXEC)) {
4706 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4707 hadcmd ? VMScmd.dsc$w_length : 0,
4708 hadcmd ? VMScmd.dsc$a_pointer : "",
4715 } /* end of do_spawn() */
4719 * A simple fwrite replacement which outputs itmsz*nitm chars without
4720 * introducing record boundaries every itmsz chars.
4721 * We are using fputs, which depends on a terminating null. We may
4722 * well be writing binary data, so we need to accommodate not only
4723 * data with nulls sprinkled in the middle but also data with no null
4726 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4728 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4730 register char *cp, *end, *cpd, *data;
4732 int bufsize = itmsz*nitm+1;
4734 _ckvmssts_noperl(lib$get_vm( &bufsize, &data ));
4735 memcpy( data, src, itmsz*nitm );
4736 data[itmsz*nitm] = '\0';
4738 end = data + itmsz * nitm;
4739 retval = (int) nitm; /* on success return # items written */
4742 while (cpd <= end) {
4743 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4744 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4746 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4750 if (data) _ckvmssts_noperl(lib$free_vm( &bufsize, &data ));
4753 } /* end of my_fwrite() */
4756 /*{{{ int my_flush(FILE *fp)*/
4761 if ((res = fflush(fp)) == 0 && fp) {
4762 #ifdef VMS_DO_SOCKETS
4764 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4766 res = fsync(fileno(fp));
4769 * If the flush succeeded but set end-of-file, we need to clear
4770 * the error because our caller may check ferror(). BTW, this
4771 * probably means we just flushed an empty file.
4773 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4780 * Here are replacements for the following Unix routines in the VMS environment:
4781 * getpwuid Get information for a particular UIC or UID
4782 * getpwnam Get information for a named user
4783 * getpwent Get information for each user in the rights database
4784 * setpwent Reset search to the start of the rights database
4785 * endpwent Finish searching for users in the rights database
4787 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4788 * (defined in pwd.h), which contains the following fields:-
4790 * char *pw_name; Username (in lower case)
4791 * char *pw_passwd; Hashed password
4792 * unsigned int pw_uid; UIC
4793 * unsigned int pw_gid; UIC group number
4794 * char *pw_unixdir; Default device/directory (VMS-style)
4795 * char *pw_gecos; Owner name
4796 * char *pw_dir; Default device/directory (Unix-style)
4797 * char *pw_shell; Default CLI name (eg. DCL)
4799 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4801 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4802 * not the UIC member number (eg. what's returned by getuid()),
4803 * getpwuid() can accept either as input (if uid is specified, the caller's
4804 * UIC group is used), though it won't recognise gid=0.
4806 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4807 * information about other users in your group or in other groups, respectively.
4808 * If the required privilege is not available, then these routines fill only
4809 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4812 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4815 /* sizes of various UAF record fields */
4816 #define UAI$S_USERNAME 12
4817 #define UAI$S_IDENT 31
4818 #define UAI$S_OWNER 31
4819 #define UAI$S_DEFDEV 31
4820 #define UAI$S_DEFDIR 63
4821 #define UAI$S_DEFCLI 31
4824 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4825 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4826 (uic).uic$v_group != UIC$K_WILD_GROUP)
4828 static char __empty[]= "";
4829 static struct passwd __passwd_empty=
4830 {(char *) __empty, (char *) __empty, 0, 0,
4831 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4832 static int contxt= 0;
4833 static struct passwd __pwdcache;
4834 static char __pw_namecache[UAI$S_IDENT+1];
4837 * This routine does most of the work extracting the user information.
4839 static int fillpasswd (const char *name, struct passwd *pwd)
4843 unsigned char length;
4844 char pw_gecos[UAI$S_OWNER+1];
4846 static union uicdef uic;
4848 unsigned char length;
4849 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4852 unsigned char length;
4853 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4856 unsigned char length;
4857 char pw_shell[UAI$S_DEFCLI+1];
4859 static char pw_passwd[UAI$S_PWD+1];
4861 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4862 struct dsc$descriptor_s name_desc;
4863 unsigned long int sts;
4865 static struct itmlst_3 itmlst[]= {
4866 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4867 {sizeof(uic), UAI$_UIC, &uic, &luic},
4868 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
4869 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
4870 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
4871 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
4872 {0, 0, NULL, NULL}};
4874 name_desc.dsc$w_length= strlen(name);
4875 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4876 name_desc.dsc$b_class= DSC$K_CLASS_S;
4877 name_desc.dsc$a_pointer= (char *) name;
4879 /* Note that sys$getuai returns many fields as counted strings. */
4880 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4881 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4882 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4884 else { _ckvmssts(sts); }
4885 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
4887 if ((int) owner.length < lowner) lowner= (int) owner.length;
4888 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4889 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4890 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4891 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4892 owner.pw_gecos[lowner]= '\0';
4893 defdev.pw_dir[ldefdev+ldefdir]= '\0';
4894 defcli.pw_shell[ldefcli]= '\0';
4895 if (valid_uic(uic)) {
4896 pwd->pw_uid= uic.uic$l_uic;
4897 pwd->pw_gid= uic.uic$v_group;
4900 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
4901 pwd->pw_passwd= pw_passwd;
4902 pwd->pw_gecos= owner.pw_gecos;
4903 pwd->pw_dir= defdev.pw_dir;
4904 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
4905 pwd->pw_shell= defcli.pw_shell;
4906 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
4908 ldir= strlen(pwd->pw_unixdir) - 1;
4909 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
4912 strcpy(pwd->pw_unixdir, pwd->pw_dir);
4913 __mystrtolower(pwd->pw_unixdir);
4918 * Get information for a named user.
4920 /*{{{struct passwd *getpwnam(char *name)*/
4921 struct passwd *my_getpwnam(char *name)
4923 struct dsc$descriptor_s name_desc;
4925 unsigned long int status, sts;
4928 __pwdcache = __passwd_empty;
4929 if (!fillpasswd(name, &__pwdcache)) {
4930 /* We still may be able to determine pw_uid and pw_gid */
4931 name_desc.dsc$w_length= strlen(name);
4932 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4933 name_desc.dsc$b_class= DSC$K_CLASS_S;
4934 name_desc.dsc$a_pointer= (char *) name;
4935 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
4936 __pwdcache.pw_uid= uic.uic$l_uic;
4937 __pwdcache.pw_gid= uic.uic$v_group;
4940 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
4941 set_vaxc_errno(sts);
4942 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
4945 else { _ckvmssts(sts); }
4948 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
4949 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
4950 __pwdcache.pw_name= __pw_namecache;
4952 } /* end of my_getpwnam() */
4956 * Get information for a particular UIC or UID.
4957 * Called by my_getpwent with uid=-1 to list all users.
4959 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
4960 struct passwd *my_getpwuid(Uid_t uid)
4962 const $DESCRIPTOR(name_desc,__pw_namecache);
4963 unsigned short lname;
4965 unsigned long int status;
4968 if (uid == (unsigned int) -1) {
4970 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
4971 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
4972 set_vaxc_errno(status);
4973 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4977 else { _ckvmssts(status); }
4978 } while (!valid_uic (uic));
4982 if (!uic.uic$v_group)
4983 uic.uic$v_group= PerlProc_getgid();
4985 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
4986 else status = SS$_IVIDENT;
4987 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
4988 status == RMS$_PRV) {
4989 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4992 else { _ckvmssts(status); }
4994 __pw_namecache[lname]= '\0';
4995 __mystrtolower(__pw_namecache);
4997 __pwdcache = __passwd_empty;
4998 __pwdcache.pw_name = __pw_namecache;
5000 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5001 The identifier's value is usually the UIC, but it doesn't have to be,
5002 so if we can, we let fillpasswd update this. */
5003 __pwdcache.pw_uid = uic.uic$l_uic;
5004 __pwdcache.pw_gid = uic.uic$v_group;
5006 fillpasswd(__pw_namecache, &__pwdcache);
5009 } /* end of my_getpwuid() */
5013 * Get information for next user.
5015 /*{{{struct passwd *my_getpwent()*/
5016 struct passwd *my_getpwent()
5018 return (my_getpwuid((unsigned int) -1));
5023 * Finish searching rights database for users.
5025 /*{{{void my_endpwent()*/
5030 _ckvmssts(sys$finish_rdb(&contxt));
5036 #ifdef HOMEGROWN_POSIX_SIGNALS
5037 /* Signal handling routines, pulled into the core from POSIX.xs.
5039 * We need these for threads, so they've been rolled into the core,
5040 * rather than left in POSIX.xs.
5042 * (DRS, Oct 23, 1997)
5045 /* sigset_t is atomic under VMS, so these routines are easy */
5046 /*{{{int my_sigemptyset(sigset_t *) */
5047 int my_sigemptyset(sigset_t *set) {
5048 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5054 /*{{{int my_sigfillset(sigset_t *)*/
5055 int my_sigfillset(sigset_t *set) {
5057 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5058 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5064 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5065 int my_sigaddset(sigset_t *set, int sig) {
5066 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5067 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5068 *set |= (1 << (sig - 1));
5074 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5075 int my_sigdelset(sigset_t *set, int sig) {
5076 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5077 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5078 *set &= ~(1 << (sig - 1));
5084 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5085 int my_sigismember(sigset_t *set, int sig) {
5086 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5087 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5088 *set & (1 << (sig - 1));
5093 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5094 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5097 /* If set and oset are both null, then things are badly wrong. Bail out. */
5098 if ((oset == NULL) && (set == NULL)) {
5099 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5103 /* If set's null, then we're just handling a fetch. */
5105 tempmask = sigblock(0);
5110 tempmask = sigsetmask(*set);
5113 tempmask = sigblock(*set);
5116 tempmask = sigblock(0);
5117 sigsetmask(*oset & ~tempmask);
5120 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5125 /* Did they pass us an oset? If so, stick our holding mask into it */
5132 #endif /* HOMEGROWN_POSIX_SIGNALS */
5135 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5136 * my_utime(), and flex_stat(), all of which operate on UTC unless
5137 * VMSISH_TIMES is true.
5139 /* method used to handle UTC conversions:
5140 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5142 static int gmtime_emulation_type;
5143 /* number of secs to add to UTC POSIX-style time to get local time */
5144 static long int utc_offset_secs;
5146 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5147 * in vmsish.h. #undef them here so we can call the CRTL routines
5156 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5157 * qualifier with the extern prefix pragma. This provisional
5158 * hack circumvents this prefix pragma problem in previous
5161 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5162 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5163 # pragma __extern_prefix save
5164 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5165 # define gmtime decc$__utctz_gmtime
5166 # define localtime decc$__utctz_localtime
5167 # define time decc$__utc_time
5168 # pragma __extern_prefix restore
5170 struct tm *gmtime(), *localtime();
5176 static time_t toutc_dst(time_t loc) {
5179 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5180 loc -= utc_offset_secs;
5181 if (rsltmp->tm_isdst) loc -= 3600;
5184 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5185 ((gmtime_emulation_type || my_time(NULL)), \
5186 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5187 ((secs) - utc_offset_secs))))
5189 static time_t toloc_dst(time_t utc) {
5192 utc += utc_offset_secs;
5193 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5194 if (rsltmp->tm_isdst) utc += 3600;
5197 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5198 ((gmtime_emulation_type || my_time(NULL)), \
5199 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5200 ((secs) + utc_offset_secs))))
5202 #ifndef RTL_USES_UTC
5205 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5206 DST starts on 1st sun of april at 02:00 std time
5207 ends on last sun of october at 02:00 dst time
5208 see the UCX management command reference, SET CONFIG TIMEZONE
5209 for formatting info.
5211 No, it's not as general as it should be, but then again, NOTHING
5212 will handle UK times in a sensible way.
5217 parse the DST start/end info:
5218 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5222 tz_parse_startend(char *s, struct tm *w, int *past)
5224 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5225 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5230 if (!past) return 0;
5233 if (w->tm_year % 4 == 0) ly = 1;
5234 if (w->tm_year % 100 == 0) ly = 0;
5235 if (w->tm_year+1900 % 400 == 0) ly = 1;
5238 dozjd = isdigit(*s);
5239 if (*s == 'J' || *s == 'j' || dozjd) {
5240 if (!dozjd && !isdigit(*++s)) return 0;
5243 d = d*10 + *s++ - '0';
5245 d = d*10 + *s++ - '0';
5248 if (d == 0) return 0;
5249 if (d > 366) return 0;
5251 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5254 } else if (*s == 'M' || *s == 'm') {
5255 if (!isdigit(*++s)) return 0;
5257 if (isdigit(*s)) m = 10*m + *s++ - '0';
5258 if (*s != '.') return 0;
5259 if (!isdigit(*++s)) return 0;
5261 if (n < 1 || n > 5) return 0;
5262 if (*s != '.') return 0;
5263 if (!isdigit(*++s)) return 0;
5265 if (d > 6) return 0;
5269 if (!isdigit(*++s)) return 0;
5271 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5273 if (!isdigit(*++s)) return 0;
5275 if (isdigit(*s)) min = 10*min + *s++ - '0';
5277 if (!isdigit(*++s)) return 0;
5279 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5289 if (w->tm_yday < d) goto before;
5290 if (w->tm_yday > d) goto after;
5292 if (w->tm_mon+1 < m) goto before;
5293 if (w->tm_mon+1 > m) goto after;
5295 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5296 k = d - j; /* mday of first d */
5298 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5299 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5300 if (w->tm_mday < k) goto before;
5301 if (w->tm_mday > k) goto after;
5304 if (w->tm_hour < hour) goto before;
5305 if (w->tm_hour > hour) goto after;
5306 if (w->tm_min < min) goto before;
5307 if (w->tm_min > min) goto after;
5308 if (w->tm_sec < sec) goto before;
5322 /* parse the offset: (+|-)hh[:mm[:ss]] */
5325 tz_parse_offset(char *s, int *offset)
5327 int hour = 0, min = 0, sec = 0;
5330 if (!offset) return 0;
5332 if (*s == '-') {neg++; s++;}
5334 if (!isdigit(*s)) return 0;
5336 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5337 if (hour > 24) return 0;
5339 if (!isdigit(*++s)) return 0;
5341 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5342 if (min > 59) return 0;
5344 if (!isdigit(*++s)) return 0;
5346 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5347 if (sec > 59) return 0;
5351 *offset = (hour*60+min)*60 + sec;
5352 if (neg) *offset = -*offset;
5357 input time is w, whatever type of time the CRTL localtime() uses.
5358 sets dst, the zone, and the gmtoff (seconds)
5360 caches the value of TZ and UCX$TZ env variables; note that
5361 my_setenv looks for these and sets a flag if they're changed
5364 We have to watch out for the "australian" case (dst starts in
5365 october, ends in april)...flagged by "reverse" and checked by
5366 scanning through the months of the previous year.
5371 tz_parse(time_t *w, int *dst, char *zone, int *gmtoff)
5376 char *dstzone, *tz, *s_start, *s_end;
5377 int std_off, dst_off, isdst;
5378 int y, dststart, dstend;
5379 static char envtz[1025]; /* longer than any logical, symbol, ... */
5380 static char ucxtz[1025];
5381 static char reversed = 0;
5387 reversed = -1; /* flag need to check */
5388 envtz[0] = ucxtz[0] = '\0';
5389 tz = my_getenv("TZ",0);
5390 if (tz) strcpy(envtz, tz);
5391 tz = my_getenv("UCX$TZ",0);
5392 if (tz) strcpy(ucxtz, tz);
5393 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5396 if (!*tz) tz = ucxtz;
5399 while (isalpha(*s)) s++;
5400 s = tz_parse_offset(s, &std_off);
5402 if (!*s) { /* no DST, hurray we're done! */
5408 while (isalpha(*s)) s++;
5409 s2 = tz_parse_offset(s, &dst_off);
5413 dst_off = std_off - 3600;
5416 if (!*s) { /* default dst start/end?? */
5417 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5418 s = strchr(ucxtz,',');
5420 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5422 if (*s != ',') return 0;
5425 when = _toutc(when); /* convert to utc */
5426 when = when - std_off; /* convert to pseudolocal time*/
5428 w2 = localtime(&when);
5431 s = tz_parse_startend(s_start,w2,&dststart);
5433 if (*s != ',') return 0;
5436 when = _toutc(when); /* convert to utc */
5437 when = when - dst_off; /* convert to pseudolocal time*/
5438 w2 = localtime(&when);
5439 if (w2->tm_year != y) { /* spans a year, just check one time */
5440 when += dst_off - std_off;
5441 w2 = localtime(&when);
5444 s = tz_parse_startend(s_end,w2,&dstend);
5447 if (reversed == -1) { /* need to check if start later than end */
5451 if (when < 2*365*86400) {
5452 when += 2*365*86400;
5456 w2 =localtime(&when);
5457 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5459 for (j = 0; j < 12; j++) {
5460 w2 =localtime(&when);
5461 (void) tz_parse_startend(s_start,w2,&ds);
5462 (void) tz_parse_startend(s_end,w2,&de);
5463 if (ds != de) break;
5467 if (de && !ds) reversed = 1;
5470 isdst = dststart && !dstend;
5471 if (reversed) isdst = dststart || !dstend;
5474 if (dst) *dst = isdst;
5475 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5476 if (isdst) tz = dstzone;
5478 while(isalpha(*tz)) *zone++ = *tz++;
5484 #endif /* !RTL_USES_UTC */
5486 /* my_time(), my_localtime(), my_gmtime()
5487 * By default traffic in UTC time values, using CRTL gmtime() or
5488 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5489 * Note: We need to use these functions even when the CRTL has working
5490 * UTC support, since they also handle C<use vmsish qw(times);>
5492 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5493 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5496 /*{{{time_t my_time(time_t *timep)*/
5497 time_t my_time(time_t *timep)
5503 if (gmtime_emulation_type == 0) {
5505 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5506 /* results of calls to gmtime() and localtime() */
5507 /* for same &base */
5509 gmtime_emulation_type++;
5510 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5511 char off[LNM$C_NAMLENGTH+1];;
5513 gmtime_emulation_type++;
5514 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5515 gmtime_emulation_type++;
5516 utc_offset_secs = 0;
5517 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5519 else { utc_offset_secs = atol(off); }
5521 else { /* We've got a working gmtime() */
5522 struct tm gmt, local;
5525 tm_p = localtime(&base);
5527 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5528 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5529 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5530 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5536 # ifdef RTL_USES_UTC
5537 if (VMSISH_TIME) when = _toloc(when);
5539 if (!VMSISH_TIME) when = _toutc(when);
5542 if (timep != NULL) *timep = when;
5545 } /* end of my_time() */
5549 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5551 my_gmtime(const time_t *timep)
5558 if (timep == NULL) {
5559 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5562 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5566 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5568 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5569 return gmtime(&when);
5571 /* CRTL localtime() wants local time as input, so does no tz correction */
5572 rsltmp = localtime(&when);
5573 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5576 } /* end of my_gmtime() */
5580 /*{{{struct tm *my_localtime(const time_t *timep)*/
5582 my_localtime(const time_t *timep)
5585 time_t when, whenutc;
5589 if (timep == NULL) {
5590 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5593 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5594 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5597 # ifdef RTL_USES_UTC
5599 if (VMSISH_TIME) when = _toutc(when);
5601 /* CRTL localtime() wants UTC as input, does tz correction itself */
5602 return localtime(&when);
5604 # else /* !RTL_USES_UTC */
5607 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5608 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5611 #ifndef RTL_USES_UTC
5612 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5613 when = whenutc - offset; /* pseudolocal time*/
5616 /* CRTL localtime() wants local time as input, so does no tz correction */
5617 rsltmp = localtime(&when);
5618 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5622 } /* end of my_localtime() */
5625 /* Reset definitions for later calls */
5626 #define gmtime(t) my_gmtime(t)
5627 #define localtime(t) my_localtime(t)
5628 #define time(t) my_time(t)
5631 /* my_utime - update modification time of a file
5632 * calling sequence is identical to POSIX utime(), but under
5633 * VMS only the modification time is changed; ODS-2 does not
5634 * maintain access times. Restrictions differ from the POSIX
5635 * definition in that the time can be changed as long as the
5636 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5637 * no separate checks are made to insure that the caller is the
5638 * owner of the file or has special privs enabled.
5639 * Code here is based on Joe Meadows' FILE utility.
5642 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5643 * to VMS epoch (01-JAN-1858 00:00:00.00)
5644 * in 100 ns intervals.
5646 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5648 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5649 int my_utime(char *file, struct utimbuf *utimes)
5653 long int bintime[2], len = 2, lowbit, unixtime,
5654 secscale = 10000000; /* seconds --> 100 ns intervals */
5655 unsigned long int chan, iosb[2], retsts;
5656 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5657 struct FAB myfab = cc$rms_fab;
5658 struct NAM mynam = cc$rms_nam;
5659 #if defined (__DECC) && defined (__VAX)
5660 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5661 * at least through VMS V6.1, which causes a type-conversion warning.
5663 # pragma message save
5664 # pragma message disable cvtdiftypes
5666 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5667 struct fibdef myfib;
5668 #if defined (__DECC) && defined (__VAX)
5669 /* This should be right after the declaration of myatr, but due
5670 * to a bug in VAX DEC C, this takes effect a statement early.
5672 # pragma message restore
5674 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5675 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5676 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5678 if (file == NULL || *file == '\0') {
5680 set_vaxc_errno(LIB$_INVARG);
5683 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5685 if (utimes != NULL) {
5686 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5687 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5688 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5689 * as input, we force the sign bit to be clear by shifting unixtime right
5690 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5692 lowbit = (utimes->modtime & 1) ? secscale : 0;
5693 unixtime = (long int) utimes->modtime;
5695 /* If input was UTC; convert to local for sys svc */
5696 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5698 unixtime >>= 1; secscale <<= 1;
5699 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5700 if (!(retsts & 1)) {
5702 set_vaxc_errno(retsts);
5705 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5706 if (!(retsts & 1)) {
5708 set_vaxc_errno(retsts);
5713 /* Just get the current time in VMS format directly */
5714 retsts = sys$gettim(bintime);
5715 if (!(retsts & 1)) {
5717 set_vaxc_errno(retsts);
5722 myfab.fab$l_fna = vmsspec;
5723 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5724 myfab.fab$l_nam = &mynam;
5725 mynam.nam$l_esa = esa;
5726 mynam.nam$b_ess = (unsigned char) sizeof esa;
5727 mynam.nam$l_rsa = rsa;
5728 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5730 /* Look for the file to be affected, letting RMS parse the file
5731 * specification for us as well. I have set errno using only
5732 * values documented in the utime() man page for VMS POSIX.
5734 retsts = sys$parse(&myfab,0,0);
5735 if (!(retsts & 1)) {
5736 set_vaxc_errno(retsts);
5737 if (retsts == RMS$_PRV) set_errno(EACCES);
5738 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5739 else set_errno(EVMSERR);
5742 retsts = sys$search(&myfab,0,0);
5743 if (!(retsts & 1)) {
5744 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5745 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5746 set_vaxc_errno(retsts);
5747 if (retsts == RMS$_PRV) set_errno(EACCES);
5748 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5749 else set_errno(EVMSERR);
5753 devdsc.dsc$w_length = mynam.nam$b_dev;
5754 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5756 retsts = sys$assign(&devdsc,&chan,0,0);
5757 if (!(retsts & 1)) {
5758 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5759 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5760 set_vaxc_errno(retsts);
5761 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5762 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5763 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5764 else set_errno(EVMSERR);
5768 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5769 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5771 memset((void *) &myfib, 0, sizeof myfib);
5772 #if defined(__DECC) || defined(__DECCXX)
5773 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5774 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5775 /* This prevents the revision time of the file being reset to the current
5776 * time as a result of our IO$_MODIFY $QIO. */
5777 myfib.fib$l_acctl = FIB$M_NORECORD;
5779 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5780 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5781 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5783 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5784 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5785 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5786 _ckvmssts(sys$dassgn(chan));
5787 if (retsts & 1) retsts = iosb[0];
5788 if (!(retsts & 1)) {
5789 set_vaxc_errno(retsts);
5790 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5791 else set_errno(EVMSERR);
5796 } /* end of my_utime() */
5800 * flex_stat, flex_fstat
5801 * basic stat, but gets it right when asked to stat
5802 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5805 /* encode_dev packs a VMS device name string into an integer to allow
5806 * simple comparisons. This can be used, for example, to check whether two
5807 * files are located on the same device, by comparing their encoded device
5808 * names. Even a string comparison would not do, because stat() reuses the
5809 * device name buffer for each call; so without encode_dev, it would be
5810 * necessary to save the buffer and use strcmp (this would mean a number of
5811 * changes to the standard Perl code, to say nothing of what a Perl script
5814 * The device lock id, if it exists, should be unique (unless perhaps compared
5815 * with lock ids transferred from other nodes). We have a lock id if the disk is
5816 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5817 * device names. Thus we use the lock id in preference, and only if that isn't
5818 * available, do we try to pack the device name into an integer (flagged by
5819 * the sign bit (LOCKID_MASK) being set).
5821 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5822 * name and its encoded form, but it seems very unlikely that we will find
5823 * two files on different disks that share the same encoded device names,
5824 * and even more remote that they will share the same file id (if the test
5825 * is to check for the same file).
5827 * A better method might be to use sys$device_scan on the first call, and to
5828 * search for the device, returning an index into the cached array.
5829 * The number returned would be more intelligable.
5830 * This is probably not worth it, and anyway would take quite a bit longer
5831 * on the first call.
5833 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5834 static mydev_t encode_dev (const char *dev)
5837 unsigned long int f;
5843 if (!dev || !dev[0]) return 0;
5847 struct dsc$descriptor_s dev_desc;
5848 unsigned long int status, lockid, item = DVI$_LOCKID;
5850 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5851 can try that first. */
5852 dev_desc.dsc$w_length = strlen (dev);
5853 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5854 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5855 dev_desc.dsc$a_pointer = (char *) dev;
5856 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5857 if (lockid) return (lockid & ~LOCKID_MASK);
5861 /* Otherwise we try to encode the device name */
5865 for (q = dev + strlen(dev); q--; q >= dev) {
5868 else if (isalpha (toupper (*q)))
5869 c= toupper (*q) - 'A' + (char)10;
5871 continue; /* Skip '$'s */
5873 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5875 enc += f * (unsigned long int) c;
5877 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
5879 } /* end of encode_dev() */
5881 static char namecache[NAM$C_MAXRSS+1];
5884 is_null_device(name)
5888 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5889 The underscore prefix, controller letter, and unit number are
5890 independently optional; for our purposes, the colon punctuation
5891 is not. The colon can be trailed by optional directory and/or
5892 filename, but two consecutive colons indicates a nodename rather
5893 than a device. [pr] */
5894 if (*name == '_') ++name;
5895 if (tolower(*name++) != 'n') return 0;
5896 if (tolower(*name++) != 'l') return 0;
5897 if (tolower(*name) == 'a') ++name;
5898 if (*name == '0') ++name;
5899 return (*name++ == ':') && (*name != ':');
5902 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
5903 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
5904 * subset of the applicable information.
5907 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
5909 char fname_phdev[NAM$C_MAXRSS+1];
5910 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
5912 char fname[NAM$C_MAXRSS+1];
5913 unsigned long int retsts;
5914 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5915 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5917 /* If the struct mystat is stale, we're OOL; stat() overwrites the
5918 device name on successive calls */
5919 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
5920 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
5921 namdsc.dsc$a_pointer = fname;
5922 namdsc.dsc$w_length = sizeof fname - 1;
5924 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
5925 &namdsc,&namdsc.dsc$w_length,0,0);
5927 fname[namdsc.dsc$w_length] = '\0';
5929 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
5930 * but if someone has redefined that logical, Perl gets very lost. Since
5931 * we have the physical device name from the stat buffer, just paste it on.
5933 strcpy( fname_phdev, statbufp->st_devnam );
5934 strcat( fname_phdev, strrchr(fname, ':') );
5936 return cando_by_name(bit,effective,fname_phdev);
5938 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5939 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
5943 return FALSE; /* Should never get to here */
5945 } /* end of cando() */
5949 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
5951 cando_by_name(I32 bit, Uid_t effective, char *fname)
5953 static char usrname[L_cuserid];
5954 static struct dsc$descriptor_s usrdsc =
5955 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
5956 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
5957 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
5958 unsigned short int retlen;
5960 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5961 union prvdef curprv;
5962 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
5963 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
5964 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
5967 if (!fname || !*fname) return FALSE;
5968 /* Make sure we expand logical names, since sys$check_access doesn't */
5969 if (!strpbrk(fname,"/]>:")) {
5970 strcpy(fileified,fname);
5971 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
5974 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
5975 retlen = namdsc.dsc$w_length = strlen(vmsname);
5976 namdsc.dsc$a_pointer = vmsname;
5977 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
5978 vmsname[retlen-1] == ':') {
5979 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
5980 namdsc.dsc$w_length = strlen(fileified);
5981 namdsc.dsc$a_pointer = fileified;
5984 if (!usrdsc.dsc$w_length) {
5986 usrdsc.dsc$w_length = strlen(usrname);
5990 case S_IXUSR: case S_IXGRP: case S_IXOTH:
5991 access = ARM$M_EXECUTE; break;
5992 case S_IRUSR: case S_IRGRP: case S_IROTH:
5993 access = ARM$M_READ; break;
5994 case S_IWUSR: case S_IWGRP: case S_IWOTH:
5995 access = ARM$M_WRITE; break;
5996 case S_IDUSR: case S_IDGRP: case S_IDOTH:
5997 access = ARM$M_DELETE; break;
6002 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6003 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6004 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6005 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6006 set_vaxc_errno(retsts);
6007 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6008 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6009 else set_errno(ENOENT);
6012 if (retsts == SS$_NORMAL) {
6013 if (!privused) return TRUE;
6014 /* We can get access, but only by using privs. Do we have the
6015 necessary privs currently enabled? */
6016 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6017 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6018 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6019 !curprv.prv$v_bypass) return FALSE;
6020 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6021 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6022 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6025 if (retsts == SS$_ACCONFLICT) {
6030 return FALSE; /* Should never get here */
6032 } /* end of cando_by_name() */
6036 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6038 flex_fstat(int fd, Stat_t *statbufp)
6041 if (!fstat(fd,(stat_t *) statbufp)) {
6042 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6043 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6044 # ifdef RTL_USES_UTC
6047 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6048 statbufp->st_atime = _toloc(statbufp->st_atime);
6049 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6054 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6058 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6059 statbufp->st_atime = _toutc(statbufp->st_atime);
6060 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6067 } /* end of flex_fstat() */
6070 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6072 flex_stat(const char *fspec, Stat_t *statbufp)
6075 char fileified[NAM$C_MAXRSS+1];
6076 char temp_fspec[NAM$C_MAXRSS+300];
6079 strcpy(temp_fspec, fspec);
6080 if (statbufp == (Stat_t *) &PL_statcache)
6081 do_tovmsspec(temp_fspec,namecache,0);
6082 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6083 memset(statbufp,0,sizeof *statbufp);
6084 statbufp->st_dev = encode_dev("_NLA0:");
6085 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6086 statbufp->st_uid = 0x00010001;
6087 statbufp->st_gid = 0x0001;
6088 time((time_t *)&statbufp->st_mtime);
6089 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6093 /* Try for a directory name first. If fspec contains a filename without
6094 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6095 * and sea:[wine.dark]water. exist, we prefer the directory here.
6096 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6097 * not sea:[wine.dark]., if the latter exists. If the intended target is
6098 * the file with null type, specify this by calling flex_stat() with
6099 * a '.' at the end of fspec.
6101 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6102 retval = stat(fileified,(stat_t *) statbufp);
6103 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6104 strcpy(namecache,fileified);
6106 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6108 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6109 # ifdef RTL_USES_UTC
6112 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6113 statbufp->st_atime = _toloc(statbufp->st_atime);
6114 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6119 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6123 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6124 statbufp->st_atime = _toutc(statbufp->st_atime);
6125 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6131 } /* end of flex_stat() */
6135 /*{{{char *my_getlogin()*/
6136 /* VMS cuserid == Unix getlogin, except calling sequence */
6140 static char user[L_cuserid];
6141 return cuserid(user);
6146 /* rmscopy - copy a file using VMS RMS routines
6148 * Copies contents and attributes of spec_in to spec_out, except owner
6149 * and protection information. Name and type of spec_in are used as
6150 * defaults for spec_out. The third parameter specifies whether rmscopy()
6151 * should try to propagate timestamps from the input file to the output file.
6152 * If it is less than 0, no timestamps are preserved. If it is 0, then
6153 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6154 * propagated to the output file at creation iff the output file specification
6155 * did not contain an explicit name or type, and the revision date is always
6156 * updated at the end of the copy operation. If it is greater than 0, then
6157 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6158 * other than the revision date should be propagated, and bit 1 indicates
6159 * that the revision date should be propagated.
6161 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6163 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6164 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6165 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6166 * as part of the Perl standard distribution under the terms of the
6167 * GNU General Public License or the Perl Artistic License. Copies
6168 * of each may be found in the Perl standard distribution.
6170 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6172 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6174 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6175 rsa[NAM$C_MAXRSS], ubf[32256];
6176 unsigned long int i, sts, sts2;
6177 struct FAB fab_in, fab_out;
6178 struct RAB rab_in, rab_out;
6180 struct XABDAT xabdat;
6181 struct XABFHC xabfhc;
6182 struct XABRDT xabrdt;
6183 struct XABSUM xabsum;
6185 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6186 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6187 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6191 fab_in = cc$rms_fab;
6192 fab_in.fab$l_fna = vmsin;
6193 fab_in.fab$b_fns = strlen(vmsin);
6194 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6195 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6196 fab_in.fab$l_fop = FAB$M_SQO;
6197 fab_in.fab$l_nam = &nam;
6198 fab_in.fab$l_xab = (void *) &xabdat;
6201 nam.nam$l_rsa = rsa;
6202 nam.nam$b_rss = sizeof(rsa);
6203 nam.nam$l_esa = esa;
6204 nam.nam$b_ess = sizeof (esa);
6205 nam.nam$b_esl = nam.nam$b_rsl = 0;
6207 xabdat = cc$rms_xabdat; /* To get creation date */
6208 xabdat.xab$l_nxt = (void *) &xabfhc;
6210 xabfhc = cc$rms_xabfhc; /* To get record length */
6211 xabfhc.xab$l_nxt = (void *) &xabsum;
6213 xabsum = cc$rms_xabsum; /* To get key and area information */
6215 if (!((sts = sys$open(&fab_in)) & 1)) {
6216 set_vaxc_errno(sts);
6218 case RMS$_FNF: case RMS$_DNF:
6219 set_errno(ENOENT); break;
6221 set_errno(ENOTDIR); break;
6223 set_errno(ENODEV); break;
6225 set_errno(EINVAL); break;
6227 set_errno(EACCES); break;
6235 fab_out.fab$w_ifi = 0;
6236 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6237 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6238 fab_out.fab$l_fop = FAB$M_SQO;
6239 fab_out.fab$l_fna = vmsout;
6240 fab_out.fab$b_fns = strlen(vmsout);
6241 fab_out.fab$l_dna = nam.nam$l_name;
6242 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6244 if (preserve_dates == 0) { /* Act like DCL COPY */
6245 nam.nam$b_nop = NAM$M_SYNCHK;
6246 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6247 if (!((sts = sys$parse(&fab_out)) & 1)) {
6248 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6249 set_vaxc_errno(sts);
6252 fab_out.fab$l_xab = (void *) &xabdat;
6253 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6255 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6256 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6257 preserve_dates =0; /* bitmask from this point forward */
6259 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6260 if (!((sts = sys$create(&fab_out)) & 1)) {
6261 set_vaxc_errno(sts);
6264 set_errno(ENOENT); break;
6266 set_errno(ENOTDIR); break;
6268 set_errno(ENODEV); break;
6270 set_errno(EINVAL); break;
6272 set_errno(EACCES); break;
6278 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6279 if (preserve_dates & 2) {
6280 /* sys$close() will process xabrdt, not xabdat */
6281 xabrdt = cc$rms_xabrdt;
6283 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6285 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6286 * is unsigned long[2], while DECC & VAXC use a struct */
6287 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6289 fab_out.fab$l_xab = (void *) &xabrdt;
6292 rab_in = cc$rms_rab;
6293 rab_in.rab$l_fab = &fab_in;
6294 rab_in.rab$l_rop = RAB$M_BIO;
6295 rab_in.rab$l_ubf = ubf;
6296 rab_in.rab$w_usz = sizeof ubf;
6297 if (!((sts = sys$connect(&rab_in)) & 1)) {
6298 sys$close(&fab_in); sys$close(&fab_out);
6299 set_errno(EVMSERR); set_vaxc_errno(sts);
6303 rab_out = cc$rms_rab;
6304 rab_out.rab$l_fab = &fab_out;
6305 rab_out.rab$l_rbf = ubf;
6306 if (!((sts = sys$connect(&rab_out)) & 1)) {
6307 sys$close(&fab_in); sys$close(&fab_out);
6308 set_errno(EVMSERR); set_vaxc_errno(sts);
6312 while ((sts = sys$read(&rab_in))) { /* always true */
6313 if (sts == RMS$_EOF) break;
6314 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6315 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6316 sys$close(&fab_in); sys$close(&fab_out);
6317 set_errno(EVMSERR); set_vaxc_errno(sts);
6322 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6323 sys$close(&fab_in); sys$close(&fab_out);
6324 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6326 set_errno(EVMSERR); set_vaxc_errno(sts);
6332 } /* end of rmscopy() */
6336 /*** The following glue provides 'hooks' to make some of the routines
6337 * from this file available from Perl. These routines are sufficiently
6338 * basic, and are required sufficiently early in the build process,
6339 * that's it's nice to have them available to miniperl as well as the
6340 * full Perl, so they're set up here instead of in an extension. The
6341 * Perl code which handles importation of these names into a given
6342 * package lives in [.VMS]Filespec.pm in @INC.
6346 rmsexpand_fromperl(pTHX_ CV *cv)
6349 char *fspec, *defspec = NULL, *rslt;
6352 if (!items || items > 2)
6353 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6354 fspec = SvPV(ST(0),n_a);
6355 if (!fspec || !*fspec) XSRETURN_UNDEF;
6356 if (items == 2) defspec = SvPV(ST(1),n_a);
6358 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6359 ST(0) = sv_newmortal();
6360 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6365 vmsify_fromperl(pTHX_ CV *cv)
6371 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6372 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6373 ST(0) = sv_newmortal();
6374 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6379 unixify_fromperl(pTHX_ CV *cv)
6385 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6386 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6387 ST(0) = sv_newmortal();
6388 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6393 fileify_fromperl(pTHX_ CV *cv)
6399 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6400 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6401 ST(0) = sv_newmortal();
6402 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6407 pathify_fromperl(pTHX_ CV *cv)
6413 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6414 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6415 ST(0) = sv_newmortal();
6416 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6421 vmspath_fromperl(pTHX_ CV *cv)
6427 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6428 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6429 ST(0) = sv_newmortal();
6430 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6435 unixpath_fromperl(pTHX_ CV *cv)
6441 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6442 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6443 ST(0) = sv_newmortal();
6444 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6449 candelete_fromperl(pTHX_ CV *cv)
6452 char fspec[NAM$C_MAXRSS+1], *fsp;
6457 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6459 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6460 if (SvTYPE(mysv) == SVt_PVGV) {
6461 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6462 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6469 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6470 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6476 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6481 rmscopy_fromperl(pTHX_ CV *cv)
6484 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6486 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6487 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6488 unsigned long int sts;
6493 if (items < 2 || items > 3)
6494 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6496 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6497 if (SvTYPE(mysv) == SVt_PVGV) {
6498 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6499 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6506 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6507 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6512 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6513 if (SvTYPE(mysv) == SVt_PVGV) {
6514 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6515 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6522 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6523 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6528 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6530 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6539 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6540 workbuff[NAM$C_MAXRSS*1 + 1];
6541 int total_namelen = 3, counter, num_entries;
6542 /* ODS-5 ups this, but we want to be consistent, so... */
6543 int max_name_len = 39;
6544 AV *in_array = (AV *)SvRV(ST(0));
6546 num_entries = av_len(in_array);
6548 /* All the names start with PL_. */
6549 strcpy(ultimate_name, "PL_");
6551 /* Clean up our working buffer */
6552 Zero(work_name, sizeof(work_name), char);
6554 /* Run through the entries and build up a working name */
6555 for(counter = 0; counter <= num_entries; counter++) {
6556 /* If it's not the first name then tack on a __ */
6558 strcat(work_name, "__");
6560 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6564 /* Check to see if we actually have to bother...*/
6565 if (strlen(work_name) + 3 <= max_name_len) {
6566 strcat(ultimate_name, work_name);
6568 /* It's too darned big, so we need to go strip. We use the same */
6569 /* algorithm as xsubpp does. First, strip out doubled __ */
6570 char *source, *dest, last;
6573 for (source = work_name; *source; source++) {
6574 if (last == *source && last == '_') {
6580 /* Go put it back */
6581 strcpy(work_name, workbuff);
6582 /* Is it still too big? */
6583 if (strlen(work_name) + 3 > max_name_len) {
6584 /* Strip duplicate letters */
6587 for (source = work_name; *source; source++) {
6588 if (last == toupper(*source)) {
6592 last = toupper(*source);
6594 strcpy(work_name, workbuff);
6597 /* Is it *still* too big? */
6598 if (strlen(work_name) + 3 > max_name_len) {
6599 /* Too bad, we truncate */
6600 work_name[max_name_len - 2] = 0;
6602 strcat(ultimate_name, work_name);
6605 /* Okay, return it */
6606 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6613 char* file = __FILE__;
6615 char temp_buff[512];
6616 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6617 no_translate_barewords = TRUE;
6619 no_translate_barewords = FALSE;
6622 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6623 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6624 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6625 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6626 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6627 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6628 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6629 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6630 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6631 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);