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 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
102 #define PERL_LNM_MAX_ALLOWED_INDEX 127
104 static char *__mystrtolower(char *str)
106 if (str) for (; *str; ++str) *str= tolower(*str);
110 static struct dsc$descriptor_s fildevdsc =
111 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
112 static struct dsc$descriptor_s crtlenvdsc =
113 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
114 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
115 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
116 static struct dsc$descriptor_s **env_tables = defenv;
117 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
119 /* True if we shouldn't treat barewords as logicals during directory */
121 static int no_translate_barewords;
123 /* Temp for subprocess commands */
124 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
127 static int tz_updated = 1;
130 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
132 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
133 struct dsc$descriptor_s **tabvec, unsigned long int flags)
135 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
136 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
137 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
138 unsigned char acmode;
139 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
140 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
141 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
142 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
144 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
145 #if defined(USE_THREADS)
146 /* We jump through these hoops because we can be called at */
147 /* platform-specific initialization time, which is before anything is */
148 /* set up--we can't even do a plain dTHX since that relies on the */
149 /* interpreter structure to be initialized */
150 struct perl_thread *thr;
152 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
158 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
159 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
161 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
162 *cp2 = _toupper(*cp1);
163 if (cp1 - lnm > LNM$C_NAMLENGTH) {
164 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
168 lnmdsc.dsc$w_length = cp1 - lnm;
169 lnmdsc.dsc$a_pointer = uplnm;
170 uplnm[lnmdsc.dsc$w_length] = '\0';
171 secure = flags & PERL__TRNENV_SECURE;
172 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
173 if (!tabvec || !*tabvec) tabvec = env_tables;
175 for (curtab = 0; tabvec[curtab]; curtab++) {
176 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
177 if (!ivenv && !secure) {
182 Perl_warn(aTHX_ "Can't read CRTL environ\n");
185 retsts = SS$_NOLOGNAM;
186 for (i = 0; environ[i]; i++) {
187 if ((eq = strchr(environ[i],'=')) &&
188 !strncmp(environ[i],uplnm,eq - environ[i])) {
190 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
191 if (!eqvlen) continue;
196 if (retsts != SS$_NOLOGNAM) break;
199 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
200 !str$case_blind_compare(&tmpdsc,&clisym)) {
201 if (!ivsym && !secure) {
202 unsigned short int deflen = LNM$C_NAMLENGTH;
203 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
204 /* dynamic dsc to accomodate possible long value */
205 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
206 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
209 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
211 /* Special hack--we might be called before the interpreter's */
212 /* fully initialized, in which case either thr or PL_curcop */
213 /* might be bogus. We have to check, since ckWARN needs them */
214 /* both to be valid if running threaded */
215 #if defined(USE_THREADS)
216 if (thr && PL_curcop) {
218 if (ckWARN(WARN_MISC)) {
219 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
221 #if defined(USE_THREADS)
223 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
228 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
230 _ckvmssts(lib$sfree1_dd(&eqvdsc));
231 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
232 if (retsts == LIB$_NOSUCHSYM) continue;
237 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
238 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
239 if (retsts == SS$_NOLOGNAM) continue;
240 /* PPFs have a prefix */
243 *((int *)uplnm) == *((int *)"SYS$") &&
245 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
246 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
247 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
248 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
249 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
250 memcpy(eqv,eqv+4,eqvlen-4);
256 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
257 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
258 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
259 retsts == SS$_NOLOGNAM) {
260 set_errno(EINVAL); set_vaxc_errno(retsts);
262 else _ckvmssts(retsts);
264 } /* end of vmstrnenv */
267 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
268 /* Define as a function so we can access statics. */
269 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
271 return vmstrnenv(lnm,eqv,idx,fildev,
272 #ifdef SECURE_INTERNAL_GETENV
273 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
282 * Note: Uses Perl temp to store result so char * can be returned to
283 * caller; this pointer will be invalidated at next Perl statement
285 * We define this as a function rather than a macro in terms of my_getenv_len()
286 * so that it'll work when PL_curinterp is undefined (and we therefore can't
289 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
291 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
293 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
294 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
295 unsigned long int idx = 0;
296 int trnsuccess, success, secure, saverr, savvmserr;
299 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
300 /* Set up a temporary buffer for the return value; Perl will
301 * clean it up at the next statement transition */
302 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
303 if (!tmpsv) return NULL;
306 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
307 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
308 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
309 getcwd(eqv,LNM$C_NAMLENGTH);
313 if ((cp2 = strchr(lnm,';')) != NULL) {
315 uplnm[cp2-lnm] = '\0';
316 idx = strtoul(cp2+1,NULL,0);
319 /* Impose security constraints only if tainting */
321 /* Impose security constraints only if tainting */
322 secure = PL_curinterp ? PL_tainting : will_taint;
323 saverr = errno; savvmserr = vaxc$errno;
326 success = vmstrnenv(lnm,eqv,idx,
327 secure ? fildev : NULL,
328 #ifdef SECURE_INTERNAL_GETENV
329 secure ? PERL__TRNENV_SECURE : 0
334 /* Discard NOLOGNAM on internal calls since we're often looking
335 * for an optional name, and this "error" often shows up as the
336 * (bogus) exit status for a die() call later on. */
337 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
338 return success ? eqv : Nullch;
341 } /* end of my_getenv() */
345 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
347 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
350 char *buf, *cp1, *cp2;
351 unsigned long idx = 0;
352 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
353 int secure, saverr, savvmserr;
356 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
357 /* Set up a temporary buffer for the return value; Perl will
358 * clean it up at the next statement transition */
359 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
360 if (!tmpsv) return NULL;
363 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
364 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
365 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
366 getcwd(buf,LNM$C_NAMLENGTH);
371 if ((cp2 = strchr(lnm,';')) != NULL) {
374 idx = strtoul(cp2+1,NULL,0);
378 /* Impose security constraints only if tainting */
379 secure = PL_curinterp ? PL_tainting : will_taint;
380 saverr = errno; savvmserr = vaxc$errno;
383 *len = vmstrnenv(lnm,buf,idx,
384 secure ? fildev : NULL,
385 #ifdef SECURE_INTERNAL_GETENV
386 secure ? PERL__TRNENV_SECURE : 0
391 /* Discard NOLOGNAM on internal calls since we're often looking
392 * for an optional name, and this "error" often shows up as the
393 * (bogus) exit status for a die() call later on. */
394 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
395 return *len ? buf : Nullch;
398 } /* end of my_getenv_len() */
401 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
403 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
405 /*{{{ void prime_env_iter() */
408 /* Fill the %ENV associative array with all logical names we can
409 * find, in preparation for iterating over it.
413 static int primed = 0;
414 HV *seenhv = NULL, *envhv;
415 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
416 unsigned short int chan;
417 #ifndef CLI$M_TRUSTED
418 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
420 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
421 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
423 bool have_sym = FALSE, have_lnm = FALSE;
424 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
425 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
426 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
427 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
428 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
429 #if defined(USE_THREADS) || defined(USE_ITHREADS)
430 static perl_mutex primenv_mutex;
431 MUTEX_INIT(&primenv_mutex);
434 if (primed || !PL_envgv) return;
435 MUTEX_LOCK(&primenv_mutex);
436 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
437 envhv = GvHVn(PL_envgv);
438 /* Perform a dummy fetch as an lval to insure that the hash table is
439 * set up. Otherwise, the hv_store() will turn into a nullop. */
440 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
442 for (i = 0; env_tables[i]; i++) {
443 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
444 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
445 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
447 if (have_sym || have_lnm) {
448 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
449 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
450 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
451 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
454 for (i--; i >= 0; i--) {
455 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
458 for (j = 0; environ[j]; j++) {
459 if (!(start = strchr(environ[j],'='))) {
460 if (ckWARN(WARN_INTERNAL))
461 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
465 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
471 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
472 !str$case_blind_compare(&tmpdsc,&clisym)) {
473 strcpy(cmd,"Show Symbol/Global *");
474 cmddsc.dsc$w_length = 20;
475 if (env_tables[i]->dsc$w_length == 12 &&
476 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
477 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
478 flags = defflags | CLI$M_NOLOGNAM;
481 strcpy(cmd,"Show Logical *");
482 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
483 strcat(cmd," /Table=");
484 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
485 cmddsc.dsc$w_length = strlen(cmd);
487 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
488 flags = defflags | CLI$M_NOCLISYM;
491 /* Create a new subprocess to execute each command, to exclude the
492 * remote possibility that someone could subvert a mbx or file used
493 * to write multiple commands to a single subprocess.
496 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
497 0,&riseandshine,0,0,&clidsc,&clitabdsc);
498 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
499 defflags &= ~CLI$M_TRUSTED;
500 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
502 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
503 if (seenhv) SvREFCNT_dec(seenhv);
506 char *cp1, *cp2, *key;
507 unsigned long int sts, iosb[2], retlen, keylen;
510 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
511 if (sts & 1) sts = iosb[0] & 0xffff;
512 if (sts == SS$_ENDOFFILE) {
514 while (substs == 0) { sys$hiber(); wakect++;}
515 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
520 retlen = iosb[0] >> 16;
521 if (!retlen) continue; /* blank line */
523 if (iosb[1] != subpid) {
525 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
529 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
530 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
532 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
533 if (*cp1 == '(' || /* Logical name table name */
534 *cp1 == '=' /* Next eqv of searchlist */) continue;
535 if (*cp1 == '"') cp1++;
536 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
537 key = cp1; keylen = cp2 - cp1;
538 if (keylen && hv_exists(seenhv,key,keylen)) continue;
539 while (*cp2 && *cp2 != '=') cp2++;
540 while (*cp2 && *cp2 == '=') cp2++;
541 while (*cp2 && *cp2 == ' ') cp2++;
542 if (*cp2 == '"') { /* String translation; may embed "" */
543 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
544 cp2++; cp1--; /* Skip "" surrounding translation */
546 else { /* Numeric translation */
547 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
548 cp1--; /* stop on last non-space char */
550 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
551 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
554 PERL_HASH(hash,key,keylen);
555 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
556 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
558 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
559 /* get the PPFs for this process, not the subprocess */
560 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
561 char eqv[LNM$C_NAMLENGTH+1];
563 for (i = 0; ppfs[i]; i++) {
564 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
565 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
570 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
571 if (buf) Safefree(buf);
572 if (seenhv) SvREFCNT_dec(seenhv);
573 MUTEX_UNLOCK(&primenv_mutex);
576 } /* end of prime_env_iter */
580 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
581 /* Define or delete an element in the same "environment" as
582 * vmstrnenv(). If an element is to be deleted, it's removed from
583 * the first place it's found. If it's to be set, it's set in the
584 * place designated by the first element of the table vector.
585 * Like setenv() returns 0 for success, non-zero on error.
588 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
590 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
591 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
592 unsigned long int retsts, usermode = PSL$C_USER;
593 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
594 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
595 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
596 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
597 $DESCRIPTOR(local,"_LOCAL");
600 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
601 *cp2 = _toupper(*cp1);
602 if (cp1 - lnm > LNM$C_NAMLENGTH) {
603 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
607 lnmdsc.dsc$w_length = cp1 - lnm;
608 if (!tabvec || !*tabvec) tabvec = env_tables;
610 if (!eqv) { /* we're deleting n element */
611 for (curtab = 0; tabvec[curtab]; curtab++) {
612 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
614 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
615 if ((cp1 = strchr(environ[i],'=')) &&
616 !strncmp(environ[i],lnm,cp1 - environ[i])) {
618 return setenv(lnm,"",1) ? vaxc$errno : 0;
621 ivenv = 1; retsts = SS$_NOLOGNAM;
623 if (ckWARN(WARN_INTERNAL))
624 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
625 ivenv = 1; retsts = SS$_NOSUCHPGM;
631 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
632 !str$case_blind_compare(&tmpdsc,&clisym)) {
633 unsigned int symtype;
634 if (tabvec[curtab]->dsc$w_length == 12 &&
635 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
636 !str$case_blind_compare(&tmpdsc,&local))
637 symtype = LIB$K_CLI_LOCAL_SYM;
638 else symtype = LIB$K_CLI_GLOBAL_SYM;
639 retsts = lib$delete_symbol(&lnmdsc,&symtype);
640 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
641 if (retsts == LIB$_NOSUCHSYM) continue;
645 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
646 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
647 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
648 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
649 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
653 else { /* we're defining a value */
654 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
656 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
658 if (ckWARN(WARN_INTERNAL))
659 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
660 retsts = SS$_NOSUCHPGM;
664 eqvdsc.dsc$a_pointer = eqv;
665 eqvdsc.dsc$w_length = strlen(eqv);
666 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
667 !str$case_blind_compare(&tmpdsc,&clisym)) {
668 unsigned int symtype;
669 if (tabvec[0]->dsc$w_length == 12 &&
670 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
671 !str$case_blind_compare(&tmpdsc,&local))
672 symtype = LIB$K_CLI_LOCAL_SYM;
673 else symtype = LIB$K_CLI_GLOBAL_SYM;
674 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
677 if (!*eqv) eqvdsc.dsc$w_length = 1;
678 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
679 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
680 if (ckWARN(WARN_MISC)) {
681 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
684 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
690 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
691 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
692 set_errno(EVMSERR); break;
693 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
694 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
695 set_errno(EINVAL); break;
702 set_vaxc_errno(retsts);
703 return (int) retsts || 44; /* retsts should never be 0, but just in case */
706 /* We reset error values on success because Perl does an hv_fetch()
707 * before each hv_store(), and if the thing we're setting didn't
708 * previously exist, we've got a leftover error message. (Of course,
709 * this fails in the face of
710 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
711 * in that the error reported in $! isn't spurious,
712 * but it's right more often than not.)
714 set_errno(0); set_vaxc_errno(retsts);
718 } /* end of vmssetenv() */
721 /*{{{ void my_setenv(char *lnm, char *eqv)*/
722 /* This has to be a function since there's a prototype for it in proto.h */
724 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
727 int len = strlen(lnm);
731 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
732 if (!strcmp(uplnm,"DEFAULT")) {
733 if (eqv && *eqv) chdir(eqv);
738 if (len == 6 || len == 2) {
741 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
743 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
744 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
748 (void) vmssetenv(lnm,eqv,NULL);
752 /*{{{static void vmssetuserlnm(char *name, char *eqv);
754 * sets a user-mode logical in the process logical name table
755 * used for redirection of sys$error
758 Perl_vmssetuserlnm(char *name, char *eqv)
760 $DESCRIPTOR(d_tab, "LNM$PROCESS");
761 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
762 unsigned long int iss, attr = 0;
763 unsigned char acmode = PSL$C_USER;
764 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
766 d_name.dsc$a_pointer = name;
767 d_name.dsc$w_length = strlen(name);
769 lnmlst[0].buflen = strlen(eqv);
770 lnmlst[0].bufadr = eqv;
772 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
773 if (!(iss&1)) lib$signal(iss);
778 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
779 /* my_crypt - VMS password hashing
780 * my_crypt() provides an interface compatible with the Unix crypt()
781 * C library function, and uses sys$hash_password() to perform VMS
782 * password hashing. The quadword hashed password value is returned
783 * as a NUL-terminated 8 character string. my_crypt() does not change
784 * the case of its string arguments; in order to match the behavior
785 * of LOGINOUT et al., alphabetic characters in both arguments must
786 * be upcased by the caller.
789 my_crypt(const char *textpasswd, const char *usrname)
791 # ifndef UAI$C_PREFERRED_ALGORITHM
792 # define UAI$C_PREFERRED_ALGORITHM 127
794 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
795 unsigned short int salt = 0;
796 unsigned long int sts;
798 unsigned short int dsc$w_length;
799 unsigned char dsc$b_type;
800 unsigned char dsc$b_class;
801 const char * dsc$a_pointer;
802 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
803 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
804 struct itmlst_3 uailst[3] = {
805 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
806 { sizeof salt, UAI$_SALT, &salt, 0},
807 { 0, 0, NULL, NULL}};
810 usrdsc.dsc$w_length = strlen(usrname);
811 usrdsc.dsc$a_pointer = usrname;
812 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
814 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
818 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
824 if (sts != RMS$_RNF) return NULL;
827 txtdsc.dsc$w_length = strlen(textpasswd);
828 txtdsc.dsc$a_pointer = textpasswd;
829 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
830 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
833 return (char *) hash;
835 } /* end of my_crypt() */
839 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
840 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
841 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
843 /*{{{int do_rmdir(char *name)*/
845 Perl_do_rmdir(pTHX_ char *name)
847 char dirfile[NAM$C_MAXRSS+1];
851 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
852 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
853 else retval = kill_file(dirfile);
856 } /* end of do_rmdir */
860 * Delete any file to which user has control access, regardless of whether
861 * delete access is explicitly allowed.
862 * Limitations: User must have write access to parent directory.
863 * Does not block signals or ASTs; if interrupted in midstream
864 * may leave file with an altered ACL.
867 /*{{{int kill_file(char *name)*/
869 kill_file(char *name)
871 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
872 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
873 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
875 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
877 unsigned char myace$b_length;
878 unsigned char myace$b_type;
879 unsigned short int myace$w_flags;
880 unsigned long int myace$l_access;
881 unsigned long int myace$l_ident;
882 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
883 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
884 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
886 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
887 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
888 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
889 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
890 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
891 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
893 /* Expand the input spec using RMS, since the CRTL remove() and
894 * system services won't do this by themselves, so we may miss
895 * a file "hiding" behind a logical name or search list. */
896 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
897 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
898 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
899 /* If not, can changing protections help? */
900 if (vaxc$errno != RMS$_PRV) return -1;
902 /* No, so we get our own UIC to use as a rights identifier,
903 * and the insert an ACE at the head of the ACL which allows us
904 * to delete the file.
906 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
907 fildsc.dsc$w_length = strlen(rspec);
908 fildsc.dsc$a_pointer = rspec;
910 newace.myace$l_ident = oldace.myace$l_ident;
911 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
913 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
914 set_errno(ENOENT); break;
916 set_errno(ENOTDIR); break;
918 set_errno(ENODEV); break;
919 case RMS$_SYN: case SS$_INVFILFOROP:
920 set_errno(EINVAL); break;
922 set_errno(EACCES); break;
926 set_vaxc_errno(aclsts);
929 /* Grab any existing ACEs with this identifier in case we fail */
930 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
931 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
932 || fndsts == SS$_NOMOREACE ) {
933 /* Add the new ACE . . . */
934 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
936 if ((rmsts = remove(name))) {
937 /* We blew it - dir with files in it, no write priv for
938 * parent directory, etc. Put things back the way they were. */
939 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
942 addlst[0].bufadr = &oldace;
943 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
950 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
951 /* We just deleted it, so of course it's not there. Some versions of
952 * VMS seem to return success on the unlock operation anyhow (after all
953 * the unlock is successful), but others don't.
955 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
956 if (aclsts & 1) aclsts = fndsts;
959 set_vaxc_errno(aclsts);
965 } /* end of kill_file() */
969 /*{{{int my_mkdir(char *,Mode_t)*/
971 my_mkdir(char *dir, Mode_t mode)
973 STRLEN dirlen = strlen(dir);
976 /* zero length string sometimes gives ACCVIO */
977 if (dirlen == 0) return -1;
979 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
980 * null file name/type. However, it's commonplace under Unix,
981 * so we'll allow it for a gain in portability.
983 if (dir[dirlen-1] == '/') {
984 char *newdir = savepvn(dir,dirlen-1);
985 int ret = mkdir(newdir,mode);
989 else return mkdir(dir,mode);
990 } /* end of my_mkdir */
993 /*{{{int my_chdir(char *)*/
997 STRLEN dirlen = strlen(dir);
1000 /* zero length string sometimes gives ACCVIO */
1001 if (dirlen == 0) return -1;
1003 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1005 * null file name/type. However, it's commonplace under Unix,
1006 * so we'll allow it for a gain in portability.
1008 if (dir[dirlen-1] == '/') {
1009 char *newdir = savepvn(dir,dirlen-1);
1010 int ret = chdir(newdir);
1014 else return chdir(dir);
1015 } /* end of my_chdir */
1019 /*{{{FILE *my_tmpfile()*/
1027 if ((fp = tmpfile())) return fp;
1029 New(1323,cp,L_tmpnam+24,char);
1030 strcpy(cp,"Sys$Scratch:");
1031 tmpnam(cp+strlen(cp));
1032 strcat(cp,".Perltmp");
1033 fp = fopen(cp,"w+","fop=dlt");
1039 /* default piping mailbox size */
1040 #define PERL_BUFSIZ 512
1044 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1046 unsigned long int mbxbufsiz;
1047 static unsigned long int syssize = 0;
1048 unsigned long int dviitm = DVI$_DEVNAM;
1050 char csize[LNM$C_NAMLENGTH+1];
1053 unsigned long syiitm = SYI$_MAXBUF;
1055 * Get the SYSGEN parameter MAXBUF
1057 * If the logical 'PERL_MBX_SIZE' is defined
1058 * use the value of the logical instead of PERL_BUFSIZ, but
1059 * keep the size between 128 and MAXBUF.
1062 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1065 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1066 mbxbufsiz = atoi(csize);
1068 mbxbufsiz = PERL_BUFSIZ;
1070 if (mbxbufsiz < 128) mbxbufsiz = 128;
1071 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1073 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1075 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1076 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1078 } /* end of create_mbx() */
1081 /*{{{ my_popen and my_pclose*/
1083 typedef struct _iosb IOSB;
1084 typedef struct _iosb* pIOSB;
1085 typedef struct _pipe Pipe;
1086 typedef struct _pipe* pPipe;
1087 typedef struct pipe_details Info;
1088 typedef struct pipe_details* pInfo;
1089 typedef struct _srqp RQE;
1090 typedef struct _srqp* pRQE;
1091 typedef struct _tochildbuf CBuf;
1092 typedef struct _tochildbuf* pCBuf;
1095 unsigned short status;
1096 unsigned short count;
1097 unsigned long dvispec;
1100 #pragma member_alignment save
1101 #pragma nomember_alignment quadword
1102 struct _srqp { /* VMS self-relative queue entry */
1103 unsigned long qptr[2];
1105 #pragma member_alignment restore
1106 static RQE RQE_ZERO = {0,0};
1108 struct _tochildbuf {
1111 unsigned short size;
1119 unsigned short chan_in;
1120 unsigned short chan_out;
1122 unsigned int bufsize;
1140 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1141 int pid; /* PID of subprocess */
1142 int mode; /* == 'r' if pipe open for reading */
1143 int done; /* subprocess has completed */
1144 int closing; /* my_pclose is closing this pipe */
1145 unsigned long completion; /* termination status of subprocess */
1146 pPipe in; /* pipe in to sub */
1147 pPipe out; /* pipe out of sub */
1148 pPipe err; /* pipe of sub's sys$error */
1149 int in_done; /* true when in pipe finished */
1154 struct exit_control_block
1156 struct exit_control_block *flink;
1157 unsigned long int (*exit_routine)();
1158 unsigned long int arg_count;
1159 unsigned long int *status_address;
1160 unsigned long int exit_status;
1163 #define RETRY_DELAY "0 ::0.20"
1164 #define MAX_RETRY 50
1166 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1167 static unsigned long mypid;
1168 static unsigned long delaytime[2];
1170 static pInfo open_pipes = NULL;
1171 static $DESCRIPTOR(nl_desc, "NL:");
1174 static unsigned long int
1178 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1179 int sts, did_stuff, need_eof;
1183 first we try sending an EOF...ignore if doesn't work, make sure we
1191 _ckvmssts(sys$setast(0));
1192 if (info->in && !info->in->shut_on_empty) {
1193 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1197 _ckvmssts(sys$setast(1));
1200 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1205 _ckvmssts(sys$setast(0));
1206 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1207 sts = sys$forcex(&info->pid,0,&abort);
1208 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1211 _ckvmssts(sys$setast(1));
1214 if (did_stuff) sleep(1); /* wait for them to respond */
1218 _ckvmssts(sys$setast(0));
1219 if (!info->done) { /* We tried to be nice . . . */
1220 sts = sys$delprc(&info->pid,0);
1221 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1223 _ckvmssts(sys$setast(1));
1228 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1229 else if (!(sts & 1)) retsts = sts;
1234 static struct exit_control_block pipe_exitblock =
1235 {(struct exit_control_block *) 0,
1236 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1238 static void pipe_mbxtofd_ast(pPipe p);
1239 static void pipe_tochild1_ast(pPipe p);
1240 static void pipe_tochild2_ast(pPipe p);
1243 popen_completion_ast(pInfo info)
1246 pInfo i = open_pipes;
1250 if (i == info) break;
1253 if (!i) return; /* unlinked, probably freed too */
1255 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1259 Writing to subprocess ...
1260 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1262 chan_out may be waiting for "done" flag, or hung waiting
1263 for i/o completion to child...cancel the i/o. This will
1264 put it into "snarf mode" (done but no EOF yet) that discards
1267 Output from subprocess (stdout, stderr) needs to be flushed and
1268 shut down. We try sending an EOF, but if the mbx is full the pipe
1269 routine should still catch the "shut_on_empty" flag, telling it to
1270 use immediate-style reads so that "mbx empty" -> EOF.
1274 if (info->in && !info->in_done) { /* only for mode=w */
1275 if (info->in->shut_on_empty && info->in->need_wake) {
1276 info->in->need_wake = FALSE;
1277 _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1279 _ckvmssts(sys$cancel(info->in->chan_out));
1283 if (info->out && !info->out_done) { /* were we also piping output? */
1284 info->out->shut_on_empty = TRUE;
1285 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1286 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1290 if (info->err && !info->err_done) { /* we were piping stderr */
1291 info->err->shut_on_empty = TRUE;
1292 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1293 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1296 _ckvmssts(sys$setef(pipe_ef));
1300 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1301 static void vms_execfree(pTHX);
1304 we actually differ from vmstrnenv since we use this to
1305 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1306 are pointing to the same thing
1309 static unsigned short
1310 popen_translate(char *logical, char *result)
1313 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1314 $DESCRIPTOR(d_log,"");
1316 unsigned short length;
1317 unsigned short code;
1319 unsigned short *retlenaddr;
1321 unsigned short l, ifi;
1323 d_log.dsc$a_pointer = logical;
1324 d_log.dsc$w_length = strlen(logical);
1326 itmlst[0].code = LNM$_STRING;
1327 itmlst[0].length = 255;
1328 itmlst[0].buffer_addr = result;
1329 itmlst[0].retlenaddr = &l;
1332 itmlst[1].length = 0;
1333 itmlst[1].buffer_addr = 0;
1334 itmlst[1].retlenaddr = 0;
1336 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1337 if (iss == SS$_NOLOGNAM) {
1341 if (!(iss&1)) lib$signal(iss);
1344 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1345 strip it off and return the ifi, if any
1348 if (result[0] == 0x1b && result[1] == 0x00) {
1349 memcpy(&ifi,result+2,2);
1350 strcpy(result,result+4);
1352 return ifi; /* this is the RMS internal file id */
1355 #define MAX_DCL_SYMBOL 255
1356 static void pipe_infromchild_ast(pPipe p);
1359 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1360 inside an AST routine without worrying about reentrancy and which Perl
1361 memory allocator is being used.
1363 We read data and queue up the buffers, then spit them out one at a
1364 time to the output mailbox when the output mailbox is ready for one.
1367 #define INITIAL_TOCHILDQUEUE 2
1370 pipe_tochild_setup(char *rmbx, char *wmbx)
1375 char mbx1[64], mbx2[64];
1376 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1377 DSC$K_CLASS_S, mbx1},
1378 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1379 DSC$K_CLASS_S, mbx2};
1380 unsigned int dviitm = DVI$_DEVBUFSIZ;
1383 New(1368, p, 1, Pipe);
1385 create_mbx(&p->chan_in , &d_mbx1);
1386 create_mbx(&p->chan_out, &d_mbx2);
1387 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1390 p->shut_on_empty = FALSE;
1391 p->need_wake = FALSE;
1394 p->iosb.status = SS$_NORMAL;
1395 p->iosb2.status = SS$_NORMAL;
1402 n = sizeof(CBuf) + p->bufsize;
1404 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1405 _ckvmssts(lib$get_vm(&n, &b));
1406 b->buf = (char *) b + sizeof(CBuf);
1407 _ckvmssts(lib$insqhi(b, &p->free));
1410 pipe_tochild2_ast(p);
1411 pipe_tochild1_ast(p);
1417 /* reads the MBX Perl is writing, and queues */
1420 pipe_tochild1_ast(pPipe p)
1424 int iss = p->iosb.status;
1425 int eof = (iss == SS$_ENDOFFILE);
1429 p->shut_on_empty = TRUE;
1431 _ckvmssts(sys$dassgn(p->chan_in));
1437 b->size = p->iosb.count;
1438 _ckvmssts(lib$insqhi(b, &p->wait));
1440 p->need_wake = FALSE;
1441 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1444 p->retry = 1; /* initial call */
1447 if (eof) { /* flush the free queue, return when done */
1448 int n = sizeof(CBuf) + p->bufsize;
1450 iss = lib$remqti(&p->free, &b);
1451 if (iss == LIB$_QUEWASEMP) return;
1453 _ckvmssts(lib$free_vm(&n, &b));
1457 iss = lib$remqti(&p->free, &b);
1458 if (iss == LIB$_QUEWASEMP) {
1459 int n = sizeof(CBuf) + p->bufsize;
1460 _ckvmssts(lib$get_vm(&n, &b));
1461 b->buf = (char *) b + sizeof(CBuf);
1467 iss = sys$qio(0,p->chan_in,
1468 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1470 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1471 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1476 /* writes queued buffers to output, waits for each to complete before
1480 pipe_tochild2_ast(pPipe p)
1484 int iss = p->iosb2.status;
1485 int n = sizeof(CBuf) + p->bufsize;
1486 int done = (p->info && p->info->done) ||
1487 iss == SS$_CANCEL || iss == SS$_ABORT;
1490 if (p->type) { /* type=1 has old buffer, dispose */
1491 if (p->shut_on_empty) {
1492 _ckvmssts(lib$free_vm(&n, &b));
1494 _ckvmssts(lib$insqhi(b, &p->free));
1499 iss = lib$remqti(&p->wait, &b);
1500 if (iss == LIB$_QUEWASEMP) {
1501 if (p->shut_on_empty) {
1503 _ckvmssts(sys$dassgn(p->chan_out));
1504 *p->pipe_done = TRUE;
1505 _ckvmssts(sys$setef(pipe_ef));
1507 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1508 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1512 p->need_wake = TRUE;
1522 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1523 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1525 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1526 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1535 pipe_infromchild_setup(char *rmbx, char *wmbx)
1539 char mbx1[64], mbx2[64];
1540 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1541 DSC$K_CLASS_S, mbx1},
1542 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1543 DSC$K_CLASS_S, mbx2};
1544 unsigned int dviitm = DVI$_DEVBUFSIZ;
1546 New(1367, p, 1, Pipe);
1547 create_mbx(&p->chan_in , &d_mbx1);
1548 create_mbx(&p->chan_out, &d_mbx2);
1550 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1551 New(1367, p->buf, p->bufsize, char);
1552 p->shut_on_empty = FALSE;
1555 p->iosb.status = SS$_NORMAL;
1556 pipe_infromchild_ast(p);
1564 pipe_infromchild_ast(pPipe p)
1567 int iss = p->iosb.status;
1568 int eof = (iss == SS$_ENDOFFILE);
1569 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1570 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1572 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1573 _ckvmssts(sys$dassgn(p->chan_out));
1578 input shutdown if EOF from self (done or shut_on_empty)
1579 output shutdown if closing flag set (my_pclose)
1580 send data/eof from child or eof from self
1581 otherwise, re-read (snarf of data from child)
1586 if (myeof && p->chan_in) { /* input shutdown */
1587 _ckvmssts(sys$dassgn(p->chan_in));
1592 if (myeof || kideof) { /* pass EOF to parent */
1593 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1594 pipe_infromchild_ast, p,
1597 } else if (eof) { /* eat EOF --- fall through to read*/
1599 } else { /* transmit data */
1600 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1601 pipe_infromchild_ast,p,
1602 p->buf, p->iosb.count, 0, 0, 0, 0));
1608 /* everything shut? flag as done */
1610 if (!p->chan_in && !p->chan_out) {
1611 *p->pipe_done = TRUE;
1612 _ckvmssts(sys$setef(pipe_ef));
1616 /* write completed (or read, if snarfing from child)
1617 if still have input active,
1618 queue read...immediate mode if shut_on_empty so we get EOF if empty
1620 check if Perl reading, generate EOFs as needed
1626 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1627 pipe_infromchild_ast,p,
1628 p->buf, p->bufsize, 0, 0, 0, 0);
1629 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1631 } else { /* send EOFs for extra reads */
1632 p->iosb.status = SS$_ENDOFFILE;
1633 p->iosb.dvispec = 0;
1634 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1636 pipe_infromchild_ast, p, 0, 0, 0, 0));
1642 pipe_mbxtofd_setup(int fd, char *out)
1647 unsigned long dviitm = DVI$_DEVBUFSIZ;
1649 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1650 DSC$K_CLASS_S, mbx};
1652 /* things like terminals and mbx's don't need this filter */
1653 if (fd && fstat(fd,&s) == 0) {
1654 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1655 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1656 DSC$K_CLASS_S, s.st_dev};
1658 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1659 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1660 strcpy(out, s.st_dev);
1665 New(1366, p, 1, Pipe);
1666 p->fd_out = dup(fd);
1667 create_mbx(&p->chan_in, &d_mbx);
1668 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1669 New(1366, p->buf, p->bufsize+1, char);
1670 p->shut_on_empty = FALSE;
1675 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1676 pipe_mbxtofd_ast, p,
1677 p->buf, p->bufsize, 0, 0, 0, 0));
1683 pipe_mbxtofd_ast(pPipe p)
1686 int iss = p->iosb.status;
1687 int done = p->info->done;
1689 int eof = (iss == SS$_ENDOFFILE);
1690 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1691 int err = !(iss&1) && !eof;
1694 if (done && myeof) { /* end piping */
1696 sys$dassgn(p->chan_in);
1697 *p->pipe_done = TRUE;
1698 _ckvmssts(sys$setef(pipe_ef));
1702 if (!err && !eof) { /* good data to send to file */
1703 p->buf[p->iosb.count] = '\n';
1704 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1707 if (p->retry < MAX_RETRY) {
1708 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1718 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1719 pipe_mbxtofd_ast, p,
1720 p->buf, p->bufsize, 0, 0, 0, 0);
1721 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1726 typedef struct _pipeloc PLOC;
1727 typedef struct _pipeloc* pPLOC;
1731 char dir[NAM$C_MAXRSS+1];
1733 static pPLOC head_PLOC = 0;
1741 AV *av = GvAVn(PL_incgv);
1746 char temp[NAM$C_MAXRSS+1];
1749 /* the . directory from @INC comes last */
1752 p->next = head_PLOC;
1754 strcpy(p->dir,"./");
1756 /* get the directory from $^X */
1758 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1759 strcpy(temp, PL_origargv[0]);
1760 x = strrchr(temp,']');
1763 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1765 p->next = head_PLOC;
1767 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1768 p->dir[NAM$C_MAXRSS] = '\0';
1772 /* reverse order of @INC entries, skip "." since entered above */
1774 for (i = 0; i <= AvFILL(av); i++) {
1775 dirsv = *av_fetch(av,i,TRUE);
1777 if (SvROK(dirsv)) continue;
1778 dir = SvPVx(dirsv,n_a);
1779 if (strcmp(dir,".") == 0) continue;
1780 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1784 p->next = head_PLOC;
1786 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1787 p->dir[NAM$C_MAXRSS] = '\0';
1790 /* most likely spot (ARCHLIB) put first in the list */
1793 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1795 p->next = head_PLOC;
1797 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1798 p->dir[NAM$C_MAXRSS] = '\0';
1808 static int vmspipe_file_status = 0;
1809 static char vmspipe_file[NAM$C_MAXRSS+1];
1811 /* already found? Check and use ... need read+execute permission */
1813 if (vmspipe_file_status == 1) {
1814 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1815 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1816 return vmspipe_file;
1818 vmspipe_file_status = 0;
1821 /* scan through stored @INC, $^X */
1823 if (vmspipe_file_status == 0) {
1824 char file[NAM$C_MAXRSS+1];
1825 pPLOC p = head_PLOC;
1828 strcpy(file, p->dir);
1829 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1830 file[NAM$C_MAXRSS] = '\0';
1833 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1835 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1836 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1837 vmspipe_file_status = 1;
1838 return vmspipe_file;
1841 vmspipe_file_status = -1; /* failed, use tempfiles */
1848 vmspipe_tempfile(void)
1850 char file[NAM$C_MAXRSS+1];
1852 static int index = 0;
1855 /* create a tempfile */
1857 /* we can't go from W, shr=get to R, shr=get without
1858 an intermediate vulnerable state, so don't bother trying...
1860 and lib$spawn doesn't shr=put, so have to close the write
1862 So... match up the creation date/time and the FID to
1863 make sure we're dealing with the same file
1868 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1869 fp = fopen(file,"w");
1871 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1872 fp = fopen(file,"w");
1874 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1875 fp = fopen(file,"w");
1878 if (!fp) return 0; /* we're hosed */
1880 fprintf(fp,"$! 'f$verify(0)\n");
1881 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1882 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1883 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1884 fprintf(fp,"$ perl_on = \"set noon\"\n");
1885 fprintf(fp,"$ perl_exit = \"exit\"\n");
1886 fprintf(fp,"$ perl_del = \"delete\"\n");
1887 fprintf(fp,"$ pif = \"if\"\n");
1888 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1889 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user sys$input 'perl_popen_in'\n");
1890 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user sys$error 'perl_popen_err'\n");
1891 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1892 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1893 fprintf(fp,"$! --- get rid of global symbols\n");
1894 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1895 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1896 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1897 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1898 fprintf(fp,"$ perl_on\n");
1899 fprintf(fp,"$ 'cmd\n");
1900 fprintf(fp,"$ perl_status = $STATUS\n");
1901 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1902 fprintf(fp,"$ perl_exit 'perl_status'\n");
1905 fgetname(fp, file, 1);
1906 fstat(fileno(fp), &s0);
1909 fp = fopen(file,"r","shr=get");
1911 fstat(fileno(fp), &s1);
1913 if (s0.st_ino[0] != s1.st_ino[0] ||
1914 s0.st_ino[1] != s1.st_ino[1] ||
1915 s0.st_ino[2] != s1.st_ino[2] ||
1916 s0.st_ctime != s1.st_ctime ) {
1927 safe_popen(char *cmd, char *mode)
1930 static int handler_set_up = FALSE;
1931 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1932 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1933 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1934 char in[512], out[512], err[512], mbx[512];
1936 char tfilebuf[NAM$C_MAXRSS+1];
1938 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1939 DSC$K_CLASS_S, symbol};
1940 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1943 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1944 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1945 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1946 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1948 /* once-per-program initialization...
1949 note that the SETAST calls and the dual test of pipe_ef
1950 makes sure that only the FIRST thread through here does
1951 the initialization...all other threads wait until it's
1954 Yeah, uglier than a pthread call, it's got all the stuff inline
1955 rather than in a separate routine.
1959 _ckvmssts(sys$setast(0));
1961 unsigned long int pidcode = JPI$_PID;
1962 $DESCRIPTOR(d_delay, RETRY_DELAY);
1963 _ckvmssts(lib$get_ef(&pipe_ef));
1964 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1965 _ckvmssts(sys$bintim(&d_delay, delaytime));
1967 if (!handler_set_up) {
1968 _ckvmssts(sys$dclexh(&pipe_exitblock));
1969 handler_set_up = TRUE;
1971 _ckvmssts(sys$setast(1));
1974 /* see if we can find a VMSPIPE.COM */
1977 vmspipe = find_vmspipe();
1979 strcpy(tfilebuf+1,vmspipe);
1980 } else { /* uh, oh...we're in tempfile hell */
1981 tpipe = vmspipe_tempfile();
1982 if (!tpipe) { /* a fish popular in Boston */
1983 if (ckWARN(WARN_PIPE)) {
1984 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1988 fgetname(tpipe,tfilebuf+1,1);
1990 vmspipedsc.dsc$a_pointer = tfilebuf;
1991 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1993 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1994 New(1301,info,1,Info);
1998 info->completion = 0;
1999 info->closing = FALSE;
2003 info->in_done = TRUE;
2004 info->out_done = TRUE;
2005 info->err_done = TRUE;
2006 in[0] = out[0] = err[0] = '\0';
2008 if (*mode == 'r') { /* piping from subroutine */
2010 info->out = pipe_infromchild_setup(mbx,out);
2012 info->out->pipe_done = &info->out_done;
2013 info->out_done = FALSE;
2014 info->out->info = info;
2016 info->fp = PerlIO_open(mbx, mode);
2017 if (!info->fp && info->out) {
2018 sys$cancel(info->out->chan_out);
2020 while (!info->out_done) {
2022 _ckvmssts(sys$setast(0));
2023 done = info->out_done;
2024 if (!done) _ckvmssts(sys$clref(pipe_ef));
2025 _ckvmssts(sys$setast(1));
2026 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2029 if (info->out->buf) Safefree(info->out->buf);
2030 Safefree(info->out);
2035 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2037 info->err->pipe_done = &info->err_done;
2038 info->err_done = FALSE;
2039 info->err->info = info;
2042 } else { /* piping to subroutine , mode=w*/
2044 info->in = pipe_tochild_setup(in,mbx);
2045 info->fp = PerlIO_open(mbx, mode);
2047 info->in->pipe_done = &info->in_done;
2048 info->in_done = FALSE;
2049 info->in->info = info;
2053 if (!info->fp && info->in) {
2055 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2056 0, 0, 0, 0, 0, 0, 0, 0));
2058 while (!info->in_done) {
2060 _ckvmssts(sys$setast(0));
2061 done = info->in_done;
2062 if (!done) _ckvmssts(sys$clref(pipe_ef));
2063 _ckvmssts(sys$setast(1));
2064 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2067 if (info->in->buf) Safefree(info->in->buf);
2074 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2076 info->out->pipe_done = &info->out_done;
2077 info->out_done = FALSE;
2078 info->out->info = info;
2081 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2083 info->err->pipe_done = &info->err_done;
2084 info->err_done = FALSE;
2085 info->err->info = info;
2089 symbol[MAX_DCL_SYMBOL] = '\0';
2091 strncpy(symbol, in, MAX_DCL_SYMBOL);
2092 d_symbol.dsc$w_length = strlen(symbol);
2093 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2095 strncpy(symbol, err, MAX_DCL_SYMBOL);
2096 d_symbol.dsc$w_length = strlen(symbol);
2097 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2099 strncpy(symbol, out, MAX_DCL_SYMBOL);
2100 d_symbol.dsc$w_length = strlen(symbol);
2101 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2103 p = VMScmd.dsc$a_pointer;
2104 while (*p && *p != '\n') p++;
2105 *p = '\0'; /* truncate on \n */
2106 p = VMScmd.dsc$a_pointer;
2107 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2108 if (*p == '$') p++; /* remove leading $ */
2109 while (*p == ' ' || *p == '\t') p++;
2110 strncpy(symbol, p, MAX_DCL_SYMBOL);
2111 d_symbol.dsc$w_length = strlen(symbol);
2112 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2114 _ckvmssts(sys$setast(0));
2115 info->next=open_pipes; /* prepend to list */
2117 _ckvmssts(sys$setast(1));
2118 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2119 0, &info->pid, &info->completion,
2120 0, popen_completion_ast,info,0,0,0));
2122 /* if we were using a tempfile, close it now */
2124 if (tpipe) fclose(tpipe);
2126 /* once the subprocess is spawned, its copied the symbols and
2127 we can get rid of ours */
2129 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2130 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2131 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2132 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2135 PL_forkprocess = info->pid;
2137 } /* end of safe_popen */
2140 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2142 Perl_my_popen(pTHX_ char *cmd, char *mode)
2145 TAINT_PROPER("popen");
2146 PERL_FLUSHALL_FOR_CHILD;
2147 return safe_popen(cmd,mode);
2152 /*{{{ I32 my_pclose(FILE *fp)*/
2153 I32 Perl_my_pclose(pTHX_ FILE *fp)
2156 pInfo info, last = NULL;
2157 unsigned long int retsts;
2160 for (info = open_pipes; info != NULL; last = info, info = info->next)
2161 if (info->fp == fp) break;
2163 if (info == NULL) { /* no such pipe open */
2164 set_errno(ECHILD); /* quoth POSIX */
2165 set_vaxc_errno(SS$_NONEXPR);
2169 /* If we were writing to a subprocess, insure that someone reading from
2170 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2171 * produce an EOF record in the mailbox.
2173 * well, at least sometimes it *does*, so we have to watch out for
2174 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2177 fsync(fileno(info->fp)); /* first, flush data */
2179 _ckvmssts(sys$setast(0));
2180 info->closing = TRUE;
2181 done = info->done && info->in_done && info->out_done && info->err_done;
2182 /* hanging on write to Perl's input? cancel it */
2183 if (info->mode == 'r' && info->out && !info->out_done) {
2184 if (info->out->chan_out) {
2185 _ckvmssts(sys$cancel(info->out->chan_out));
2186 if (!info->out->chan_in) { /* EOF generation, need AST */
2187 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2191 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2192 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2194 _ckvmssts(sys$setast(1));
2195 PerlIO_close(info->fp);
2198 we have to wait until subprocess completes, but ALSO wait until all
2199 the i/o completes...otherwise we'll be freeing the "info" structure
2200 that the i/o ASTs could still be using...
2204 _ckvmssts(sys$setast(0));
2205 done = info->done && info->in_done && info->out_done && info->err_done;
2206 if (!done) _ckvmssts(sys$clref(pipe_ef));
2207 _ckvmssts(sys$setast(1));
2208 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2210 retsts = info->completion;
2212 /* remove from list of open pipes */
2213 _ckvmssts(sys$setast(0));
2214 if (last) last->next = info->next;
2215 else open_pipes = info->next;
2216 _ckvmssts(sys$setast(1));
2218 /* free buffers and structures */
2221 if (info->in->buf) Safefree(info->in->buf);
2225 if (info->out->buf) Safefree(info->out->buf);
2226 Safefree(info->out);
2229 if (info->err->buf) Safefree(info->err->buf);
2230 Safefree(info->err);
2236 } /* end of my_pclose() */
2238 /* sort-of waitpid; use only with popen() */
2239 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2241 my_waitpid(Pid_t pid, int *statusp, int flags)
2247 for (info = open_pipes; info != NULL; info = info->next)
2248 if (info->pid == pid) break;
2250 if (info != NULL) { /* we know about this child */
2251 while (!info->done) {
2252 _ckvmssts(sys$setast(0));
2254 if (!done) _ckvmssts(sys$clref(pipe_ef));
2255 _ckvmssts(sys$setast(1));
2256 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2259 *statusp = info->completion;
2262 else { /* we haven't heard of this child */
2263 $DESCRIPTOR(intdsc,"0 00:00:01");
2264 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2265 unsigned long int interval[2],sts;
2267 if (ckWARN(WARN_EXEC)) {
2268 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2269 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2270 if (ownerpid != mypid)
2271 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2274 _ckvmssts(sys$bintim(&intdsc,interval));
2275 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2276 _ckvmssts(sys$schdwk(0,0,interval,0));
2277 _ckvmssts(sys$hiber());
2279 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2282 /* There's no easy way to find the termination status a child we're
2283 * not aware of beforehand. If we're really interested in the future,
2284 * we can go looking for a termination mailbox, or chase after the
2285 * accounting record for the process.
2291 } /* end of waitpid() */
2296 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2298 my_gconvert(double val, int ndig, int trail, char *buf)
2300 static char __gcvtbuf[DBL_DIG+1];
2303 loc = buf ? buf : __gcvtbuf;
2305 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2307 sprintf(loc,"%.*g",ndig,val);
2313 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2314 return gcvt(val,ndig,loc);
2317 loc[0] = '0'; loc[1] = '\0';
2325 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2326 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2327 * to expand file specification. Allows for a single default file
2328 * specification and a simple mask of options. If outbuf is non-NULL,
2329 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2330 * the resultant file specification is placed. If outbuf is NULL, the
2331 * resultant file specification is placed into a static buffer.
2332 * The third argument, if non-NULL, is taken to be a default file
2333 * specification string. The fourth argument is unused at present.
2334 * rmesexpand() returns the address of the resultant string if
2335 * successful, and NULL on error.
2337 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2340 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2342 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2343 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2344 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2345 struct FAB myfab = cc$rms_fab;
2346 struct NAM mynam = cc$rms_nam;
2348 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2350 if (!filespec || !*filespec) {
2351 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2355 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2356 else outbuf = __rmsexpand_retbuf;
2358 if ((isunix = (strchr(filespec,'/') != NULL))) {
2359 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2360 filespec = vmsfspec;
2363 myfab.fab$l_fna = filespec;
2364 myfab.fab$b_fns = strlen(filespec);
2365 myfab.fab$l_nam = &mynam;
2367 if (defspec && *defspec) {
2368 if (strchr(defspec,'/') != NULL) {
2369 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2372 myfab.fab$l_dna = defspec;
2373 myfab.fab$b_dns = strlen(defspec);
2376 mynam.nam$l_esa = esa;
2377 mynam.nam$b_ess = sizeof esa;
2378 mynam.nam$l_rsa = outbuf;
2379 mynam.nam$b_rss = NAM$C_MAXRSS;
2381 retsts = sys$parse(&myfab,0,0);
2382 if (!(retsts & 1)) {
2383 mynam.nam$b_nop |= NAM$M_SYNCHK;
2384 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2385 retsts = sys$parse(&myfab,0,0);
2386 if (retsts & 1) goto expanded;
2388 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2389 (void) sys$parse(&myfab,0,0); /* Free search context */
2390 if (out) Safefree(out);
2391 set_vaxc_errno(retsts);
2392 if (retsts == RMS$_PRV) set_errno(EACCES);
2393 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2394 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2395 else set_errno(EVMSERR);
2398 retsts = sys$search(&myfab,0,0);
2399 if (!(retsts & 1) && retsts != RMS$_FNF) {
2400 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2401 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2402 if (out) Safefree(out);
2403 set_vaxc_errno(retsts);
2404 if (retsts == RMS$_PRV) set_errno(EACCES);
2405 else set_errno(EVMSERR);
2409 /* If the input filespec contained any lowercase characters,
2410 * downcase the result for compatibility with Unix-minded code. */
2412 for (out = myfab.fab$l_fna; *out; out++)
2413 if (islower(*out)) { haslower = 1; break; }
2414 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2415 else { out = esa; speclen = mynam.nam$b_esl; }
2416 /* Trim off null fields added by $PARSE
2417 * If type > 1 char, must have been specified in original or default spec
2418 * (not true for version; $SEARCH may have added version of existing file).
2420 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2421 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2422 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2423 if (trimver || trimtype) {
2424 if (defspec && *defspec) {
2425 char defesa[NAM$C_MAXRSS];
2426 struct FAB deffab = cc$rms_fab;
2427 struct NAM defnam = cc$rms_nam;
2429 deffab.fab$l_nam = &defnam;
2430 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2431 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2432 defnam.nam$b_nop = NAM$M_SYNCHK;
2433 if (sys$parse(&deffab,0,0) & 1) {
2434 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2435 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2438 if (trimver) speclen = mynam.nam$l_ver - out;
2440 /* If we didn't already trim version, copy down */
2441 if (speclen > mynam.nam$l_ver - out)
2442 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2443 speclen - (mynam.nam$l_ver - out));
2444 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2447 /* If we just had a directory spec on input, $PARSE "helpfully"
2448 * adds an empty name and type for us */
2449 if (mynam.nam$l_name == mynam.nam$l_type &&
2450 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2451 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2452 speclen = mynam.nam$l_name - out;
2453 out[speclen] = '\0';
2454 if (haslower) __mystrtolower(out);
2456 /* Have we been working with an expanded, but not resultant, spec? */
2457 /* Also, convert back to Unix syntax if necessary. */
2458 if (!mynam.nam$b_rsl) {
2460 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2462 else strcpy(outbuf,esa);
2465 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2466 strcpy(outbuf,tmpfspec);
2468 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2469 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2470 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2474 /* External entry points */
2475 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2476 { return do_rmsexpand(spec,buf,0,def,opt); }
2477 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2478 { return do_rmsexpand(spec,buf,1,def,opt); }
2482 ** The following routines are provided to make life easier when
2483 ** converting among VMS-style and Unix-style directory specifications.
2484 ** All will take input specifications in either VMS or Unix syntax. On
2485 ** failure, all return NULL. If successful, the routines listed below
2486 ** return a pointer to a buffer containing the appropriately
2487 ** reformatted spec (and, therefore, subsequent calls to that routine
2488 ** will clobber the result), while the routines of the same names with
2489 ** a _ts suffix appended will return a pointer to a mallocd string
2490 ** containing the appropriately reformatted spec.
2491 ** In all cases, only explicit syntax is altered; no check is made that
2492 ** the resulting string is valid or that the directory in question
2495 ** fileify_dirspec() - convert a directory spec into the name of the
2496 ** directory file (i.e. what you can stat() to see if it's a dir).
2497 ** The style (VMS or Unix) of the result is the same as the style
2498 ** of the parameter passed in.
2499 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2500 ** what you prepend to a filename to indicate what directory it's in).
2501 ** The style (VMS or Unix) of the result is the same as the style
2502 ** of the parameter passed in.
2503 ** tounixpath() - convert a directory spec into a Unix-style path.
2504 ** tovmspath() - convert a directory spec into a VMS-style path.
2505 ** tounixspec() - convert any file spec into a Unix-style file spec.
2506 ** tovmsspec() - convert any file spec into a VMS-style spec.
2508 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2509 ** Permission is given to distribute this code as part of the Perl
2510 ** standard distribution under the terms of the GNU General Public
2511 ** License or the Perl Artistic License. Copies of each may be
2512 ** found in the Perl standard distribution.
2515 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2516 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2518 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2519 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2520 char *retspec, *cp1, *cp2, *lastdir;
2521 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2523 if (!dir || !*dir) {
2524 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2526 dirlen = strlen(dir);
2527 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2528 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2529 strcpy(trndir,"/sys$disk/000000");
2533 if (dirlen > NAM$C_MAXRSS) {
2534 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2536 if (!strpbrk(dir+1,"/]>:")) {
2537 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2538 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2540 dirlen = strlen(dir);
2543 strncpy(trndir,dir,dirlen);
2544 trndir[dirlen] = '\0';
2547 /* If we were handed a rooted logical name or spec, treat it like a
2548 * simple directory, so that
2549 * $ Define myroot dev:[dir.]
2550 * ... do_fileify_dirspec("myroot",buf,1) ...
2551 * does something useful.
2553 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2554 dir[--dirlen] = '\0';
2555 dir[dirlen-1] = ']';
2558 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2559 /* If we've got an explicit filename, we can just shuffle the string. */
2560 if (*(cp1+1)) hasfilename = 1;
2561 /* Similarly, we can just back up a level if we've got multiple levels
2562 of explicit directories in a VMS spec which ends with directories. */
2564 for (cp2 = cp1; cp2 > dir; cp2--) {
2566 *cp2 = *cp1; *cp1 = '\0';
2570 if (*cp2 == '[' || *cp2 == '<') break;
2575 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2576 if (dir[0] == '.') {
2577 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2578 return do_fileify_dirspec("[]",buf,ts);
2579 else if (dir[1] == '.' &&
2580 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2581 return do_fileify_dirspec("[-]",buf,ts);
2583 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2584 dirlen -= 1; /* to last element */
2585 lastdir = strrchr(dir,'/');
2587 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2588 /* If we have "/." or "/..", VMSify it and let the VMS code
2589 * below expand it, rather than repeating the code to handle
2590 * relative components of a filespec here */
2592 if (*(cp1+2) == '.') cp1++;
2593 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2594 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2595 if (strchr(vmsdir,'/') != NULL) {
2596 /* If do_tovmsspec() returned it, it must have VMS syntax
2597 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2598 * the time to check this here only so we avoid a recursion
2599 * loop; otherwise, gigo.
2601 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2603 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2604 return do_tounixspec(trndir,buf,ts);
2607 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2608 lastdir = strrchr(dir,'/');
2610 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2611 /* Ditto for specs that end in an MFD -- let the VMS code
2612 * figure out whether it's a real device or a rooted logical. */
2613 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2614 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2615 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2616 return do_tounixspec(trndir,buf,ts);
2619 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2620 !(lastdir = cp1 = strrchr(dir,']')) &&
2621 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2622 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2624 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2625 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2626 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2627 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2628 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2629 (ver || *cp3)))))) {
2631 set_vaxc_errno(RMS$_DIR);
2637 /* If we lead off with a device or rooted logical, add the MFD
2638 if we're specifying a top-level directory. */
2639 if (lastdir && *dir == '/') {
2641 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2648 retlen = dirlen + (addmfd ? 13 : 6);
2649 if (buf) retspec = buf;
2650 else if (ts) New(1309,retspec,retlen+1,char);
2651 else retspec = __fileify_retbuf;
2653 dirlen = lastdir - dir;
2654 memcpy(retspec,dir,dirlen);
2655 strcpy(&retspec[dirlen],"/000000");
2656 strcpy(&retspec[dirlen+7],lastdir);
2659 memcpy(retspec,dir,dirlen);
2660 retspec[dirlen] = '\0';
2662 /* We've picked up everything up to the directory file name.
2663 Now just add the type and version, and we're set. */
2664 strcat(retspec,".dir;1");
2667 else { /* VMS-style directory spec */
2668 char esa[NAM$C_MAXRSS+1], term, *cp;
2669 unsigned long int sts, cmplen, haslower = 0;
2670 struct FAB dirfab = cc$rms_fab;
2671 struct NAM savnam, dirnam = cc$rms_nam;
2673 dirfab.fab$b_fns = strlen(dir);
2674 dirfab.fab$l_fna = dir;
2675 dirfab.fab$l_nam = &dirnam;
2676 dirfab.fab$l_dna = ".DIR;1";
2677 dirfab.fab$b_dns = 6;
2678 dirnam.nam$b_ess = NAM$C_MAXRSS;
2679 dirnam.nam$l_esa = esa;
2681 for (cp = dir; *cp; cp++)
2682 if (islower(*cp)) { haslower = 1; break; }
2683 if (!((sts = sys$parse(&dirfab))&1)) {
2684 if (dirfab.fab$l_sts == RMS$_DIR) {
2685 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2686 sts = sys$parse(&dirfab) & 1;
2690 set_vaxc_errno(dirfab.fab$l_sts);
2696 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2697 /* Yes; fake the fnb bits so we'll check type below */
2698 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2700 else { /* No; just work with potential name */
2701 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2703 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2704 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2705 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2710 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2711 cp1 = strchr(esa,']');
2712 if (!cp1) cp1 = strchr(esa,'>');
2713 if (cp1) { /* Should always be true */
2714 dirnam.nam$b_esl -= cp1 - esa - 1;
2715 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2718 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2719 /* Yep; check version while we're at it, if it's there. */
2720 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2721 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2722 /* Something other than .DIR[;1]. Bzzt. */
2723 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2724 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2726 set_vaxc_errno(RMS$_DIR);
2730 esa[dirnam.nam$b_esl] = '\0';
2731 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2732 /* They provided at least the name; we added the type, if necessary, */
2733 if (buf) retspec = buf; /* in sys$parse() */
2734 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2735 else retspec = __fileify_retbuf;
2736 strcpy(retspec,esa);
2737 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2738 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2741 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2742 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2744 dirnam.nam$b_esl -= 9;
2746 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2747 if (cp1 == NULL) { /* should never happen */
2748 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2749 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2754 retlen = strlen(esa);
2755 if ((cp1 = strrchr(esa,'.')) != NULL) {
2756 /* There's more than one directory in the path. Just roll back. */
2758 if (buf) retspec = buf;
2759 else if (ts) New(1311,retspec,retlen+7,char);
2760 else retspec = __fileify_retbuf;
2761 strcpy(retspec,esa);
2764 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2765 /* Go back and expand rooted logical name */
2766 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2767 if (!(sys$parse(&dirfab) & 1)) {
2768 dirnam.nam$l_rlf = NULL;
2769 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2771 set_vaxc_errno(dirfab.fab$l_sts);
2774 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2775 if (buf) retspec = buf;
2776 else if (ts) New(1312,retspec,retlen+16,char);
2777 else retspec = __fileify_retbuf;
2778 cp1 = strstr(esa,"][");
2780 memcpy(retspec,esa,dirlen);
2781 if (!strncmp(cp1+2,"000000]",7)) {
2782 retspec[dirlen-1] = '\0';
2783 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2784 if (*cp1 == '.') *cp1 = ']';
2786 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2787 memcpy(cp1+1,"000000]",7);
2791 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2792 retspec[retlen] = '\0';
2793 /* Convert last '.' to ']' */
2794 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2795 if (*cp1 == '.') *cp1 = ']';
2797 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2798 memcpy(cp1+1,"000000]",7);
2802 else { /* This is a top-level dir. Add the MFD to the path. */
2803 if (buf) retspec = buf;
2804 else if (ts) New(1312,retspec,retlen+16,char);
2805 else retspec = __fileify_retbuf;
2808 while (*cp1 != ':') *(cp2++) = *(cp1++);
2809 strcpy(cp2,":[000000]");
2814 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2815 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2816 /* We've set up the string up through the filename. Add the
2817 type and version, and we're done. */
2818 strcat(retspec,".DIR;1");
2820 /* $PARSE may have upcased filespec, so convert output to lower
2821 * case if input contained any lowercase characters. */
2822 if (haslower) __mystrtolower(retspec);
2825 } /* end of do_fileify_dirspec() */
2827 /* External entry points */
2828 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2829 { return do_fileify_dirspec(dir,buf,0); }
2830 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2831 { return do_fileify_dirspec(dir,buf,1); }
2833 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2834 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2836 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2837 unsigned long int retlen;
2838 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2840 if (!dir || !*dir) {
2841 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2844 if (*dir) strcpy(trndir,dir);
2845 else getcwd(trndir,sizeof trndir - 1);
2847 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2848 && my_trnlnm(trndir,trndir,0)) {
2849 STRLEN trnlen = strlen(trndir);
2851 /* Trap simple rooted lnms, and return lnm:[000000] */
2852 if (!strcmp(trndir+trnlen-2,".]")) {
2853 if (buf) retpath = buf;
2854 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2855 else retpath = __pathify_retbuf;
2856 strcpy(retpath,dir);
2857 strcat(retpath,":[000000]");
2863 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2864 if (*dir == '.' && (*(dir+1) == '\0' ||
2865 (*(dir+1) == '.' && *(dir+2) == '\0')))
2866 retlen = 2 + (*(dir+1) != '\0');
2868 if ( !(cp1 = strrchr(dir,'/')) &&
2869 !(cp1 = strrchr(dir,']')) &&
2870 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2871 if ((cp2 = strchr(cp1,'.')) != NULL &&
2872 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2873 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2874 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2875 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2877 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2878 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2879 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2880 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2881 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2882 (ver || *cp3)))))) {
2884 set_vaxc_errno(RMS$_DIR);
2887 retlen = cp2 - dir + 1;
2889 else { /* No file type present. Treat the filename as a directory. */
2890 retlen = strlen(dir) + 1;
2893 if (buf) retpath = buf;
2894 else if (ts) New(1313,retpath,retlen+1,char);
2895 else retpath = __pathify_retbuf;
2896 strncpy(retpath,dir,retlen-1);
2897 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2898 retpath[retlen-1] = '/'; /* with '/', add it. */
2899 retpath[retlen] = '\0';
2901 else retpath[retlen-1] = '\0';
2903 else { /* VMS-style directory spec */
2904 char esa[NAM$C_MAXRSS+1], *cp;
2905 unsigned long int sts, cmplen, haslower;
2906 struct FAB dirfab = cc$rms_fab;
2907 struct NAM savnam, dirnam = cc$rms_nam;
2909 /* If we've got an explicit filename, we can just shuffle the string. */
2910 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2911 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2912 if ((cp2 = strchr(cp1,'.')) != NULL) {
2914 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2915 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2916 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2917 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2918 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2919 (ver || *cp3)))))) {
2921 set_vaxc_errno(RMS$_DIR);
2925 else { /* No file type, so just draw name into directory part */
2926 for (cp2 = cp1; *cp2; cp2++) ;
2929 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2931 /* We've now got a VMS 'path'; fall through */
2933 dirfab.fab$b_fns = strlen(dir);
2934 dirfab.fab$l_fna = dir;
2935 if (dir[dirfab.fab$b_fns-1] == ']' ||
2936 dir[dirfab.fab$b_fns-1] == '>' ||
2937 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2938 if (buf) retpath = buf;
2939 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2940 else retpath = __pathify_retbuf;
2941 strcpy(retpath,dir);
2944 dirfab.fab$l_dna = ".DIR;1";
2945 dirfab.fab$b_dns = 6;
2946 dirfab.fab$l_nam = &dirnam;
2947 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2948 dirnam.nam$l_esa = esa;
2950 for (cp = dir; *cp; cp++)
2951 if (islower(*cp)) { haslower = 1; break; }
2953 if (!(sts = (sys$parse(&dirfab)&1))) {
2954 if (dirfab.fab$l_sts == RMS$_DIR) {
2955 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2956 sts = sys$parse(&dirfab) & 1;
2960 set_vaxc_errno(dirfab.fab$l_sts);
2966 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
2967 if (dirfab.fab$l_sts != RMS$_FNF) {
2968 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2969 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2971 set_vaxc_errno(dirfab.fab$l_sts);
2974 dirnam = savnam; /* No; just work with potential name */
2977 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2978 /* Yep; check version while we're at it, if it's there. */
2979 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2980 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2981 /* Something other than .DIR[;1]. Bzzt. */
2982 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2983 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2985 set_vaxc_errno(RMS$_DIR);
2989 /* OK, the type was fine. Now pull any file name into the
2991 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
2993 cp1 = strrchr(esa,'>');
2994 *dirnam.nam$l_type = '>';
2997 *(dirnam.nam$l_type + 1) = '\0';
2998 retlen = dirnam.nam$l_type - esa + 2;
2999 if (buf) retpath = buf;
3000 else if (ts) New(1314,retpath,retlen,char);
3001 else retpath = __pathify_retbuf;
3002 strcpy(retpath,esa);
3003 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3004 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3005 /* $PARSE may have upcased filespec, so convert output to lower
3006 * case if input contained any lowercase characters. */
3007 if (haslower) __mystrtolower(retpath);
3011 } /* end of do_pathify_dirspec() */
3013 /* External entry points */
3014 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3015 { return do_pathify_dirspec(dir,buf,0); }
3016 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3017 { return do_pathify_dirspec(dir,buf,1); }
3019 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3020 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3022 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3023 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3024 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3026 if (spec == NULL) return NULL;
3027 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3028 if (buf) rslt = buf;
3030 retlen = strlen(spec);
3031 cp1 = strchr(spec,'[');
3032 if (!cp1) cp1 = strchr(spec,'<');
3034 for (cp1++; *cp1; cp1++) {
3035 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3036 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3037 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3040 New(1315,rslt,retlen+2+2*expand,char);
3042 else rslt = __tounixspec_retbuf;
3043 if (strchr(spec,'/') != NULL) {
3050 dirend = strrchr(spec,']');
3051 if (dirend == NULL) dirend = strrchr(spec,'>');
3052 if (dirend == NULL) dirend = strchr(spec,':');
3053 if (dirend == NULL) {
3057 if (*cp2 != '[' && *cp2 != '<') {
3060 else { /* the VMS spec begins with directories */
3062 if (*cp2 == ']' || *cp2 == '>') {
3063 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3066 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3067 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3068 if (ts) Safefree(rslt);
3073 while (*cp3 != ':' && *cp3) cp3++;
3075 if (strchr(cp3,']') != NULL) break;
3076 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3078 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3079 retlen = devlen + dirlen;
3080 Renew(rslt,retlen+1+2*expand,char);
3086 *(cp1++) = *(cp3++);
3087 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3091 else if ( *cp2 == '.') {
3092 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3093 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3099 for (; cp2 <= dirend; cp2++) {
3102 if (*(cp2+1) == '[') cp2++;
3104 else if (*cp2 == ']' || *cp2 == '>') {
3105 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3107 else if (*cp2 == '.') {
3109 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3110 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3111 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3112 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3113 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3115 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3116 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3120 else if (*cp2 == '-') {
3121 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3122 while (*cp2 == '-') {
3124 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3126 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3127 if (ts) Safefree(rslt); /* filespecs like */
3128 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3132 else *(cp1++) = *cp2;
3134 else *(cp1++) = *cp2;
3136 while (*cp2) *(cp1++) = *(cp2++);
3141 } /* end of do_tounixspec() */
3143 /* External entry points */
3144 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3145 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3147 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3148 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3149 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3150 char *rslt, *dirend;
3151 register char *cp1, *cp2;
3152 unsigned long int infront = 0, hasdir = 1;
3154 if (path == NULL) return NULL;
3155 if (buf) rslt = buf;
3156 else if (ts) New(1316,rslt,strlen(path)+9,char);
3157 else rslt = __tovmsspec_retbuf;
3158 if (strpbrk(path,"]:>") ||
3159 (dirend = strrchr(path,'/')) == NULL) {
3160 if (path[0] == '.') {
3161 if (path[1] == '\0') strcpy(rslt,"[]");
3162 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3163 else strcpy(rslt,path); /* probably garbage */
3165 else strcpy(rslt,path);
3168 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3169 if (!*(dirend+2)) dirend +=2;
3170 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3171 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3176 char trndev[NAM$C_MAXRSS+1];
3180 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3182 if (!buf & ts) Renew(rslt,18,char);
3183 strcpy(rslt,"sys$disk:[000000]");
3186 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3188 islnm = my_trnlnm(rslt,trndev,0);
3189 trnend = islnm ? strlen(trndev) - 1 : 0;
3190 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3191 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3192 /* If the first element of the path is a logical name, determine
3193 * whether it has to be translated so we can add more directories. */
3194 if (!islnm || rooted) {
3197 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3201 if (cp2 != dirend) {
3202 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3203 strcpy(rslt,trndev);
3204 cp1 = rslt + trnend;
3217 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3218 cp2 += 2; /* skip over "./" - it's redundant */
3219 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3221 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3222 *(cp1++) = '-'; /* "../" --> "-" */
3225 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3226 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3227 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3228 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3231 if (cp2 > dirend) cp2 = dirend;
3233 else *(cp1++) = '.';
3235 for (; cp2 < dirend; cp2++) {
3237 if (*(cp2-1) == '/') continue;
3238 if (*(cp1-1) != '.') *(cp1++) = '.';
3241 else if (!infront && *cp2 == '.') {
3242 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3243 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3244 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3245 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3246 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3247 else { /* back up over previous directory name */
3249 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3250 if (*(cp1-1) == '[') {
3251 memcpy(cp1,"000000.",7);
3256 if (cp2 == dirend) break;
3258 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3259 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3260 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3261 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3263 *(cp1++) = '.'; /* Simulate trailing '/' */
3264 cp2 += 2; /* for loop will incr this to == dirend */
3266 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3268 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3271 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3272 if (*cp2 == '.') *(cp1++) = '_';
3273 else *(cp1++) = *cp2;
3277 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3278 if (hasdir) *(cp1++) = ']';
3279 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3280 while (*cp2) *(cp1++) = *(cp2++);
3285 } /* end of do_tovmsspec() */
3287 /* External entry points */
3288 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3289 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3291 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3292 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3293 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3295 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3297 if (path == NULL) return NULL;
3298 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3299 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3300 if (buf) return buf;
3302 vmslen = strlen(vmsified);
3303 New(1317,cp,vmslen+1,char);
3304 memcpy(cp,vmsified,vmslen);
3309 strcpy(__tovmspath_retbuf,vmsified);
3310 return __tovmspath_retbuf;
3313 } /* end of do_tovmspath() */
3315 /* External entry points */
3316 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3317 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3320 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3321 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3322 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3324 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3326 if (path == NULL) return NULL;
3327 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3328 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3329 if (buf) return buf;
3331 unixlen = strlen(unixified);
3332 New(1317,cp,unixlen+1,char);
3333 memcpy(cp,unixified,unixlen);
3338 strcpy(__tounixpath_retbuf,unixified);
3339 return __tounixpath_retbuf;
3342 } /* end of do_tounixpath() */
3344 /* External entry points */
3345 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3346 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3349 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3351 *****************************************************************************
3353 * Copyright (C) 1989-1994 by *
3354 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3356 * Permission is hereby granted for the reproduction of this software, *
3357 * on condition that this copyright notice is included in the reproduction, *
3358 * and that such reproduction is not for purposes of profit or material *
3361 * 27-Aug-1994 Modified for inclusion in perl5 *
3362 * by Charles Bailey bailey@newman.upenn.edu *
3363 *****************************************************************************
3367 * getredirection() is intended to aid in porting C programs
3368 * to VMS (Vax-11 C). The native VMS environment does not support
3369 * '>' and '<' I/O redirection, or command line wild card expansion,
3370 * or a command line pipe mechanism using the '|' AND background
3371 * command execution '&'. All of these capabilities are provided to any
3372 * C program which calls this procedure as the first thing in the
3374 * The piping mechanism will probably work with almost any 'filter' type
3375 * of program. With suitable modification, it may useful for other
3376 * portability problems as well.
3378 * Author: Mark Pizzolato mark@infocomm.com
3382 struct list_item *next;
3386 static void add_item(struct list_item **head,
3387 struct list_item **tail,
3391 static void mp_expand_wild_cards(pTHX_ char *item,
3392 struct list_item **head,
3393 struct list_item **tail,
3396 static int background_process(int argc, char **argv);
3398 static void pipe_and_fork(char **cmargv);
3400 /*{{{ void getredirection(int *ac, char ***av)*/
3402 mp_getredirection(pTHX_ int *ac, char ***av)
3404 * Process vms redirection arg's. Exit if any error is seen.
3405 * If getredirection() processes an argument, it is erased
3406 * from the vector. getredirection() returns a new argc and argv value.
3407 * In the event that a background command is requested (by a trailing "&"),
3408 * this routine creates a background subprocess, and simply exits the program.
3410 * Warning: do not try to simplify the code for vms. The code
3411 * presupposes that getredirection() is called before any data is
3412 * read from stdin or written to stdout.
3414 * Normal usage is as follows:
3420 * getredirection(&argc, &argv);
3424 int argc = *ac; /* Argument Count */
3425 char **argv = *av; /* Argument Vector */
3426 char *ap; /* Argument pointer */
3427 int j; /* argv[] index */
3428 int item_count = 0; /* Count of Items in List */
3429 struct list_item *list_head = 0; /* First Item in List */
3430 struct list_item *list_tail; /* Last Item in List */
3431 char *in = NULL; /* Input File Name */
3432 char *out = NULL; /* Output File Name */
3433 char *outmode = "w"; /* Mode to Open Output File */
3434 char *err = NULL; /* Error File Name */
3435 char *errmode = "w"; /* Mode to Open Error File */
3436 int cmargc = 0; /* Piped Command Arg Count */
3437 char **cmargv = NULL;/* Piped Command Arg Vector */
3440 * First handle the case where the last thing on the line ends with
3441 * a '&'. This indicates the desire for the command to be run in a
3442 * subprocess, so we satisfy that desire.
3445 if (0 == strcmp("&", ap))
3446 exit(background_process(--argc, argv));
3447 if (*ap && '&' == ap[strlen(ap)-1])
3449 ap[strlen(ap)-1] = '\0';
3450 exit(background_process(argc, argv));
3453 * Now we handle the general redirection cases that involve '>', '>>',
3454 * '<', and pipes '|'.
3456 for (j = 0; j < argc; ++j)
3458 if (0 == strcmp("<", argv[j]))
3462 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3463 exit(LIB$_WRONUMARG);
3468 if ('<' == *(ap = argv[j]))
3473 if (0 == strcmp(">", ap))
3477 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3478 exit(LIB$_WRONUMARG);
3497 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3498 exit(LIB$_WRONUMARG);
3502 if (('2' == *ap) && ('>' == ap[1]))
3519 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3520 exit(LIB$_WRONUMARG);
3524 if (0 == strcmp("|", argv[j]))
3528 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3529 exit(LIB$_WRONUMARG);
3531 cmargc = argc-(j+1);
3532 cmargv = &argv[j+1];
3536 if ('|' == *(ap = argv[j]))
3544 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3547 * Allocate and fill in the new argument vector, Some Unix's terminate
3548 * the list with an extra null pointer.
3550 New(1302, argv, item_count+1, char *);
3552 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3553 argv[j] = list_head->value;
3559 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3560 exit(LIB$_INVARGORD);
3562 pipe_and_fork(cmargv);
3565 /* Check for input from a pipe (mailbox) */
3567 if (in == NULL && 1 == isapipe(0))
3569 char mbxname[L_tmpnam];
3571 long int dvi_item = DVI$_DEVBUFSIZ;
3572 $DESCRIPTOR(mbxnam, "");
3573 $DESCRIPTOR(mbxdevnam, "");
3575 /* Input from a pipe, reopen it in binary mode to disable */
3576 /* carriage control processing. */
3578 PerlIO_getname(stdin, mbxname);
3579 mbxnam.dsc$a_pointer = mbxname;
3580 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3581 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3582 mbxdevnam.dsc$a_pointer = mbxname;
3583 mbxdevnam.dsc$w_length = sizeof(mbxname);
3584 dvi_item = DVI$_DEVNAM;
3585 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3586 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3589 freopen(mbxname, "rb", stdin);
3592 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3596 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3598 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3601 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3603 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3606 if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
3609 if (strcmp(err,"&1") == 0) {
3610 dup2(fileno(stdout), fileno(Perl_debug_log));
3611 Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
3614 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3616 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3620 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3624 Perl_vmssetuserlnm("SYS$ERROR",err);
3627 #ifdef ARGPROC_DEBUG
3628 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3629 for (j = 0; j < *ac; ++j)
3630 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3632 /* Clear errors we may have hit expanding wildcards, so they don't
3633 show up in Perl's $! later */
3634 set_errno(0); set_vaxc_errno(1);
3635 } /* end of getredirection() */
3638 static void add_item(struct list_item **head,
3639 struct list_item **tail,
3645 New(1303,*head,1,struct list_item);
3649 New(1304,(*tail)->next,1,struct list_item);
3650 *tail = (*tail)->next;
3652 (*tail)->value = value;
3656 static void mp_expand_wild_cards(pTHX_ char *item,
3657 struct list_item **head,
3658 struct list_item **tail,
3662 unsigned long int context = 0;
3668 char vmsspec[NAM$C_MAXRSS+1];
3669 $DESCRIPTOR(filespec, "");
3670 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3671 $DESCRIPTOR(resultspec, "");
3672 unsigned long int zero = 0, sts;
3674 for (cp = item; *cp; cp++) {
3675 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3676 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3678 if (!*cp || isspace(*cp))
3680 add_item(head, tail, item, count);
3683 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3684 resultspec.dsc$b_class = DSC$K_CLASS_D;
3685 resultspec.dsc$a_pointer = NULL;
3686 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3687 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3688 if (!isunix || !filespec.dsc$a_pointer)
3689 filespec.dsc$a_pointer = item;
3690 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3692 * Only return version specs, if the caller specified a version
3694 had_version = strchr(item, ';');
3696 * Only return device and directory specs, if the caller specifed either.
3698 had_device = strchr(item, ':');
3699 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3701 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3702 &defaultspec, 0, 0, &zero))))
3707 New(1305,string,resultspec.dsc$w_length+1,char);
3708 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3709 string[resultspec.dsc$w_length] = '\0';
3710 if (NULL == had_version)
3711 *((char *)strrchr(string, ';')) = '\0';
3712 if ((!had_directory) && (had_device == NULL))
3714 if (NULL == (devdir = strrchr(string, ']')))
3715 devdir = strrchr(string, '>');
3716 strcpy(string, devdir + 1);
3719 * Be consistent with what the C RTL has already done to the rest of
3720 * the argv items and lowercase all of these names.
3722 for (c = string; *c; ++c)
3725 if (isunix) trim_unixpath(string,item,1);
3726 add_item(head, tail, string, count);
3729 if (sts != RMS$_NMF)
3731 set_vaxc_errno(sts);
3734 case RMS$_FNF: case RMS$_DNF:
3735 set_errno(ENOENT); break;
3737 set_errno(ENOTDIR); break;
3739 set_errno(ENODEV); break;
3740 case RMS$_FNM: case RMS$_SYN:
3741 set_errno(EINVAL); break;
3743 set_errno(EACCES); break;
3745 _ckvmssts_noperl(sts);
3749 add_item(head, tail, item, count);
3750 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3751 _ckvmssts_noperl(lib$find_file_end(&context));
3754 static int child_st[2];/* Event Flag set when child process completes */
3756 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3758 static unsigned long int exit_handler(int *status)
3762 if (0 == child_st[0])
3764 #ifdef ARGPROC_DEBUG
3765 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3767 fflush(stdout); /* Have to flush pipe for binary data to */
3768 /* terminate properly -- <tp@mccall.com> */
3769 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3770 sys$dassgn(child_chan);
3772 sys$synch(0, child_st);
3777 static void sig_child(int chan)
3779 #ifdef ARGPROC_DEBUG
3780 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3782 if (child_st[0] == 0)
3786 static struct exit_control_block exit_block =
3791 &exit_block.exit_status,
3795 static void pipe_and_fork(char **cmargv)
3798 $DESCRIPTOR(cmddsc, "");
3799 static char mbxname[64];
3800 $DESCRIPTOR(mbxdsc, mbxname);
3802 unsigned long int zero = 0, one = 1;
3804 strcpy(subcmd, cmargv[0]);
3805 for (j = 1; NULL != cmargv[j]; ++j)
3807 strcat(subcmd, " \"");
3808 strcat(subcmd, cmargv[j]);
3809 strcat(subcmd, "\"");
3811 cmddsc.dsc$a_pointer = subcmd;
3812 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3814 create_mbx(&child_chan,&mbxdsc);
3815 #ifdef ARGPROC_DEBUG
3816 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3817 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3819 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3820 0, &pid, child_st, &zero, sig_child,
3822 #ifdef ARGPROC_DEBUG
3823 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3825 sys$dclexh(&exit_block);
3826 if (NULL == freopen(mbxname, "wb", stdout))
3828 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3832 static int background_process(int argc, char **argv)
3834 char command[2048] = "$";
3835 $DESCRIPTOR(value, "");
3836 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3837 static $DESCRIPTOR(null, "NLA0:");
3838 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3840 $DESCRIPTOR(pidstr, "");
3842 unsigned long int flags = 17, one = 1, retsts;
3844 strcat(command, argv[0]);
3847 strcat(command, " \"");
3848 strcat(command, *(++argv));
3849 strcat(command, "\"");
3851 value.dsc$a_pointer = command;
3852 value.dsc$w_length = strlen(value.dsc$a_pointer);
3853 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3854 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3855 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3856 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3859 _ckvmssts_noperl(retsts);
3861 #ifdef ARGPROC_DEBUG
3862 PerlIO_printf(Perl_debug_log, "%s\n", command);
3864 sprintf(pidstring, "%08X", pid);
3865 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3866 pidstr.dsc$a_pointer = pidstring;
3867 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3868 lib$set_symbol(&pidsymbol, &pidstr);
3872 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3875 /* OS-specific initialization at image activation (not thread startup) */
3876 /* Older VAXC header files lack these constants */
3877 #ifndef JPI$_RIGHTS_SIZE
3878 # define JPI$_RIGHTS_SIZE 817
3880 #ifndef KGB$M_SUBSYSTEM
3881 # define KGB$M_SUBSYSTEM 0x8
3884 /*{{{void vms_image_init(int *, char ***)*/
3886 vms_image_init(int *argcp, char ***argvp)
3888 char eqv[LNM$C_NAMLENGTH+1] = "";
3889 unsigned int len, tabct = 8, tabidx = 0;
3890 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3891 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3892 unsigned short int dummy, rlen;
3893 struct dsc$descriptor_s **tabvec;
3895 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3896 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3897 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3900 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3902 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3903 if (iprv[i]) { /* Running image installed with privs? */
3904 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3909 /* Rights identifiers might trigger tainting as well. */
3910 if (!will_taint && (rlen || rsz)) {
3911 while (rlen < rsz) {
3912 /* We didn't get all the identifiers on the first pass. Allocate a
3913 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3914 * were needed to hold all identifiers at time of last call; we'll
3915 * allocate that many unsigned long ints), and go back and get 'em.
3916 * If it gave us less than it wanted to despite ample buffer space,
3917 * something's broken. Is your system missing a system identifier?
3919 if (rsz <= jpilist[1].buflen) {
3920 /* Perl_croak accvios when used this early in startup. */
3921 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3922 rsz, (unsigned long) jpilist[1].buflen,
3923 "Check your rights database for corruption.\n");
3926 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3927 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3928 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3929 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3932 mask = jpilist[1].bufadr;
3933 /* Check attribute flags for each identifier (2nd longword); protected
3934 * subsystem identifiers trigger tainting.
3936 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3937 if (mask[i] & KGB$M_SUBSYSTEM) {
3942 if (mask != rlst) Safefree(mask);
3944 /* We need to use this hack to tell Perl it should run with tainting,
3945 * since its tainting flag may be part of the PL_curinterp struct, which
3946 * hasn't been allocated when vms_image_init() is called.
3950 New(1320,newap,*argcp+2,char **);
3951 newap[0] = argvp[0];
3953 Copy(argvp[1],newap[2],*argcp-1,char **);
3954 /* We orphan the old argv, since we don't know where it's come from,
3955 * so we don't know how to free it.
3957 *argcp++; argvp = newap;
3959 else { /* Did user explicitly request tainting? */
3961 char *cp, **av = *argvp;
3962 for (i = 1; i < *argcp; i++) {
3963 if (*av[i] != '-') break;
3964 for (cp = av[i]+1; *cp; cp++) {
3965 if (*cp == 'T') { will_taint = 1; break; }
3966 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3967 strchr("DFIiMmx",*cp)) break;
3969 if (will_taint) break;
3974 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3976 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3977 else if (tabidx >= tabct) {
3979 Renew(tabvec,tabct,struct dsc$descriptor_s *);
3981 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3982 tabvec[tabidx]->dsc$w_length = 0;
3983 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
3984 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
3985 tabvec[tabidx]->dsc$a_pointer = NULL;
3986 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3988 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
3990 getredirection(argcp,argvp);
3991 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
3993 # include <reentrancy.h>
3994 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4003 * Trim Unix-style prefix off filespec, so it looks like what a shell
4004 * glob expansion would return (i.e. from specified prefix on, not
4005 * full path). Note that returned filespec is Unix-style, regardless
4006 * of whether input filespec was VMS-style or Unix-style.
4008 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4009 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4010 * vector of options; at present, only bit 0 is used, and if set tells
4011 * trim unixpath to try the current default directory as a prefix when
4012 * presented with a possibly ambiguous ... wildcard.
4014 * Returns !=0 on success, with trimmed filespec replacing contents of
4015 * fspec, and 0 on failure, with contents of fpsec unchanged.
4017 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4019 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4021 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4022 *template, *base, *end, *cp1, *cp2;
4023 register int tmplen, reslen = 0, dirs = 0;
4025 if (!wildspec || !fspec) return 0;
4026 if (strpbrk(wildspec,"]>:") != NULL) {
4027 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4028 else template = unixwild;
4030 else template = wildspec;
4031 if (strpbrk(fspec,"]>:") != NULL) {
4032 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4033 else base = unixified;
4034 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4035 * check to see that final result fits into (isn't longer than) fspec */
4036 reslen = strlen(fspec);
4040 /* No prefix or absolute path on wildcard, so nothing to remove */
4041 if (!*template || *template == '/') {
4042 if (base == fspec) return 1;
4043 tmplen = strlen(unixified);
4044 if (tmplen > reslen) return 0; /* not enough space */
4045 /* Copy unixified resultant, including trailing NUL */
4046 memmove(fspec,unixified,tmplen+1);
4050 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4051 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4052 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4053 for (cp1 = end ;cp1 >= base; cp1--)
4054 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4056 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4060 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4061 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4062 int ells = 1, totells, segdirs, match;
4063 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4064 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4066 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4068 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4069 if (ellipsis == template && opts & 1) {
4070 /* Template begins with an ellipsis. Since we can't tell how many
4071 * directory names at the front of the resultant to keep for an
4072 * arbitrary starting point, we arbitrarily choose the current
4073 * default directory as a starting point. If it's there as a prefix,
4074 * clip it off. If not, fall through and act as if the leading
4075 * ellipsis weren't there (i.e. return shortest possible path that
4076 * could match template).
4078 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4079 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4080 if (_tolower(*cp1) != _tolower(*cp2)) break;
4081 segdirs = dirs - totells; /* Min # of dirs we must have left */
4082 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4083 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4084 memcpy(fspec,cp2+1,end - cp2);
4088 /* First off, back up over constant elements at end of path */
4090 for (front = end ; front >= base; front--)
4091 if (*front == '/' && !dirs--) { front++; break; }
4093 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4094 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4095 if (cp1 != '\0') return 0; /* Path too long. */
4097 *cp2 = '\0'; /* Pick up with memcpy later */
4098 lcfront = lcres + (front - base);
4099 /* Now skip over each ellipsis and try to match the path in front of it. */
4101 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4102 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4103 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4104 if (cp1 < template) break; /* template started with an ellipsis */
4105 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4106 ellipsis = cp1; continue;
4108 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4110 for (segdirs = 0, cp2 = tpl;
4111 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4113 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4114 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4115 if (*cp2 == '/') segdirs++;
4117 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4118 /* Back up at least as many dirs as in template before matching */
4119 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4120 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4121 for (match = 0; cp1 > lcres;) {
4122 resdsc.dsc$a_pointer = cp1;
4123 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4125 if (match == 1) lcfront = cp1;
4127 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4129 if (!match) return 0; /* Can't find prefix ??? */
4130 if (match > 1 && opts & 1) {
4131 /* This ... wildcard could cover more than one set of dirs (i.e.
4132 * a set of similar dir names is repeated). If the template
4133 * contains more than 1 ..., upstream elements could resolve the
4134 * ambiguity, but it's not worth a full backtracking setup here.
4135 * As a quick heuristic, clip off the current default directory
4136 * if it's present to find the trimmed spec, else use the
4137 * shortest string that this ... could cover.
4139 char def[NAM$C_MAXRSS+1], *st;
4141 if (getcwd(def, sizeof def,0) == NULL) return 0;
4142 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4143 if (_tolower(*cp1) != _tolower(*cp2)) break;
4144 segdirs = dirs - totells; /* Min # of dirs we must have left */
4145 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4146 if (*cp1 == '\0' && *cp2 == '/') {
4147 memcpy(fspec,cp2+1,end - cp2);
4150 /* Nope -- stick with lcfront from above and keep going. */
4153 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4158 } /* end of trim_unixpath() */
4163 * VMS readdir() routines.
4164 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4166 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4167 * Minor modifications to original routines.
4170 /* Number of elements in vms_versions array */
4171 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4174 * Open a directory, return a handle for later use.
4176 /*{{{ DIR *opendir(char*name) */
4178 Perl_opendir(pTHX_ char *name)
4181 char dir[NAM$C_MAXRSS+1];
4184 if (do_tovmspath(name,dir,0) == NULL) {
4187 if (flex_stat(dir,&sb) == -1) return NULL;
4188 if (!S_ISDIR(sb.st_mode)) {
4189 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4192 if (!cando_by_name(S_IRUSR,0,dir)) {
4193 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4196 /* Get memory for the handle, and the pattern. */
4198 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4200 /* Fill in the fields; mainly playing with the descriptor. */
4201 (void)sprintf(dd->pattern, "%s*.*",dir);
4204 dd->vms_wantversions = 0;
4205 dd->pat.dsc$a_pointer = dd->pattern;
4206 dd->pat.dsc$w_length = strlen(dd->pattern);
4207 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4208 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4211 } /* end of opendir() */
4215 * Set the flag to indicate we want versions or not.
4217 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4219 vmsreaddirversions(DIR *dd, int flag)
4221 dd->vms_wantversions = flag;
4226 * Free up an opened directory.
4228 /*{{{ void closedir(DIR *dd)*/
4232 (void)lib$find_file_end(&dd->context);
4233 Safefree(dd->pattern);
4234 Safefree((char *)dd);
4239 * Collect all the version numbers for the current file.
4245 struct dsc$descriptor_s pat;
4246 struct dsc$descriptor_s res;
4248 char *p, *text, buff[sizeof dd->entry.d_name];
4250 unsigned long context, tmpsts;
4253 /* Convenient shorthand. */
4256 /* Add the version wildcard, ignoring the "*.*" put on before */
4257 i = strlen(dd->pattern);
4258 New(1308,text,i + e->d_namlen + 3,char);
4259 (void)strcpy(text, dd->pattern);
4260 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4262 /* Set up the pattern descriptor. */
4263 pat.dsc$a_pointer = text;
4264 pat.dsc$w_length = i + e->d_namlen - 1;
4265 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4266 pat.dsc$b_class = DSC$K_CLASS_S;
4268 /* Set up result descriptor. */
4269 res.dsc$a_pointer = buff;
4270 res.dsc$w_length = sizeof buff - 2;
4271 res.dsc$b_dtype = DSC$K_DTYPE_T;
4272 res.dsc$b_class = DSC$K_CLASS_S;
4274 /* Read files, collecting versions. */
4275 for (context = 0, e->vms_verscount = 0;
4276 e->vms_verscount < VERSIZE(e);
4277 e->vms_verscount++) {
4278 tmpsts = lib$find_file(&pat, &res, &context);
4279 if (tmpsts == RMS$_NMF || context == 0) break;
4281 buff[sizeof buff - 1] = '\0';
4282 if ((p = strchr(buff, ';')))
4283 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4285 e->vms_versions[e->vms_verscount] = -1;
4288 _ckvmssts(lib$find_file_end(&context));
4291 } /* end of collectversions() */
4294 * Read the next entry from the directory.
4296 /*{{{ struct dirent *readdir(DIR *dd)*/
4300 struct dsc$descriptor_s res;
4301 char *p, buff[sizeof dd->entry.d_name];
4302 unsigned long int tmpsts;
4304 /* Set up result descriptor, and get next file. */
4305 res.dsc$a_pointer = buff;
4306 res.dsc$w_length = sizeof buff - 2;
4307 res.dsc$b_dtype = DSC$K_DTYPE_T;
4308 res.dsc$b_class = DSC$K_CLASS_S;
4309 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4310 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4311 if (!(tmpsts & 1)) {
4312 set_vaxc_errno(tmpsts);
4315 set_errno(EACCES); break;
4317 set_errno(ENODEV); break;
4319 set_errno(ENOTDIR); break;
4320 case RMS$_FNF: case RMS$_DNF:
4321 set_errno(ENOENT); break;
4328 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4329 buff[sizeof buff - 1] = '\0';
4330 for (p = buff; *p; p++) *p = _tolower(*p);
4331 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4334 /* Skip any directory component and just copy the name. */
4335 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4336 else (void)strcpy(dd->entry.d_name, buff);
4338 /* Clobber the version. */
4339 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4341 dd->entry.d_namlen = strlen(dd->entry.d_name);
4342 dd->entry.vms_verscount = 0;
4343 if (dd->vms_wantversions) collectversions(dd);
4346 } /* end of readdir() */
4350 * Return something that can be used in a seekdir later.
4352 /*{{{ long telldir(DIR *dd)*/
4361 * Return to a spot where we used to be. Brute force.
4363 /*{{{ void seekdir(DIR *dd,long count)*/
4365 seekdir(DIR *dd, long count)
4367 int vms_wantversions;
4370 /* If we haven't done anything yet... */
4374 /* Remember some state, and clear it. */
4375 vms_wantversions = dd->vms_wantversions;
4376 dd->vms_wantversions = 0;
4377 _ckvmssts(lib$find_file_end(&dd->context));
4380 /* The increment is in readdir(). */
4381 for (dd->count = 0; dd->count < count; )
4384 dd->vms_wantversions = vms_wantversions;
4386 } /* end of seekdir() */
4389 /* VMS subprocess management
4391 * my_vfork() - just a vfork(), after setting a flag to record that
4392 * the current script is trying a Unix-style fork/exec.
4394 * vms_do_aexec() and vms_do_exec() are called in response to the
4395 * perl 'exec' function. If this follows a vfork call, then they
4396 * call out the the regular perl routines in doio.c which do an
4397 * execvp (for those who really want to try this under VMS).
4398 * Otherwise, they do exactly what the perl docs say exec should
4399 * do - terminate the current script and invoke a new command
4400 * (See below for notes on command syntax.)
4402 * do_aspawn() and do_spawn() implement the VMS side of the perl
4403 * 'system' function.
4405 * Note on command arguments to perl 'exec' and 'system': When handled
4406 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4407 * are concatenated to form a DCL command string. If the first arg
4408 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4409 * the the command string is handed off to DCL directly. Otherwise,
4410 * the first token of the command is taken as the filespec of an image
4411 * to run. The filespec is expanded using a default type of '.EXE' and
4412 * the process defaults for device, directory, etc., and if found, the resultant
4413 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4414 * the command string as parameters. This is perhaps a bit complicated,
4415 * but I hope it will form a happy medium between what VMS folks expect
4416 * from lib$spawn and what Unix folks expect from exec.
4419 static int vfork_called;
4421 /*{{{int my_vfork()*/
4432 vms_execfree(pTHX) {
4434 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4437 if (VMScmd.dsc$a_pointer) {
4438 Safefree(VMScmd.dsc$a_pointer);
4439 VMScmd.dsc$w_length = 0;
4440 VMScmd.dsc$a_pointer = Nullch;
4445 setup_argstr(SV *really, SV **mark, SV **sp)
4448 char *junk, *tmps = Nullch;
4449 register size_t cmdlen = 0;
4456 tmps = SvPV(really,rlen);
4463 for (idx++; idx <= sp; idx++) {
4465 junk = SvPVx(*idx,rlen);
4466 cmdlen += rlen ? rlen + 1 : 0;
4469 New(401,PL_Cmd,cmdlen+1,char);
4471 if (tmps && *tmps) {
4472 strcpy(PL_Cmd,tmps);
4475 else *PL_Cmd = '\0';
4476 while (++mark <= sp) {
4478 char *s = SvPVx(*mark,n_a);
4480 if (*PL_Cmd) strcat(PL_Cmd," ");
4486 } /* end of setup_argstr() */
4489 static unsigned long int
4490 setup_cmddsc(char *cmd, int check_img)
4492 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4493 $DESCRIPTOR(defdsc,".EXE");
4494 $DESCRIPTOR(defdsc2,".");
4495 $DESCRIPTOR(resdsc,resspec);
4496 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4497 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4498 register char *s, *rest, *cp, *wordbreak;
4503 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4506 while (*s && isspace(*s)) s++;
4508 if (*s == '@' || *s == '$') {
4509 vmsspec[0] = *s; rest = s + 1;
4510 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4512 else { cp = vmsspec; rest = s; }
4513 if (*rest == '.' || *rest == '/') {
4516 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4517 rest++, cp2++) *cp2 = *rest;
4519 if (do_tovmsspec(resspec,cp,0)) {
4522 for (cp2 = vmsspec + strlen(vmsspec);
4523 *rest && cp2 - vmsspec < sizeof vmsspec;
4524 rest++, cp2++) *cp2 = *rest;
4529 /* Intuit whether verb (first word of cmd) is a DCL command:
4530 * - if first nonspace char is '@', it's a DCL indirection
4532 * - if verb contains a filespec separator, it's not a DCL command
4533 * - if it doesn't, caller tells us whether to default to a DCL
4534 * command, or to a local image unless told it's DCL (by leading '$')
4536 if (*s == '@') isdcl = 1;
4538 register char *filespec = strpbrk(s,":<[.;");
4539 rest = wordbreak = strpbrk(s," \"\t/");
4540 if (!wordbreak) wordbreak = s + strlen(s);
4541 if (*s == '$') check_img = 0;
4542 if (filespec && (filespec < wordbreak)) isdcl = 0;
4543 else isdcl = !check_img;
4547 imgdsc.dsc$a_pointer = s;
4548 imgdsc.dsc$w_length = wordbreak - s;
4549 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4551 _ckvmssts(lib$find_file_end(&cxt));
4552 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4553 if (!(retsts & 1) && *s == '$') {
4554 _ckvmssts(lib$find_file_end(&cxt));
4555 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4556 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4558 _ckvmssts(lib$find_file_end(&cxt));
4559 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4563 _ckvmssts(lib$find_file_end(&cxt));
4568 while (*s && !isspace(*s)) s++;
4571 /* check that it's really not DCL with no file extension */
4572 fp = fopen(resspec,"r","ctx=bin,shr=get");
4574 char b[4] = {0,0,0,0};
4575 read(fileno(fp),b,4);
4576 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4579 if (check_img && isdcl) return RMS$_FNF;
4581 if (cando_by_name(S_IXUSR,0,resspec)) {
4582 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4584 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4586 strcpy(VMScmd.dsc$a_pointer,"@");
4588 strcat(VMScmd.dsc$a_pointer,resspec);
4589 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4590 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4593 else retsts = RMS$_PRV;
4596 /* It's either a DCL command or we couldn't find a suitable image */
4597 VMScmd.dsc$w_length = strlen(cmd);
4598 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4599 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4600 if (!(retsts & 1)) {
4601 /* just hand off status values likely to be due to user error */
4602 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4603 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4604 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4605 else { _ckvmssts(retsts); }
4608 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4610 } /* end of setup_cmddsc() */
4613 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4615 vms_do_aexec(SV *really,SV **mark,SV **sp)
4619 if (vfork_called) { /* this follows a vfork - act Unixish */
4621 if (vfork_called < 0) {
4622 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4625 else return do_aexec(really,mark,sp);
4627 /* no vfork - act VMSish */
4628 return vms_do_exec(setup_argstr(really,mark,sp));
4633 } /* end of vms_do_aexec() */
4636 /* {{{bool vms_do_exec(char *cmd) */
4638 vms_do_exec(char *cmd)
4642 if (vfork_called) { /* this follows a vfork - act Unixish */
4644 if (vfork_called < 0) {
4645 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4648 else return do_exec(cmd);
4651 { /* no vfork - act VMSish */
4652 unsigned long int retsts;
4655 TAINT_PROPER("exec");
4656 if ((retsts = setup_cmddsc(cmd,1)) & 1)
4657 retsts = lib$do_command(&VMScmd);
4660 case RMS$_FNF: case RMS$_DNF:
4661 set_errno(ENOENT); break;
4663 set_errno(ENOTDIR); break;
4665 set_errno(ENODEV); break;
4667 set_errno(EACCES); break;
4669 set_errno(EINVAL); break;
4671 set_errno(E2BIG); break;
4672 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4673 _ckvmssts(retsts); /* fall through */
4674 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4677 set_vaxc_errno(retsts);
4678 if (ckWARN(WARN_EXEC)) {
4679 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4680 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4687 } /* end of vms_do_exec() */
4690 unsigned long int do_spawn(char *);
4692 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4694 do_aspawn(void *really,void **mark,void **sp)
4697 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4700 } /* end of do_aspawn() */
4703 /* {{{unsigned long int do_spawn(char *cmd) */
4707 unsigned long int sts, substs, hadcmd = 1;
4711 TAINT_PROPER("spawn");
4712 if (!cmd || !*cmd) {
4714 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4716 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4717 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4722 case RMS$_FNF: case RMS$_DNF:
4723 set_errno(ENOENT); break;
4725 set_errno(ENOTDIR); break;
4727 set_errno(ENODEV); break;
4729 set_errno(EACCES); break;
4731 set_errno(EINVAL); break;
4733 set_errno(E2BIG); break;
4734 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4735 _ckvmssts(sts); /* fall through */
4736 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4739 set_vaxc_errno(sts);
4740 if (ckWARN(WARN_EXEC)) {
4741 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4742 hadcmd ? VMScmd.dsc$w_length : 0,
4743 hadcmd ? VMScmd.dsc$a_pointer : "",
4750 } /* end of do_spawn() */
4754 static unsigned int *sockflags, sockflagsize;
4757 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4758 * routines found in some versions of the CRTL can't deal with sockets.
4759 * We don't shim the other file open routines since a socket isn't
4760 * likely to be opened by a name.
4762 /*{{{ FILE *my_fdopen(int fd, char *mode)*/
4763 FILE *my_fdopen(int fd, char *mode)
4765 FILE *fp = fdopen(fd,mode);
4768 unsigned int fdoff = fd / sizeof(unsigned int);
4769 struct stat sbuf; /* native stat; we don't need flex_stat */
4770 if (!sockflagsize || fdoff > sockflagsize) {
4771 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4772 else New (1324,sockflags,fdoff+2,unsigned int);
4773 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4774 sockflagsize = fdoff + 2;
4776 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4777 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4786 * Clear the corresponding bit when the (possibly) socket stream is closed.
4787 * There still a small hole: we miss an implicit close which might occur
4788 * via freopen(). >> Todo
4790 /*{{{ int my_fclose(FILE *fp)*/
4791 int my_fclose(FILE *fp) {
4793 unsigned int fd = fileno(fp);
4794 unsigned int fdoff = fd / sizeof(unsigned int);
4796 if (sockflagsize && fdoff <= sockflagsize)
4797 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4805 * A simple fwrite replacement which outputs itmsz*nitm chars without
4806 * introducing record boundaries every itmsz chars.
4807 * We are using fputs, which depends on a terminating null. We may
4808 * well be writing binary data, so we need to accommodate not only
4809 * data with nulls sprinkled in the middle but also data with no null
4812 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4814 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4816 register char *cp, *end, *cpd, *data;
4817 register unsigned int fd = fileno(dest);
4818 register unsigned int fdoff = fd / sizeof(unsigned int);
4820 int bufsize = itmsz * nitm + 1;
4822 if (fdoff < sockflagsize &&
4823 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4824 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4828 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4829 memcpy( data, src, itmsz*nitm );
4830 data[itmsz*nitm] = '\0';
4832 end = data + itmsz * nitm;
4833 retval = (int) nitm; /* on success return # items written */
4836 while (cpd <= end) {
4837 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4838 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4840 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4844 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4847 } /* end of my_fwrite() */
4850 /*{{{ int my_flush(FILE *fp)*/
4855 if ((res = fflush(fp)) == 0 && fp) {
4856 #ifdef VMS_DO_SOCKETS
4858 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4860 res = fsync(fileno(fp));
4863 * If the flush succeeded but set end-of-file, we need to clear
4864 * the error because our caller may check ferror(). BTW, this
4865 * probably means we just flushed an empty file.
4867 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4874 * Here are replacements for the following Unix routines in the VMS environment:
4875 * getpwuid Get information for a particular UIC or UID
4876 * getpwnam Get information for a named user
4877 * getpwent Get information for each user in the rights database
4878 * setpwent Reset search to the start of the rights database
4879 * endpwent Finish searching for users in the rights database
4881 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4882 * (defined in pwd.h), which contains the following fields:-
4884 * char *pw_name; Username (in lower case)
4885 * char *pw_passwd; Hashed password
4886 * unsigned int pw_uid; UIC
4887 * unsigned int pw_gid; UIC group number
4888 * char *pw_unixdir; Default device/directory (VMS-style)
4889 * char *pw_gecos; Owner name
4890 * char *pw_dir; Default device/directory (Unix-style)
4891 * char *pw_shell; Default CLI name (eg. DCL)
4893 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4895 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4896 * not the UIC member number (eg. what's returned by getuid()),
4897 * getpwuid() can accept either as input (if uid is specified, the caller's
4898 * UIC group is used), though it won't recognise gid=0.
4900 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4901 * information about other users in your group or in other groups, respectively.
4902 * If the required privilege is not available, then these routines fill only
4903 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4906 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4909 /* sizes of various UAF record fields */
4910 #define UAI$S_USERNAME 12
4911 #define UAI$S_IDENT 31
4912 #define UAI$S_OWNER 31
4913 #define UAI$S_DEFDEV 31
4914 #define UAI$S_DEFDIR 63
4915 #define UAI$S_DEFCLI 31
4918 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4919 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4920 (uic).uic$v_group != UIC$K_WILD_GROUP)
4922 static char __empty[]= "";
4923 static struct passwd __passwd_empty=
4924 {(char *) __empty, (char *) __empty, 0, 0,
4925 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4926 static int contxt= 0;
4927 static struct passwd __pwdcache;
4928 static char __pw_namecache[UAI$S_IDENT+1];
4931 * This routine does most of the work extracting the user information.
4933 static int fillpasswd (const char *name, struct passwd *pwd)
4937 unsigned char length;
4938 char pw_gecos[UAI$S_OWNER+1];
4940 static union uicdef uic;
4942 unsigned char length;
4943 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4946 unsigned char length;
4947 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4950 unsigned char length;
4951 char pw_shell[UAI$S_DEFCLI+1];
4953 static char pw_passwd[UAI$S_PWD+1];
4955 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4956 struct dsc$descriptor_s name_desc;
4957 unsigned long int sts;
4959 static struct itmlst_3 itmlst[]= {
4960 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4961 {sizeof(uic), UAI$_UIC, &uic, &luic},
4962 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
4963 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
4964 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
4965 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
4966 {0, 0, NULL, NULL}};
4968 name_desc.dsc$w_length= strlen(name);
4969 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4970 name_desc.dsc$b_class= DSC$K_CLASS_S;
4971 name_desc.dsc$a_pointer= (char *) name;
4973 /* Note that sys$getuai returns many fields as counted strings. */
4974 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4975 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4976 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4978 else { _ckvmssts(sts); }
4979 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
4981 if ((int) owner.length < lowner) lowner= (int) owner.length;
4982 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4983 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4984 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4985 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4986 owner.pw_gecos[lowner]= '\0';
4987 defdev.pw_dir[ldefdev+ldefdir]= '\0';
4988 defcli.pw_shell[ldefcli]= '\0';
4989 if (valid_uic(uic)) {
4990 pwd->pw_uid= uic.uic$l_uic;
4991 pwd->pw_gid= uic.uic$v_group;
4994 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
4995 pwd->pw_passwd= pw_passwd;
4996 pwd->pw_gecos= owner.pw_gecos;
4997 pwd->pw_dir= defdev.pw_dir;
4998 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
4999 pwd->pw_shell= defcli.pw_shell;
5000 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5002 ldir= strlen(pwd->pw_unixdir) - 1;
5003 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5006 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5007 __mystrtolower(pwd->pw_unixdir);
5012 * Get information for a named user.
5014 /*{{{struct passwd *getpwnam(char *name)*/
5015 struct passwd *my_getpwnam(char *name)
5017 struct dsc$descriptor_s name_desc;
5019 unsigned long int status, sts;
5022 __pwdcache = __passwd_empty;
5023 if (!fillpasswd(name, &__pwdcache)) {
5024 /* We still may be able to determine pw_uid and pw_gid */
5025 name_desc.dsc$w_length= strlen(name);
5026 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5027 name_desc.dsc$b_class= DSC$K_CLASS_S;
5028 name_desc.dsc$a_pointer= (char *) name;
5029 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5030 __pwdcache.pw_uid= uic.uic$l_uic;
5031 __pwdcache.pw_gid= uic.uic$v_group;
5034 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5035 set_vaxc_errno(sts);
5036 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5039 else { _ckvmssts(sts); }
5042 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5043 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5044 __pwdcache.pw_name= __pw_namecache;
5046 } /* end of my_getpwnam() */
5050 * Get information for a particular UIC or UID.
5051 * Called by my_getpwent with uid=-1 to list all users.
5053 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5054 struct passwd *my_getpwuid(Uid_t uid)
5056 const $DESCRIPTOR(name_desc,__pw_namecache);
5057 unsigned short lname;
5059 unsigned long int status;
5062 if (uid == (unsigned int) -1) {
5064 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5065 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5066 set_vaxc_errno(status);
5067 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5071 else { _ckvmssts(status); }
5072 } while (!valid_uic (uic));
5076 if (!uic.uic$v_group)
5077 uic.uic$v_group= PerlProc_getgid();
5079 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5080 else status = SS$_IVIDENT;
5081 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5082 status == RMS$_PRV) {
5083 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5086 else { _ckvmssts(status); }
5088 __pw_namecache[lname]= '\0';
5089 __mystrtolower(__pw_namecache);
5091 __pwdcache = __passwd_empty;
5092 __pwdcache.pw_name = __pw_namecache;
5094 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5095 The identifier's value is usually the UIC, but it doesn't have to be,
5096 so if we can, we let fillpasswd update this. */
5097 __pwdcache.pw_uid = uic.uic$l_uic;
5098 __pwdcache.pw_gid = uic.uic$v_group;
5100 fillpasswd(__pw_namecache, &__pwdcache);
5103 } /* end of my_getpwuid() */
5107 * Get information for next user.
5109 /*{{{struct passwd *my_getpwent()*/
5110 struct passwd *my_getpwent()
5112 return (my_getpwuid((unsigned int) -1));
5117 * Finish searching rights database for users.
5119 /*{{{void my_endpwent()*/
5124 _ckvmssts(sys$finish_rdb(&contxt));
5130 #ifdef HOMEGROWN_POSIX_SIGNALS
5131 /* Signal handling routines, pulled into the core from POSIX.xs.
5133 * We need these for threads, so they've been rolled into the core,
5134 * rather than left in POSIX.xs.
5136 * (DRS, Oct 23, 1997)
5139 /* sigset_t is atomic under VMS, so these routines are easy */
5140 /*{{{int my_sigemptyset(sigset_t *) */
5141 int my_sigemptyset(sigset_t *set) {
5142 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5148 /*{{{int my_sigfillset(sigset_t *)*/
5149 int my_sigfillset(sigset_t *set) {
5151 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5152 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5158 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5159 int my_sigaddset(sigset_t *set, int sig) {
5160 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5161 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5162 *set |= (1 << (sig - 1));
5168 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5169 int my_sigdelset(sigset_t *set, int sig) {
5170 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5171 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5172 *set &= ~(1 << (sig - 1));
5178 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5179 int my_sigismember(sigset_t *set, int sig) {
5180 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5181 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5182 *set & (1 << (sig - 1));
5187 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5188 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5191 /* If set and oset are both null, then things are badly wrong. Bail out. */
5192 if ((oset == NULL) && (set == NULL)) {
5193 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5197 /* If set's null, then we're just handling a fetch. */
5199 tempmask = sigblock(0);
5204 tempmask = sigsetmask(*set);
5207 tempmask = sigblock(*set);
5210 tempmask = sigblock(0);
5211 sigsetmask(*oset & ~tempmask);
5214 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5219 /* Did they pass us an oset? If so, stick our holding mask into it */
5226 #endif /* HOMEGROWN_POSIX_SIGNALS */
5229 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5230 * my_utime(), and flex_stat(), all of which operate on UTC unless
5231 * VMSISH_TIMES is true.
5233 /* method used to handle UTC conversions:
5234 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5236 static int gmtime_emulation_type;
5237 /* number of secs to add to UTC POSIX-style time to get local time */
5238 static long int utc_offset_secs;
5240 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5241 * in vmsish.h. #undef them here so we can call the CRTL routines
5250 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5251 * qualifier with the extern prefix pragma. This provisional
5252 * hack circumvents this prefix pragma problem in previous
5255 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5256 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5257 # pragma __extern_prefix save
5258 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5259 # define gmtime decc$__utctz_gmtime
5260 # define localtime decc$__utctz_localtime
5261 # define time decc$__utc_time
5262 # pragma __extern_prefix restore
5264 struct tm *gmtime(), *localtime();
5270 static time_t toutc_dst(time_t loc) {
5273 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5274 loc -= utc_offset_secs;
5275 if (rsltmp->tm_isdst) loc -= 3600;
5278 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5279 ((gmtime_emulation_type || my_time(NULL)), \
5280 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5281 ((secs) - utc_offset_secs))))
5283 static time_t toloc_dst(time_t utc) {
5286 utc += utc_offset_secs;
5287 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5288 if (rsltmp->tm_isdst) utc += 3600;
5291 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5292 ((gmtime_emulation_type || my_time(NULL)), \
5293 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5294 ((secs) + utc_offset_secs))))
5296 #ifndef RTL_USES_UTC
5299 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5300 DST starts on 1st sun of april at 02:00 std time
5301 ends on last sun of october at 02:00 dst time
5302 see the UCX management command reference, SET CONFIG TIMEZONE
5303 for formatting info.
5305 No, it's not as general as it should be, but then again, NOTHING
5306 will handle UK times in a sensible way.
5311 parse the DST start/end info:
5312 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5316 tz_parse_startend(char *s, struct tm *w, int *past)
5318 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5319 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5324 if (!past) return 0;
5327 if (w->tm_year % 4 == 0) ly = 1;
5328 if (w->tm_year % 100 == 0) ly = 0;
5329 if (w->tm_year+1900 % 400 == 0) ly = 1;
5332 dozjd = isdigit(*s);
5333 if (*s == 'J' || *s == 'j' || dozjd) {
5334 if (!dozjd && !isdigit(*++s)) return 0;
5337 d = d*10 + *s++ - '0';
5339 d = d*10 + *s++ - '0';
5342 if (d == 0) return 0;
5343 if (d > 366) return 0;
5345 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5348 } else if (*s == 'M' || *s == 'm') {
5349 if (!isdigit(*++s)) return 0;
5351 if (isdigit(*s)) m = 10*m + *s++ - '0';
5352 if (*s != '.') return 0;
5353 if (!isdigit(*++s)) return 0;
5355 if (n < 1 || n > 5) return 0;
5356 if (*s != '.') return 0;
5357 if (!isdigit(*++s)) return 0;
5359 if (d > 6) return 0;
5363 if (!isdigit(*++s)) return 0;
5365 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5367 if (!isdigit(*++s)) return 0;
5369 if (isdigit(*s)) min = 10*min + *s++ - '0';
5371 if (!isdigit(*++s)) return 0;
5373 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5383 if (w->tm_yday < d) goto before;
5384 if (w->tm_yday > d) goto after;
5386 if (w->tm_mon+1 < m) goto before;
5387 if (w->tm_mon+1 > m) goto after;
5389 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5390 k = d - j; /* mday of first d */
5392 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5393 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5394 if (w->tm_mday < k) goto before;
5395 if (w->tm_mday > k) goto after;
5398 if (w->tm_hour < hour) goto before;
5399 if (w->tm_hour > hour) goto after;
5400 if (w->tm_min < min) goto before;
5401 if (w->tm_min > min) goto after;
5402 if (w->tm_sec < sec) goto before;
5416 /* parse the offset: (+|-)hh[:mm[:ss]] */
5419 tz_parse_offset(char *s, int *offset)
5421 int hour = 0, min = 0, sec = 0;
5424 if (!offset) return 0;
5426 if (*s == '-') {neg++; s++;}
5428 if (!isdigit(*s)) return 0;
5430 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5431 if (hour > 24) return 0;
5433 if (!isdigit(*++s)) return 0;
5435 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5436 if (min > 59) return 0;
5438 if (!isdigit(*++s)) return 0;
5440 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5441 if (sec > 59) return 0;
5445 *offset = (hour*60+min)*60 + sec;
5446 if (neg) *offset = -*offset;
5451 input time is w, whatever type of time the CRTL localtime() uses.
5452 sets dst, the zone, and the gmtoff (seconds)
5454 caches the value of TZ and UCX$TZ env variables; note that
5455 my_setenv looks for these and sets a flag if they're changed
5458 We have to watch out for the "australian" case (dst starts in
5459 october, ends in april)...flagged by "reverse" and checked by
5460 scanning through the months of the previous year.
5465 tz_parse(time_t *w, int *dst, char *zone, int *gmtoff)
5470 char *dstzone, *tz, *s_start, *s_end;
5471 int std_off, dst_off, isdst;
5472 int y, dststart, dstend;
5473 static char envtz[1025]; /* longer than any logical, symbol, ... */
5474 static char ucxtz[1025];
5475 static char reversed = 0;
5481 reversed = -1; /* flag need to check */
5482 envtz[0] = ucxtz[0] = '\0';
5483 tz = my_getenv("TZ",0);
5484 if (tz) strcpy(envtz, tz);
5485 tz = my_getenv("UCX$TZ",0);
5486 if (tz) strcpy(ucxtz, tz);
5487 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5490 if (!*tz) tz = ucxtz;
5493 while (isalpha(*s)) s++;
5494 s = tz_parse_offset(s, &std_off);
5496 if (!*s) { /* no DST, hurray we're done! */
5502 while (isalpha(*s)) s++;
5503 s2 = tz_parse_offset(s, &dst_off);
5507 dst_off = std_off - 3600;
5510 if (!*s) { /* default dst start/end?? */
5511 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5512 s = strchr(ucxtz,',');
5514 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5516 if (*s != ',') return 0;
5519 when = _toutc(when); /* convert to utc */
5520 when = when - std_off; /* convert to pseudolocal time*/
5522 w2 = localtime(&when);
5525 s = tz_parse_startend(s_start,w2,&dststart);
5527 if (*s != ',') return 0;
5530 when = _toutc(when); /* convert to utc */
5531 when = when - dst_off; /* convert to pseudolocal time*/
5532 w2 = localtime(&when);
5533 if (w2->tm_year != y) { /* spans a year, just check one time */
5534 when += dst_off - std_off;
5535 w2 = localtime(&when);
5538 s = tz_parse_startend(s_end,w2,&dstend);
5541 if (reversed == -1) { /* need to check if start later than end */
5545 if (when < 2*365*86400) {
5546 when += 2*365*86400;
5550 w2 =localtime(&when);
5551 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5553 for (j = 0; j < 12; j++) {
5554 w2 =localtime(&when);
5555 (void) tz_parse_startend(s_start,w2,&ds);
5556 (void) tz_parse_startend(s_end,w2,&de);
5557 if (ds != de) break;
5561 if (de && !ds) reversed = 1;
5564 isdst = dststart && !dstend;
5565 if (reversed) isdst = dststart || !dstend;
5568 if (dst) *dst = isdst;
5569 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5570 if (isdst) tz = dstzone;
5572 while(isalpha(*tz)) *zone++ = *tz++;
5578 #endif /* !RTL_USES_UTC */
5580 /* my_time(), my_localtime(), my_gmtime()
5581 * By default traffic in UTC time values, using CRTL gmtime() or
5582 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5583 * Note: We need to use these functions even when the CRTL has working
5584 * UTC support, since they also handle C<use vmsish qw(times);>
5586 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5587 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5590 /*{{{time_t my_time(time_t *timep)*/
5591 time_t my_time(time_t *timep)
5597 if (gmtime_emulation_type == 0) {
5599 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5600 /* results of calls to gmtime() and localtime() */
5601 /* for same &base */
5603 gmtime_emulation_type++;
5604 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5605 char off[LNM$C_NAMLENGTH+1];;
5607 gmtime_emulation_type++;
5608 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5609 gmtime_emulation_type++;
5610 utc_offset_secs = 0;
5611 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5613 else { utc_offset_secs = atol(off); }
5615 else { /* We've got a working gmtime() */
5616 struct tm gmt, local;
5619 tm_p = localtime(&base);
5621 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5622 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5623 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5624 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5630 # ifdef RTL_USES_UTC
5631 if (VMSISH_TIME) when = _toloc(when);
5633 if (!VMSISH_TIME) when = _toutc(when);
5636 if (timep != NULL) *timep = when;
5639 } /* end of my_time() */
5643 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5645 my_gmtime(const time_t *timep)
5652 if (timep == NULL) {
5653 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5656 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5660 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5662 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5663 return gmtime(&when);
5665 /* CRTL localtime() wants local time as input, so does no tz correction */
5666 rsltmp = localtime(&when);
5667 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5670 } /* end of my_gmtime() */
5674 /*{{{struct tm *my_localtime(const time_t *timep)*/
5676 my_localtime(const time_t *timep)
5679 time_t when, whenutc;
5683 if (timep == NULL) {
5684 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5687 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5688 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5691 # ifdef RTL_USES_UTC
5693 if (VMSISH_TIME) when = _toutc(when);
5695 /* CRTL localtime() wants UTC as input, does tz correction itself */
5696 return localtime(&when);
5698 # else /* !RTL_USES_UTC */
5701 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5702 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5705 #ifndef RTL_USES_UTC
5706 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5707 when = whenutc - offset; /* pseudolocal time*/
5710 /* CRTL localtime() wants local time as input, so does no tz correction */
5711 rsltmp = localtime(&when);
5712 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5716 } /* end of my_localtime() */
5719 /* Reset definitions for later calls */
5720 #define gmtime(t) my_gmtime(t)
5721 #define localtime(t) my_localtime(t)
5722 #define time(t) my_time(t)
5725 /* my_utime - update modification time of a file
5726 * calling sequence is identical to POSIX utime(), but under
5727 * VMS only the modification time is changed; ODS-2 does not
5728 * maintain access times. Restrictions differ from the POSIX
5729 * definition in that the time can be changed as long as the
5730 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5731 * no separate checks are made to insure that the caller is the
5732 * owner of the file or has special privs enabled.
5733 * Code here is based on Joe Meadows' FILE utility.
5736 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5737 * to VMS epoch (01-JAN-1858 00:00:00.00)
5738 * in 100 ns intervals.
5740 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5742 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5743 int my_utime(char *file, struct utimbuf *utimes)
5747 long int bintime[2], len = 2, lowbit, unixtime,
5748 secscale = 10000000; /* seconds --> 100 ns intervals */
5749 unsigned long int chan, iosb[2], retsts;
5750 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5751 struct FAB myfab = cc$rms_fab;
5752 struct NAM mynam = cc$rms_nam;
5753 #if defined (__DECC) && defined (__VAX)
5754 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5755 * at least through VMS V6.1, which causes a type-conversion warning.
5757 # pragma message save
5758 # pragma message disable cvtdiftypes
5760 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5761 struct fibdef myfib;
5762 #if defined (__DECC) && defined (__VAX)
5763 /* This should be right after the declaration of myatr, but due
5764 * to a bug in VAX DEC C, this takes effect a statement early.
5766 # pragma message restore
5768 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5769 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5770 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5772 if (file == NULL || *file == '\0') {
5774 set_vaxc_errno(LIB$_INVARG);
5777 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5779 if (utimes != NULL) {
5780 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5781 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5782 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5783 * as input, we force the sign bit to be clear by shifting unixtime right
5784 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5786 lowbit = (utimes->modtime & 1) ? secscale : 0;
5787 unixtime = (long int) utimes->modtime;
5789 /* If input was UTC; convert to local for sys svc */
5790 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5792 unixtime >>= 1; secscale <<= 1;
5793 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5794 if (!(retsts & 1)) {
5796 set_vaxc_errno(retsts);
5799 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5800 if (!(retsts & 1)) {
5802 set_vaxc_errno(retsts);
5807 /* Just get the current time in VMS format directly */
5808 retsts = sys$gettim(bintime);
5809 if (!(retsts & 1)) {
5811 set_vaxc_errno(retsts);
5816 myfab.fab$l_fna = vmsspec;
5817 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5818 myfab.fab$l_nam = &mynam;
5819 mynam.nam$l_esa = esa;
5820 mynam.nam$b_ess = (unsigned char) sizeof esa;
5821 mynam.nam$l_rsa = rsa;
5822 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5824 /* Look for the file to be affected, letting RMS parse the file
5825 * specification for us as well. I have set errno using only
5826 * values documented in the utime() man page for VMS POSIX.
5828 retsts = sys$parse(&myfab,0,0);
5829 if (!(retsts & 1)) {
5830 set_vaxc_errno(retsts);
5831 if (retsts == RMS$_PRV) set_errno(EACCES);
5832 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5833 else set_errno(EVMSERR);
5836 retsts = sys$search(&myfab,0,0);
5837 if (!(retsts & 1)) {
5838 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5839 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5840 set_vaxc_errno(retsts);
5841 if (retsts == RMS$_PRV) set_errno(EACCES);
5842 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5843 else set_errno(EVMSERR);
5847 devdsc.dsc$w_length = mynam.nam$b_dev;
5848 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5850 retsts = sys$assign(&devdsc,&chan,0,0);
5851 if (!(retsts & 1)) {
5852 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5853 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5854 set_vaxc_errno(retsts);
5855 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5856 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5857 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5858 else set_errno(EVMSERR);
5862 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5863 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5865 memset((void *) &myfib, 0, sizeof myfib);
5866 #if defined(__DECC) || defined(__DECCXX)
5867 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5868 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5869 /* This prevents the revision time of the file being reset to the current
5870 * time as a result of our IO$_MODIFY $QIO. */
5871 myfib.fib$l_acctl = FIB$M_NORECORD;
5873 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5874 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5875 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5877 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5878 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5879 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5880 _ckvmssts(sys$dassgn(chan));
5881 if (retsts & 1) retsts = iosb[0];
5882 if (!(retsts & 1)) {
5883 set_vaxc_errno(retsts);
5884 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5885 else set_errno(EVMSERR);
5890 } /* end of my_utime() */
5894 * flex_stat, flex_fstat
5895 * basic stat, but gets it right when asked to stat
5896 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5899 /* encode_dev packs a VMS device name string into an integer to allow
5900 * simple comparisons. This can be used, for example, to check whether two
5901 * files are located on the same device, by comparing their encoded device
5902 * names. Even a string comparison would not do, because stat() reuses the
5903 * device name buffer for each call; so without encode_dev, it would be
5904 * necessary to save the buffer and use strcmp (this would mean a number of
5905 * changes to the standard Perl code, to say nothing of what a Perl script
5908 * The device lock id, if it exists, should be unique (unless perhaps compared
5909 * with lock ids transferred from other nodes). We have a lock id if the disk is
5910 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5911 * device names. Thus we use the lock id in preference, and only if that isn't
5912 * available, do we try to pack the device name into an integer (flagged by
5913 * the sign bit (LOCKID_MASK) being set).
5915 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5916 * name and its encoded form, but it seems very unlikely that we will find
5917 * two files on different disks that share the same encoded device names,
5918 * and even more remote that they will share the same file id (if the test
5919 * is to check for the same file).
5921 * A better method might be to use sys$device_scan on the first call, and to
5922 * search for the device, returning an index into the cached array.
5923 * The number returned would be more intelligable.
5924 * This is probably not worth it, and anyway would take quite a bit longer
5925 * on the first call.
5927 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5928 static mydev_t encode_dev (const char *dev)
5931 unsigned long int f;
5937 if (!dev || !dev[0]) return 0;
5941 struct dsc$descriptor_s dev_desc;
5942 unsigned long int status, lockid, item = DVI$_LOCKID;
5944 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5945 can try that first. */
5946 dev_desc.dsc$w_length = strlen (dev);
5947 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5948 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5949 dev_desc.dsc$a_pointer = (char *) dev;
5950 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5951 if (lockid) return (lockid & ~LOCKID_MASK);
5955 /* Otherwise we try to encode the device name */
5959 for (q = dev + strlen(dev); q--; q >= dev) {
5962 else if (isalpha (toupper (*q)))
5963 c= toupper (*q) - 'A' + (char)10;
5965 continue; /* Skip '$'s */
5967 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5969 enc += f * (unsigned long int) c;
5971 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
5973 } /* end of encode_dev() */
5975 static char namecache[NAM$C_MAXRSS+1];
5978 is_null_device(name)
5982 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5983 The underscore prefix, controller letter, and unit number are
5984 independently optional; for our purposes, the colon punctuation
5985 is not. The colon can be trailed by optional directory and/or
5986 filename, but two consecutive colons indicates a nodename rather
5987 than a device. [pr] */
5988 if (*name == '_') ++name;
5989 if (tolower(*name++) != 'n') return 0;
5990 if (tolower(*name++) != 'l') return 0;
5991 if (tolower(*name) == 'a') ++name;
5992 if (*name == '0') ++name;
5993 return (*name++ == ':') && (*name != ':');
5996 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
5997 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
5998 * subset of the applicable information.
6001 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6003 char fname_phdev[NAM$C_MAXRSS+1];
6004 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6006 char fname[NAM$C_MAXRSS+1];
6007 unsigned long int retsts;
6008 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6009 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6011 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6012 device name on successive calls */
6013 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6014 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6015 namdsc.dsc$a_pointer = fname;
6016 namdsc.dsc$w_length = sizeof fname - 1;
6018 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6019 &namdsc,&namdsc.dsc$w_length,0,0);
6021 fname[namdsc.dsc$w_length] = '\0';
6023 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6024 * but if someone has redefined that logical, Perl gets very lost. Since
6025 * we have the physical device name from the stat buffer, just paste it on.
6027 strcpy( fname_phdev, statbufp->st_devnam );
6028 strcat( fname_phdev, strrchr(fname, ':') );
6030 return cando_by_name(bit,effective,fname_phdev);
6032 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6033 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6037 return FALSE; /* Should never get to here */
6039 } /* end of cando() */
6043 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6045 cando_by_name(I32 bit, Uid_t effective, char *fname)
6047 static char usrname[L_cuserid];
6048 static struct dsc$descriptor_s usrdsc =
6049 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6050 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6051 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6052 unsigned short int retlen;
6054 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6055 union prvdef curprv;
6056 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6057 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6058 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6061 if (!fname || !*fname) return FALSE;
6062 /* Make sure we expand logical names, since sys$check_access doesn't */
6063 if (!strpbrk(fname,"/]>:")) {
6064 strcpy(fileified,fname);
6065 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6068 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6069 retlen = namdsc.dsc$w_length = strlen(vmsname);
6070 namdsc.dsc$a_pointer = vmsname;
6071 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6072 vmsname[retlen-1] == ':') {
6073 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6074 namdsc.dsc$w_length = strlen(fileified);
6075 namdsc.dsc$a_pointer = fileified;
6078 if (!usrdsc.dsc$w_length) {
6080 usrdsc.dsc$w_length = strlen(usrname);
6084 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6085 access = ARM$M_EXECUTE; break;
6086 case S_IRUSR: case S_IRGRP: case S_IROTH:
6087 access = ARM$M_READ; break;
6088 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6089 access = ARM$M_WRITE; break;
6090 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6091 access = ARM$M_DELETE; break;
6096 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6097 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6098 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6099 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6100 set_vaxc_errno(retsts);
6101 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6102 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6103 else set_errno(ENOENT);
6106 if (retsts == SS$_NORMAL) {
6107 if (!privused) return TRUE;
6108 /* We can get access, but only by using privs. Do we have the
6109 necessary privs currently enabled? */
6110 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6111 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6112 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6113 !curprv.prv$v_bypass) return FALSE;
6114 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6115 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6116 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6119 if (retsts == SS$_ACCONFLICT) {
6124 return FALSE; /* Should never get here */
6126 } /* end of cando_by_name() */
6130 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6132 flex_fstat(int fd, Stat_t *statbufp)
6135 if (!fstat(fd,(stat_t *) statbufp)) {
6136 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6137 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6138 # ifdef RTL_USES_UTC
6141 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6142 statbufp->st_atime = _toloc(statbufp->st_atime);
6143 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6148 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6152 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6153 statbufp->st_atime = _toutc(statbufp->st_atime);
6154 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6161 } /* end of flex_fstat() */
6164 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6166 flex_stat(const char *fspec, Stat_t *statbufp)
6169 char fileified[NAM$C_MAXRSS+1];
6170 char temp_fspec[NAM$C_MAXRSS+300];
6173 strcpy(temp_fspec, fspec);
6174 if (statbufp == (Stat_t *) &PL_statcache)
6175 do_tovmsspec(temp_fspec,namecache,0);
6176 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6177 memset(statbufp,0,sizeof *statbufp);
6178 statbufp->st_dev = encode_dev("_NLA0:");
6179 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6180 statbufp->st_uid = 0x00010001;
6181 statbufp->st_gid = 0x0001;
6182 time((time_t *)&statbufp->st_mtime);
6183 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6187 /* Try for a directory name first. If fspec contains a filename without
6188 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6189 * and sea:[wine.dark]water. exist, we prefer the directory here.
6190 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6191 * not sea:[wine.dark]., if the latter exists. If the intended target is
6192 * the file with null type, specify this by calling flex_stat() with
6193 * a '.' at the end of fspec.
6195 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6196 retval = stat(fileified,(stat_t *) statbufp);
6197 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6198 strcpy(namecache,fileified);
6200 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6202 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6203 # ifdef RTL_USES_UTC
6206 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6207 statbufp->st_atime = _toloc(statbufp->st_atime);
6208 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6213 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6217 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6218 statbufp->st_atime = _toutc(statbufp->st_atime);
6219 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6225 } /* end of flex_stat() */
6229 /*{{{char *my_getlogin()*/
6230 /* VMS cuserid == Unix getlogin, except calling sequence */
6234 static char user[L_cuserid];
6235 return cuserid(user);
6240 /* rmscopy - copy a file using VMS RMS routines
6242 * Copies contents and attributes of spec_in to spec_out, except owner
6243 * and protection information. Name and type of spec_in are used as
6244 * defaults for spec_out. The third parameter specifies whether rmscopy()
6245 * should try to propagate timestamps from the input file to the output file.
6246 * If it is less than 0, no timestamps are preserved. If it is 0, then
6247 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6248 * propagated to the output file at creation iff the output file specification
6249 * did not contain an explicit name or type, and the revision date is always
6250 * updated at the end of the copy operation. If it is greater than 0, then
6251 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6252 * other than the revision date should be propagated, and bit 1 indicates
6253 * that the revision date should be propagated.
6255 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6257 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6258 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6259 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6260 * as part of the Perl standard distribution under the terms of the
6261 * GNU General Public License or the Perl Artistic License. Copies
6262 * of each may be found in the Perl standard distribution.
6264 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6266 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6268 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6269 rsa[NAM$C_MAXRSS], ubf[32256];
6270 unsigned long int i, sts, sts2;
6271 struct FAB fab_in, fab_out;
6272 struct RAB rab_in, rab_out;
6274 struct XABDAT xabdat;
6275 struct XABFHC xabfhc;
6276 struct XABRDT xabrdt;
6277 struct XABSUM xabsum;
6279 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6280 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6281 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6285 fab_in = cc$rms_fab;
6286 fab_in.fab$l_fna = vmsin;
6287 fab_in.fab$b_fns = strlen(vmsin);
6288 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6289 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6290 fab_in.fab$l_fop = FAB$M_SQO;
6291 fab_in.fab$l_nam = &nam;
6292 fab_in.fab$l_xab = (void *) &xabdat;
6295 nam.nam$l_rsa = rsa;
6296 nam.nam$b_rss = sizeof(rsa);
6297 nam.nam$l_esa = esa;
6298 nam.nam$b_ess = sizeof (esa);
6299 nam.nam$b_esl = nam.nam$b_rsl = 0;
6301 xabdat = cc$rms_xabdat; /* To get creation date */
6302 xabdat.xab$l_nxt = (void *) &xabfhc;
6304 xabfhc = cc$rms_xabfhc; /* To get record length */
6305 xabfhc.xab$l_nxt = (void *) &xabsum;
6307 xabsum = cc$rms_xabsum; /* To get key and area information */
6309 if (!((sts = sys$open(&fab_in)) & 1)) {
6310 set_vaxc_errno(sts);
6312 case RMS$_FNF: case RMS$_DNF:
6313 set_errno(ENOENT); break;
6315 set_errno(ENOTDIR); break;
6317 set_errno(ENODEV); break;
6319 set_errno(EINVAL); break;
6321 set_errno(EACCES); break;
6329 fab_out.fab$w_ifi = 0;
6330 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6331 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6332 fab_out.fab$l_fop = FAB$M_SQO;
6333 fab_out.fab$l_fna = vmsout;
6334 fab_out.fab$b_fns = strlen(vmsout);
6335 fab_out.fab$l_dna = nam.nam$l_name;
6336 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6338 if (preserve_dates == 0) { /* Act like DCL COPY */
6339 nam.nam$b_nop = NAM$M_SYNCHK;
6340 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6341 if (!((sts = sys$parse(&fab_out)) & 1)) {
6342 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6343 set_vaxc_errno(sts);
6346 fab_out.fab$l_xab = (void *) &xabdat;
6347 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6349 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6350 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6351 preserve_dates =0; /* bitmask from this point forward */
6353 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6354 if (!((sts = sys$create(&fab_out)) & 1)) {
6355 set_vaxc_errno(sts);
6358 set_errno(ENOENT); break;
6360 set_errno(ENOTDIR); break;
6362 set_errno(ENODEV); break;
6364 set_errno(EINVAL); break;
6366 set_errno(EACCES); break;
6372 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6373 if (preserve_dates & 2) {
6374 /* sys$close() will process xabrdt, not xabdat */
6375 xabrdt = cc$rms_xabrdt;
6377 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6379 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6380 * is unsigned long[2], while DECC & VAXC use a struct */
6381 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6383 fab_out.fab$l_xab = (void *) &xabrdt;
6386 rab_in = cc$rms_rab;
6387 rab_in.rab$l_fab = &fab_in;
6388 rab_in.rab$l_rop = RAB$M_BIO;
6389 rab_in.rab$l_ubf = ubf;
6390 rab_in.rab$w_usz = sizeof ubf;
6391 if (!((sts = sys$connect(&rab_in)) & 1)) {
6392 sys$close(&fab_in); sys$close(&fab_out);
6393 set_errno(EVMSERR); set_vaxc_errno(sts);
6397 rab_out = cc$rms_rab;
6398 rab_out.rab$l_fab = &fab_out;
6399 rab_out.rab$l_rbf = ubf;
6400 if (!((sts = sys$connect(&rab_out)) & 1)) {
6401 sys$close(&fab_in); sys$close(&fab_out);
6402 set_errno(EVMSERR); set_vaxc_errno(sts);
6406 while ((sts = sys$read(&rab_in))) { /* always true */
6407 if (sts == RMS$_EOF) break;
6408 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6409 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6410 sys$close(&fab_in); sys$close(&fab_out);
6411 set_errno(EVMSERR); set_vaxc_errno(sts);
6416 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6417 sys$close(&fab_in); sys$close(&fab_out);
6418 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6420 set_errno(EVMSERR); set_vaxc_errno(sts);
6426 } /* end of rmscopy() */
6430 /*** The following glue provides 'hooks' to make some of the routines
6431 * from this file available from Perl. These routines are sufficiently
6432 * basic, and are required sufficiently early in the build process,
6433 * that's it's nice to have them available to miniperl as well as the
6434 * full Perl, so they're set up here instead of in an extension. The
6435 * Perl code which handles importation of these names into a given
6436 * package lives in [.VMS]Filespec.pm in @INC.
6440 rmsexpand_fromperl(pTHX_ CV *cv)
6443 char *fspec, *defspec = NULL, *rslt;
6446 if (!items || items > 2)
6447 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6448 fspec = SvPV(ST(0),n_a);
6449 if (!fspec || !*fspec) XSRETURN_UNDEF;
6450 if (items == 2) defspec = SvPV(ST(1),n_a);
6452 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6453 ST(0) = sv_newmortal();
6454 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6459 vmsify_fromperl(pTHX_ CV *cv)
6465 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6466 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6467 ST(0) = sv_newmortal();
6468 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6473 unixify_fromperl(pTHX_ CV *cv)
6479 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6480 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6481 ST(0) = sv_newmortal();
6482 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6487 fileify_fromperl(pTHX_ CV *cv)
6493 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6494 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6495 ST(0) = sv_newmortal();
6496 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6501 pathify_fromperl(pTHX_ CV *cv)
6507 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6508 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6509 ST(0) = sv_newmortal();
6510 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6515 vmspath_fromperl(pTHX_ CV *cv)
6521 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6522 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6523 ST(0) = sv_newmortal();
6524 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6529 unixpath_fromperl(pTHX_ CV *cv)
6535 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6536 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6537 ST(0) = sv_newmortal();
6538 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6543 candelete_fromperl(pTHX_ CV *cv)
6546 char fspec[NAM$C_MAXRSS+1], *fsp;
6551 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6553 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6554 if (SvTYPE(mysv) == SVt_PVGV) {
6555 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6556 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6563 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6564 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6570 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6575 rmscopy_fromperl(pTHX_ CV *cv)
6578 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6580 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6581 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6582 unsigned long int sts;
6587 if (items < 2 || items > 3)
6588 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6590 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6591 if (SvTYPE(mysv) == SVt_PVGV) {
6592 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6593 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6600 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6601 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6606 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6607 if (SvTYPE(mysv) == SVt_PVGV) {
6608 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6609 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6616 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6617 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6622 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6624 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6633 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6634 workbuff[NAM$C_MAXRSS*1 + 1];
6635 int total_namelen = 3, counter, num_entries;
6636 /* ODS-5 ups this, but we want to be consistent, so... */
6637 int max_name_len = 39;
6638 AV *in_array = (AV *)SvRV(ST(0));
6640 num_entries = av_len(in_array);
6642 /* All the names start with PL_. */
6643 strcpy(ultimate_name, "PL_");
6645 /* Clean up our working buffer */
6646 Zero(work_name, sizeof(work_name), char);
6648 /* Run through the entries and build up a working name */
6649 for(counter = 0; counter <= num_entries; counter++) {
6650 /* If it's not the first name then tack on a __ */
6652 strcat(work_name, "__");
6654 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6658 /* Check to see if we actually have to bother...*/
6659 if (strlen(work_name) + 3 <= max_name_len) {
6660 strcat(ultimate_name, work_name);
6662 /* It's too darned big, so we need to go strip. We use the same */
6663 /* algorithm as xsubpp does. First, strip out doubled __ */
6664 char *source, *dest, last;
6667 for (source = work_name; *source; source++) {
6668 if (last == *source && last == '_') {
6674 /* Go put it back */
6675 strcpy(work_name, workbuff);
6676 /* Is it still too big? */
6677 if (strlen(work_name) + 3 > max_name_len) {
6678 /* Strip duplicate letters */
6681 for (source = work_name; *source; source++) {
6682 if (last == toupper(*source)) {
6686 last = toupper(*source);
6688 strcpy(work_name, workbuff);
6691 /* Is it *still* too big? */
6692 if (strlen(work_name) + 3 > max_name_len) {
6693 /* Too bad, we truncate */
6694 work_name[max_name_len - 2] = 0;
6696 strcat(ultimate_name, work_name);
6699 /* Okay, return it */
6700 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6707 char* file = __FILE__;
6709 char temp_buff[512];
6710 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6711 no_translate_barewords = TRUE;
6713 no_translate_barewords = FALSE;
6716 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6717 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6718 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6719 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6720 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6721 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6722 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6723 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6724 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6725 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);