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;
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 */
320 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
321 if (vmstrnenv(lnm,eqv,idx,
323 #ifdef SECURE_INTERNAL_GETENV
324 sys ? PERL__TRNENV_SECURE : 0
332 } /* end of my_getenv() */
336 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
338 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
341 char *buf, *cp1, *cp2;
342 unsigned long idx = 0;
343 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
346 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
347 /* Set up a temporary buffer for the return value; Perl will
348 * clean it up at the next statement transition */
349 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
350 if (!tmpsv) return NULL;
353 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
354 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
355 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
356 getcwd(buf,LNM$C_NAMLENGTH);
361 if ((cp2 = strchr(lnm,';')) != NULL) {
364 idx = strtoul(cp2+1,NULL,0);
367 /* Impose security constraints only if tainting */
368 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
369 if ((*len = vmstrnenv(lnm,buf,idx,
371 #ifdef SECURE_INTERNAL_GETENV
372 sys ? PERL__TRNENV_SECURE : 0
382 } /* end of my_getenv_len() */
385 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
387 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
389 /*{{{ void prime_env_iter() */
392 /* Fill the %ENV associative array with all logical names we can
393 * find, in preparation for iterating over it.
397 static int primed = 0;
398 HV *seenhv = NULL, *envhv;
399 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
400 unsigned short int chan;
401 #ifndef CLI$M_TRUSTED
402 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
404 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
405 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
407 bool have_sym = FALSE, have_lnm = FALSE;
408 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
409 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
410 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
411 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
412 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
413 #if defined(USE_THREADS) || defined(USE_ITHREADS)
414 static perl_mutex primenv_mutex;
415 MUTEX_INIT(&primenv_mutex);
418 if (primed || !PL_envgv) return;
419 MUTEX_LOCK(&primenv_mutex);
420 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
421 envhv = GvHVn(PL_envgv);
422 /* Perform a dummy fetch as an lval to insure that the hash table is
423 * set up. Otherwise, the hv_store() will turn into a nullop. */
424 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
426 for (i = 0; env_tables[i]; i++) {
427 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
428 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
429 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
431 if (have_sym || have_lnm) {
432 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
433 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
434 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
435 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
438 for (i--; i >= 0; i--) {
439 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
442 for (j = 0; environ[j]; j++) {
443 if (!(start = strchr(environ[j],'='))) {
444 if (ckWARN(WARN_INTERNAL))
445 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
449 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
455 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
456 !str$case_blind_compare(&tmpdsc,&clisym)) {
457 strcpy(cmd,"Show Symbol/Global *");
458 cmddsc.dsc$w_length = 20;
459 if (env_tables[i]->dsc$w_length == 12 &&
460 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
461 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
462 flags = defflags | CLI$M_NOLOGNAM;
465 strcpy(cmd,"Show Logical *");
466 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
467 strcat(cmd," /Table=");
468 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
469 cmddsc.dsc$w_length = strlen(cmd);
471 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
472 flags = defflags | CLI$M_NOCLISYM;
475 /* Create a new subprocess to execute each command, to exclude the
476 * remote possibility that someone could subvert a mbx or file used
477 * to write multiple commands to a single subprocess.
480 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
481 0,&riseandshine,0,0,&clidsc,&clitabdsc);
482 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
483 defflags &= ~CLI$M_TRUSTED;
484 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
486 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
487 if (seenhv) SvREFCNT_dec(seenhv);
490 char *cp1, *cp2, *key;
491 unsigned long int sts, iosb[2], retlen, keylen;
494 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
495 if (sts & 1) sts = iosb[0] & 0xffff;
496 if (sts == SS$_ENDOFFILE) {
498 while (substs == 0) { sys$hiber(); wakect++;}
499 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
504 retlen = iosb[0] >> 16;
505 if (!retlen) continue; /* blank line */
507 if (iosb[1] != subpid) {
509 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
513 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
514 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
516 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
517 if (*cp1 == '(' || /* Logical name table name */
518 *cp1 == '=' /* Next eqv of searchlist */) continue;
519 if (*cp1 == '"') cp1++;
520 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
521 key = cp1; keylen = cp2 - cp1;
522 if (keylen && hv_exists(seenhv,key,keylen)) continue;
523 while (*cp2 && *cp2 != '=') cp2++;
524 while (*cp2 && *cp2 == '=') cp2++;
525 while (*cp2 && *cp2 == ' ') cp2++;
526 if (*cp2 == '"') { /* String translation; may embed "" */
527 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
528 cp2++; cp1--; /* Skip "" surrounding translation */
530 else { /* Numeric translation */
531 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
532 cp1--; /* stop on last non-space char */
534 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
535 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
538 PERL_HASH(hash,key,keylen);
539 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
540 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
542 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
543 /* get the PPFs for this process, not the subprocess */
544 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
545 char eqv[LNM$C_NAMLENGTH+1];
547 for (i = 0; ppfs[i]; i++) {
548 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
549 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
554 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
555 if (buf) Safefree(buf);
556 if (seenhv) SvREFCNT_dec(seenhv);
557 MUTEX_UNLOCK(&primenv_mutex);
560 } /* end of prime_env_iter */
564 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
565 /* Define or delete an element in the same "environment" as
566 * vmstrnenv(). If an element is to be deleted, it's removed from
567 * the first place it's found. If it's to be set, it's set in the
568 * place designated by the first element of the table vector.
569 * Like setenv() returns 0 for success, non-zero on error.
572 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
574 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
575 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
576 unsigned long int retsts, usermode = PSL$C_USER;
577 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
578 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
579 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
580 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
581 $DESCRIPTOR(local,"_LOCAL");
584 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
585 *cp2 = _toupper(*cp1);
586 if (cp1 - lnm > LNM$C_NAMLENGTH) {
587 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
591 lnmdsc.dsc$w_length = cp1 - lnm;
592 if (!tabvec || !*tabvec) tabvec = env_tables;
594 if (!eqv) { /* we're deleting n element */
595 for (curtab = 0; tabvec[curtab]; curtab++) {
596 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
598 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
599 if ((cp1 = strchr(environ[i],'=')) &&
600 !strncmp(environ[i],lnm,cp1 - environ[i])) {
602 return setenv(lnm,"",1) ? vaxc$errno : 0;
605 ivenv = 1; retsts = SS$_NOLOGNAM;
607 if (ckWARN(WARN_INTERNAL))
608 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
609 ivenv = 1; retsts = SS$_NOSUCHPGM;
615 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
616 !str$case_blind_compare(&tmpdsc,&clisym)) {
617 unsigned int symtype;
618 if (tabvec[curtab]->dsc$w_length == 12 &&
619 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
620 !str$case_blind_compare(&tmpdsc,&local))
621 symtype = LIB$K_CLI_LOCAL_SYM;
622 else symtype = LIB$K_CLI_GLOBAL_SYM;
623 retsts = lib$delete_symbol(&lnmdsc,&symtype);
624 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
625 if (retsts == LIB$_NOSUCHSYM) continue;
629 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
630 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
631 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
632 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
633 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
637 else { /* we're defining a value */
638 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
640 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
642 if (ckWARN(WARN_INTERNAL))
643 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
644 retsts = SS$_NOSUCHPGM;
648 eqvdsc.dsc$a_pointer = eqv;
649 eqvdsc.dsc$w_length = strlen(eqv);
650 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
651 !str$case_blind_compare(&tmpdsc,&clisym)) {
652 unsigned int symtype;
653 if (tabvec[0]->dsc$w_length == 12 &&
654 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
655 !str$case_blind_compare(&tmpdsc,&local))
656 symtype = LIB$K_CLI_LOCAL_SYM;
657 else symtype = LIB$K_CLI_GLOBAL_SYM;
658 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
661 if (!*eqv) eqvdsc.dsc$w_length = 1;
662 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
663 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
664 if (ckWARN(WARN_MISC)) {
665 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
668 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
674 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
675 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
676 set_errno(EVMSERR); break;
677 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
678 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
679 set_errno(EINVAL); break;
686 set_vaxc_errno(retsts);
687 return (int) retsts || 44; /* retsts should never be 0, but just in case */
690 /* We reset error values on success because Perl does an hv_fetch()
691 * before each hv_store(), and if the thing we're setting didn't
692 * previously exist, we've got a leftover error message. (Of course,
693 * this fails in the face of
694 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
695 * in that the error reported in $! isn't spurious,
696 * but it's right more often than not.)
698 set_errno(0); set_vaxc_errno(retsts);
702 } /* end of vmssetenv() */
705 /*{{{ void my_setenv(char *lnm, char *eqv)*/
706 /* This has to be a function since there's a prototype for it in proto.h */
708 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
711 int len = strlen(lnm);
715 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
716 if (!strcmp(uplnm,"DEFAULT")) {
717 if (eqv && *eqv) chdir(eqv);
722 if (len == 6 || len == 2) {
725 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
727 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
728 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
732 (void) vmssetenv(lnm,eqv,NULL);
736 /*{{{static void vmssetuserlnm(char *name, char *eqv);
738 * sets a user-mode logical in the process logical name table
739 * used for redirection of sys$error
742 Perl_vmssetuserlnm(char *name, char *eqv)
744 $DESCRIPTOR(d_tab, "LNM$PROCESS");
745 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
746 unsigned long int iss, attr = 0;
747 unsigned char acmode = PSL$C_USER;
748 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
750 d_name.dsc$a_pointer = name;
751 d_name.dsc$w_length = strlen(name);
753 lnmlst[0].buflen = strlen(eqv);
754 lnmlst[0].bufadr = eqv;
756 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
757 if (!(iss&1)) lib$signal(iss);
762 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
763 /* my_crypt - VMS password hashing
764 * my_crypt() provides an interface compatible with the Unix crypt()
765 * C library function, and uses sys$hash_password() to perform VMS
766 * password hashing. The quadword hashed password value is returned
767 * as a NUL-terminated 8 character string. my_crypt() does not change
768 * the case of its string arguments; in order to match the behavior
769 * of LOGINOUT et al., alphabetic characters in both arguments must
770 * be upcased by the caller.
773 my_crypt(const char *textpasswd, const char *usrname)
775 # ifndef UAI$C_PREFERRED_ALGORITHM
776 # define UAI$C_PREFERRED_ALGORITHM 127
778 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
779 unsigned short int salt = 0;
780 unsigned long int sts;
782 unsigned short int dsc$w_length;
783 unsigned char dsc$b_type;
784 unsigned char dsc$b_class;
785 const char * dsc$a_pointer;
786 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
787 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
788 struct itmlst_3 uailst[3] = {
789 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
790 { sizeof salt, UAI$_SALT, &salt, 0},
791 { 0, 0, NULL, NULL}};
794 usrdsc.dsc$w_length = strlen(usrname);
795 usrdsc.dsc$a_pointer = usrname;
796 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
798 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
802 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
808 if (sts != RMS$_RNF) return NULL;
811 txtdsc.dsc$w_length = strlen(textpasswd);
812 txtdsc.dsc$a_pointer = textpasswd;
813 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
814 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
817 return (char *) hash;
819 } /* end of my_crypt() */
823 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
824 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
825 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
827 /*{{{int do_rmdir(char *name)*/
829 Perl_do_rmdir(pTHX_ char *name)
831 char dirfile[NAM$C_MAXRSS+1];
835 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
836 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
837 else retval = kill_file(dirfile);
840 } /* end of do_rmdir */
844 * Delete any file to which user has control access, regardless of whether
845 * delete access is explicitly allowed.
846 * Limitations: User must have write access to parent directory.
847 * Does not block signals or ASTs; if interrupted in midstream
848 * may leave file with an altered ACL.
851 /*{{{int kill_file(char *name)*/
853 kill_file(char *name)
855 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
856 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
857 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
859 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
861 unsigned char myace$b_length;
862 unsigned char myace$b_type;
863 unsigned short int myace$w_flags;
864 unsigned long int myace$l_access;
865 unsigned long int myace$l_ident;
866 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
867 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
868 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
870 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
871 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
872 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
873 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
874 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
875 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
877 /* Expand the input spec using RMS, since the CRTL remove() and
878 * system services won't do this by themselves, so we may miss
879 * a file "hiding" behind a logical name or search list. */
880 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
881 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
882 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
883 /* If not, can changing protections help? */
884 if (vaxc$errno != RMS$_PRV) return -1;
886 /* No, so we get our own UIC to use as a rights identifier,
887 * and the insert an ACE at the head of the ACL which allows us
888 * to delete the file.
890 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
891 fildsc.dsc$w_length = strlen(rspec);
892 fildsc.dsc$a_pointer = rspec;
894 newace.myace$l_ident = oldace.myace$l_ident;
895 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
897 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
898 set_errno(ENOENT); break;
900 set_errno(ENOTDIR); break;
902 set_errno(ENODEV); break;
903 case RMS$_SYN: case SS$_INVFILFOROP:
904 set_errno(EINVAL); break;
906 set_errno(EACCES); break;
910 set_vaxc_errno(aclsts);
913 /* Grab any existing ACEs with this identifier in case we fail */
914 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
915 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
916 || fndsts == SS$_NOMOREACE ) {
917 /* Add the new ACE . . . */
918 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
920 if ((rmsts = remove(name))) {
921 /* We blew it - dir with files in it, no write priv for
922 * parent directory, etc. Put things back the way they were. */
923 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
926 addlst[0].bufadr = &oldace;
927 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
934 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
935 /* We just deleted it, so of course it's not there. Some versions of
936 * VMS seem to return success on the unlock operation anyhow (after all
937 * the unlock is successful), but others don't.
939 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
940 if (aclsts & 1) aclsts = fndsts;
943 set_vaxc_errno(aclsts);
949 } /* end of kill_file() */
953 /*{{{int my_mkdir(char *,Mode_t)*/
955 my_mkdir(char *dir, Mode_t mode)
957 STRLEN dirlen = strlen(dir);
960 /* zero length string sometimes gives ACCVIO */
961 if (dirlen == 0) return -1;
963 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
964 * null file name/type. However, it's commonplace under Unix,
965 * so we'll allow it for a gain in portability.
967 if (dir[dirlen-1] == '/') {
968 char *newdir = savepvn(dir,dirlen-1);
969 int ret = mkdir(newdir,mode);
973 else return mkdir(dir,mode);
974 } /* end of my_mkdir */
977 /*{{{int my_chdir(char *)*/
981 STRLEN dirlen = strlen(dir);
984 /* zero length string sometimes gives ACCVIO */
985 if (dirlen == 0) return -1;
987 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
989 * null file name/type. However, it's commonplace under Unix,
990 * so we'll allow it for a gain in portability.
992 if (dir[dirlen-1] == '/') {
993 char *newdir = savepvn(dir,dirlen-1);
994 int ret = chdir(newdir);
998 else return chdir(dir);
999 } /* end of my_chdir */
1003 /*{{{FILE *my_tmpfile()*/
1011 if ((fp = tmpfile())) return fp;
1013 New(1323,cp,L_tmpnam+24,char);
1014 strcpy(cp,"Sys$Scratch:");
1015 tmpnam(cp+strlen(cp));
1016 strcat(cp,".Perltmp");
1017 fp = fopen(cp,"w+","fop=dlt");
1023 /* default piping mailbox size */
1024 #define PERL_BUFSIZ 512
1028 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1030 unsigned long int mbxbufsiz;
1031 static unsigned long int syssize = 0;
1032 unsigned long int dviitm = DVI$_DEVNAM;
1034 char csize[LNM$C_NAMLENGTH+1];
1037 unsigned long syiitm = SYI$_MAXBUF;
1039 * Get the SYSGEN parameter MAXBUF
1041 * If the logical 'PERL_MBX_SIZE' is defined
1042 * use the value of the logical instead of PERL_BUFSIZ, but
1043 * keep the size between 128 and MAXBUF.
1046 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1049 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1050 mbxbufsiz = atoi(csize);
1052 mbxbufsiz = PERL_BUFSIZ;
1054 if (mbxbufsiz < 128) mbxbufsiz = 128;
1055 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1057 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1059 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1060 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1062 } /* end of create_mbx() */
1065 /*{{{ my_popen and my_pclose*/
1067 typedef struct _iosb IOSB;
1068 typedef struct _iosb* pIOSB;
1069 typedef struct _pipe Pipe;
1070 typedef struct _pipe* pPipe;
1071 typedef struct pipe_details Info;
1072 typedef struct pipe_details* pInfo;
1073 typedef struct _srqp RQE;
1074 typedef struct _srqp* pRQE;
1075 typedef struct _tochildbuf CBuf;
1076 typedef struct _tochildbuf* pCBuf;
1079 unsigned short status;
1080 unsigned short count;
1081 unsigned long dvispec;
1084 #pragma member_alignment save
1085 #pragma nomember_alignment quadword
1086 struct _srqp { /* VMS self-relative queue entry */
1087 unsigned long qptr[2];
1089 #pragma member_alignment restore
1090 static RQE RQE_ZERO = {0,0};
1092 struct _tochildbuf {
1095 unsigned short size;
1103 unsigned short chan_in;
1104 unsigned short chan_out;
1106 unsigned int bufsize;
1124 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1125 int pid; /* PID of subprocess */
1126 int mode; /* == 'r' if pipe open for reading */
1127 int done; /* subprocess has completed */
1128 int closing; /* my_pclose is closing this pipe */
1129 unsigned long completion; /* termination status of subprocess */
1130 pPipe in; /* pipe in to sub */
1131 pPipe out; /* pipe out of sub */
1132 pPipe err; /* pipe of sub's sys$error */
1133 int in_done; /* true when in pipe finished */
1138 struct exit_control_block
1140 struct exit_control_block *flink;
1141 unsigned long int (*exit_routine)();
1142 unsigned long int arg_count;
1143 unsigned long int *status_address;
1144 unsigned long int exit_status;
1147 #define RETRY_DELAY "0 ::0.20"
1148 #define MAX_RETRY 50
1150 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1151 static unsigned long mypid;
1152 static unsigned long delaytime[2];
1154 static pInfo open_pipes = NULL;
1155 static $DESCRIPTOR(nl_desc, "NL:");
1158 static unsigned long int
1162 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1163 int sts, did_stuff, need_eof;
1167 first we try sending an EOF...ignore if doesn't work, make sure we
1175 _ckvmssts(sys$setast(0));
1176 if (info->in && !info->in->shut_on_empty) {
1177 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1181 _ckvmssts(sys$setast(1));
1184 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1189 _ckvmssts(sys$setast(0));
1190 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1191 sts = sys$forcex(&info->pid,0,&abort);
1192 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1195 _ckvmssts(sys$setast(1));
1198 if (did_stuff) sleep(1); /* wait for them to respond */
1202 _ckvmssts(sys$setast(0));
1203 if (!info->done) { /* We tried to be nice . . . */
1204 sts = sys$delprc(&info->pid,0);
1205 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1207 _ckvmssts(sys$setast(1));
1212 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1213 else if (!(sts & 1)) retsts = sts;
1218 static struct exit_control_block pipe_exitblock =
1219 {(struct exit_control_block *) 0,
1220 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1222 static void pipe_mbxtofd_ast(pPipe p);
1223 static void pipe_tochild1_ast(pPipe p);
1224 static void pipe_tochild2_ast(pPipe p);
1227 popen_completion_ast(pInfo info)
1230 pInfo i = open_pipes;
1234 if (i == info) break;
1237 if (!i) return; /* unlinked, probably freed too */
1239 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1243 Writing to subprocess ...
1244 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1246 chan_out may be waiting for "done" flag, or hung waiting
1247 for i/o completion to child...cancel the i/o. This will
1248 put it into "snarf mode" (done but no EOF yet) that discards
1251 Output from subprocess (stdout, stderr) needs to be flushed and
1252 shut down. We try sending an EOF, but if the mbx is full the pipe
1253 routine should still catch the "shut_on_empty" flag, telling it to
1254 use immediate-style reads so that "mbx empty" -> EOF.
1258 if (info->in && !info->in_done) { /* only for mode=w */
1259 if (info->in->shut_on_empty && info->in->need_wake) {
1260 info->in->need_wake = FALSE;
1261 _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1263 _ckvmssts(sys$cancel(info->in->chan_out));
1267 if (info->out && !info->out_done) { /* were we also piping output? */
1268 info->out->shut_on_empty = TRUE;
1269 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1270 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1274 if (info->err && !info->err_done) { /* we were piping stderr */
1275 info->err->shut_on_empty = TRUE;
1276 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1277 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1280 _ckvmssts(sys$setef(pipe_ef));
1284 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1285 static void vms_execfree(pTHX);
1288 we actually differ from vmstrnenv since we use this to
1289 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1290 are pointing to the same thing
1293 static unsigned short
1294 popen_translate(char *logical, char *result)
1297 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1298 $DESCRIPTOR(d_log,"");
1300 unsigned short length;
1301 unsigned short code;
1303 unsigned short *retlenaddr;
1305 unsigned short l, ifi;
1307 d_log.dsc$a_pointer = logical;
1308 d_log.dsc$w_length = strlen(logical);
1310 itmlst[0].code = LNM$_STRING;
1311 itmlst[0].length = 255;
1312 itmlst[0].buffer_addr = result;
1313 itmlst[0].retlenaddr = &l;
1316 itmlst[1].length = 0;
1317 itmlst[1].buffer_addr = 0;
1318 itmlst[1].retlenaddr = 0;
1320 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1321 if (iss == SS$_NOLOGNAM) {
1325 if (!(iss&1)) lib$signal(iss);
1328 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1329 strip it off and return the ifi, if any
1332 if (result[0] == 0x1b && result[1] == 0x00) {
1333 memcpy(&ifi,result+2,2);
1334 strcpy(result,result+4);
1336 return ifi; /* this is the RMS internal file id */
1339 #define MAX_DCL_SYMBOL 255
1340 static void pipe_infromchild_ast(pPipe p);
1343 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1344 inside an AST routine without worrying about reentrancy and which Perl
1345 memory allocator is being used.
1347 We read data and queue up the buffers, then spit them out one at a
1348 time to the output mailbox when the output mailbox is ready for one.
1351 #define INITIAL_TOCHILDQUEUE 2
1354 pipe_tochild_setup(char *rmbx, char *wmbx)
1359 char mbx1[64], mbx2[64];
1360 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1361 DSC$K_CLASS_S, mbx1},
1362 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1363 DSC$K_CLASS_S, mbx2};
1364 unsigned int dviitm = DVI$_DEVBUFSIZ;
1367 New(1368, p, 1, Pipe);
1369 create_mbx(&p->chan_in , &d_mbx1);
1370 create_mbx(&p->chan_out, &d_mbx2);
1371 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1374 p->shut_on_empty = FALSE;
1375 p->need_wake = FALSE;
1378 p->iosb.status = SS$_NORMAL;
1379 p->iosb2.status = SS$_NORMAL;
1386 n = sizeof(CBuf) + p->bufsize;
1388 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1389 _ckvmssts(lib$get_vm(&n, &b));
1390 b->buf = (char *) b + sizeof(CBuf);
1391 _ckvmssts(lib$insqhi(b, &p->free));
1394 pipe_tochild2_ast(p);
1395 pipe_tochild1_ast(p);
1401 /* reads the MBX Perl is writing, and queues */
1404 pipe_tochild1_ast(pPipe p)
1408 int iss = p->iosb.status;
1409 int eof = (iss == SS$_ENDOFFILE);
1413 p->shut_on_empty = TRUE;
1415 _ckvmssts(sys$dassgn(p->chan_in));
1421 b->size = p->iosb.count;
1422 _ckvmssts(lib$insqhi(b, &p->wait));
1424 p->need_wake = FALSE;
1425 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1428 p->retry = 1; /* initial call */
1431 if (eof) { /* flush the free queue, return when done */
1432 int n = sizeof(CBuf) + p->bufsize;
1434 iss = lib$remqti(&p->free, &b);
1435 if (iss == LIB$_QUEWASEMP) return;
1437 _ckvmssts(lib$free_vm(&n, &b));
1441 iss = lib$remqti(&p->free, &b);
1442 if (iss == LIB$_QUEWASEMP) {
1443 int n = sizeof(CBuf) + p->bufsize;
1444 _ckvmssts(lib$get_vm(&n, &b));
1445 b->buf = (char *) b + sizeof(CBuf);
1451 iss = sys$qio(0,p->chan_in,
1452 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1454 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1455 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1460 /* writes queued buffers to output, waits for each to complete before
1464 pipe_tochild2_ast(pPipe p)
1468 int iss = p->iosb2.status;
1469 int n = sizeof(CBuf) + p->bufsize;
1470 int done = (p->info && p->info->done) ||
1471 iss == SS$_CANCEL || iss == SS$_ABORT;
1474 if (p->type) { /* type=1 has old buffer, dispose */
1475 if (p->shut_on_empty) {
1476 _ckvmssts(lib$free_vm(&n, &b));
1478 _ckvmssts(lib$insqhi(b, &p->free));
1483 iss = lib$remqti(&p->wait, &b);
1484 if (iss == LIB$_QUEWASEMP) {
1485 if (p->shut_on_empty) {
1487 _ckvmssts(sys$dassgn(p->chan_out));
1488 *p->pipe_done = TRUE;
1489 _ckvmssts(sys$setef(pipe_ef));
1491 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1492 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1496 p->need_wake = TRUE;
1506 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1507 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1509 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1510 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1519 pipe_infromchild_setup(char *rmbx, char *wmbx)
1523 char mbx1[64], mbx2[64];
1524 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1525 DSC$K_CLASS_S, mbx1},
1526 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1527 DSC$K_CLASS_S, mbx2};
1528 unsigned int dviitm = DVI$_DEVBUFSIZ;
1530 New(1367, p, 1, Pipe);
1531 create_mbx(&p->chan_in , &d_mbx1);
1532 create_mbx(&p->chan_out, &d_mbx2);
1534 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1535 New(1367, p->buf, p->bufsize, char);
1536 p->shut_on_empty = FALSE;
1539 p->iosb.status = SS$_NORMAL;
1540 pipe_infromchild_ast(p);
1548 pipe_infromchild_ast(pPipe p)
1551 int iss = p->iosb.status;
1552 int eof = (iss == SS$_ENDOFFILE);
1553 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1554 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1556 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1557 _ckvmssts(sys$dassgn(p->chan_out));
1562 input shutdown if EOF from self (done or shut_on_empty)
1563 output shutdown if closing flag set (my_pclose)
1564 send data/eof from child or eof from self
1565 otherwise, re-read (snarf of data from child)
1570 if (myeof && p->chan_in) { /* input shutdown */
1571 _ckvmssts(sys$dassgn(p->chan_in));
1576 if (myeof || kideof) { /* pass EOF to parent */
1577 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1578 pipe_infromchild_ast, p,
1581 } else if (eof) { /* eat EOF --- fall through to read*/
1583 } else { /* transmit data */
1584 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1585 pipe_infromchild_ast,p,
1586 p->buf, p->iosb.count, 0, 0, 0, 0));
1592 /* everything shut? flag as done */
1594 if (!p->chan_in && !p->chan_out) {
1595 *p->pipe_done = TRUE;
1596 _ckvmssts(sys$setef(pipe_ef));
1600 /* write completed (or read, if snarfing from child)
1601 if still have input active,
1602 queue read...immediate mode if shut_on_empty so we get EOF if empty
1604 check if Perl reading, generate EOFs as needed
1610 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1611 pipe_infromchild_ast,p,
1612 p->buf, p->bufsize, 0, 0, 0, 0);
1613 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1615 } else { /* send EOFs for extra reads */
1616 p->iosb.status = SS$_ENDOFFILE;
1617 p->iosb.dvispec = 0;
1618 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1620 pipe_infromchild_ast, p, 0, 0, 0, 0));
1626 pipe_mbxtofd_setup(int fd, char *out)
1631 unsigned long dviitm = DVI$_DEVBUFSIZ;
1633 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1634 DSC$K_CLASS_S, mbx};
1636 /* things like terminals and mbx's don't need this filter */
1637 if (fd && fstat(fd,&s) == 0) {
1638 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1639 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1640 DSC$K_CLASS_S, s.st_dev};
1642 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1643 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1644 strcpy(out, s.st_dev);
1649 New(1366, p, 1, Pipe);
1650 p->fd_out = dup(fd);
1651 create_mbx(&p->chan_in, &d_mbx);
1652 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1653 New(1366, p->buf, p->bufsize+1, char);
1654 p->shut_on_empty = FALSE;
1659 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1660 pipe_mbxtofd_ast, p,
1661 p->buf, p->bufsize, 0, 0, 0, 0));
1667 pipe_mbxtofd_ast(pPipe p)
1670 int iss = p->iosb.status;
1671 int done = p->info->done;
1673 int eof = (iss == SS$_ENDOFFILE);
1674 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1675 int err = !(iss&1) && !eof;
1678 if (done && myeof) { /* end piping */
1680 sys$dassgn(p->chan_in);
1681 *p->pipe_done = TRUE;
1682 _ckvmssts(sys$setef(pipe_ef));
1686 if (!err && !eof) { /* good data to send to file */
1687 p->buf[p->iosb.count] = '\n';
1688 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1691 if (p->retry < MAX_RETRY) {
1692 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1702 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1703 pipe_mbxtofd_ast, p,
1704 p->buf, p->bufsize, 0, 0, 0, 0);
1705 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1710 typedef struct _pipeloc PLOC;
1711 typedef struct _pipeloc* pPLOC;
1715 char dir[NAM$C_MAXRSS+1];
1717 static pPLOC head_PLOC = 0;
1725 AV *av = GvAVn(PL_incgv);
1730 char temp[NAM$C_MAXRSS+1];
1733 /* the . directory from @INC comes last */
1736 p->next = head_PLOC;
1738 strcpy(p->dir,"./");
1740 /* get the directory from $^X */
1742 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1743 strcpy(temp, PL_origargv[0]);
1744 x = strrchr(temp,']');
1747 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1749 p->next = head_PLOC;
1751 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1752 p->dir[NAM$C_MAXRSS] = '\0';
1756 /* reverse order of @INC entries, skip "." since entered above */
1758 for (i = 0; i <= AvFILL(av); i++) {
1759 dirsv = *av_fetch(av,i,TRUE);
1761 if (SvROK(dirsv)) continue;
1762 dir = SvPVx(dirsv,n_a);
1763 if (strcmp(dir,".") == 0) continue;
1764 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1768 p->next = head_PLOC;
1770 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1771 p->dir[NAM$C_MAXRSS] = '\0';
1774 /* most likely spot (ARCHLIB) put first in the list */
1777 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1779 p->next = head_PLOC;
1781 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1782 p->dir[NAM$C_MAXRSS] = '\0';
1792 static int vmspipe_file_status = 0;
1793 static char vmspipe_file[NAM$C_MAXRSS+1];
1795 /* already found? Check and use ... need read+execute permission */
1797 if (vmspipe_file_status == 1) {
1798 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1799 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1800 return vmspipe_file;
1802 vmspipe_file_status = 0;
1805 /* scan through stored @INC, $^X */
1807 if (vmspipe_file_status == 0) {
1808 char file[NAM$C_MAXRSS+1];
1809 pPLOC p = head_PLOC;
1812 strcpy(file, p->dir);
1813 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1814 file[NAM$C_MAXRSS] = '\0';
1817 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1819 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1820 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1821 vmspipe_file_status = 1;
1822 return vmspipe_file;
1825 vmspipe_file_status = -1; /* failed, use tempfiles */
1832 vmspipe_tempfile(void)
1834 char file[NAM$C_MAXRSS+1];
1836 static int index = 0;
1839 /* create a tempfile */
1841 /* we can't go from W, shr=get to R, shr=get without
1842 an intermediate vulnerable state, so don't bother trying...
1844 and lib$spawn doesn't shr=put, so have to close the write
1846 So... match up the creation date/time and the FID to
1847 make sure we're dealing with the same file
1852 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1853 fp = fopen(file,"w");
1855 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1856 fp = fopen(file,"w");
1858 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1859 fp = fopen(file,"w");
1862 if (!fp) return 0; /* we're hosed */
1864 fprintf(fp,"$! 'f$verify(0)\n");
1865 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1866 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1867 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1868 fprintf(fp,"$ perl_on = \"set noon\"\n");
1869 fprintf(fp,"$ perl_exit = \"exit\"\n");
1870 fprintf(fp,"$ perl_del = \"delete\"\n");
1871 fprintf(fp,"$ pif = \"if\"\n");
1872 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1873 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user sys$input 'perl_popen_in'\n");
1874 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user sys$error 'perl_popen_err'\n");
1875 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1876 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1877 fprintf(fp,"$! --- get rid of global symbols\n");
1878 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1879 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1880 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1881 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1882 fprintf(fp,"$ perl_on\n");
1883 fprintf(fp,"$ 'cmd\n");
1884 fprintf(fp,"$ perl_status = $STATUS\n");
1885 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1886 fprintf(fp,"$ perl_exit 'perl_status'\n");
1889 fgetname(fp, file, 1);
1890 fstat(fileno(fp), &s0);
1893 fp = fopen(file,"r","shr=get");
1895 fstat(fileno(fp), &s1);
1897 if (s0.st_ino[0] != s1.st_ino[0] ||
1898 s0.st_ino[1] != s1.st_ino[1] ||
1899 s0.st_ino[2] != s1.st_ino[2] ||
1900 s0.st_ctime != s1.st_ctime ) {
1911 safe_popen(char *cmd, char *mode)
1914 static int handler_set_up = FALSE;
1915 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1916 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1917 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1918 char in[512], out[512], err[512], mbx[512];
1920 char tfilebuf[NAM$C_MAXRSS+1];
1922 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1923 DSC$K_CLASS_S, symbol};
1924 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1927 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1928 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1929 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1930 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1932 /* once-per-program initialization...
1933 note that the SETAST calls and the dual test of pipe_ef
1934 makes sure that only the FIRST thread through here does
1935 the initialization...all other threads wait until it's
1938 Yeah, uglier than a pthread call, it's got all the stuff inline
1939 rather than in a separate routine.
1943 _ckvmssts(sys$setast(0));
1945 unsigned long int pidcode = JPI$_PID;
1946 $DESCRIPTOR(d_delay, RETRY_DELAY);
1947 _ckvmssts(lib$get_ef(&pipe_ef));
1948 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1949 _ckvmssts(sys$bintim(&d_delay, delaytime));
1951 if (!handler_set_up) {
1952 _ckvmssts(sys$dclexh(&pipe_exitblock));
1953 handler_set_up = TRUE;
1955 _ckvmssts(sys$setast(1));
1958 /* see if we can find a VMSPIPE.COM */
1961 vmspipe = find_vmspipe();
1963 strcpy(tfilebuf+1,vmspipe);
1964 } else { /* uh, oh...we're in tempfile hell */
1965 tpipe = vmspipe_tempfile();
1966 if (!tpipe) { /* a fish popular in Boston */
1967 if (ckWARN(WARN_PIPE)) {
1968 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1972 fgetname(tpipe,tfilebuf+1,1);
1974 vmspipedsc.dsc$a_pointer = tfilebuf;
1975 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1977 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1978 New(1301,info,1,Info);
1982 info->completion = 0;
1983 info->closing = FALSE;
1987 info->in_done = TRUE;
1988 info->out_done = TRUE;
1989 info->err_done = TRUE;
1990 in[0] = out[0] = err[0] = '\0';
1992 if (*mode == 'r') { /* piping from subroutine */
1994 info->out = pipe_infromchild_setup(mbx,out);
1996 info->out->pipe_done = &info->out_done;
1997 info->out_done = FALSE;
1998 info->out->info = info;
2000 info->fp = PerlIO_open(mbx, mode);
2001 if (!info->fp && info->out) {
2002 sys$cancel(info->out->chan_out);
2004 while (!info->out_done) {
2006 _ckvmssts(sys$setast(0));
2007 done = info->out_done;
2008 if (!done) _ckvmssts(sys$clref(pipe_ef));
2009 _ckvmssts(sys$setast(1));
2010 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2013 if (info->out->buf) Safefree(info->out->buf);
2014 Safefree(info->out);
2019 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2021 info->err->pipe_done = &info->err_done;
2022 info->err_done = FALSE;
2023 info->err->info = info;
2026 } else { /* piping to subroutine , mode=w*/
2028 info->in = pipe_tochild_setup(in,mbx);
2029 info->fp = PerlIO_open(mbx, mode);
2031 info->in->pipe_done = &info->in_done;
2032 info->in_done = FALSE;
2033 info->in->info = info;
2037 if (!info->fp && info->in) {
2039 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2040 0, 0, 0, 0, 0, 0, 0, 0));
2042 while (!info->in_done) {
2044 _ckvmssts(sys$setast(0));
2045 done = info->in_done;
2046 if (!done) _ckvmssts(sys$clref(pipe_ef));
2047 _ckvmssts(sys$setast(1));
2048 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2051 if (info->in->buf) Safefree(info->in->buf);
2058 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2060 info->out->pipe_done = &info->out_done;
2061 info->out_done = FALSE;
2062 info->out->info = info;
2065 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2067 info->err->pipe_done = &info->err_done;
2068 info->err_done = FALSE;
2069 info->err->info = info;
2073 symbol[MAX_DCL_SYMBOL] = '\0';
2075 strncpy(symbol, in, MAX_DCL_SYMBOL);
2076 d_symbol.dsc$w_length = strlen(symbol);
2077 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2079 strncpy(symbol, err, MAX_DCL_SYMBOL);
2080 d_symbol.dsc$w_length = strlen(symbol);
2081 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2083 strncpy(symbol, out, MAX_DCL_SYMBOL);
2084 d_symbol.dsc$w_length = strlen(symbol);
2085 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2087 p = VMScmd.dsc$a_pointer;
2088 while (*p && *p != '\n') p++;
2089 *p = '\0'; /* truncate on \n */
2090 p = VMScmd.dsc$a_pointer;
2091 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2092 if (*p == '$') p++; /* remove leading $ */
2093 while (*p == ' ' || *p == '\t') p++;
2094 strncpy(symbol, p, MAX_DCL_SYMBOL);
2095 d_symbol.dsc$w_length = strlen(symbol);
2096 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2098 _ckvmssts(sys$setast(0));
2099 info->next=open_pipes; /* prepend to list */
2101 _ckvmssts(sys$setast(1));
2102 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2103 0, &info->pid, &info->completion,
2104 0, popen_completion_ast,info,0,0,0));
2106 /* if we were using a tempfile, close it now */
2108 if (tpipe) fclose(tpipe);
2110 /* once the subprocess is spawned, its copied the symbols and
2111 we can get rid of ours */
2113 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2114 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2115 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2116 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2119 PL_forkprocess = info->pid;
2121 } /* end of safe_popen */
2124 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2126 Perl_my_popen(pTHX_ char *cmd, char *mode)
2129 TAINT_PROPER("popen");
2130 PERL_FLUSHALL_FOR_CHILD;
2131 return safe_popen(cmd,mode);
2136 /*{{{ I32 my_pclose(FILE *fp)*/
2137 I32 Perl_my_pclose(pTHX_ FILE *fp)
2140 pInfo info, last = NULL;
2141 unsigned long int retsts;
2144 for (info = open_pipes; info != NULL; last = info, info = info->next)
2145 if (info->fp == fp) break;
2147 if (info == NULL) { /* no such pipe open */
2148 set_errno(ECHILD); /* quoth POSIX */
2149 set_vaxc_errno(SS$_NONEXPR);
2153 /* If we were writing to a subprocess, insure that someone reading from
2154 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2155 * produce an EOF record in the mailbox.
2157 * well, at least sometimes it *does*, so we have to watch out for
2158 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2161 fsync(fileno(info->fp)); /* first, flush data */
2163 _ckvmssts(sys$setast(0));
2164 info->closing = TRUE;
2165 done = info->done && info->in_done && info->out_done && info->err_done;
2166 /* hanging on write to Perl's input? cancel it */
2167 if (info->mode == 'r' && info->out && !info->out_done) {
2168 if (info->out->chan_out) {
2169 _ckvmssts(sys$cancel(info->out->chan_out));
2170 if (!info->out->chan_in) { /* EOF generation, need AST */
2171 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2175 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2176 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2178 _ckvmssts(sys$setast(1));
2179 PerlIO_close(info->fp);
2182 we have to wait until subprocess completes, but ALSO wait until all
2183 the i/o completes...otherwise we'll be freeing the "info" structure
2184 that the i/o ASTs could still be using...
2188 _ckvmssts(sys$setast(0));
2189 done = info->done && info->in_done && info->out_done && info->err_done;
2190 if (!done) _ckvmssts(sys$clref(pipe_ef));
2191 _ckvmssts(sys$setast(1));
2192 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2194 retsts = info->completion;
2196 /* remove from list of open pipes */
2197 _ckvmssts(sys$setast(0));
2198 if (last) last->next = info->next;
2199 else open_pipes = info->next;
2200 _ckvmssts(sys$setast(1));
2202 /* free buffers and structures */
2205 if (info->in->buf) Safefree(info->in->buf);
2209 if (info->out->buf) Safefree(info->out->buf);
2210 Safefree(info->out);
2213 if (info->err->buf) Safefree(info->err->buf);
2214 Safefree(info->err);
2220 } /* end of my_pclose() */
2222 /* sort-of waitpid; use only with popen() */
2223 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2225 my_waitpid(Pid_t pid, int *statusp, int flags)
2231 for (info = open_pipes; info != NULL; info = info->next)
2232 if (info->pid == pid) break;
2234 if (info != NULL) { /* we know about this child */
2235 while (!info->done) {
2236 _ckvmssts(sys$setast(0));
2238 if (!done) _ckvmssts(sys$clref(pipe_ef));
2239 _ckvmssts(sys$setast(1));
2240 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2243 *statusp = info->completion;
2246 else { /* we haven't heard of this child */
2247 $DESCRIPTOR(intdsc,"0 00:00:01");
2248 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2249 unsigned long int interval[2],sts;
2251 if (ckWARN(WARN_EXEC)) {
2252 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2253 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2254 if (ownerpid != mypid)
2255 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2258 _ckvmssts(sys$bintim(&intdsc,interval));
2259 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2260 _ckvmssts(sys$schdwk(0,0,interval,0));
2261 _ckvmssts(sys$hiber());
2263 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2266 /* There's no easy way to find the termination status a child we're
2267 * not aware of beforehand. If we're really interested in the future,
2268 * we can go looking for a termination mailbox, or chase after the
2269 * accounting record for the process.
2275 } /* end of waitpid() */
2280 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2282 my_gconvert(double val, int ndig, int trail, char *buf)
2284 static char __gcvtbuf[DBL_DIG+1];
2287 loc = buf ? buf : __gcvtbuf;
2289 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2291 sprintf(loc,"%.*g",ndig,val);
2297 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2298 return gcvt(val,ndig,loc);
2301 loc[0] = '0'; loc[1] = '\0';
2309 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2310 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2311 * to expand file specification. Allows for a single default file
2312 * specification and a simple mask of options. If outbuf is non-NULL,
2313 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2314 * the resultant file specification is placed. If outbuf is NULL, the
2315 * resultant file specification is placed into a static buffer.
2316 * The third argument, if non-NULL, is taken to be a default file
2317 * specification string. The fourth argument is unused at present.
2318 * rmesexpand() returns the address of the resultant string if
2319 * successful, and NULL on error.
2321 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2324 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2326 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2327 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2328 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2329 struct FAB myfab = cc$rms_fab;
2330 struct NAM mynam = cc$rms_nam;
2332 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2334 if (!filespec || !*filespec) {
2335 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2339 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2340 else outbuf = __rmsexpand_retbuf;
2342 if ((isunix = (strchr(filespec,'/') != NULL))) {
2343 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2344 filespec = vmsfspec;
2347 myfab.fab$l_fna = filespec;
2348 myfab.fab$b_fns = strlen(filespec);
2349 myfab.fab$l_nam = &mynam;
2351 if (defspec && *defspec) {
2352 if (strchr(defspec,'/') != NULL) {
2353 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2356 myfab.fab$l_dna = defspec;
2357 myfab.fab$b_dns = strlen(defspec);
2360 mynam.nam$l_esa = esa;
2361 mynam.nam$b_ess = sizeof esa;
2362 mynam.nam$l_rsa = outbuf;
2363 mynam.nam$b_rss = NAM$C_MAXRSS;
2365 retsts = sys$parse(&myfab,0,0);
2366 if (!(retsts & 1)) {
2367 mynam.nam$b_nop |= NAM$M_SYNCHK;
2368 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2369 retsts = sys$parse(&myfab,0,0);
2370 if (retsts & 1) goto expanded;
2372 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2373 (void) sys$parse(&myfab,0,0); /* Free search context */
2374 if (out) Safefree(out);
2375 set_vaxc_errno(retsts);
2376 if (retsts == RMS$_PRV) set_errno(EACCES);
2377 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2378 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2379 else set_errno(EVMSERR);
2382 retsts = sys$search(&myfab,0,0);
2383 if (!(retsts & 1) && retsts != RMS$_FNF) {
2384 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2385 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2386 if (out) Safefree(out);
2387 set_vaxc_errno(retsts);
2388 if (retsts == RMS$_PRV) set_errno(EACCES);
2389 else set_errno(EVMSERR);
2393 /* If the input filespec contained any lowercase characters,
2394 * downcase the result for compatibility with Unix-minded code. */
2396 for (out = myfab.fab$l_fna; *out; out++)
2397 if (islower(*out)) { haslower = 1; break; }
2398 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2399 else { out = esa; speclen = mynam.nam$b_esl; }
2400 /* Trim off null fields added by $PARSE
2401 * If type > 1 char, must have been specified in original or default spec
2402 * (not true for version; $SEARCH may have added version of existing file).
2404 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2405 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2406 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2407 if (trimver || trimtype) {
2408 if (defspec && *defspec) {
2409 char defesa[NAM$C_MAXRSS];
2410 struct FAB deffab = cc$rms_fab;
2411 struct NAM defnam = cc$rms_nam;
2413 deffab.fab$l_nam = &defnam;
2414 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2415 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2416 defnam.nam$b_nop = NAM$M_SYNCHK;
2417 if (sys$parse(&deffab,0,0) & 1) {
2418 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2419 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2422 if (trimver) speclen = mynam.nam$l_ver - out;
2424 /* If we didn't already trim version, copy down */
2425 if (speclen > mynam.nam$l_ver - out)
2426 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2427 speclen - (mynam.nam$l_ver - out));
2428 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2431 /* If we just had a directory spec on input, $PARSE "helpfully"
2432 * adds an empty name and type for us */
2433 if (mynam.nam$l_name == mynam.nam$l_type &&
2434 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2435 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2436 speclen = mynam.nam$l_name - out;
2437 out[speclen] = '\0';
2438 if (haslower) __mystrtolower(out);
2440 /* Have we been working with an expanded, but not resultant, spec? */
2441 /* Also, convert back to Unix syntax if necessary. */
2442 if (!mynam.nam$b_rsl) {
2444 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2446 else strcpy(outbuf,esa);
2449 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2450 strcpy(outbuf,tmpfspec);
2452 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2453 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2454 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2458 /* External entry points */
2459 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2460 { return do_rmsexpand(spec,buf,0,def,opt); }
2461 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2462 { return do_rmsexpand(spec,buf,1,def,opt); }
2466 ** The following routines are provided to make life easier when
2467 ** converting among VMS-style and Unix-style directory specifications.
2468 ** All will take input specifications in either VMS or Unix syntax. On
2469 ** failure, all return NULL. If successful, the routines listed below
2470 ** return a pointer to a buffer containing the appropriately
2471 ** reformatted spec (and, therefore, subsequent calls to that routine
2472 ** will clobber the result), while the routines of the same names with
2473 ** a _ts suffix appended will return a pointer to a mallocd string
2474 ** containing the appropriately reformatted spec.
2475 ** In all cases, only explicit syntax is altered; no check is made that
2476 ** the resulting string is valid or that the directory in question
2479 ** fileify_dirspec() - convert a directory spec into the name of the
2480 ** directory file (i.e. what you can stat() to see if it's a dir).
2481 ** The style (VMS or Unix) of the result is the same as the style
2482 ** of the parameter passed in.
2483 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2484 ** what you prepend to a filename to indicate what directory it's in).
2485 ** The style (VMS or Unix) of the result is the same as the style
2486 ** of the parameter passed in.
2487 ** tounixpath() - convert a directory spec into a Unix-style path.
2488 ** tovmspath() - convert a directory spec into a VMS-style path.
2489 ** tounixspec() - convert any file spec into a Unix-style file spec.
2490 ** tovmsspec() - convert any file spec into a VMS-style spec.
2492 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2493 ** Permission is given to distribute this code as part of the Perl
2494 ** standard distribution under the terms of the GNU General Public
2495 ** License or the Perl Artistic License. Copies of each may be
2496 ** found in the Perl standard distribution.
2499 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2500 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2502 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2503 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2504 char *retspec, *cp1, *cp2, *lastdir;
2505 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2507 if (!dir || !*dir) {
2508 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2510 dirlen = strlen(dir);
2511 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2512 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2513 strcpy(trndir,"/sys$disk/000000");
2517 if (dirlen > NAM$C_MAXRSS) {
2518 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2520 if (!strpbrk(dir+1,"/]>:")) {
2521 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2522 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2524 dirlen = strlen(dir);
2527 strncpy(trndir,dir,dirlen);
2528 trndir[dirlen] = '\0';
2531 /* If we were handed a rooted logical name or spec, treat it like a
2532 * simple directory, so that
2533 * $ Define myroot dev:[dir.]
2534 * ... do_fileify_dirspec("myroot",buf,1) ...
2535 * does something useful.
2537 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2538 dir[--dirlen] = '\0';
2539 dir[dirlen-1] = ']';
2542 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2543 /* If we've got an explicit filename, we can just shuffle the string. */
2544 if (*(cp1+1)) hasfilename = 1;
2545 /* Similarly, we can just back up a level if we've got multiple levels
2546 of explicit directories in a VMS spec which ends with directories. */
2548 for (cp2 = cp1; cp2 > dir; cp2--) {
2550 *cp2 = *cp1; *cp1 = '\0';
2554 if (*cp2 == '[' || *cp2 == '<') break;
2559 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2560 if (dir[0] == '.') {
2561 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2562 return do_fileify_dirspec("[]",buf,ts);
2563 else if (dir[1] == '.' &&
2564 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2565 return do_fileify_dirspec("[-]",buf,ts);
2567 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2568 dirlen -= 1; /* to last element */
2569 lastdir = strrchr(dir,'/');
2571 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2572 /* If we have "/." or "/..", VMSify it and let the VMS code
2573 * below expand it, rather than repeating the code to handle
2574 * relative components of a filespec here */
2576 if (*(cp1+2) == '.') cp1++;
2577 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2578 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2579 if (strchr(vmsdir,'/') != NULL) {
2580 /* If do_tovmsspec() returned it, it must have VMS syntax
2581 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2582 * the time to check this here only so we avoid a recursion
2583 * loop; otherwise, gigo.
2585 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2587 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2588 return do_tounixspec(trndir,buf,ts);
2591 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2592 lastdir = strrchr(dir,'/');
2594 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2595 /* Ditto for specs that end in an MFD -- let the VMS code
2596 * figure out whether it's a real device or a rooted logical. */
2597 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2598 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2599 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2600 return do_tounixspec(trndir,buf,ts);
2603 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2604 !(lastdir = cp1 = strrchr(dir,']')) &&
2605 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2606 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2608 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2609 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2610 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2611 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2612 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2613 (ver || *cp3)))))) {
2615 set_vaxc_errno(RMS$_DIR);
2621 /* If we lead off with a device or rooted logical, add the MFD
2622 if we're specifying a top-level directory. */
2623 if (lastdir && *dir == '/') {
2625 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2632 retlen = dirlen + (addmfd ? 13 : 6);
2633 if (buf) retspec = buf;
2634 else if (ts) New(1309,retspec,retlen+1,char);
2635 else retspec = __fileify_retbuf;
2637 dirlen = lastdir - dir;
2638 memcpy(retspec,dir,dirlen);
2639 strcpy(&retspec[dirlen],"/000000");
2640 strcpy(&retspec[dirlen+7],lastdir);
2643 memcpy(retspec,dir,dirlen);
2644 retspec[dirlen] = '\0';
2646 /* We've picked up everything up to the directory file name.
2647 Now just add the type and version, and we're set. */
2648 strcat(retspec,".dir;1");
2651 else { /* VMS-style directory spec */
2652 char esa[NAM$C_MAXRSS+1], term, *cp;
2653 unsigned long int sts, cmplen, haslower = 0;
2654 struct FAB dirfab = cc$rms_fab;
2655 struct NAM savnam, dirnam = cc$rms_nam;
2657 dirfab.fab$b_fns = strlen(dir);
2658 dirfab.fab$l_fna = dir;
2659 dirfab.fab$l_nam = &dirnam;
2660 dirfab.fab$l_dna = ".DIR;1";
2661 dirfab.fab$b_dns = 6;
2662 dirnam.nam$b_ess = NAM$C_MAXRSS;
2663 dirnam.nam$l_esa = esa;
2665 for (cp = dir; *cp; cp++)
2666 if (islower(*cp)) { haslower = 1; break; }
2667 if (!((sts = sys$parse(&dirfab))&1)) {
2668 if (dirfab.fab$l_sts == RMS$_DIR) {
2669 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2670 sts = sys$parse(&dirfab) & 1;
2674 set_vaxc_errno(dirfab.fab$l_sts);
2680 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2681 /* Yes; fake the fnb bits so we'll check type below */
2682 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2684 else { /* No; just work with potential name */
2685 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2687 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2688 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2689 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2694 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2695 cp1 = strchr(esa,']');
2696 if (!cp1) cp1 = strchr(esa,'>');
2697 if (cp1) { /* Should always be true */
2698 dirnam.nam$b_esl -= cp1 - esa - 1;
2699 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2702 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2703 /* Yep; check version while we're at it, if it's there. */
2704 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2705 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2706 /* Something other than .DIR[;1]. Bzzt. */
2707 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2708 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2710 set_vaxc_errno(RMS$_DIR);
2714 esa[dirnam.nam$b_esl] = '\0';
2715 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2716 /* They provided at least the name; we added the type, if necessary, */
2717 if (buf) retspec = buf; /* in sys$parse() */
2718 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2719 else retspec = __fileify_retbuf;
2720 strcpy(retspec,esa);
2721 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2722 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2725 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2726 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2728 dirnam.nam$b_esl -= 9;
2730 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2731 if (cp1 == NULL) { /* should never happen */
2732 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2733 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2738 retlen = strlen(esa);
2739 if ((cp1 = strrchr(esa,'.')) != NULL) {
2740 /* There's more than one directory in the path. Just roll back. */
2742 if (buf) retspec = buf;
2743 else if (ts) New(1311,retspec,retlen+7,char);
2744 else retspec = __fileify_retbuf;
2745 strcpy(retspec,esa);
2748 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2749 /* Go back and expand rooted logical name */
2750 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2751 if (!(sys$parse(&dirfab) & 1)) {
2752 dirnam.nam$l_rlf = NULL;
2753 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2755 set_vaxc_errno(dirfab.fab$l_sts);
2758 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2759 if (buf) retspec = buf;
2760 else if (ts) New(1312,retspec,retlen+16,char);
2761 else retspec = __fileify_retbuf;
2762 cp1 = strstr(esa,"][");
2764 memcpy(retspec,esa,dirlen);
2765 if (!strncmp(cp1+2,"000000]",7)) {
2766 retspec[dirlen-1] = '\0';
2767 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2768 if (*cp1 == '.') *cp1 = ']';
2770 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2771 memcpy(cp1+1,"000000]",7);
2775 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2776 retspec[retlen] = '\0';
2777 /* Convert last '.' to ']' */
2778 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2779 if (*cp1 == '.') *cp1 = ']';
2781 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2782 memcpy(cp1+1,"000000]",7);
2786 else { /* This is a top-level dir. Add the MFD to the path. */
2787 if (buf) retspec = buf;
2788 else if (ts) New(1312,retspec,retlen+16,char);
2789 else retspec = __fileify_retbuf;
2792 while (*cp1 != ':') *(cp2++) = *(cp1++);
2793 strcpy(cp2,":[000000]");
2798 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2799 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2800 /* We've set up the string up through the filename. Add the
2801 type and version, and we're done. */
2802 strcat(retspec,".DIR;1");
2804 /* $PARSE may have upcased filespec, so convert output to lower
2805 * case if input contained any lowercase characters. */
2806 if (haslower) __mystrtolower(retspec);
2809 } /* end of do_fileify_dirspec() */
2811 /* External entry points */
2812 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2813 { return do_fileify_dirspec(dir,buf,0); }
2814 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2815 { return do_fileify_dirspec(dir,buf,1); }
2817 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2818 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2820 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2821 unsigned long int retlen;
2822 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2824 if (!dir || !*dir) {
2825 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2828 if (*dir) strcpy(trndir,dir);
2829 else getcwd(trndir,sizeof trndir - 1);
2831 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2832 && my_trnlnm(trndir,trndir,0)) {
2833 STRLEN trnlen = strlen(trndir);
2835 /* Trap simple rooted lnms, and return lnm:[000000] */
2836 if (!strcmp(trndir+trnlen-2,".]")) {
2837 if (buf) retpath = buf;
2838 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2839 else retpath = __pathify_retbuf;
2840 strcpy(retpath,dir);
2841 strcat(retpath,":[000000]");
2847 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2848 if (*dir == '.' && (*(dir+1) == '\0' ||
2849 (*(dir+1) == '.' && *(dir+2) == '\0')))
2850 retlen = 2 + (*(dir+1) != '\0');
2852 if ( !(cp1 = strrchr(dir,'/')) &&
2853 !(cp1 = strrchr(dir,']')) &&
2854 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2855 if ((cp2 = strchr(cp1,'.')) != NULL &&
2856 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2857 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2858 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2859 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2861 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2862 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2863 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2864 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2865 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2866 (ver || *cp3)))))) {
2868 set_vaxc_errno(RMS$_DIR);
2871 retlen = cp2 - dir + 1;
2873 else { /* No file type present. Treat the filename as a directory. */
2874 retlen = strlen(dir) + 1;
2877 if (buf) retpath = buf;
2878 else if (ts) New(1313,retpath,retlen+1,char);
2879 else retpath = __pathify_retbuf;
2880 strncpy(retpath,dir,retlen-1);
2881 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2882 retpath[retlen-1] = '/'; /* with '/', add it. */
2883 retpath[retlen] = '\0';
2885 else retpath[retlen-1] = '\0';
2887 else { /* VMS-style directory spec */
2888 char esa[NAM$C_MAXRSS+1], *cp;
2889 unsigned long int sts, cmplen, haslower;
2890 struct FAB dirfab = cc$rms_fab;
2891 struct NAM savnam, dirnam = cc$rms_nam;
2893 /* If we've got an explicit filename, we can just shuffle the string. */
2894 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2895 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2896 if ((cp2 = strchr(cp1,'.')) != NULL) {
2898 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2899 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2900 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2901 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2902 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2903 (ver || *cp3)))))) {
2905 set_vaxc_errno(RMS$_DIR);
2909 else { /* No file type, so just draw name into directory part */
2910 for (cp2 = cp1; *cp2; cp2++) ;
2913 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2915 /* We've now got a VMS 'path'; fall through */
2917 dirfab.fab$b_fns = strlen(dir);
2918 dirfab.fab$l_fna = dir;
2919 if (dir[dirfab.fab$b_fns-1] == ']' ||
2920 dir[dirfab.fab$b_fns-1] == '>' ||
2921 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2922 if (buf) retpath = buf;
2923 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2924 else retpath = __pathify_retbuf;
2925 strcpy(retpath,dir);
2928 dirfab.fab$l_dna = ".DIR;1";
2929 dirfab.fab$b_dns = 6;
2930 dirfab.fab$l_nam = &dirnam;
2931 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2932 dirnam.nam$l_esa = esa;
2934 for (cp = dir; *cp; cp++)
2935 if (islower(*cp)) { haslower = 1; break; }
2937 if (!(sts = (sys$parse(&dirfab)&1))) {
2938 if (dirfab.fab$l_sts == RMS$_DIR) {
2939 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2940 sts = sys$parse(&dirfab) & 1;
2944 set_vaxc_errno(dirfab.fab$l_sts);
2950 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
2951 if (dirfab.fab$l_sts != RMS$_FNF) {
2952 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2953 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2955 set_vaxc_errno(dirfab.fab$l_sts);
2958 dirnam = savnam; /* No; just work with potential name */
2961 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2962 /* Yep; check version while we're at it, if it's there. */
2963 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2964 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2965 /* Something other than .DIR[;1]. Bzzt. */
2966 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2967 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2969 set_vaxc_errno(RMS$_DIR);
2973 /* OK, the type was fine. Now pull any file name into the
2975 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
2977 cp1 = strrchr(esa,'>');
2978 *dirnam.nam$l_type = '>';
2981 *(dirnam.nam$l_type + 1) = '\0';
2982 retlen = dirnam.nam$l_type - esa + 2;
2983 if (buf) retpath = buf;
2984 else if (ts) New(1314,retpath,retlen,char);
2985 else retpath = __pathify_retbuf;
2986 strcpy(retpath,esa);
2987 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2988 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2989 /* $PARSE may have upcased filespec, so convert output to lower
2990 * case if input contained any lowercase characters. */
2991 if (haslower) __mystrtolower(retpath);
2995 } /* end of do_pathify_dirspec() */
2997 /* External entry points */
2998 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2999 { return do_pathify_dirspec(dir,buf,0); }
3000 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3001 { return do_pathify_dirspec(dir,buf,1); }
3003 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3004 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3006 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3007 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3008 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3010 if (spec == NULL) return NULL;
3011 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3012 if (buf) rslt = buf;
3014 retlen = strlen(spec);
3015 cp1 = strchr(spec,'[');
3016 if (!cp1) cp1 = strchr(spec,'<');
3018 for (cp1++; *cp1; cp1++) {
3019 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3020 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3021 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3024 New(1315,rslt,retlen+2+2*expand,char);
3026 else rslt = __tounixspec_retbuf;
3027 if (strchr(spec,'/') != NULL) {
3034 dirend = strrchr(spec,']');
3035 if (dirend == NULL) dirend = strrchr(spec,'>');
3036 if (dirend == NULL) dirend = strchr(spec,':');
3037 if (dirend == NULL) {
3041 if (*cp2 != '[' && *cp2 != '<') {
3044 else { /* the VMS spec begins with directories */
3046 if (*cp2 == ']' || *cp2 == '>') {
3047 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3050 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3051 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3052 if (ts) Safefree(rslt);
3057 while (*cp3 != ':' && *cp3) cp3++;
3059 if (strchr(cp3,']') != NULL) break;
3060 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3062 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3063 retlen = devlen + dirlen;
3064 Renew(rslt,retlen+1+2*expand,char);
3070 *(cp1++) = *(cp3++);
3071 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3075 else if ( *cp2 == '.') {
3076 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3077 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3083 for (; cp2 <= dirend; cp2++) {
3086 if (*(cp2+1) == '[') cp2++;
3088 else if (*cp2 == ']' || *cp2 == '>') {
3089 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3091 else if (*cp2 == '.') {
3093 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3094 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3095 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3096 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3097 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3099 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3100 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3104 else if (*cp2 == '-') {
3105 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3106 while (*cp2 == '-') {
3108 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3110 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3111 if (ts) Safefree(rslt); /* filespecs like */
3112 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3116 else *(cp1++) = *cp2;
3118 else *(cp1++) = *cp2;
3120 while (*cp2) *(cp1++) = *(cp2++);
3125 } /* end of do_tounixspec() */
3127 /* External entry points */
3128 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3129 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3131 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3132 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3133 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3134 char *rslt, *dirend;
3135 register char *cp1, *cp2;
3136 unsigned long int infront = 0, hasdir = 1;
3138 if (path == NULL) return NULL;
3139 if (buf) rslt = buf;
3140 else if (ts) New(1316,rslt,strlen(path)+9,char);
3141 else rslt = __tovmsspec_retbuf;
3142 if (strpbrk(path,"]:>") ||
3143 (dirend = strrchr(path,'/')) == NULL) {
3144 if (path[0] == '.') {
3145 if (path[1] == '\0') strcpy(rslt,"[]");
3146 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3147 else strcpy(rslt,path); /* probably garbage */
3149 else strcpy(rslt,path);
3152 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3153 if (!*(dirend+2)) dirend +=2;
3154 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3155 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3160 char trndev[NAM$C_MAXRSS+1];
3164 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3166 if (!buf & ts) Renew(rslt,18,char);
3167 strcpy(rslt,"sys$disk:[000000]");
3170 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3172 islnm = my_trnlnm(rslt,trndev,0);
3173 trnend = islnm ? strlen(trndev) - 1 : 0;
3174 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3175 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3176 /* If the first element of the path is a logical name, determine
3177 * whether it has to be translated so we can add more directories. */
3178 if (!islnm || rooted) {
3181 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3185 if (cp2 != dirend) {
3186 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3187 strcpy(rslt,trndev);
3188 cp1 = rslt + trnend;
3201 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3202 cp2 += 2; /* skip over "./" - it's redundant */
3203 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3205 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3206 *(cp1++) = '-'; /* "../" --> "-" */
3209 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3210 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3211 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3212 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3215 if (cp2 > dirend) cp2 = dirend;
3217 else *(cp1++) = '.';
3219 for (; cp2 < dirend; cp2++) {
3221 if (*(cp2-1) == '/') continue;
3222 if (*(cp1-1) != '.') *(cp1++) = '.';
3225 else if (!infront && *cp2 == '.') {
3226 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3227 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3228 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3229 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3230 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3231 else { /* back up over previous directory name */
3233 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3234 if (*(cp1-1) == '[') {
3235 memcpy(cp1,"000000.",7);
3240 if (cp2 == dirend) break;
3242 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3243 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3244 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3245 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3247 *(cp1++) = '.'; /* Simulate trailing '/' */
3248 cp2 += 2; /* for loop will incr this to == dirend */
3250 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3252 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3255 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3256 if (*cp2 == '.') *(cp1++) = '_';
3257 else *(cp1++) = *cp2;
3261 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3262 if (hasdir) *(cp1++) = ']';
3263 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3264 while (*cp2) *(cp1++) = *(cp2++);
3269 } /* end of do_tovmsspec() */
3271 /* External entry points */
3272 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3273 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3275 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3276 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3277 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3279 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3281 if (path == NULL) return NULL;
3282 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3283 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3284 if (buf) return buf;
3286 vmslen = strlen(vmsified);
3287 New(1317,cp,vmslen+1,char);
3288 memcpy(cp,vmsified,vmslen);
3293 strcpy(__tovmspath_retbuf,vmsified);
3294 return __tovmspath_retbuf;
3297 } /* end of do_tovmspath() */
3299 /* External entry points */
3300 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3301 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3304 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3305 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3306 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3308 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3310 if (path == NULL) return NULL;
3311 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3312 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3313 if (buf) return buf;
3315 unixlen = strlen(unixified);
3316 New(1317,cp,unixlen+1,char);
3317 memcpy(cp,unixified,unixlen);
3322 strcpy(__tounixpath_retbuf,unixified);
3323 return __tounixpath_retbuf;
3326 } /* end of do_tounixpath() */
3328 /* External entry points */
3329 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3330 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3333 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3335 *****************************************************************************
3337 * Copyright (C) 1989-1994 by *
3338 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3340 * Permission is hereby granted for the reproduction of this software, *
3341 * on condition that this copyright notice is included in the reproduction, *
3342 * and that such reproduction is not for purposes of profit or material *
3345 * 27-Aug-1994 Modified for inclusion in perl5 *
3346 * by Charles Bailey bailey@newman.upenn.edu *
3347 *****************************************************************************
3351 * getredirection() is intended to aid in porting C programs
3352 * to VMS (Vax-11 C). The native VMS environment does not support
3353 * '>' and '<' I/O redirection, or command line wild card expansion,
3354 * or a command line pipe mechanism using the '|' AND background
3355 * command execution '&'. All of these capabilities are provided to any
3356 * C program which calls this procedure as the first thing in the
3358 * The piping mechanism will probably work with almost any 'filter' type
3359 * of program. With suitable modification, it may useful for other
3360 * portability problems as well.
3362 * Author: Mark Pizzolato mark@infocomm.com
3366 struct list_item *next;
3370 static void add_item(struct list_item **head,
3371 struct list_item **tail,
3375 static void mp_expand_wild_cards(pTHX_ char *item,
3376 struct list_item **head,
3377 struct list_item **tail,
3380 static int background_process(int argc, char **argv);
3382 static void pipe_and_fork(char **cmargv);
3384 /*{{{ void getredirection(int *ac, char ***av)*/
3386 mp_getredirection(pTHX_ int *ac, char ***av)
3388 * Process vms redirection arg's. Exit if any error is seen.
3389 * If getredirection() processes an argument, it is erased
3390 * from the vector. getredirection() returns a new argc and argv value.
3391 * In the event that a background command is requested (by a trailing "&"),
3392 * this routine creates a background subprocess, and simply exits the program.
3394 * Warning: do not try to simplify the code for vms. The code
3395 * presupposes that getredirection() is called before any data is
3396 * read from stdin or written to stdout.
3398 * Normal usage is as follows:
3404 * getredirection(&argc, &argv);
3408 int argc = *ac; /* Argument Count */
3409 char **argv = *av; /* Argument Vector */
3410 char *ap; /* Argument pointer */
3411 int j; /* argv[] index */
3412 int item_count = 0; /* Count of Items in List */
3413 struct list_item *list_head = 0; /* First Item in List */
3414 struct list_item *list_tail; /* Last Item in List */
3415 char *in = NULL; /* Input File Name */
3416 char *out = NULL; /* Output File Name */
3417 char *outmode = "w"; /* Mode to Open Output File */
3418 char *err = NULL; /* Error File Name */
3419 char *errmode = "w"; /* Mode to Open Error File */
3420 int cmargc = 0; /* Piped Command Arg Count */
3421 char **cmargv = NULL;/* Piped Command Arg Vector */
3424 * First handle the case where the last thing on the line ends with
3425 * a '&'. This indicates the desire for the command to be run in a
3426 * subprocess, so we satisfy that desire.
3429 if (0 == strcmp("&", ap))
3430 exit(background_process(--argc, argv));
3431 if (*ap && '&' == ap[strlen(ap)-1])
3433 ap[strlen(ap)-1] = '\0';
3434 exit(background_process(argc, argv));
3437 * Now we handle the general redirection cases that involve '>', '>>',
3438 * '<', and pipes '|'.
3440 for (j = 0; j < argc; ++j)
3442 if (0 == strcmp("<", argv[j]))
3446 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3447 exit(LIB$_WRONUMARG);
3452 if ('<' == *(ap = argv[j]))
3457 if (0 == strcmp(">", ap))
3461 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3462 exit(LIB$_WRONUMARG);
3481 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3482 exit(LIB$_WRONUMARG);
3486 if (('2' == *ap) && ('>' == ap[1]))
3503 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3504 exit(LIB$_WRONUMARG);
3508 if (0 == strcmp("|", argv[j]))
3512 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3513 exit(LIB$_WRONUMARG);
3515 cmargc = argc-(j+1);
3516 cmargv = &argv[j+1];
3520 if ('|' == *(ap = argv[j]))
3528 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3531 * Allocate and fill in the new argument vector, Some Unix's terminate
3532 * the list with an extra null pointer.
3534 New(1302, argv, item_count+1, char *);
3536 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3537 argv[j] = list_head->value;
3543 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3544 exit(LIB$_INVARGORD);
3546 pipe_and_fork(cmargv);
3549 /* Check for input from a pipe (mailbox) */
3551 if (in == NULL && 1 == isapipe(0))
3553 char mbxname[L_tmpnam];
3555 long int dvi_item = DVI$_DEVBUFSIZ;
3556 $DESCRIPTOR(mbxnam, "");
3557 $DESCRIPTOR(mbxdevnam, "");
3559 /* Input from a pipe, reopen it in binary mode to disable */
3560 /* carriage control processing. */
3562 PerlIO_getname(stdin, mbxname);
3563 mbxnam.dsc$a_pointer = mbxname;
3564 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3565 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3566 mbxdevnam.dsc$a_pointer = mbxname;
3567 mbxdevnam.dsc$w_length = sizeof(mbxname);
3568 dvi_item = DVI$_DEVNAM;
3569 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3570 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3573 freopen(mbxname, "rb", stdin);
3576 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3580 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3582 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3585 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3587 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3590 if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
3593 if (strcmp(err,"&1") == 0) {
3594 dup2(fileno(stdout), fileno(Perl_debug_log));
3595 Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
3598 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3600 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3604 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3608 Perl_vmssetuserlnm("SYS$ERROR",err);
3611 #ifdef ARGPROC_DEBUG
3612 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3613 for (j = 0; j < *ac; ++j)
3614 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3616 /* Clear errors we may have hit expanding wildcards, so they don't
3617 show up in Perl's $! later */
3618 set_errno(0); set_vaxc_errno(1);
3619 } /* end of getredirection() */
3622 static void add_item(struct list_item **head,
3623 struct list_item **tail,
3629 New(1303,*head,1,struct list_item);
3633 New(1304,(*tail)->next,1,struct list_item);
3634 *tail = (*tail)->next;
3636 (*tail)->value = value;
3640 static void mp_expand_wild_cards(pTHX_ char *item,
3641 struct list_item **head,
3642 struct list_item **tail,
3646 unsigned long int context = 0;
3652 char vmsspec[NAM$C_MAXRSS+1];
3653 $DESCRIPTOR(filespec, "");
3654 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3655 $DESCRIPTOR(resultspec, "");
3656 unsigned long int zero = 0, sts;
3658 for (cp = item; *cp; cp++) {
3659 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3660 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3662 if (!*cp || isspace(*cp))
3664 add_item(head, tail, item, count);
3667 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3668 resultspec.dsc$b_class = DSC$K_CLASS_D;
3669 resultspec.dsc$a_pointer = NULL;
3670 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3671 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3672 if (!isunix || !filespec.dsc$a_pointer)
3673 filespec.dsc$a_pointer = item;
3674 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3676 * Only return version specs, if the caller specified a version
3678 had_version = strchr(item, ';');
3680 * Only return device and directory specs, if the caller specifed either.
3682 had_device = strchr(item, ':');
3683 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3685 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3686 &defaultspec, 0, 0, &zero))))
3691 New(1305,string,resultspec.dsc$w_length+1,char);
3692 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3693 string[resultspec.dsc$w_length] = '\0';
3694 if (NULL == had_version)
3695 *((char *)strrchr(string, ';')) = '\0';
3696 if ((!had_directory) && (had_device == NULL))
3698 if (NULL == (devdir = strrchr(string, ']')))
3699 devdir = strrchr(string, '>');
3700 strcpy(string, devdir + 1);
3703 * Be consistent with what the C RTL has already done to the rest of
3704 * the argv items and lowercase all of these names.
3706 for (c = string; *c; ++c)
3709 if (isunix) trim_unixpath(string,item,1);
3710 add_item(head, tail, string, count);
3713 if (sts != RMS$_NMF)
3715 set_vaxc_errno(sts);
3718 case RMS$_FNF: case RMS$_DNF:
3719 set_errno(ENOENT); break;
3721 set_errno(ENOTDIR); break;
3723 set_errno(ENODEV); break;
3724 case RMS$_FNM: case RMS$_SYN:
3725 set_errno(EINVAL); break;
3727 set_errno(EACCES); break;
3729 _ckvmssts_noperl(sts);
3733 add_item(head, tail, item, count);
3734 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3735 _ckvmssts_noperl(lib$find_file_end(&context));
3738 static int child_st[2];/* Event Flag set when child process completes */
3740 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3742 static unsigned long int exit_handler(int *status)
3746 if (0 == child_st[0])
3748 #ifdef ARGPROC_DEBUG
3749 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3751 fflush(stdout); /* Have to flush pipe for binary data to */
3752 /* terminate properly -- <tp@mccall.com> */
3753 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3754 sys$dassgn(child_chan);
3756 sys$synch(0, child_st);
3761 static void sig_child(int chan)
3763 #ifdef ARGPROC_DEBUG
3764 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3766 if (child_st[0] == 0)
3770 static struct exit_control_block exit_block =
3775 &exit_block.exit_status,
3779 static void pipe_and_fork(char **cmargv)
3782 $DESCRIPTOR(cmddsc, "");
3783 static char mbxname[64];
3784 $DESCRIPTOR(mbxdsc, mbxname);
3786 unsigned long int zero = 0, one = 1;
3788 strcpy(subcmd, cmargv[0]);
3789 for (j = 1; NULL != cmargv[j]; ++j)
3791 strcat(subcmd, " \"");
3792 strcat(subcmd, cmargv[j]);
3793 strcat(subcmd, "\"");
3795 cmddsc.dsc$a_pointer = subcmd;
3796 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3798 create_mbx(&child_chan,&mbxdsc);
3799 #ifdef ARGPROC_DEBUG
3800 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3801 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3803 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3804 0, &pid, child_st, &zero, sig_child,
3806 #ifdef ARGPROC_DEBUG
3807 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3809 sys$dclexh(&exit_block);
3810 if (NULL == freopen(mbxname, "wb", stdout))
3812 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3816 static int background_process(int argc, char **argv)
3818 char command[2048] = "$";
3819 $DESCRIPTOR(value, "");
3820 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3821 static $DESCRIPTOR(null, "NLA0:");
3822 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3824 $DESCRIPTOR(pidstr, "");
3826 unsigned long int flags = 17, one = 1, retsts;
3828 strcat(command, argv[0]);
3831 strcat(command, " \"");
3832 strcat(command, *(++argv));
3833 strcat(command, "\"");
3835 value.dsc$a_pointer = command;
3836 value.dsc$w_length = strlen(value.dsc$a_pointer);
3837 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3838 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3839 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3840 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3843 _ckvmssts_noperl(retsts);
3845 #ifdef ARGPROC_DEBUG
3846 PerlIO_printf(Perl_debug_log, "%s\n", command);
3848 sprintf(pidstring, "%08X", pid);
3849 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3850 pidstr.dsc$a_pointer = pidstring;
3851 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3852 lib$set_symbol(&pidsymbol, &pidstr);
3856 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3859 /* OS-specific initialization at image activation (not thread startup) */
3860 /* Older VAXC header files lack these constants */
3861 #ifndef JPI$_RIGHTS_SIZE
3862 # define JPI$_RIGHTS_SIZE 817
3864 #ifndef KGB$M_SUBSYSTEM
3865 # define KGB$M_SUBSYSTEM 0x8
3868 /*{{{void vms_image_init(int *, char ***)*/
3870 vms_image_init(int *argcp, char ***argvp)
3872 char eqv[LNM$C_NAMLENGTH+1] = "";
3873 unsigned int len, tabct = 8, tabidx = 0;
3874 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3875 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3876 unsigned short int dummy, rlen;
3877 struct dsc$descriptor_s **tabvec;
3879 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3880 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3881 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3884 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3886 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3887 if (iprv[i]) { /* Running image installed with privs? */
3888 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3893 /* Rights identifiers might trigger tainting as well. */
3894 if (!will_taint && (rlen || rsz)) {
3895 while (rlen < rsz) {
3896 /* We didn't get all the identifiers on the first pass. Allocate a
3897 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3898 * were needed to hold all identifiers at time of last call; we'll
3899 * allocate that many unsigned long ints), and go back and get 'em.
3900 * If it gave us less than it wanted to despite ample buffer space,
3901 * something's broken. Is your system missing a system identifier?
3903 if (rsz <= jpilist[1].buflen) {
3904 /* Perl_croak accvios when used this early in startup. */
3905 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3906 rsz, (unsigned long) jpilist[1].buflen,
3907 "Check your rights database for corruption.\n");
3910 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3911 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3912 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3913 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3916 mask = jpilist[1].bufadr;
3917 /* Check attribute flags for each identifier (2nd longword); protected
3918 * subsystem identifiers trigger tainting.
3920 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3921 if (mask[i] & KGB$M_SUBSYSTEM) {
3926 if (mask != rlst) Safefree(mask);
3928 /* We need to use this hack to tell Perl it should run with tainting,
3929 * since its tainting flag may be part of the PL_curinterp struct, which
3930 * hasn't been allocated when vms_image_init() is called.
3934 New(1320,newap,*argcp+2,char **);
3935 newap[0] = argvp[0];
3937 Copy(argvp[1],newap[2],*argcp-1,char **);
3938 /* We orphan the old argv, since we don't know where it's come from,
3939 * so we don't know how to free it.
3941 *argcp++; argvp = newap;
3943 else { /* Did user explicitly request tainting? */
3945 char *cp, **av = *argvp;
3946 for (i = 1; i < *argcp; i++) {
3947 if (*av[i] != '-') break;
3948 for (cp = av[i]+1; *cp; cp++) {
3949 if (*cp == 'T') { will_taint = 1; break; }
3950 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3951 strchr("DFIiMmx",*cp)) break;
3953 if (will_taint) break;
3958 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3960 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3961 else if (tabidx >= tabct) {
3963 Renew(tabvec,tabct,struct dsc$descriptor_s *);
3965 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3966 tabvec[tabidx]->dsc$w_length = 0;
3967 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
3968 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
3969 tabvec[tabidx]->dsc$a_pointer = NULL;
3970 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3972 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
3974 getredirection(argcp,argvp);
3975 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
3977 # include <reentrancy.h>
3978 (void) decc$set_reentrancy(C$C_MULTITHREAD);
3987 * Trim Unix-style prefix off filespec, so it looks like what a shell
3988 * glob expansion would return (i.e. from specified prefix on, not
3989 * full path). Note that returned filespec is Unix-style, regardless
3990 * of whether input filespec was VMS-style or Unix-style.
3992 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
3993 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
3994 * vector of options; at present, only bit 0 is used, and if set tells
3995 * trim unixpath to try the current default directory as a prefix when
3996 * presented with a possibly ambiguous ... wildcard.
3998 * Returns !=0 on success, with trimmed filespec replacing contents of
3999 * fspec, and 0 on failure, with contents of fpsec unchanged.
4001 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4003 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4005 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4006 *template, *base, *end, *cp1, *cp2;
4007 register int tmplen, reslen = 0, dirs = 0;
4009 if (!wildspec || !fspec) return 0;
4010 if (strpbrk(wildspec,"]>:") != NULL) {
4011 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4012 else template = unixwild;
4014 else template = wildspec;
4015 if (strpbrk(fspec,"]>:") != NULL) {
4016 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4017 else base = unixified;
4018 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4019 * check to see that final result fits into (isn't longer than) fspec */
4020 reslen = strlen(fspec);
4024 /* No prefix or absolute path on wildcard, so nothing to remove */
4025 if (!*template || *template == '/') {
4026 if (base == fspec) return 1;
4027 tmplen = strlen(unixified);
4028 if (tmplen > reslen) return 0; /* not enough space */
4029 /* Copy unixified resultant, including trailing NUL */
4030 memmove(fspec,unixified,tmplen+1);
4034 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4035 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4036 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4037 for (cp1 = end ;cp1 >= base; cp1--)
4038 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4040 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4044 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4045 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4046 int ells = 1, totells, segdirs, match;
4047 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4048 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4050 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4052 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4053 if (ellipsis == template && opts & 1) {
4054 /* Template begins with an ellipsis. Since we can't tell how many
4055 * directory names at the front of the resultant to keep for an
4056 * arbitrary starting point, we arbitrarily choose the current
4057 * default directory as a starting point. If it's there as a prefix,
4058 * clip it off. If not, fall through and act as if the leading
4059 * ellipsis weren't there (i.e. return shortest possible path that
4060 * could match template).
4062 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4063 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4064 if (_tolower(*cp1) != _tolower(*cp2)) break;
4065 segdirs = dirs - totells; /* Min # of dirs we must have left */
4066 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4067 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4068 memcpy(fspec,cp2+1,end - cp2);
4072 /* First off, back up over constant elements at end of path */
4074 for (front = end ; front >= base; front--)
4075 if (*front == '/' && !dirs--) { front++; break; }
4077 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4078 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4079 if (cp1 != '\0') return 0; /* Path too long. */
4081 *cp2 = '\0'; /* Pick up with memcpy later */
4082 lcfront = lcres + (front - base);
4083 /* Now skip over each ellipsis and try to match the path in front of it. */
4085 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4086 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4087 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4088 if (cp1 < template) break; /* template started with an ellipsis */
4089 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4090 ellipsis = cp1; continue;
4092 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4094 for (segdirs = 0, cp2 = tpl;
4095 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4097 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4098 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4099 if (*cp2 == '/') segdirs++;
4101 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4102 /* Back up at least as many dirs as in template before matching */
4103 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4104 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4105 for (match = 0; cp1 > lcres;) {
4106 resdsc.dsc$a_pointer = cp1;
4107 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4109 if (match == 1) lcfront = cp1;
4111 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4113 if (!match) return 0; /* Can't find prefix ??? */
4114 if (match > 1 && opts & 1) {
4115 /* This ... wildcard could cover more than one set of dirs (i.e.
4116 * a set of similar dir names is repeated). If the template
4117 * contains more than 1 ..., upstream elements could resolve the
4118 * ambiguity, but it's not worth a full backtracking setup here.
4119 * As a quick heuristic, clip off the current default directory
4120 * if it's present to find the trimmed spec, else use the
4121 * shortest string that this ... could cover.
4123 char def[NAM$C_MAXRSS+1], *st;
4125 if (getcwd(def, sizeof def,0) == NULL) return 0;
4126 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4127 if (_tolower(*cp1) != _tolower(*cp2)) break;
4128 segdirs = dirs - totells; /* Min # of dirs we must have left */
4129 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4130 if (*cp1 == '\0' && *cp2 == '/') {
4131 memcpy(fspec,cp2+1,end - cp2);
4134 /* Nope -- stick with lcfront from above and keep going. */
4137 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4142 } /* end of trim_unixpath() */
4147 * VMS readdir() routines.
4148 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4150 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4151 * Minor modifications to original routines.
4154 /* Number of elements in vms_versions array */
4155 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4158 * Open a directory, return a handle for later use.
4160 /*{{{ DIR *opendir(char*name) */
4162 Perl_opendir(pTHX_ char *name)
4165 char dir[NAM$C_MAXRSS+1];
4168 if (do_tovmspath(name,dir,0) == NULL) {
4171 if (flex_stat(dir,&sb) == -1) return NULL;
4172 if (!S_ISDIR(sb.st_mode)) {
4173 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4176 if (!cando_by_name(S_IRUSR,0,dir)) {
4177 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4180 /* Get memory for the handle, and the pattern. */
4182 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4184 /* Fill in the fields; mainly playing with the descriptor. */
4185 (void)sprintf(dd->pattern, "%s*.*",dir);
4188 dd->vms_wantversions = 0;
4189 dd->pat.dsc$a_pointer = dd->pattern;
4190 dd->pat.dsc$w_length = strlen(dd->pattern);
4191 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4192 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4195 } /* end of opendir() */
4199 * Set the flag to indicate we want versions or not.
4201 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4203 vmsreaddirversions(DIR *dd, int flag)
4205 dd->vms_wantversions = flag;
4210 * Free up an opened directory.
4212 /*{{{ void closedir(DIR *dd)*/
4216 (void)lib$find_file_end(&dd->context);
4217 Safefree(dd->pattern);
4218 Safefree((char *)dd);
4223 * Collect all the version numbers for the current file.
4229 struct dsc$descriptor_s pat;
4230 struct dsc$descriptor_s res;
4232 char *p, *text, buff[sizeof dd->entry.d_name];
4234 unsigned long context, tmpsts;
4237 /* Convenient shorthand. */
4240 /* Add the version wildcard, ignoring the "*.*" put on before */
4241 i = strlen(dd->pattern);
4242 New(1308,text,i + e->d_namlen + 3,char);
4243 (void)strcpy(text, dd->pattern);
4244 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4246 /* Set up the pattern descriptor. */
4247 pat.dsc$a_pointer = text;
4248 pat.dsc$w_length = i + e->d_namlen - 1;
4249 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4250 pat.dsc$b_class = DSC$K_CLASS_S;
4252 /* Set up result descriptor. */
4253 res.dsc$a_pointer = buff;
4254 res.dsc$w_length = sizeof buff - 2;
4255 res.dsc$b_dtype = DSC$K_DTYPE_T;
4256 res.dsc$b_class = DSC$K_CLASS_S;
4258 /* Read files, collecting versions. */
4259 for (context = 0, e->vms_verscount = 0;
4260 e->vms_verscount < VERSIZE(e);
4261 e->vms_verscount++) {
4262 tmpsts = lib$find_file(&pat, &res, &context);
4263 if (tmpsts == RMS$_NMF || context == 0) break;
4265 buff[sizeof buff - 1] = '\0';
4266 if ((p = strchr(buff, ';')))
4267 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4269 e->vms_versions[e->vms_verscount] = -1;
4272 _ckvmssts(lib$find_file_end(&context));
4275 } /* end of collectversions() */
4278 * Read the next entry from the directory.
4280 /*{{{ struct dirent *readdir(DIR *dd)*/
4284 struct dsc$descriptor_s res;
4285 char *p, buff[sizeof dd->entry.d_name];
4286 unsigned long int tmpsts;
4288 /* Set up result descriptor, and get next file. */
4289 res.dsc$a_pointer = buff;
4290 res.dsc$w_length = sizeof buff - 2;
4291 res.dsc$b_dtype = DSC$K_DTYPE_T;
4292 res.dsc$b_class = DSC$K_CLASS_S;
4293 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4294 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4295 if (!(tmpsts & 1)) {
4296 set_vaxc_errno(tmpsts);
4299 set_errno(EACCES); break;
4301 set_errno(ENODEV); break;
4303 set_errno(ENOTDIR); break;
4304 case RMS$_FNF: case RMS$_DNF:
4305 set_errno(ENOENT); break;
4312 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4313 buff[sizeof buff - 1] = '\0';
4314 for (p = buff; *p; p++) *p = _tolower(*p);
4315 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4318 /* Skip any directory component and just copy the name. */
4319 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4320 else (void)strcpy(dd->entry.d_name, buff);
4322 /* Clobber the version. */
4323 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4325 dd->entry.d_namlen = strlen(dd->entry.d_name);
4326 dd->entry.vms_verscount = 0;
4327 if (dd->vms_wantversions) collectversions(dd);
4330 } /* end of readdir() */
4334 * Return something that can be used in a seekdir later.
4336 /*{{{ long telldir(DIR *dd)*/
4345 * Return to a spot where we used to be. Brute force.
4347 /*{{{ void seekdir(DIR *dd,long count)*/
4349 seekdir(DIR *dd, long count)
4351 int vms_wantversions;
4354 /* If we haven't done anything yet... */
4358 /* Remember some state, and clear it. */
4359 vms_wantversions = dd->vms_wantversions;
4360 dd->vms_wantversions = 0;
4361 _ckvmssts(lib$find_file_end(&dd->context));
4364 /* The increment is in readdir(). */
4365 for (dd->count = 0; dd->count < count; )
4368 dd->vms_wantversions = vms_wantversions;
4370 } /* end of seekdir() */
4373 /* VMS subprocess management
4375 * my_vfork() - just a vfork(), after setting a flag to record that
4376 * the current script is trying a Unix-style fork/exec.
4378 * vms_do_aexec() and vms_do_exec() are called in response to the
4379 * perl 'exec' function. If this follows a vfork call, then they
4380 * call out the the regular perl routines in doio.c which do an
4381 * execvp (for those who really want to try this under VMS).
4382 * Otherwise, they do exactly what the perl docs say exec should
4383 * do - terminate the current script and invoke a new command
4384 * (See below for notes on command syntax.)
4386 * do_aspawn() and do_spawn() implement the VMS side of the perl
4387 * 'system' function.
4389 * Note on command arguments to perl 'exec' and 'system': When handled
4390 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4391 * are concatenated to form a DCL command string. If the first arg
4392 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4393 * the the command string is handed off to DCL directly. Otherwise,
4394 * the first token of the command is taken as the filespec of an image
4395 * to run. The filespec is expanded using a default type of '.EXE' and
4396 * the process defaults for device, directory, etc., and if found, the resultant
4397 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4398 * the command string as parameters. This is perhaps a bit complicated,
4399 * but I hope it will form a happy medium between what VMS folks expect
4400 * from lib$spawn and what Unix folks expect from exec.
4403 static int vfork_called;
4405 /*{{{int my_vfork()*/
4416 vms_execfree(pTHX) {
4418 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4421 if (VMScmd.dsc$a_pointer) {
4422 Safefree(VMScmd.dsc$a_pointer);
4423 VMScmd.dsc$w_length = 0;
4424 VMScmd.dsc$a_pointer = Nullch;
4429 setup_argstr(SV *really, SV **mark, SV **sp)
4432 char *junk, *tmps = Nullch;
4433 register size_t cmdlen = 0;
4440 tmps = SvPV(really,rlen);
4447 for (idx++; idx <= sp; idx++) {
4449 junk = SvPVx(*idx,rlen);
4450 cmdlen += rlen ? rlen + 1 : 0;
4453 New(401,PL_Cmd,cmdlen+1,char);
4455 if (tmps && *tmps) {
4456 strcpy(PL_Cmd,tmps);
4459 else *PL_Cmd = '\0';
4460 while (++mark <= sp) {
4462 char *s = SvPVx(*mark,n_a);
4464 if (*PL_Cmd) strcat(PL_Cmd," ");
4470 } /* end of setup_argstr() */
4473 static unsigned long int
4474 setup_cmddsc(char *cmd, int check_img)
4476 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4477 $DESCRIPTOR(defdsc,".EXE");
4478 $DESCRIPTOR(defdsc2,".");
4479 $DESCRIPTOR(resdsc,resspec);
4480 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4481 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4482 register char *s, *rest, *cp, *wordbreak;
4487 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4490 while (*s && isspace(*s)) s++;
4492 if (*s == '@' || *s == '$') {
4493 vmsspec[0] = *s; rest = s + 1;
4494 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4496 else { cp = vmsspec; rest = s; }
4497 if (*rest == '.' || *rest == '/') {
4500 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4501 rest++, cp2++) *cp2 = *rest;
4503 if (do_tovmsspec(resspec,cp,0)) {
4506 for (cp2 = vmsspec + strlen(vmsspec);
4507 *rest && cp2 - vmsspec < sizeof vmsspec;
4508 rest++, cp2++) *cp2 = *rest;
4513 /* Intuit whether verb (first word of cmd) is a DCL command:
4514 * - if first nonspace char is '@', it's a DCL indirection
4516 * - if verb contains a filespec separator, it's not a DCL command
4517 * - if it doesn't, caller tells us whether to default to a DCL
4518 * command, or to a local image unless told it's DCL (by leading '$')
4520 if (*s == '@') isdcl = 1;
4522 register char *filespec = strpbrk(s,":<[.;");
4523 rest = wordbreak = strpbrk(s," \"\t/");
4524 if (!wordbreak) wordbreak = s + strlen(s);
4525 if (*s == '$') check_img = 0;
4526 if (filespec && (filespec < wordbreak)) isdcl = 0;
4527 else isdcl = !check_img;
4531 imgdsc.dsc$a_pointer = s;
4532 imgdsc.dsc$w_length = wordbreak - s;
4533 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4535 _ckvmssts(lib$find_file_end(&cxt));
4536 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4537 if (!(retsts & 1) && *s == '$') {
4538 _ckvmssts(lib$find_file_end(&cxt));
4539 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4540 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4542 _ckvmssts(lib$find_file_end(&cxt));
4543 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4547 _ckvmssts(lib$find_file_end(&cxt));
4552 while (*s && !isspace(*s)) s++;
4555 /* check that it's really not DCL with no file extension */
4556 fp = fopen(resspec,"r","ctx=bin,shr=get");
4558 char b[4] = {0,0,0,0};
4559 read(fileno(fp),b,4);
4560 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4563 if (check_img && isdcl) return RMS$_FNF;
4565 if (cando_by_name(S_IXUSR,0,resspec)) {
4566 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4568 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4570 strcpy(VMScmd.dsc$a_pointer,"@");
4572 strcat(VMScmd.dsc$a_pointer,resspec);
4573 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4574 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4577 else retsts = RMS$_PRV;
4580 /* It's either a DCL command or we couldn't find a suitable image */
4581 VMScmd.dsc$w_length = strlen(cmd);
4582 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4583 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4584 if (!(retsts & 1)) {
4585 /* just hand off status values likely to be due to user error */
4586 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4587 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4588 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4589 else { _ckvmssts(retsts); }
4592 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4594 } /* end of setup_cmddsc() */
4597 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4599 vms_do_aexec(SV *really,SV **mark,SV **sp)
4603 if (vfork_called) { /* this follows a vfork - act Unixish */
4605 if (vfork_called < 0) {
4606 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4609 else return do_aexec(really,mark,sp);
4611 /* no vfork - act VMSish */
4612 return vms_do_exec(setup_argstr(really,mark,sp));
4617 } /* end of vms_do_aexec() */
4620 /* {{{bool vms_do_exec(char *cmd) */
4622 vms_do_exec(char *cmd)
4626 if (vfork_called) { /* this follows a vfork - act Unixish */
4628 if (vfork_called < 0) {
4629 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4632 else return do_exec(cmd);
4635 { /* no vfork - act VMSish */
4636 unsigned long int retsts;
4639 TAINT_PROPER("exec");
4640 if ((retsts = setup_cmddsc(cmd,1)) & 1)
4641 retsts = lib$do_command(&VMScmd);
4644 case RMS$_FNF: case RMS$_DNF:
4645 set_errno(ENOENT); break;
4647 set_errno(ENOTDIR); break;
4649 set_errno(ENODEV); break;
4651 set_errno(EACCES); break;
4653 set_errno(EINVAL); break;
4655 set_errno(E2BIG); break;
4656 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4657 _ckvmssts(retsts); /* fall through */
4658 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4661 set_vaxc_errno(retsts);
4662 if (ckWARN(WARN_EXEC)) {
4663 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4664 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4671 } /* end of vms_do_exec() */
4674 unsigned long int do_spawn(char *);
4676 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4678 do_aspawn(void *really,void **mark,void **sp)
4681 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4684 } /* end of do_aspawn() */
4687 /* {{{unsigned long int do_spawn(char *cmd) */
4691 unsigned long int sts, substs, hadcmd = 1;
4695 TAINT_PROPER("spawn");
4696 if (!cmd || !*cmd) {
4698 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4700 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4701 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4706 case RMS$_FNF: case RMS$_DNF:
4707 set_errno(ENOENT); break;
4709 set_errno(ENOTDIR); break;
4711 set_errno(ENODEV); break;
4713 set_errno(EACCES); break;
4715 set_errno(EINVAL); break;
4717 set_errno(E2BIG); break;
4718 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4719 _ckvmssts(sts); /* fall through */
4720 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4723 set_vaxc_errno(sts);
4724 if (ckWARN(WARN_EXEC)) {
4725 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4726 hadcmd ? VMScmd.dsc$w_length : 0,
4727 hadcmd ? VMScmd.dsc$a_pointer : "",
4734 } /* end of do_spawn() */
4738 * A simple fwrite replacement which outputs itmsz*nitm chars without
4739 * introducing record boundaries every itmsz chars.
4740 * We are using fputs, which depends on a terminating null. We may
4741 * well be writing binary data, so we need to accommodate not only
4742 * data with nulls sprinkled in the middle but also data with no null
4745 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4747 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4749 register char *cp, *end, *cpd, *data;
4751 int bufsize = itmsz*nitm+1;
4753 _ckvmssts_noperl(lib$get_vm( &bufsize, &data ));
4754 memcpy( data, src, itmsz*nitm );
4755 data[itmsz*nitm] = '\0';
4757 end = data + itmsz * nitm;
4758 retval = (int) nitm; /* on success return # items written */
4761 while (cpd <= end) {
4762 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4763 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4765 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4769 if (data) _ckvmssts_noperl(lib$free_vm( &bufsize, &data ));
4772 } /* end of my_fwrite() */
4775 /*{{{ int my_flush(FILE *fp)*/
4780 if ((res = fflush(fp)) == 0 && fp) {
4781 #ifdef VMS_DO_SOCKETS
4783 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4785 res = fsync(fileno(fp));
4788 * If the flush succeeded but set end-of-file, we need to clear
4789 * the error because our caller may check ferror(). BTW, this
4790 * probably means we just flushed an empty file.
4792 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4799 * Here are replacements for the following Unix routines in the VMS environment:
4800 * getpwuid Get information for a particular UIC or UID
4801 * getpwnam Get information for a named user
4802 * getpwent Get information for each user in the rights database
4803 * setpwent Reset search to the start of the rights database
4804 * endpwent Finish searching for users in the rights database
4806 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4807 * (defined in pwd.h), which contains the following fields:-
4809 * char *pw_name; Username (in lower case)
4810 * char *pw_passwd; Hashed password
4811 * unsigned int pw_uid; UIC
4812 * unsigned int pw_gid; UIC group number
4813 * char *pw_unixdir; Default device/directory (VMS-style)
4814 * char *pw_gecos; Owner name
4815 * char *pw_dir; Default device/directory (Unix-style)
4816 * char *pw_shell; Default CLI name (eg. DCL)
4818 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4820 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4821 * not the UIC member number (eg. what's returned by getuid()),
4822 * getpwuid() can accept either as input (if uid is specified, the caller's
4823 * UIC group is used), though it won't recognise gid=0.
4825 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4826 * information about other users in your group or in other groups, respectively.
4827 * If the required privilege is not available, then these routines fill only
4828 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4831 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4834 /* sizes of various UAF record fields */
4835 #define UAI$S_USERNAME 12
4836 #define UAI$S_IDENT 31
4837 #define UAI$S_OWNER 31
4838 #define UAI$S_DEFDEV 31
4839 #define UAI$S_DEFDIR 63
4840 #define UAI$S_DEFCLI 31
4843 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4844 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4845 (uic).uic$v_group != UIC$K_WILD_GROUP)
4847 static char __empty[]= "";
4848 static struct passwd __passwd_empty=
4849 {(char *) __empty, (char *) __empty, 0, 0,
4850 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4851 static int contxt= 0;
4852 static struct passwd __pwdcache;
4853 static char __pw_namecache[UAI$S_IDENT+1];
4856 * This routine does most of the work extracting the user information.
4858 static int fillpasswd (const char *name, struct passwd *pwd)
4862 unsigned char length;
4863 char pw_gecos[UAI$S_OWNER+1];
4865 static union uicdef uic;
4867 unsigned char length;
4868 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4871 unsigned char length;
4872 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4875 unsigned char length;
4876 char pw_shell[UAI$S_DEFCLI+1];
4878 static char pw_passwd[UAI$S_PWD+1];
4880 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4881 struct dsc$descriptor_s name_desc;
4882 unsigned long int sts;
4884 static struct itmlst_3 itmlst[]= {
4885 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4886 {sizeof(uic), UAI$_UIC, &uic, &luic},
4887 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
4888 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
4889 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
4890 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
4891 {0, 0, NULL, NULL}};
4893 name_desc.dsc$w_length= strlen(name);
4894 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4895 name_desc.dsc$b_class= DSC$K_CLASS_S;
4896 name_desc.dsc$a_pointer= (char *) name;
4898 /* Note that sys$getuai returns many fields as counted strings. */
4899 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4900 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4901 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4903 else { _ckvmssts(sts); }
4904 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
4906 if ((int) owner.length < lowner) lowner= (int) owner.length;
4907 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4908 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4909 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4910 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4911 owner.pw_gecos[lowner]= '\0';
4912 defdev.pw_dir[ldefdev+ldefdir]= '\0';
4913 defcli.pw_shell[ldefcli]= '\0';
4914 if (valid_uic(uic)) {
4915 pwd->pw_uid= uic.uic$l_uic;
4916 pwd->pw_gid= uic.uic$v_group;
4919 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
4920 pwd->pw_passwd= pw_passwd;
4921 pwd->pw_gecos= owner.pw_gecos;
4922 pwd->pw_dir= defdev.pw_dir;
4923 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
4924 pwd->pw_shell= defcli.pw_shell;
4925 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
4927 ldir= strlen(pwd->pw_unixdir) - 1;
4928 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
4931 strcpy(pwd->pw_unixdir, pwd->pw_dir);
4932 __mystrtolower(pwd->pw_unixdir);
4937 * Get information for a named user.
4939 /*{{{struct passwd *getpwnam(char *name)*/
4940 struct passwd *my_getpwnam(char *name)
4942 struct dsc$descriptor_s name_desc;
4944 unsigned long int status, sts;
4947 __pwdcache = __passwd_empty;
4948 if (!fillpasswd(name, &__pwdcache)) {
4949 /* We still may be able to determine pw_uid and pw_gid */
4950 name_desc.dsc$w_length= strlen(name);
4951 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4952 name_desc.dsc$b_class= DSC$K_CLASS_S;
4953 name_desc.dsc$a_pointer= (char *) name;
4954 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
4955 __pwdcache.pw_uid= uic.uic$l_uic;
4956 __pwdcache.pw_gid= uic.uic$v_group;
4959 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
4960 set_vaxc_errno(sts);
4961 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
4964 else { _ckvmssts(sts); }
4967 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
4968 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
4969 __pwdcache.pw_name= __pw_namecache;
4971 } /* end of my_getpwnam() */
4975 * Get information for a particular UIC or UID.
4976 * Called by my_getpwent with uid=-1 to list all users.
4978 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
4979 struct passwd *my_getpwuid(Uid_t uid)
4981 const $DESCRIPTOR(name_desc,__pw_namecache);
4982 unsigned short lname;
4984 unsigned long int status;
4987 if (uid == (unsigned int) -1) {
4989 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
4990 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
4991 set_vaxc_errno(status);
4992 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4996 else { _ckvmssts(status); }
4997 } while (!valid_uic (uic));
5001 if (!uic.uic$v_group)
5002 uic.uic$v_group= PerlProc_getgid();
5004 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5005 else status = SS$_IVIDENT;
5006 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5007 status == RMS$_PRV) {
5008 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5011 else { _ckvmssts(status); }
5013 __pw_namecache[lname]= '\0';
5014 __mystrtolower(__pw_namecache);
5016 __pwdcache = __passwd_empty;
5017 __pwdcache.pw_name = __pw_namecache;
5019 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5020 The identifier's value is usually the UIC, but it doesn't have to be,
5021 so if we can, we let fillpasswd update this. */
5022 __pwdcache.pw_uid = uic.uic$l_uic;
5023 __pwdcache.pw_gid = uic.uic$v_group;
5025 fillpasswd(__pw_namecache, &__pwdcache);
5028 } /* end of my_getpwuid() */
5032 * Get information for next user.
5034 /*{{{struct passwd *my_getpwent()*/
5035 struct passwd *my_getpwent()
5037 return (my_getpwuid((unsigned int) -1));
5042 * Finish searching rights database for users.
5044 /*{{{void my_endpwent()*/
5049 _ckvmssts(sys$finish_rdb(&contxt));
5055 #ifdef HOMEGROWN_POSIX_SIGNALS
5056 /* Signal handling routines, pulled into the core from POSIX.xs.
5058 * We need these for threads, so they've been rolled into the core,
5059 * rather than left in POSIX.xs.
5061 * (DRS, Oct 23, 1997)
5064 /* sigset_t is atomic under VMS, so these routines are easy */
5065 /*{{{int my_sigemptyset(sigset_t *) */
5066 int my_sigemptyset(sigset_t *set) {
5067 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5073 /*{{{int my_sigfillset(sigset_t *)*/
5074 int my_sigfillset(sigset_t *set) {
5076 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5077 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5083 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5084 int my_sigaddset(sigset_t *set, int sig) {
5085 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5086 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5087 *set |= (1 << (sig - 1));
5093 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5094 int my_sigdelset(sigset_t *set, int sig) {
5095 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5096 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5097 *set &= ~(1 << (sig - 1));
5103 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5104 int my_sigismember(sigset_t *set, int sig) {
5105 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5106 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5107 *set & (1 << (sig - 1));
5112 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5113 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5116 /* If set and oset are both null, then things are badly wrong. Bail out. */
5117 if ((oset == NULL) && (set == NULL)) {
5118 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5122 /* If set's null, then we're just handling a fetch. */
5124 tempmask = sigblock(0);
5129 tempmask = sigsetmask(*set);
5132 tempmask = sigblock(*set);
5135 tempmask = sigblock(0);
5136 sigsetmask(*oset & ~tempmask);
5139 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5144 /* Did they pass us an oset? If so, stick our holding mask into it */
5151 #endif /* HOMEGROWN_POSIX_SIGNALS */
5154 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5155 * my_utime(), and flex_stat(), all of which operate on UTC unless
5156 * VMSISH_TIMES is true.
5158 /* method used to handle UTC conversions:
5159 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5161 static int gmtime_emulation_type;
5162 /* number of secs to add to UTC POSIX-style time to get local time */
5163 static long int utc_offset_secs;
5165 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5166 * in vmsish.h. #undef them here so we can call the CRTL routines
5175 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5176 * qualifier with the extern prefix pragma. This provisional
5177 * hack circumvents this prefix pragma problem in previous
5180 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5181 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5182 # pragma __extern_prefix save
5183 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5184 # define gmtime decc$__utctz_gmtime
5185 # define localtime decc$__utctz_localtime
5186 # define time decc$__utc_time
5187 # pragma __extern_prefix restore
5189 struct tm *gmtime(), *localtime();
5195 static time_t toutc_dst(time_t loc) {
5198 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5199 loc -= utc_offset_secs;
5200 if (rsltmp->tm_isdst) loc -= 3600;
5203 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5204 ((gmtime_emulation_type || my_time(NULL)), \
5205 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5206 ((secs) - utc_offset_secs))))
5208 static time_t toloc_dst(time_t utc) {
5211 utc += utc_offset_secs;
5212 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5213 if (rsltmp->tm_isdst) utc += 3600;
5216 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5217 ((gmtime_emulation_type || my_time(NULL)), \
5218 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5219 ((secs) + utc_offset_secs))))
5221 #ifndef RTL_USES_UTC
5224 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5225 DST starts on 1st sun of april at 02:00 std time
5226 ends on last sun of october at 02:00 dst time
5227 see the UCX management command reference, SET CONFIG TIMEZONE
5228 for formatting info.
5230 No, it's not as general as it should be, but then again, NOTHING
5231 will handle UK times in a sensible way.
5236 parse the DST start/end info:
5237 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5241 tz_parse_startend(char *s, struct tm *w, int *past)
5243 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5244 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5249 if (!past) return 0;
5252 if (w->tm_year % 4 == 0) ly = 1;
5253 if (w->tm_year % 100 == 0) ly = 0;
5254 if (w->tm_year+1900 % 400 == 0) ly = 1;
5257 dozjd = isdigit(*s);
5258 if (*s == 'J' || *s == 'j' || dozjd) {
5259 if (!dozjd && !isdigit(*++s)) return 0;
5262 d = d*10 + *s++ - '0';
5264 d = d*10 + *s++ - '0';
5267 if (d == 0) return 0;
5268 if (d > 366) return 0;
5270 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5273 } else if (*s == 'M' || *s == 'm') {
5274 if (!isdigit(*++s)) return 0;
5276 if (isdigit(*s)) m = 10*m + *s++ - '0';
5277 if (*s != '.') return 0;
5278 if (!isdigit(*++s)) return 0;
5280 if (n < 1 || n > 5) return 0;
5281 if (*s != '.') return 0;
5282 if (!isdigit(*++s)) return 0;
5284 if (d > 6) return 0;
5288 if (!isdigit(*++s)) return 0;
5290 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5292 if (!isdigit(*++s)) return 0;
5294 if (isdigit(*s)) min = 10*min + *s++ - '0';
5296 if (!isdigit(*++s)) return 0;
5298 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5308 if (w->tm_yday < d) goto before;
5309 if (w->tm_yday > d) goto after;
5311 if (w->tm_mon+1 < m) goto before;
5312 if (w->tm_mon+1 > m) goto after;
5314 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5315 k = d - j; /* mday of first d */
5317 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5318 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5319 if (w->tm_mday < k) goto before;
5320 if (w->tm_mday > k) goto after;
5323 if (w->tm_hour < hour) goto before;
5324 if (w->tm_hour > hour) goto after;
5325 if (w->tm_min < min) goto before;
5326 if (w->tm_min > min) goto after;
5327 if (w->tm_sec < sec) goto before;
5341 /* parse the offset: (+|-)hh[:mm[:ss]] */
5344 tz_parse_offset(char *s, int *offset)
5346 int hour = 0, min = 0, sec = 0;
5349 if (!offset) return 0;
5351 if (*s == '-') {neg++; s++;}
5353 if (!isdigit(*s)) return 0;
5355 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5356 if (hour > 24) return 0;
5358 if (!isdigit(*++s)) return 0;
5360 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5361 if (min > 59) return 0;
5363 if (!isdigit(*++s)) return 0;
5365 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5366 if (sec > 59) return 0;
5370 *offset = (hour*60+min)*60 + sec;
5371 if (neg) *offset = -*offset;
5376 input time is w, whatever type of time the CRTL localtime() uses.
5377 sets dst, the zone, and the gmtoff (seconds)
5379 caches the value of TZ and UCX$TZ env variables; note that
5380 my_setenv looks for these and sets a flag if they're changed
5383 We have to watch out for the "australian" case (dst starts in
5384 october, ends in april)...flagged by "reverse" and checked by
5385 scanning through the months of the previous year.
5390 tz_parse(time_t *w, int *dst, char *zone, int *gmtoff)
5395 char *dstzone, *tz, *s_start, *s_end;
5396 int std_off, dst_off, isdst;
5397 int y, dststart, dstend;
5398 static char envtz[1025]; /* longer than any logical, symbol, ... */
5399 static char ucxtz[1025];
5400 static char reversed = 0;
5406 reversed = -1; /* flag need to check */
5407 envtz[0] = ucxtz[0] = '\0';
5408 tz = my_getenv("TZ",0);
5409 if (tz) strcpy(envtz, tz);
5410 tz = my_getenv("UCX$TZ",0);
5411 if (tz) strcpy(ucxtz, tz);
5412 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5415 if (!*tz) tz = ucxtz;
5418 while (isalpha(*s)) s++;
5419 s = tz_parse_offset(s, &std_off);
5421 if (!*s) { /* no DST, hurray we're done! */
5427 while (isalpha(*s)) s++;
5428 s2 = tz_parse_offset(s, &dst_off);
5432 dst_off = std_off - 3600;
5435 if (!*s) { /* default dst start/end?? */
5436 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5437 s = strchr(ucxtz,',');
5439 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5441 if (*s != ',') return 0;
5444 when = _toutc(when); /* convert to utc */
5445 when = when - std_off; /* convert to pseudolocal time*/
5447 w2 = localtime(&when);
5450 s = tz_parse_startend(s_start,w2,&dststart);
5452 if (*s != ',') return 0;
5455 when = _toutc(when); /* convert to utc */
5456 when = when - dst_off; /* convert to pseudolocal time*/
5457 w2 = localtime(&when);
5458 if (w2->tm_year != y) { /* spans a year, just check one time */
5459 when += dst_off - std_off;
5460 w2 = localtime(&when);
5463 s = tz_parse_startend(s_end,w2,&dstend);
5466 if (reversed == -1) { /* need to check if start later than end */
5470 if (when < 2*365*86400) {
5471 when += 2*365*86400;
5475 w2 =localtime(&when);
5476 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5478 for (j = 0; j < 12; j++) {
5479 w2 =localtime(&when);
5480 (void) tz_parse_startend(s_start,w2,&ds);
5481 (void) tz_parse_startend(s_end,w2,&de);
5482 if (ds != de) break;
5486 if (de && !ds) reversed = 1;
5489 isdst = dststart && !dstend;
5490 if (reversed) isdst = dststart || !dstend;
5493 if (dst) *dst = isdst;
5494 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5495 if (isdst) tz = dstzone;
5497 while(isalpha(*tz)) *zone++ = *tz++;
5503 #endif /* !RTL_USES_UTC */
5505 /* my_time(), my_localtime(), my_gmtime()
5506 * By default traffic in UTC time values, using CRTL gmtime() or
5507 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5508 * Note: We need to use these functions even when the CRTL has working
5509 * UTC support, since they also handle C<use vmsish qw(times);>
5511 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5512 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5515 /*{{{time_t my_time(time_t *timep)*/
5516 time_t my_time(time_t *timep)
5522 if (gmtime_emulation_type == 0) {
5524 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5525 /* results of calls to gmtime() and localtime() */
5526 /* for same &base */
5528 gmtime_emulation_type++;
5529 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5530 char off[LNM$C_NAMLENGTH+1];;
5532 gmtime_emulation_type++;
5533 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5534 gmtime_emulation_type++;
5535 utc_offset_secs = 0;
5536 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5538 else { utc_offset_secs = atol(off); }
5540 else { /* We've got a working gmtime() */
5541 struct tm gmt, local;
5544 tm_p = localtime(&base);
5546 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5547 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5548 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5549 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5555 # ifdef RTL_USES_UTC
5556 if (VMSISH_TIME) when = _toloc(when);
5558 if (!VMSISH_TIME) when = _toutc(when);
5561 if (timep != NULL) *timep = when;
5564 } /* end of my_time() */
5568 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5570 my_gmtime(const time_t *timep)
5577 if (timep == NULL) {
5578 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5581 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5585 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5587 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5588 return gmtime(&when);
5590 /* CRTL localtime() wants local time as input, so does no tz correction */
5591 rsltmp = localtime(&when);
5592 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5595 } /* end of my_gmtime() */
5599 /*{{{struct tm *my_localtime(const time_t *timep)*/
5601 my_localtime(const time_t *timep)
5604 time_t when, whenutc;
5608 if (timep == NULL) {
5609 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5612 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5613 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5616 # ifdef RTL_USES_UTC
5618 if (VMSISH_TIME) when = _toutc(when);
5620 /* CRTL localtime() wants UTC as input, does tz correction itself */
5621 return localtime(&when);
5623 # else /* !RTL_USES_UTC */
5626 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5627 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5630 #ifndef RTL_USES_UTC
5631 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5632 when = whenutc - offset; /* pseudolocal time*/
5635 /* CRTL localtime() wants local time as input, so does no tz correction */
5636 rsltmp = localtime(&when);
5637 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5641 } /* end of my_localtime() */
5644 /* Reset definitions for later calls */
5645 #define gmtime(t) my_gmtime(t)
5646 #define localtime(t) my_localtime(t)
5647 #define time(t) my_time(t)
5650 /* my_utime - update modification time of a file
5651 * calling sequence is identical to POSIX utime(), but under
5652 * VMS only the modification time is changed; ODS-2 does not
5653 * maintain access times. Restrictions differ from the POSIX
5654 * definition in that the time can be changed as long as the
5655 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5656 * no separate checks are made to insure that the caller is the
5657 * owner of the file or has special privs enabled.
5658 * Code here is based on Joe Meadows' FILE utility.
5661 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5662 * to VMS epoch (01-JAN-1858 00:00:00.00)
5663 * in 100 ns intervals.
5665 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5667 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5668 int my_utime(char *file, struct utimbuf *utimes)
5672 long int bintime[2], len = 2, lowbit, unixtime,
5673 secscale = 10000000; /* seconds --> 100 ns intervals */
5674 unsigned long int chan, iosb[2], retsts;
5675 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5676 struct FAB myfab = cc$rms_fab;
5677 struct NAM mynam = cc$rms_nam;
5678 #if defined (__DECC) && defined (__VAX)
5679 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5680 * at least through VMS V6.1, which causes a type-conversion warning.
5682 # pragma message save
5683 # pragma message disable cvtdiftypes
5685 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5686 struct fibdef myfib;
5687 #if defined (__DECC) && defined (__VAX)
5688 /* This should be right after the declaration of myatr, but due
5689 * to a bug in VAX DEC C, this takes effect a statement early.
5691 # pragma message restore
5693 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5694 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5695 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5697 if (file == NULL || *file == '\0') {
5699 set_vaxc_errno(LIB$_INVARG);
5702 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5704 if (utimes != NULL) {
5705 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5706 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5707 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5708 * as input, we force the sign bit to be clear by shifting unixtime right
5709 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5711 lowbit = (utimes->modtime & 1) ? secscale : 0;
5712 unixtime = (long int) utimes->modtime;
5714 /* If input was UTC; convert to local for sys svc */
5715 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5717 unixtime >>= 1; secscale <<= 1;
5718 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5719 if (!(retsts & 1)) {
5721 set_vaxc_errno(retsts);
5724 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5725 if (!(retsts & 1)) {
5727 set_vaxc_errno(retsts);
5732 /* Just get the current time in VMS format directly */
5733 retsts = sys$gettim(bintime);
5734 if (!(retsts & 1)) {
5736 set_vaxc_errno(retsts);
5741 myfab.fab$l_fna = vmsspec;
5742 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5743 myfab.fab$l_nam = &mynam;
5744 mynam.nam$l_esa = esa;
5745 mynam.nam$b_ess = (unsigned char) sizeof esa;
5746 mynam.nam$l_rsa = rsa;
5747 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5749 /* Look for the file to be affected, letting RMS parse the file
5750 * specification for us as well. I have set errno using only
5751 * values documented in the utime() man page for VMS POSIX.
5753 retsts = sys$parse(&myfab,0,0);
5754 if (!(retsts & 1)) {
5755 set_vaxc_errno(retsts);
5756 if (retsts == RMS$_PRV) set_errno(EACCES);
5757 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5758 else set_errno(EVMSERR);
5761 retsts = sys$search(&myfab,0,0);
5762 if (!(retsts & 1)) {
5763 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5764 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5765 set_vaxc_errno(retsts);
5766 if (retsts == RMS$_PRV) set_errno(EACCES);
5767 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5768 else set_errno(EVMSERR);
5772 devdsc.dsc$w_length = mynam.nam$b_dev;
5773 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5775 retsts = sys$assign(&devdsc,&chan,0,0);
5776 if (!(retsts & 1)) {
5777 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5778 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5779 set_vaxc_errno(retsts);
5780 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5781 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5782 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5783 else set_errno(EVMSERR);
5787 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5788 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5790 memset((void *) &myfib, 0, sizeof myfib);
5791 #if defined(__DECC) || defined(__DECCXX)
5792 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5793 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5794 /* This prevents the revision time of the file being reset to the current
5795 * time as a result of our IO$_MODIFY $QIO. */
5796 myfib.fib$l_acctl = FIB$M_NORECORD;
5798 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5799 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5800 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5802 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5803 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5804 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5805 _ckvmssts(sys$dassgn(chan));
5806 if (retsts & 1) retsts = iosb[0];
5807 if (!(retsts & 1)) {
5808 set_vaxc_errno(retsts);
5809 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5810 else set_errno(EVMSERR);
5815 } /* end of my_utime() */
5819 * flex_stat, flex_fstat
5820 * basic stat, but gets it right when asked to stat
5821 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5824 /* encode_dev packs a VMS device name string into an integer to allow
5825 * simple comparisons. This can be used, for example, to check whether two
5826 * files are located on the same device, by comparing their encoded device
5827 * names. Even a string comparison would not do, because stat() reuses the
5828 * device name buffer for each call; so without encode_dev, it would be
5829 * necessary to save the buffer and use strcmp (this would mean a number of
5830 * changes to the standard Perl code, to say nothing of what a Perl script
5833 * The device lock id, if it exists, should be unique (unless perhaps compared
5834 * with lock ids transferred from other nodes). We have a lock id if the disk is
5835 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5836 * device names. Thus we use the lock id in preference, and only if that isn't
5837 * available, do we try to pack the device name into an integer (flagged by
5838 * the sign bit (LOCKID_MASK) being set).
5840 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5841 * name and its encoded form, but it seems very unlikely that we will find
5842 * two files on different disks that share the same encoded device names,
5843 * and even more remote that they will share the same file id (if the test
5844 * is to check for the same file).
5846 * A better method might be to use sys$device_scan on the first call, and to
5847 * search for the device, returning an index into the cached array.
5848 * The number returned would be more intelligable.
5849 * This is probably not worth it, and anyway would take quite a bit longer
5850 * on the first call.
5852 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5853 static mydev_t encode_dev (const char *dev)
5856 unsigned long int f;
5862 if (!dev || !dev[0]) return 0;
5866 struct dsc$descriptor_s dev_desc;
5867 unsigned long int status, lockid, item = DVI$_LOCKID;
5869 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5870 can try that first. */
5871 dev_desc.dsc$w_length = strlen (dev);
5872 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5873 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5874 dev_desc.dsc$a_pointer = (char *) dev;
5875 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5876 if (lockid) return (lockid & ~LOCKID_MASK);
5880 /* Otherwise we try to encode the device name */
5884 for (q = dev + strlen(dev); q--; q >= dev) {
5887 else if (isalpha (toupper (*q)))
5888 c= toupper (*q) - 'A' + (char)10;
5890 continue; /* Skip '$'s */
5892 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5894 enc += f * (unsigned long int) c;
5896 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
5898 } /* end of encode_dev() */
5900 static char namecache[NAM$C_MAXRSS+1];
5903 is_null_device(name)
5907 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5908 The underscore prefix, controller letter, and unit number are
5909 independently optional; for our purposes, the colon punctuation
5910 is not. The colon can be trailed by optional directory and/or
5911 filename, but two consecutive colons indicates a nodename rather
5912 than a device. [pr] */
5913 if (*name == '_') ++name;
5914 if (tolower(*name++) != 'n') return 0;
5915 if (tolower(*name++) != 'l') return 0;
5916 if (tolower(*name) == 'a') ++name;
5917 if (*name == '0') ++name;
5918 return (*name++ == ':') && (*name != ':');
5921 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
5922 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
5923 * subset of the applicable information.
5926 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
5928 char fname_phdev[NAM$C_MAXRSS+1];
5929 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
5931 char fname[NAM$C_MAXRSS+1];
5932 unsigned long int retsts;
5933 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5934 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5936 /* If the struct mystat is stale, we're OOL; stat() overwrites the
5937 device name on successive calls */
5938 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
5939 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
5940 namdsc.dsc$a_pointer = fname;
5941 namdsc.dsc$w_length = sizeof fname - 1;
5943 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
5944 &namdsc,&namdsc.dsc$w_length,0,0);
5946 fname[namdsc.dsc$w_length] = '\0';
5948 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
5949 * but if someone has redefined that logical, Perl gets very lost. Since
5950 * we have the physical device name from the stat buffer, just paste it on.
5952 strcpy( fname_phdev, statbufp->st_devnam );
5953 strcat( fname_phdev, strrchr(fname, ':') );
5955 return cando_by_name(bit,effective,fname_phdev);
5957 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5958 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
5962 return FALSE; /* Should never get to here */
5964 } /* end of cando() */
5968 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
5970 cando_by_name(I32 bit, Uid_t effective, char *fname)
5972 static char usrname[L_cuserid];
5973 static struct dsc$descriptor_s usrdsc =
5974 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
5975 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
5976 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
5977 unsigned short int retlen;
5979 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5980 union prvdef curprv;
5981 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
5982 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
5983 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
5986 if (!fname || !*fname) return FALSE;
5987 /* Make sure we expand logical names, since sys$check_access doesn't */
5988 if (!strpbrk(fname,"/]>:")) {
5989 strcpy(fileified,fname);
5990 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
5993 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
5994 retlen = namdsc.dsc$w_length = strlen(vmsname);
5995 namdsc.dsc$a_pointer = vmsname;
5996 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
5997 vmsname[retlen-1] == ':') {
5998 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
5999 namdsc.dsc$w_length = strlen(fileified);
6000 namdsc.dsc$a_pointer = fileified;
6003 if (!usrdsc.dsc$w_length) {
6005 usrdsc.dsc$w_length = strlen(usrname);
6009 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6010 access = ARM$M_EXECUTE; break;
6011 case S_IRUSR: case S_IRGRP: case S_IROTH:
6012 access = ARM$M_READ; break;
6013 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6014 access = ARM$M_WRITE; break;
6015 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6016 access = ARM$M_DELETE; break;
6021 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6022 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6023 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6024 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6025 set_vaxc_errno(retsts);
6026 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6027 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6028 else set_errno(ENOENT);
6031 if (retsts == SS$_NORMAL) {
6032 if (!privused) return TRUE;
6033 /* We can get access, but only by using privs. Do we have the
6034 necessary privs currently enabled? */
6035 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6036 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6037 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6038 !curprv.prv$v_bypass) return FALSE;
6039 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6040 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6041 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6044 if (retsts == SS$_ACCONFLICT) {
6049 return FALSE; /* Should never get here */
6051 } /* end of cando_by_name() */
6055 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6057 flex_fstat(int fd, Stat_t *statbufp)
6060 if (!fstat(fd,(stat_t *) statbufp)) {
6061 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6062 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6063 # ifdef RTL_USES_UTC
6066 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6067 statbufp->st_atime = _toloc(statbufp->st_atime);
6068 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6073 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6077 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6078 statbufp->st_atime = _toutc(statbufp->st_atime);
6079 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6086 } /* end of flex_fstat() */
6089 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6091 flex_stat(const char *fspec, Stat_t *statbufp)
6094 char fileified[NAM$C_MAXRSS+1];
6095 char temp_fspec[NAM$C_MAXRSS+300];
6098 strcpy(temp_fspec, fspec);
6099 if (statbufp == (Stat_t *) &PL_statcache)
6100 do_tovmsspec(temp_fspec,namecache,0);
6101 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6102 memset(statbufp,0,sizeof *statbufp);
6103 statbufp->st_dev = encode_dev("_NLA0:");
6104 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6105 statbufp->st_uid = 0x00010001;
6106 statbufp->st_gid = 0x0001;
6107 time((time_t *)&statbufp->st_mtime);
6108 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6112 /* Try for a directory name first. If fspec contains a filename without
6113 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6114 * and sea:[wine.dark]water. exist, we prefer the directory here.
6115 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6116 * not sea:[wine.dark]., if the latter exists. If the intended target is
6117 * the file with null type, specify this by calling flex_stat() with
6118 * a '.' at the end of fspec.
6120 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6121 retval = stat(fileified,(stat_t *) statbufp);
6122 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6123 strcpy(namecache,fileified);
6125 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6127 statbufp->st_dev = encode_dev(statbufp->st_devnam);
6128 # ifdef RTL_USES_UTC
6131 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6132 statbufp->st_atime = _toloc(statbufp->st_atime);
6133 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6138 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6142 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6143 statbufp->st_atime = _toutc(statbufp->st_atime);
6144 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6150 } /* end of flex_stat() */
6154 /*{{{char *my_getlogin()*/
6155 /* VMS cuserid == Unix getlogin, except calling sequence */
6159 static char user[L_cuserid];
6160 return cuserid(user);
6165 /* rmscopy - copy a file using VMS RMS routines
6167 * Copies contents and attributes of spec_in to spec_out, except owner
6168 * and protection information. Name and type of spec_in are used as
6169 * defaults for spec_out. The third parameter specifies whether rmscopy()
6170 * should try to propagate timestamps from the input file to the output file.
6171 * If it is less than 0, no timestamps are preserved. If it is 0, then
6172 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6173 * propagated to the output file at creation iff the output file specification
6174 * did not contain an explicit name or type, and the revision date is always
6175 * updated at the end of the copy operation. If it is greater than 0, then
6176 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6177 * other than the revision date should be propagated, and bit 1 indicates
6178 * that the revision date should be propagated.
6180 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6182 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6183 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6184 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6185 * as part of the Perl standard distribution under the terms of the
6186 * GNU General Public License or the Perl Artistic License. Copies
6187 * of each may be found in the Perl standard distribution.
6189 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6191 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6193 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6194 rsa[NAM$C_MAXRSS], ubf[32256];
6195 unsigned long int i, sts, sts2;
6196 struct FAB fab_in, fab_out;
6197 struct RAB rab_in, rab_out;
6199 struct XABDAT xabdat;
6200 struct XABFHC xabfhc;
6201 struct XABRDT xabrdt;
6202 struct XABSUM xabsum;
6204 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6205 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6206 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6210 fab_in = cc$rms_fab;
6211 fab_in.fab$l_fna = vmsin;
6212 fab_in.fab$b_fns = strlen(vmsin);
6213 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6214 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6215 fab_in.fab$l_fop = FAB$M_SQO;
6216 fab_in.fab$l_nam = &nam;
6217 fab_in.fab$l_xab = (void *) &xabdat;
6220 nam.nam$l_rsa = rsa;
6221 nam.nam$b_rss = sizeof(rsa);
6222 nam.nam$l_esa = esa;
6223 nam.nam$b_ess = sizeof (esa);
6224 nam.nam$b_esl = nam.nam$b_rsl = 0;
6226 xabdat = cc$rms_xabdat; /* To get creation date */
6227 xabdat.xab$l_nxt = (void *) &xabfhc;
6229 xabfhc = cc$rms_xabfhc; /* To get record length */
6230 xabfhc.xab$l_nxt = (void *) &xabsum;
6232 xabsum = cc$rms_xabsum; /* To get key and area information */
6234 if (!((sts = sys$open(&fab_in)) & 1)) {
6235 set_vaxc_errno(sts);
6237 case RMS$_FNF: case RMS$_DNF:
6238 set_errno(ENOENT); break;
6240 set_errno(ENOTDIR); break;
6242 set_errno(ENODEV); break;
6244 set_errno(EINVAL); break;
6246 set_errno(EACCES); break;
6254 fab_out.fab$w_ifi = 0;
6255 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6256 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6257 fab_out.fab$l_fop = FAB$M_SQO;
6258 fab_out.fab$l_fna = vmsout;
6259 fab_out.fab$b_fns = strlen(vmsout);
6260 fab_out.fab$l_dna = nam.nam$l_name;
6261 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6263 if (preserve_dates == 0) { /* Act like DCL COPY */
6264 nam.nam$b_nop = NAM$M_SYNCHK;
6265 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6266 if (!((sts = sys$parse(&fab_out)) & 1)) {
6267 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6268 set_vaxc_errno(sts);
6271 fab_out.fab$l_xab = (void *) &xabdat;
6272 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6274 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6275 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6276 preserve_dates =0; /* bitmask from this point forward */
6278 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6279 if (!((sts = sys$create(&fab_out)) & 1)) {
6280 set_vaxc_errno(sts);
6283 set_errno(ENOENT); break;
6285 set_errno(ENOTDIR); break;
6287 set_errno(ENODEV); break;
6289 set_errno(EINVAL); break;
6291 set_errno(EACCES); break;
6297 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6298 if (preserve_dates & 2) {
6299 /* sys$close() will process xabrdt, not xabdat */
6300 xabrdt = cc$rms_xabrdt;
6302 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6304 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6305 * is unsigned long[2], while DECC & VAXC use a struct */
6306 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6308 fab_out.fab$l_xab = (void *) &xabrdt;
6311 rab_in = cc$rms_rab;
6312 rab_in.rab$l_fab = &fab_in;
6313 rab_in.rab$l_rop = RAB$M_BIO;
6314 rab_in.rab$l_ubf = ubf;
6315 rab_in.rab$w_usz = sizeof ubf;
6316 if (!((sts = sys$connect(&rab_in)) & 1)) {
6317 sys$close(&fab_in); sys$close(&fab_out);
6318 set_errno(EVMSERR); set_vaxc_errno(sts);
6322 rab_out = cc$rms_rab;
6323 rab_out.rab$l_fab = &fab_out;
6324 rab_out.rab$l_rbf = ubf;
6325 if (!((sts = sys$connect(&rab_out)) & 1)) {
6326 sys$close(&fab_in); sys$close(&fab_out);
6327 set_errno(EVMSERR); set_vaxc_errno(sts);
6331 while ((sts = sys$read(&rab_in))) { /* always true */
6332 if (sts == RMS$_EOF) break;
6333 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6334 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6335 sys$close(&fab_in); sys$close(&fab_out);
6336 set_errno(EVMSERR); set_vaxc_errno(sts);
6341 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6342 sys$close(&fab_in); sys$close(&fab_out);
6343 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6345 set_errno(EVMSERR); set_vaxc_errno(sts);
6351 } /* end of rmscopy() */
6355 /*** The following glue provides 'hooks' to make some of the routines
6356 * from this file available from Perl. These routines are sufficiently
6357 * basic, and are required sufficiently early in the build process,
6358 * that's it's nice to have them available to miniperl as well as the
6359 * full Perl, so they're set up here instead of in an extension. The
6360 * Perl code which handles importation of these names into a given
6361 * package lives in [.VMS]Filespec.pm in @INC.
6365 rmsexpand_fromperl(pTHX_ CV *cv)
6368 char *fspec, *defspec = NULL, *rslt;
6371 if (!items || items > 2)
6372 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6373 fspec = SvPV(ST(0),n_a);
6374 if (!fspec || !*fspec) XSRETURN_UNDEF;
6375 if (items == 2) defspec = SvPV(ST(1),n_a);
6377 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6378 ST(0) = sv_newmortal();
6379 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6384 vmsify_fromperl(pTHX_ CV *cv)
6390 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6391 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6392 ST(0) = sv_newmortal();
6393 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6398 unixify_fromperl(pTHX_ CV *cv)
6404 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6405 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6406 ST(0) = sv_newmortal();
6407 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6412 fileify_fromperl(pTHX_ CV *cv)
6418 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6419 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6420 ST(0) = sv_newmortal();
6421 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6426 pathify_fromperl(pTHX_ CV *cv)
6432 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6433 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6434 ST(0) = sv_newmortal();
6435 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6440 vmspath_fromperl(pTHX_ CV *cv)
6446 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6447 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6448 ST(0) = sv_newmortal();
6449 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6454 unixpath_fromperl(pTHX_ CV *cv)
6460 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6461 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6462 ST(0) = sv_newmortal();
6463 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6468 candelete_fromperl(pTHX_ CV *cv)
6471 char fspec[NAM$C_MAXRSS+1], *fsp;
6476 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6478 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6479 if (SvTYPE(mysv) == SVt_PVGV) {
6480 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6481 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6488 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6489 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6495 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6500 rmscopy_fromperl(pTHX_ CV *cv)
6503 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6505 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6506 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6507 unsigned long int sts;
6512 if (items < 2 || items > 3)
6513 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6515 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6516 if (SvTYPE(mysv) == SVt_PVGV) {
6517 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6518 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6525 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6526 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6531 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6532 if (SvTYPE(mysv) == SVt_PVGV) {
6533 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6534 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6541 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6542 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6547 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6549 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6558 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6559 workbuff[NAM$C_MAXRSS*1 + 1];
6560 int total_namelen = 3, counter, num_entries;
6561 /* ODS-5 ups this, but we want to be consistent, so... */
6562 int max_name_len = 39;
6563 AV *in_array = (AV *)SvRV(ST(0));
6565 num_entries = av_len(in_array);
6567 /* All the names start with PL_. */
6568 strcpy(ultimate_name, "PL_");
6570 /* Clean up our working buffer */
6571 Zero(work_name, sizeof(work_name), char);
6573 /* Run through the entries and build up a working name */
6574 for(counter = 0; counter <= num_entries; counter++) {
6575 /* If it's not the first name then tack on a __ */
6577 strcat(work_name, "__");
6579 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6583 /* Check to see if we actually have to bother...*/
6584 if (strlen(work_name) + 3 <= max_name_len) {
6585 strcat(ultimate_name, work_name);
6587 /* It's too darned big, so we need to go strip. We use the same */
6588 /* algorithm as xsubpp does. First, strip out doubled __ */
6589 char *source, *dest, last;
6592 for (source = work_name; *source; source++) {
6593 if (last == *source && last == '_') {
6599 /* Go put it back */
6600 strcpy(work_name, workbuff);
6601 /* Is it still too big? */
6602 if (strlen(work_name) + 3 > max_name_len) {
6603 /* Strip duplicate letters */
6606 for (source = work_name; *source; source++) {
6607 if (last == toupper(*source)) {
6611 last = toupper(*source);
6613 strcpy(work_name, workbuff);
6616 /* Is it *still* too big? */
6617 if (strlen(work_name) + 3 > max_name_len) {
6618 /* Too bad, we truncate */
6619 work_name[max_name_len - 2] = 0;
6621 strcat(ultimate_name, work_name);
6624 /* Okay, return it */
6625 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6632 char* file = __FILE__;
6634 char temp_buff[512];
6635 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6636 no_translate_barewords = TRUE;
6638 no_translate_barewords = FALSE;
6641 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6642 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6643 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6644 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6645 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6646 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6647 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6648 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6649 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6650 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);