3 * VMS-specific routines for perl5
5 * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
25 #include <libclidef.h>
27 #include <lib$routines.h>
36 #include <str$routines.h>
41 /* Older versions of ssdef.h don't have these */
42 #ifndef SS$_INVFILFOROP
43 # define SS$_INVFILFOROP 3930
45 #ifndef SS$_NOSUCHOBJECT
46 # define SS$_NOSUCHOBJECT 2696
49 /* Don't replace system definitions of vfork, getenv, and stat,
50 * code below needs to get to the underlying CRTL routines. */
51 #define DONT_MASK_RTL_CALLS
55 /* Anticipating future expansion in lexical warnings . . . */
57 # define WARN_INTERNAL WARN_MISC
60 /* gcc's header files don't #define direct access macros
61 * corresponding to VAXC's variant structs */
63 # define uic$v_format uic$r_uic_form.uic$v_format
64 # define uic$v_group uic$r_uic_form.uic$v_group
65 # define uic$v_member uic$r_uic_form.uic$v_member
66 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
67 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
68 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
69 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
72 #if defined(NEED_AN_H_ERRNO)
77 unsigned short int buflen;
78 unsigned short int itmcode;
80 unsigned short int *retlen;
83 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
84 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
85 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
86 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
87 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
88 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
89 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
90 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
91 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
93 static char *__mystrtolower(char *str)
95 if (str) for (; *str; ++str) *str= tolower(*str);
99 static struct dsc$descriptor_s fildevdsc =
100 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
101 static struct dsc$descriptor_s crtlenvdsc =
102 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
103 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
104 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
105 static struct dsc$descriptor_s **env_tables = defenv;
106 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
108 /* True if we shouldn't treat barewords as logicals during directory */
110 static int no_translate_barewords;
112 /* Temp for subprocess commands */
113 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
115 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
117 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
118 struct dsc$descriptor_s **tabvec, unsigned long int flags)
120 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
121 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
122 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
123 unsigned char acmode;
124 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
125 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
126 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
127 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
129 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
130 #if defined(USE_THREADS)
131 /* We jump through these hoops because we can be called at */
132 /* platform-specific initialization time, which is before anything is */
133 /* set up--we can't even do a plain dTHX since that relies on the */
134 /* interpreter structure to be initialized */
135 struct perl_thread *thr;
137 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
143 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
144 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
146 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
147 *cp2 = _toupper(*cp1);
148 if (cp1 - lnm > LNM$C_NAMLENGTH) {
149 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
153 lnmdsc.dsc$w_length = cp1 - lnm;
154 lnmdsc.dsc$a_pointer = uplnm;
155 uplnm[lnmdsc.dsc$w_length] = '\0';
156 secure = flags & PERL__TRNENV_SECURE;
157 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
158 if (!tabvec || !*tabvec) tabvec = env_tables;
160 for (curtab = 0; tabvec[curtab]; curtab++) {
161 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
162 if (!ivenv && !secure) {
167 Perl_warn(aTHX_ "Can't read CRTL environ\n");
170 retsts = SS$_NOLOGNAM;
171 for (i = 0; environ[i]; i++) {
172 if ((eq = strchr(environ[i],'=')) &&
173 !strncmp(environ[i],uplnm,eq - environ[i])) {
175 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
176 if (!eqvlen) continue;
181 if (retsts != SS$_NOLOGNAM) break;
184 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
185 !str$case_blind_compare(&tmpdsc,&clisym)) {
186 if (!ivsym && !secure) {
187 unsigned short int deflen = LNM$C_NAMLENGTH;
188 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
189 /* dynamic dsc to accomodate possible long value */
190 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
191 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
194 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
196 /* Special hack--we might be called before the interpreter's */
197 /* fully initialized, in which case either thr or PL_curcop */
198 /* might be bogus. We have to check, since ckWARN needs them */
199 /* both to be valid if running threaded */
200 #if defined(USE_THREADS)
201 if (thr && PL_curcop) {
203 if (ckWARN(WARN_MISC)) {
204 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
206 #if defined(USE_THREADS)
208 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
213 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
215 _ckvmssts(lib$sfree1_dd(&eqvdsc));
216 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
217 if (retsts == LIB$_NOSUCHSYM) continue;
222 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
223 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
224 if (retsts == SS$_NOLOGNAM) continue;
225 /* PPFs have a prefix */
228 *((int *)uplnm) == *((int *)"SYS$") &&
230 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
231 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
232 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
233 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
234 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
235 memcpy(eqv,eqv+4,eqvlen-4);
241 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
242 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
243 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
244 retsts == SS$_NOLOGNAM) {
245 set_errno(EINVAL); set_vaxc_errno(retsts);
247 else _ckvmssts(retsts);
249 } /* end of vmstrnenv */
252 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
253 /* Define as a function so we can access statics. */
254 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
256 return vmstrnenv(lnm,eqv,idx,fildev,
257 #ifdef SECURE_INTERNAL_GETENV
258 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
267 * Note: Uses Perl temp to store result so char * can be returned to
268 * caller; this pointer will be invalidated at next Perl statement
270 * We define this as a function rather than a macro in terms of my_getenv_len()
271 * so that it'll work when PL_curinterp is undefined (and we therefore can't
274 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
276 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
278 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
279 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
280 unsigned long int idx = 0;
284 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
285 /* Set up a temporary buffer for the return value; Perl will
286 * clean it up at the next statement transition */
287 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
288 if (!tmpsv) return NULL;
291 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
292 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
293 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
294 getcwd(eqv,LNM$C_NAMLENGTH);
298 if ((cp2 = strchr(lnm,';')) != NULL) {
300 uplnm[cp2-lnm] = '\0';
301 idx = strtoul(cp2+1,NULL,0);
304 /* Impose security constraints only if tainting */
305 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
306 if (vmstrnenv(lnm,eqv,idx,
308 #ifdef SECURE_INTERNAL_GETENV
309 sys ? PERL__TRNENV_SECURE : 0
317 } /* end of my_getenv() */
321 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
323 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
326 char *buf, *cp1, *cp2;
327 unsigned long idx = 0;
328 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
331 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
332 /* Set up a temporary buffer for the return value; Perl will
333 * clean it up at the next statement transition */
334 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
335 if (!tmpsv) return NULL;
338 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
339 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
340 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
341 getcwd(buf,LNM$C_NAMLENGTH);
346 if ((cp2 = strchr(lnm,';')) != NULL) {
349 idx = strtoul(cp2+1,NULL,0);
352 /* Impose security constraints only if tainting */
353 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
354 if ((*len = vmstrnenv(lnm,buf,idx,
356 #ifdef SECURE_INTERNAL_GETENV
357 sys ? PERL__TRNENV_SECURE : 0
367 } /* end of my_getenv_len() */
370 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
372 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
374 /*{{{ void prime_env_iter() */
377 /* Fill the %ENV associative array with all logical names we can
378 * find, in preparation for iterating over it.
382 static int primed = 0;
383 HV *seenhv = NULL, *envhv;
384 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
385 unsigned short int chan;
386 #ifndef CLI$M_TRUSTED
387 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
389 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
390 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
392 bool have_sym = FALSE, have_lnm = FALSE;
393 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
394 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
395 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
396 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
397 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
398 #if defined(USE_THREADS) || defined(USE_ITHREADS)
399 static perl_mutex primenv_mutex;
400 MUTEX_INIT(&primenv_mutex);
403 if (primed || !PL_envgv) return;
404 MUTEX_LOCK(&primenv_mutex);
405 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
406 envhv = GvHVn(PL_envgv);
407 /* Perform a dummy fetch as an lval to insure that the hash table is
408 * set up. Otherwise, the hv_store() will turn into a nullop. */
409 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
411 for (i = 0; env_tables[i]; i++) {
412 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
413 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
414 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
416 if (have_sym || have_lnm) {
417 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
418 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
419 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
420 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
423 for (i--; i >= 0; i--) {
424 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
427 for (j = 0; environ[j]; j++) {
428 if (!(start = strchr(environ[j],'='))) {
429 if (ckWARN(WARN_INTERNAL))
430 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
434 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
440 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
441 !str$case_blind_compare(&tmpdsc,&clisym)) {
442 strcpy(cmd,"Show Symbol/Global *");
443 cmddsc.dsc$w_length = 20;
444 if (env_tables[i]->dsc$w_length == 12 &&
445 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
446 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
447 flags = defflags | CLI$M_NOLOGNAM;
450 strcpy(cmd,"Show Logical *");
451 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
452 strcat(cmd," /Table=");
453 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
454 cmddsc.dsc$w_length = strlen(cmd);
456 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
457 flags = defflags | CLI$M_NOCLISYM;
460 /* Create a new subprocess to execute each command, to exclude the
461 * remote possibility that someone could subvert a mbx or file used
462 * to write multiple commands to a single subprocess.
465 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
466 0,&riseandshine,0,0,&clidsc,&clitabdsc);
467 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
468 defflags &= ~CLI$M_TRUSTED;
469 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
471 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
472 if (seenhv) SvREFCNT_dec(seenhv);
475 char *cp1, *cp2, *key;
476 unsigned long int sts, iosb[2], retlen, keylen;
479 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
480 if (sts & 1) sts = iosb[0] & 0xffff;
481 if (sts == SS$_ENDOFFILE) {
483 while (substs == 0) { sys$hiber(); wakect++;}
484 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
489 retlen = iosb[0] >> 16;
490 if (!retlen) continue; /* blank line */
492 if (iosb[1] != subpid) {
494 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
498 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
499 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
501 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
502 if (*cp1 == '(' || /* Logical name table name */
503 *cp1 == '=' /* Next eqv of searchlist */) continue;
504 if (*cp1 == '"') cp1++;
505 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
506 key = cp1; keylen = cp2 - cp1;
507 if (keylen && hv_exists(seenhv,key,keylen)) continue;
508 while (*cp2 && *cp2 != '=') cp2++;
509 while (*cp2 && *cp2 == '=') cp2++;
510 while (*cp2 && *cp2 == ' ') cp2++;
511 if (*cp2 == '"') { /* String translation; may embed "" */
512 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
513 cp2++; cp1--; /* Skip "" surrounding translation */
515 else { /* Numeric translation */
516 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
517 cp1--; /* stop on last non-space char */
519 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
520 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
523 PERL_HASH(hash,key,keylen);
524 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
525 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
527 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
528 /* get the PPFs for this process, not the subprocess */
529 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
530 char eqv[LNM$C_NAMLENGTH+1];
532 for (i = 0; ppfs[i]; i++) {
533 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
534 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
539 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
540 if (buf) Safefree(buf);
541 if (seenhv) SvREFCNT_dec(seenhv);
542 MUTEX_UNLOCK(&primenv_mutex);
545 } /* end of prime_env_iter */
549 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
550 /* Define or delete an element in the same "environment" as
551 * vmstrnenv(). If an element is to be deleted, it's removed from
552 * the first place it's found. If it's to be set, it's set in the
553 * place designated by the first element of the table vector.
554 * Like setenv() returns 0 for success, non-zero on error.
557 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
559 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
560 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
561 unsigned long int retsts, usermode = PSL$C_USER;
562 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
563 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
564 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
565 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
566 $DESCRIPTOR(local,"_LOCAL");
569 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
570 *cp2 = _toupper(*cp1);
571 if (cp1 - lnm > LNM$C_NAMLENGTH) {
572 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
576 lnmdsc.dsc$w_length = cp1 - lnm;
577 if (!tabvec || !*tabvec) tabvec = env_tables;
579 if (!eqv) { /* we're deleting n element */
580 for (curtab = 0; tabvec[curtab]; curtab++) {
581 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
583 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
584 if ((cp1 = strchr(environ[i],'=')) &&
585 !strncmp(environ[i],lnm,cp1 - environ[i])) {
587 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
590 ivenv = 1; retsts = SS$_NOLOGNAM;
592 if (ckWARN(WARN_INTERNAL))
593 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
594 ivenv = 1; retsts = SS$_NOSUCHPGM;
600 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
601 !str$case_blind_compare(&tmpdsc,&clisym)) {
602 unsigned int symtype;
603 if (tabvec[curtab]->dsc$w_length == 12 &&
604 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
605 !str$case_blind_compare(&tmpdsc,&local))
606 symtype = LIB$K_CLI_LOCAL_SYM;
607 else symtype = LIB$K_CLI_GLOBAL_SYM;
608 retsts = lib$delete_symbol(&lnmdsc,&symtype);
609 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
610 if (retsts == LIB$_NOSUCHSYM) continue;
614 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
615 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
616 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
617 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
618 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
622 else { /* we're defining a value */
623 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
625 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
627 if (ckWARN(WARN_INTERNAL))
628 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
629 retsts = SS$_NOSUCHPGM;
633 eqvdsc.dsc$a_pointer = eqv;
634 eqvdsc.dsc$w_length = strlen(eqv);
635 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
636 !str$case_blind_compare(&tmpdsc,&clisym)) {
637 unsigned int symtype;
638 if (tabvec[0]->dsc$w_length == 12 &&
639 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
640 !str$case_blind_compare(&tmpdsc,&local))
641 symtype = LIB$K_CLI_LOCAL_SYM;
642 else symtype = LIB$K_CLI_GLOBAL_SYM;
643 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
646 if (!*eqv) eqvdsc.dsc$w_length = 1;
647 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
648 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
649 if (ckWARN(WARN_MISC)) {
650 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
653 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
659 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
660 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
661 set_errno(EVMSERR); break;
662 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
663 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
664 set_errno(EINVAL); break;
671 set_vaxc_errno(retsts);
672 return (int) retsts || 44; /* retsts should never be 0, but just in case */
675 /* We reset error values on success because Perl does an hv_fetch()
676 * before each hv_store(), and if the thing we're setting didn't
677 * previously exist, we've got a leftover error message. (Of course,
678 * this fails in the face of
679 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
680 * in that the error reported in $! isn't spurious,
681 * but it's right more often than not.)
683 set_errno(0); set_vaxc_errno(retsts);
687 } /* end of vmssetenv() */
690 /*{{{ void my_setenv(char *lnm, char *eqv)*/
691 /* This has to be a function since there's a prototype for it in proto.h */
693 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
695 if (lnm && *lnm && strlen(lnm) == 7) {
698 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
699 if (!strcmp(uplnm,"DEFAULT")) {
700 if (eqv && *eqv) chdir(eqv);
704 (void) vmssetenv(lnm,eqv,NULL);
710 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
711 /* my_crypt - VMS password hashing
712 * my_crypt() provides an interface compatible with the Unix crypt()
713 * C library function, and uses sys$hash_password() to perform VMS
714 * password hashing. The quadword hashed password value is returned
715 * as a NUL-terminated 8 character string. my_crypt() does not change
716 * the case of its string arguments; in order to match the behavior
717 * of LOGINOUT et al., alphabetic characters in both arguments must
718 * be upcased by the caller.
721 my_crypt(const char *textpasswd, const char *usrname)
723 # ifndef UAI$C_PREFERRED_ALGORITHM
724 # define UAI$C_PREFERRED_ALGORITHM 127
726 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
727 unsigned short int salt = 0;
728 unsigned long int sts;
730 unsigned short int dsc$w_length;
731 unsigned char dsc$b_type;
732 unsigned char dsc$b_class;
733 const char * dsc$a_pointer;
734 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
735 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
736 struct itmlst_3 uailst[3] = {
737 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
738 { sizeof salt, UAI$_SALT, &salt, 0},
739 { 0, 0, NULL, NULL}};
742 usrdsc.dsc$w_length = strlen(usrname);
743 usrdsc.dsc$a_pointer = usrname;
744 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
746 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
750 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
756 if (sts != RMS$_RNF) return NULL;
759 txtdsc.dsc$w_length = strlen(textpasswd);
760 txtdsc.dsc$a_pointer = textpasswd;
761 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
762 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
765 return (char *) hash;
767 } /* end of my_crypt() */
771 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
772 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
773 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
775 /*{{{int do_rmdir(char *name)*/
777 Perl_do_rmdir(pTHX_ char *name)
779 char dirfile[NAM$C_MAXRSS+1];
783 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
784 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
785 else retval = kill_file(dirfile);
788 } /* end of do_rmdir */
792 * Delete any file to which user has control access, regardless of whether
793 * delete access is explicitly allowed.
794 * Limitations: User must have write access to parent directory.
795 * Does not block signals or ASTs; if interrupted in midstream
796 * may leave file with an altered ACL.
799 /*{{{int kill_file(char *name)*/
801 kill_file(char *name)
803 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
804 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
805 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
807 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
809 unsigned char myace$b_length;
810 unsigned char myace$b_type;
811 unsigned short int myace$w_flags;
812 unsigned long int myace$l_access;
813 unsigned long int myace$l_ident;
814 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
815 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
816 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
818 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
819 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
820 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
821 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
822 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
823 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
825 /* Expand the input spec using RMS, since the CRTL remove() and
826 * system services won't do this by themselves, so we may miss
827 * a file "hiding" behind a logical name or search list. */
828 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
829 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
830 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
831 /* If not, can changing protections help? */
832 if (vaxc$errno != RMS$_PRV) return -1;
834 /* No, so we get our own UIC to use as a rights identifier,
835 * and the insert an ACE at the head of the ACL which allows us
836 * to delete the file.
838 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
839 fildsc.dsc$w_length = strlen(rspec);
840 fildsc.dsc$a_pointer = rspec;
842 newace.myace$l_ident = oldace.myace$l_ident;
843 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
845 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
846 set_errno(ENOENT); break;
848 set_errno(ENOTDIR); break;
850 set_errno(ENODEV); break;
851 case RMS$_SYN: case SS$_INVFILFOROP:
852 set_errno(EINVAL); break;
854 set_errno(EACCES); break;
858 set_vaxc_errno(aclsts);
861 /* Grab any existing ACEs with this identifier in case we fail */
862 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
863 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
864 || fndsts == SS$_NOMOREACE ) {
865 /* Add the new ACE . . . */
866 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
868 if ((rmsts = remove(name))) {
869 /* We blew it - dir with files in it, no write priv for
870 * parent directory, etc. Put things back the way they were. */
871 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
874 addlst[0].bufadr = &oldace;
875 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
882 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
883 /* We just deleted it, so of course it's not there. Some versions of
884 * VMS seem to return success on the unlock operation anyhow (after all
885 * the unlock is successful), but others don't.
887 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
888 if (aclsts & 1) aclsts = fndsts;
891 set_vaxc_errno(aclsts);
897 } /* end of kill_file() */
901 /*{{{int my_mkdir(char *,Mode_t)*/
903 my_mkdir(char *dir, Mode_t mode)
905 STRLEN dirlen = strlen(dir);
908 /* zero length string sometimes gives ACCVIO */
909 if (dirlen == 0) return -1;
911 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
912 * null file name/type. However, it's commonplace under Unix,
913 * so we'll allow it for a gain in portability.
915 if (dir[dirlen-1] == '/') {
916 char *newdir = savepvn(dir,dirlen-1);
917 int ret = mkdir(newdir,mode);
921 else return mkdir(dir,mode);
922 } /* end of my_mkdir */
925 /*{{{int my_chdir(char *)*/
929 STRLEN dirlen = strlen(dir);
932 /* zero length string sometimes gives ACCVIO */
933 if (dirlen == 0) return -1;
935 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
937 * null file name/type. However, it's commonplace under Unix,
938 * so we'll allow it for a gain in portability.
940 if (dir[dirlen-1] == '/') {
941 char *newdir = savepvn(dir,dirlen-1);
942 int ret = chdir(newdir);
946 else return chdir(dir);
947 } /* end of my_chdir */
951 /*{{{FILE *my_tmpfile()*/
959 if ((fp = tmpfile())) return fp;
961 New(1323,cp,L_tmpnam+24,char);
962 strcpy(cp,"Sys$Scratch:");
963 tmpnam(cp+strlen(cp));
964 strcat(cp,".Perltmp");
965 fp = fopen(cp,"w+","fop=dlt");
973 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
975 unsigned long int mbxbufsiz;
976 static unsigned long int syssize = 0;
977 unsigned long int dviitm = DVI$_DEVNAM;
979 char csize[LNM$C_NAMLENGTH+1];
982 unsigned long syiitm = SYI$_MAXBUF;
984 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
985 * preprocessor consant BUFSIZ from stdio.h defaults as the size of the
988 * If the logical 'PERL_MBX_SIZE' is defined
989 * use the value of the logical instead of BUFSIZ, but again
990 * keep the size between 128 and MAXBUF.
993 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
996 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
997 mbxbufsiz = atoi(csize);
1001 if (mbxbufsiz < 128) mbxbufsiz = 128;
1002 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1004 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1006 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1007 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1009 } /* end of create_mbx() */
1012 /*{{{ my_popen and my_pclose*/
1014 typedef struct _iosb IOSB;
1015 typedef struct _iosb* pIOSB;
1016 typedef struct _pipe Pipe;
1017 typedef struct _pipe* pPipe;
1018 typedef struct pipe_details Info;
1019 typedef struct pipe_details* pInfo;
1020 typedef struct _srqp RQE;
1021 typedef struct _srqp* pRQE;
1022 typedef struct _tochildbuf CBuf;
1023 typedef struct _tochildbuf* pCBuf;
1026 unsigned short status;
1027 unsigned short count;
1028 unsigned long dvispec;
1031 #pragma member_alignment save
1032 #pragma nomember_alignment quadword
1033 struct _srqp { /* VMS self-relative queue entry */
1034 unsigned long qptr[2];
1036 #pragma member_alignment restore
1037 static RQE RQE_ZERO = {0,0};
1039 struct _tochildbuf {
1042 unsigned short size;
1050 unsigned short chan_in;
1051 unsigned short chan_out;
1053 unsigned int bufsize;
1071 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1072 int pid; /* PID of subprocess */
1073 int mode; /* == 'r' if pipe open for reading */
1074 int done; /* subprocess has completed */
1075 int closing; /* my_pclose is closing this pipe */
1076 unsigned long completion; /* termination status of subprocess */
1077 pPipe in; /* pipe in to sub */
1078 pPipe out; /* pipe out of sub */
1079 pPipe err; /* pipe of sub's sys$error */
1080 int in_done; /* true when in pipe finished */
1085 struct exit_control_block
1087 struct exit_control_block *flink;
1088 unsigned long int (*exit_routine)();
1089 unsigned long int arg_count;
1090 unsigned long int *status_address;
1091 unsigned long int exit_status;
1094 #define RETRY_DELAY "0 ::0.20"
1095 #define MAX_RETRY 50
1097 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1098 static unsigned long mypid;
1099 static unsigned long delaytime[2];
1101 static pInfo open_pipes = NULL;
1102 static $DESCRIPTOR(nl_desc, "NL:");
1105 static unsigned long int
1109 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1110 int sts, did_stuff, need_eof;
1114 first we try sending an EOF...ignore if doesn't work, make sure we
1122 _ckvmssts(sys$setast(0));
1123 if (info->in && !info->in->shut_on_empty) {
1124 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1128 _ckvmssts(sys$setast(1));
1131 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1136 _ckvmssts(sys$setast(0));
1137 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1138 sts = sys$forcex(&info->pid,0,&abort);
1139 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1142 _ckvmssts(sys$setast(1));
1145 if (did_stuff) sleep(1); /* wait for them to respond */
1149 _ckvmssts(sys$setast(0));
1150 if (!info->done) { /* We tried to be nice . . . */
1151 sts = sys$delprc(&info->pid,0);
1152 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1154 _ckvmssts(sys$setast(1));
1159 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1160 else if (!(sts & 1)) retsts = sts;
1165 static struct exit_control_block pipe_exitblock =
1166 {(struct exit_control_block *) 0,
1167 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1169 static void pipe_mbxtofd_ast(pPipe p);
1170 static void pipe_tochild1_ast(pPipe p);
1171 static void pipe_tochild2_ast(pPipe p);
1174 popen_completion_ast(pInfo info)
1177 pInfo i = open_pipes;
1181 if (i == info) break;
1184 if (!i) return; /* unlinked, probably freed too */
1186 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1190 Writing to subprocess ...
1191 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1193 chan_out may be waiting for "done" flag, or hung waiting
1194 for i/o completion to child...cancel the i/o. This will
1195 put it into "snarf mode" (done but no EOF yet) that discards
1198 Output from subprocess (stdout, stderr) needs to be flushed and
1199 shut down. We try sending an EOF, but if the mbx is full the pipe
1200 routine should still catch the "shut_on_empty" flag, telling it to
1201 use immediate-style reads so that "mbx empty" -> EOF.
1205 if (info->in && !info->in_done) { /* only for mode=w */
1206 if (info->in->shut_on_empty && info->in->need_wake) {
1207 info->in->need_wake = FALSE;
1208 _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1210 _ckvmssts(sys$cancel(info->in->chan_out));
1214 if (info->out && !info->out_done) { /* were we also piping output? */
1215 info->out->shut_on_empty = TRUE;
1216 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1217 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1221 if (info->err && !info->err_done) { /* we were piping stderr */
1222 info->err->shut_on_empty = TRUE;
1223 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1224 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1227 _ckvmssts(sys$setef(pipe_ef));
1231 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1232 static void vms_execfree(pTHX);
1235 we actually differ from vmstrnenv since we use this to
1236 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1237 are pointing to the same thing
1240 static unsigned short
1241 popen_translate(char *logical, char *result)
1244 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1245 $DESCRIPTOR(d_log,"");
1247 unsigned short length;
1248 unsigned short code;
1250 unsigned short *retlenaddr;
1252 unsigned short l, ifi;
1254 d_log.dsc$a_pointer = logical;
1255 d_log.dsc$w_length = strlen(logical);
1257 itmlst[0].code = LNM$_STRING;
1258 itmlst[0].length = 255;
1259 itmlst[0].buffer_addr = result;
1260 itmlst[0].retlenaddr = &l;
1263 itmlst[1].length = 0;
1264 itmlst[1].buffer_addr = 0;
1265 itmlst[1].retlenaddr = 0;
1267 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1268 if (iss == SS$_NOLOGNAM) {
1272 if (!(iss&1)) lib$signal(iss);
1275 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1276 strip it off and return the ifi, if any
1279 if (result[0] == 0x1b && result[1] == 0x00) {
1280 memcpy(&ifi,result+2,2);
1281 strcpy(result,result+4);
1283 return ifi; /* this is the RMS internal file id */
1286 #define MAX_DCL_SYMBOL 255
1287 static void pipe_infromchild_ast(pPipe p);
1290 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1291 inside an AST routine without worrying about reentrancy and which Perl
1292 memory allocator is being used.
1294 We read data and queue up the buffers, then spit them out one at a
1295 time to the output mailbox when the output mailbox is ready for one.
1298 #define INITIAL_TOCHILDQUEUE 2
1301 pipe_tochild_setup(char *rmbx, char *wmbx)
1306 char mbx1[64], mbx2[64];
1307 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1308 DSC$K_CLASS_S, mbx1},
1309 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1310 DSC$K_CLASS_S, mbx2};
1311 unsigned int dviitm = DVI$_DEVBUFSIZ;
1314 New(1368, p, 1, Pipe);
1316 create_mbx(&p->chan_in , &d_mbx1);
1317 create_mbx(&p->chan_out, &d_mbx2);
1318 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1321 p->shut_on_empty = FALSE;
1322 p->need_wake = FALSE;
1325 p->iosb.status = SS$_NORMAL;
1326 p->iosb2.status = SS$_NORMAL;
1333 n = sizeof(CBuf) + p->bufsize;
1335 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1336 _ckvmssts(lib$get_vm(&n, &b));
1337 b->buf = (char *) b + sizeof(CBuf);
1338 _ckvmssts(lib$insqhi(b, &p->free));
1341 pipe_tochild2_ast(p);
1342 pipe_tochild1_ast(p);
1348 /* reads the MBX Perl is writing, and queues */
1351 pipe_tochild1_ast(pPipe p)
1355 int iss = p->iosb.status;
1356 int eof = (iss == SS$_ENDOFFILE);
1360 p->shut_on_empty = TRUE;
1362 _ckvmssts(sys$dassgn(p->chan_in));
1368 b->size = p->iosb.count;
1369 _ckvmssts(lib$insqhi(b, &p->wait));
1371 p->need_wake = FALSE;
1372 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1375 p->retry = 1; /* initial call */
1378 if (eof) { /* flush the free queue, return when done */
1379 int n = sizeof(CBuf) + p->bufsize;
1381 iss = lib$remqti(&p->free, &b);
1382 if (iss == LIB$_QUEWASEMP) return;
1384 _ckvmssts(lib$free_vm(&n, &b));
1388 iss = lib$remqti(&p->free, &b);
1389 if (iss == LIB$_QUEWASEMP) {
1390 int n = sizeof(CBuf) + p->bufsize;
1391 _ckvmssts(lib$get_vm(&n, &b));
1392 b->buf = (char *) b + sizeof(CBuf);
1398 iss = sys$qio(0,p->chan_in,
1399 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1401 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1402 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1407 /* writes queued buffers to output, waits for each to complete before
1411 pipe_tochild2_ast(pPipe p)
1415 int iss = p->iosb2.status;
1416 int n = sizeof(CBuf) + p->bufsize;
1417 int done = (p->info && p->info->done) ||
1418 iss == SS$_CANCEL || iss == SS$_ABORT;
1421 if (p->type) { /* type=1 has old buffer, dispose */
1422 if (p->shut_on_empty) {
1423 _ckvmssts(lib$free_vm(&n, &b));
1425 _ckvmssts(lib$insqhi(b, &p->free));
1430 iss = lib$remqti(&p->wait, &b);
1431 if (iss == LIB$_QUEWASEMP) {
1432 if (p->shut_on_empty) {
1434 _ckvmssts(sys$dassgn(p->chan_out));
1435 *p->pipe_done = TRUE;
1436 _ckvmssts(sys$setef(pipe_ef));
1438 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1439 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1443 p->need_wake = TRUE;
1453 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1454 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1456 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1457 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1466 pipe_infromchild_setup(char *rmbx, char *wmbx)
1470 char mbx1[64], mbx2[64];
1471 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1472 DSC$K_CLASS_S, mbx1},
1473 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1474 DSC$K_CLASS_S, mbx2};
1475 unsigned int dviitm = DVI$_DEVBUFSIZ;
1477 New(1367, p, 1, Pipe);
1478 create_mbx(&p->chan_in , &d_mbx1);
1479 create_mbx(&p->chan_out, &d_mbx2);
1481 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1482 New(1367, p->buf, p->bufsize, char);
1483 p->shut_on_empty = FALSE;
1486 p->iosb.status = SS$_NORMAL;
1487 pipe_infromchild_ast(p);
1495 pipe_infromchild_ast(pPipe p)
1498 int iss = p->iosb.status;
1499 int eof = (iss == SS$_ENDOFFILE);
1500 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1501 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1503 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1504 _ckvmssts(sys$dassgn(p->chan_out));
1509 input shutdown if EOF from self (done or shut_on_empty)
1510 output shutdown if closing flag set (my_pclose)
1511 send data/eof from child or eof from self
1512 otherwise, re-read (snarf of data from child)
1517 if (myeof && p->chan_in) { /* input shutdown */
1518 _ckvmssts(sys$dassgn(p->chan_in));
1523 if (myeof || kideof) { /* pass EOF to parent */
1524 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1525 pipe_infromchild_ast, p,
1528 } else if (eof) { /* eat EOF --- fall through to read*/
1530 } else { /* transmit data */
1531 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1532 pipe_infromchild_ast,p,
1533 p->buf, p->iosb.count, 0, 0, 0, 0));
1539 /* everything shut? flag as done */
1541 if (!p->chan_in && !p->chan_out) {
1542 *p->pipe_done = TRUE;
1543 _ckvmssts(sys$setef(pipe_ef));
1547 /* write completed (or read, if snarfing from child)
1548 if still have input active,
1549 queue read...immediate mode if shut_on_empty so we get EOF if empty
1551 check if Perl reading, generate EOFs as needed
1557 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1558 pipe_infromchild_ast,p,
1559 p->buf, p->bufsize, 0, 0, 0, 0);
1560 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1562 } else { /* send EOFs for extra reads */
1563 p->iosb.status = SS$_ENDOFFILE;
1564 p->iosb.dvispec = 0;
1565 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1567 pipe_infromchild_ast, p, 0, 0, 0, 0));
1573 pipe_mbxtofd_setup(int fd, char *out)
1578 unsigned long dviitm = DVI$_DEVBUFSIZ;
1580 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1581 DSC$K_CLASS_S, mbx};
1583 /* things like terminals and mbx's don't need this filter */
1584 if (fd && fstat(fd,&s) == 0) {
1585 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1586 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1587 DSC$K_CLASS_S, s.st_dev};
1589 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1590 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1591 strcpy(out, s.st_dev);
1596 New(1366, p, 1, Pipe);
1597 p->fd_out = dup(fd);
1598 create_mbx(&p->chan_in, &d_mbx);
1599 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1600 New(1366, p->buf, p->bufsize+1, char);
1601 p->shut_on_empty = FALSE;
1606 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1607 pipe_mbxtofd_ast, p,
1608 p->buf, p->bufsize, 0, 0, 0, 0));
1614 pipe_mbxtofd_ast(pPipe p)
1617 int iss = p->iosb.status;
1618 int done = p->info->done;
1620 int eof = (iss == SS$_ENDOFFILE);
1621 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1622 int err = !(iss&1) && !eof;
1625 if (done && myeof) { /* end piping */
1627 sys$dassgn(p->chan_in);
1628 *p->pipe_done = TRUE;
1629 _ckvmssts(sys$setef(pipe_ef));
1633 if (!err && !eof) { /* good data to send to file */
1634 p->buf[p->iosb.count] = '\n';
1635 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1638 if (p->retry < MAX_RETRY) {
1639 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1649 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1650 pipe_mbxtofd_ast, p,
1651 p->buf, p->bufsize, 0, 0, 0, 0);
1652 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1657 typedef struct _pipeloc PLOC;
1658 typedef struct _pipeloc* pPLOC;
1662 char dir[NAM$C_MAXRSS+1];
1664 static pPLOC head_PLOC = 0;
1672 AV *av = GvAVn(PL_incgv);
1677 char temp[NAM$C_MAXRSS+1];
1680 /* the . directory from @INC comes last */
1683 p->next = head_PLOC;
1685 strcpy(p->dir,"./");
1687 /* get the directory from $^X */
1689 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1690 strcpy(temp, PL_origargv[0]);
1691 x = strrchr(temp,']');
1694 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1696 p->next = head_PLOC;
1698 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1699 p->dir[NAM$C_MAXRSS] = '\0';
1703 /* reverse order of @INC entries, skip "." since entered above */
1705 for (i = 0; i <= AvFILL(av); i++) {
1706 dirsv = *av_fetch(av,i,TRUE);
1708 if (SvROK(dirsv)) continue;
1709 dir = SvPVx(dirsv,n_a);
1710 if (strcmp(dir,".") == 0) continue;
1711 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1715 p->next = head_PLOC;
1717 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1718 p->dir[NAM$C_MAXRSS] = '\0';
1721 /* most likely spot (ARCHLIB) put first in the list */
1724 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1726 p->next = head_PLOC;
1728 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1729 p->dir[NAM$C_MAXRSS] = '\0';
1739 static int vmspipe_file_status = 0;
1740 static char vmspipe_file[NAM$C_MAXRSS+1];
1742 /* already found? Check and use ... need read+execute permission */
1744 if (vmspipe_file_status == 1) {
1745 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1746 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1747 return vmspipe_file;
1749 vmspipe_file_status = 0;
1752 /* scan through stored @INC, $^X */
1754 if (vmspipe_file_status == 0) {
1755 char file[NAM$C_MAXRSS+1];
1756 pPLOC p = head_PLOC;
1759 strcpy(file, p->dir);
1760 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1761 file[NAM$C_MAXRSS] = '\0';
1764 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1766 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1767 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1768 vmspipe_file_status = 1;
1769 return vmspipe_file;
1772 vmspipe_file_status = -1; /* failed, use tempfiles */
1779 vmspipe_tempfile(void)
1781 char file[NAM$C_MAXRSS+1];
1783 static int index = 0;
1786 /* create a tempfile */
1788 /* we can't go from W, shr=get to R, shr=get without
1789 an intermediate vulnerable state, so don't bother trying...
1791 and lib$spawn doesn't shr=put, so have to close the write
1793 So... match up the creation date/time and the FID to
1794 make sure we're dealing with the same file
1799 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1800 fp = fopen(file,"w");
1802 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1803 fp = fopen(file,"w");
1805 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1806 fp = fopen(file,"w");
1809 if (!fp) return 0; /* we're hosed */
1811 fprintf(fp,"$! 'f$verify(0)\n");
1812 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1813 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1814 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1815 fprintf(fp,"$ perl_on = \"set noon\"\n");
1816 fprintf(fp,"$ perl_exit = \"exit\"\n");
1817 fprintf(fp,"$ perl_del = \"delete\"\n");
1818 fprintf(fp,"$ pif = \"if\"\n");
1819 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1820 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n");
1821 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\n");
1822 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1823 fprintf(fp,"$! --- get rid of global symbols\n");
1824 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1825 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1826 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1827 fprintf(fp,"$ perl_on\n");
1828 fprintf(fp,"$ 'cmd\n");
1829 fprintf(fp,"$ perl_status = $STATUS\n");
1830 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1831 fprintf(fp,"$ perl_exit 'perl_status'\n");
1834 fgetname(fp, file, 1);
1835 fstat(fileno(fp), &s0);
1838 fp = fopen(file,"r","shr=get");
1840 fstat(fileno(fp), &s1);
1842 if (s0.st_ino[0] != s1.st_ino[0] ||
1843 s0.st_ino[1] != s1.st_ino[1] ||
1844 s0.st_ino[2] != s1.st_ino[2] ||
1845 s0.st_ctime != s1.st_ctime ) {
1856 safe_popen(char *cmd, char *mode)
1859 static int handler_set_up = FALSE;
1860 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1861 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1862 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1863 char in[512], out[512], err[512], mbx[512];
1865 char tfilebuf[NAM$C_MAXRSS+1];
1867 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1868 DSC$K_CLASS_S, symbol};
1869 struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
1870 DSC$K_CLASS_S, out};
1871 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1873 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1874 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1875 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1877 /* once-per-program initialization...
1878 note that the SETAST calls and the dual test of pipe_ef
1879 makes sure that only the FIRST thread through here does
1880 the initialization...all other threads wait until it's
1883 Yeah, uglier than a pthread call, it's got all the stuff inline
1884 rather than in a separate routine.
1888 _ckvmssts(sys$setast(0));
1890 unsigned long int pidcode = JPI$_PID;
1891 $DESCRIPTOR(d_delay, RETRY_DELAY);
1892 _ckvmssts(lib$get_ef(&pipe_ef));
1893 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1894 _ckvmssts(sys$bintim(&d_delay, delaytime));
1896 if (!handler_set_up) {
1897 _ckvmssts(sys$dclexh(&pipe_exitblock));
1898 handler_set_up = TRUE;
1900 _ckvmssts(sys$setast(1));
1903 /* see if we can find a VMSPIPE.COM */
1906 vmspipe = find_vmspipe();
1908 strcpy(tfilebuf+1,vmspipe);
1909 } else { /* uh, oh...we're in tempfile hell */
1910 tpipe = vmspipe_tempfile();
1911 if (!tpipe) { /* a fish popular in Boston */
1912 if (ckWARN(WARN_PIPE)) {
1913 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1917 fgetname(tpipe,tfilebuf+1,1);
1919 vmspipedsc.dsc$a_pointer = tfilebuf;
1920 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1922 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1923 New(1301,info,1,Info);
1927 info->completion = 0;
1928 info->closing = FALSE;
1932 info->in_done = TRUE;
1933 info->out_done = TRUE;
1934 info->err_done = TRUE;
1936 if (*mode == 'r') { /* piping from subroutine */
1939 info->out = pipe_infromchild_setup(mbx,out);
1941 info->out->pipe_done = &info->out_done;
1942 info->out_done = FALSE;
1943 info->out->info = info;
1945 info->fp = PerlIO_open(mbx, mode);
1946 if (!info->fp && info->out) {
1947 sys$cancel(info->out->chan_out);
1949 while (!info->out_done) {
1951 _ckvmssts(sys$setast(0));
1952 done = info->out_done;
1953 if (!done) _ckvmssts(sys$clref(pipe_ef));
1954 _ckvmssts(sys$setast(1));
1955 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1958 if (info->out->buf) Safefree(info->out->buf);
1959 Safefree(info->out);
1964 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1966 info->err->pipe_done = &info->err_done;
1967 info->err_done = FALSE;
1968 info->err->info = info;
1971 } else { /* piping to subroutine , mode=w*/
1974 info->in = pipe_tochild_setup(in,mbx);
1975 info->fp = PerlIO_open(mbx, mode);
1977 info->in->pipe_done = &info->in_done;
1978 info->in_done = FALSE;
1979 info->in->info = info;
1983 if (!info->fp && info->in) {
1985 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
1986 0, 0, 0, 0, 0, 0, 0, 0));
1988 while (!info->in_done) {
1990 _ckvmssts(sys$setast(0));
1991 done = info->in_done;
1992 if (!done) _ckvmssts(sys$clref(pipe_ef));
1993 _ckvmssts(sys$setast(1));
1994 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1997 if (info->in->buf) Safefree(info->in->buf);
2003 /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
2006 fgetname(stderr, err);
2007 if (strncmp(err,"SYS$ERROR:",10) == 0) {
2008 fgetname(stdout, out);
2009 if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
2010 if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
2016 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2018 info->out->pipe_done = &info->out_done;
2019 info->out_done = FALSE;
2020 info->out->info = info;
2023 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2025 info->err->pipe_done = &info->err_done;
2026 info->err_done = FALSE;
2027 info->err->info = info;
2033 d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/
2035 symbol[MAX_DCL_SYMBOL] = '\0';
2037 strncpy(symbol, in, MAX_DCL_SYMBOL);
2038 d_symbol.dsc$w_length = strlen(symbol);
2039 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2041 strncpy(symbol, err, MAX_DCL_SYMBOL);
2042 d_symbol.dsc$w_length = strlen(symbol);
2043 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2046 p = VMScmd.dsc$a_pointer;
2047 while (*p && *p != '\n') p++;
2048 *p = '\0'; /* truncate on \n */
2049 p = VMScmd.dsc$a_pointer;
2050 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2051 if (*p == '$') p++; /* remove leading $ */
2052 while (*p == ' ' || *p == '\t') p++;
2053 strncpy(symbol, p, MAX_DCL_SYMBOL);
2054 d_symbol.dsc$w_length = strlen(symbol);
2055 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2057 _ckvmssts(sys$setast(0));
2058 info->next=open_pipes; /* prepend to list */
2060 _ckvmssts(sys$setast(1));
2061 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
2062 0, &info->pid, &info->completion,
2063 0, popen_completion_ast,info,0,0,0));
2065 /* if we were using a tempfile, close it now */
2067 if (tpipe) fclose(tpipe);
2069 /* once the subprocess is spawned, its copied the symbols and
2070 we can get rid of ours */
2072 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2073 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2074 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2078 PL_forkprocess = info->pid;
2080 } /* end of safe_popen */
2083 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2085 Perl_my_popen(pTHX_ char *cmd, char *mode)
2088 TAINT_PROPER("popen");
2089 PERL_FLUSHALL_FOR_CHILD;
2090 return safe_popen(cmd,mode);
2095 /*{{{ I32 my_pclose(FILE *fp)*/
2096 I32 Perl_my_pclose(pTHX_ FILE *fp)
2099 pInfo info, last = NULL;
2100 unsigned long int retsts;
2103 for (info = open_pipes; info != NULL; last = info, info = info->next)
2104 if (info->fp == fp) break;
2106 if (info == NULL) { /* no such pipe open */
2107 set_errno(ECHILD); /* quoth POSIX */
2108 set_vaxc_errno(SS$_NONEXPR);
2112 /* If we were writing to a subprocess, insure that someone reading from
2113 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2114 * produce an EOF record in the mailbox.
2116 * well, at least sometimes it *does*, so we have to watch out for
2117 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2120 fsync(fileno(info->fp)); /* first, flush data */
2122 _ckvmssts(sys$setast(0));
2123 info->closing = TRUE;
2124 done = info->done && info->in_done && info->out_done && info->err_done;
2125 /* hanging on write to Perl's input? cancel it */
2126 if (info->mode == 'r' && info->out && !info->out_done) {
2127 if (info->out->chan_out) {
2128 _ckvmssts(sys$cancel(info->out->chan_out));
2129 if (!info->out->chan_in) { /* EOF generation, need AST */
2130 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2134 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2135 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2137 _ckvmssts(sys$setast(1));
2138 PerlIO_close(info->fp);
2141 we have to wait until subprocess completes, but ALSO wait until all
2142 the i/o completes...otherwise we'll be freeing the "info" structure
2143 that the i/o ASTs could still be using...
2147 _ckvmssts(sys$setast(0));
2148 done = info->done && info->in_done && info->out_done && info->err_done;
2149 if (!done) _ckvmssts(sys$clref(pipe_ef));
2150 _ckvmssts(sys$setast(1));
2151 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2153 retsts = info->completion;
2155 /* remove from list of open pipes */
2156 _ckvmssts(sys$setast(0));
2157 if (last) last->next = info->next;
2158 else open_pipes = info->next;
2159 _ckvmssts(sys$setast(1));
2161 /* free buffers and structures */
2164 if (info->in->buf) Safefree(info->in->buf);
2168 if (info->out->buf) Safefree(info->out->buf);
2169 Safefree(info->out);
2172 if (info->err->buf) Safefree(info->err->buf);
2173 Safefree(info->err);
2179 } /* end of my_pclose() */
2181 /* sort-of waitpid; use only with popen() */
2182 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2184 my_waitpid(Pid_t pid, int *statusp, int flags)
2190 for (info = open_pipes; info != NULL; info = info->next)
2191 if (info->pid == pid) break;
2193 if (info != NULL) { /* we know about this child */
2194 while (!info->done) {
2195 _ckvmssts(sys$setast(0));
2197 if (!done) _ckvmssts(sys$clref(pipe_ef));
2198 _ckvmssts(sys$setast(1));
2199 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2202 *statusp = info->completion;
2205 else { /* we haven't heard of this child */
2206 $DESCRIPTOR(intdsc,"0 00:00:01");
2207 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2208 unsigned long int interval[2],sts;
2210 if (ckWARN(WARN_EXEC)) {
2211 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2212 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2213 if (ownerpid != mypid)
2214 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2217 _ckvmssts(sys$bintim(&intdsc,interval));
2218 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2219 _ckvmssts(sys$schdwk(0,0,interval,0));
2220 _ckvmssts(sys$hiber());
2222 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2225 /* There's no easy way to find the termination status a child we're
2226 * not aware of beforehand. If we're really interested in the future,
2227 * we can go looking for a termination mailbox, or chase after the
2228 * accounting record for the process.
2234 } /* end of waitpid() */
2239 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2241 my_gconvert(double val, int ndig, int trail, char *buf)
2243 static char __gcvtbuf[DBL_DIG+1];
2246 loc = buf ? buf : __gcvtbuf;
2248 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2250 sprintf(loc,"%.*g",ndig,val);
2256 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2257 return gcvt(val,ndig,loc);
2260 loc[0] = '0'; loc[1] = '\0';
2268 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2269 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2270 * to expand file specification. Allows for a single default file
2271 * specification and a simple mask of options. If outbuf is non-NULL,
2272 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2273 * the resultant file specification is placed. If outbuf is NULL, the
2274 * resultant file specification is placed into a static buffer.
2275 * The third argument, if non-NULL, is taken to be a default file
2276 * specification string. The fourth argument is unused at present.
2277 * rmesexpand() returns the address of the resultant string if
2278 * successful, and NULL on error.
2280 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2283 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2285 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2286 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2287 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2288 struct FAB myfab = cc$rms_fab;
2289 struct NAM mynam = cc$rms_nam;
2291 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2293 if (!filespec || !*filespec) {
2294 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2298 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2299 else outbuf = __rmsexpand_retbuf;
2301 if ((isunix = (strchr(filespec,'/') != NULL))) {
2302 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2303 filespec = vmsfspec;
2306 myfab.fab$l_fna = filespec;
2307 myfab.fab$b_fns = strlen(filespec);
2308 myfab.fab$l_nam = &mynam;
2310 if (defspec && *defspec) {
2311 if (strchr(defspec,'/') != NULL) {
2312 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2315 myfab.fab$l_dna = defspec;
2316 myfab.fab$b_dns = strlen(defspec);
2319 mynam.nam$l_esa = esa;
2320 mynam.nam$b_ess = sizeof esa;
2321 mynam.nam$l_rsa = outbuf;
2322 mynam.nam$b_rss = NAM$C_MAXRSS;
2324 retsts = sys$parse(&myfab,0,0);
2325 if (!(retsts & 1)) {
2326 mynam.nam$b_nop |= NAM$M_SYNCHK;
2327 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2328 retsts = sys$parse(&myfab,0,0);
2329 if (retsts & 1) goto expanded;
2331 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2332 (void) sys$parse(&myfab,0,0); /* Free search context */
2333 if (out) Safefree(out);
2334 set_vaxc_errno(retsts);
2335 if (retsts == RMS$_PRV) set_errno(EACCES);
2336 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2337 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2338 else set_errno(EVMSERR);
2341 retsts = sys$search(&myfab,0,0);
2342 if (!(retsts & 1) && retsts != RMS$_FNF) {
2343 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2344 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2345 if (out) Safefree(out);
2346 set_vaxc_errno(retsts);
2347 if (retsts == RMS$_PRV) set_errno(EACCES);
2348 else set_errno(EVMSERR);
2352 /* If the input filespec contained any lowercase characters,
2353 * downcase the result for compatibility with Unix-minded code. */
2355 for (out = myfab.fab$l_fna; *out; out++)
2356 if (islower(*out)) { haslower = 1; break; }
2357 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2358 else { out = esa; speclen = mynam.nam$b_esl; }
2359 /* Trim off null fields added by $PARSE
2360 * If type > 1 char, must have been specified in original or default spec
2361 * (not true for version; $SEARCH may have added version of existing file).
2363 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2364 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2365 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2366 if (trimver || trimtype) {
2367 if (defspec && *defspec) {
2368 char defesa[NAM$C_MAXRSS];
2369 struct FAB deffab = cc$rms_fab;
2370 struct NAM defnam = cc$rms_nam;
2372 deffab.fab$l_nam = &defnam;
2373 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2374 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2375 defnam.nam$b_nop = NAM$M_SYNCHK;
2376 if (sys$parse(&deffab,0,0) & 1) {
2377 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2378 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2381 if (trimver) speclen = mynam.nam$l_ver - out;
2383 /* If we didn't already trim version, copy down */
2384 if (speclen > mynam.nam$l_ver - out)
2385 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2386 speclen - (mynam.nam$l_ver - out));
2387 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2390 /* If we just had a directory spec on input, $PARSE "helpfully"
2391 * adds an empty name and type for us */
2392 if (mynam.nam$l_name == mynam.nam$l_type &&
2393 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2394 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2395 speclen = mynam.nam$l_name - out;
2396 out[speclen] = '\0';
2397 if (haslower) __mystrtolower(out);
2399 /* Have we been working with an expanded, but not resultant, spec? */
2400 /* Also, convert back to Unix syntax if necessary. */
2401 if (!mynam.nam$b_rsl) {
2403 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2405 else strcpy(outbuf,esa);
2408 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2409 strcpy(outbuf,tmpfspec);
2411 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2412 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2413 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2417 /* External entry points */
2418 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2419 { return do_rmsexpand(spec,buf,0,def,opt); }
2420 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2421 { return do_rmsexpand(spec,buf,1,def,opt); }
2425 ** The following routines are provided to make life easier when
2426 ** converting among VMS-style and Unix-style directory specifications.
2427 ** All will take input specifications in either VMS or Unix syntax. On
2428 ** failure, all return NULL. If successful, the routines listed below
2429 ** return a pointer to a buffer containing the appropriately
2430 ** reformatted spec (and, therefore, subsequent calls to that routine
2431 ** will clobber the result), while the routines of the same names with
2432 ** a _ts suffix appended will return a pointer to a mallocd string
2433 ** containing the appropriately reformatted spec.
2434 ** In all cases, only explicit syntax is altered; no check is made that
2435 ** the resulting string is valid or that the directory in question
2438 ** fileify_dirspec() - convert a directory spec into the name of the
2439 ** directory file (i.e. what you can stat() to see if it's a dir).
2440 ** The style (VMS or Unix) of the result is the same as the style
2441 ** of the parameter passed in.
2442 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2443 ** what you prepend to a filename to indicate what directory it's in).
2444 ** The style (VMS or Unix) of the result is the same as the style
2445 ** of the parameter passed in.
2446 ** tounixpath() - convert a directory spec into a Unix-style path.
2447 ** tovmspath() - convert a directory spec into a VMS-style path.
2448 ** tounixspec() - convert any file spec into a Unix-style file spec.
2449 ** tovmsspec() - convert any file spec into a VMS-style spec.
2451 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2452 ** Permission is given to distribute this code as part of the Perl
2453 ** standard distribution under the terms of the GNU General Public
2454 ** License or the Perl Artistic License. Copies of each may be
2455 ** found in the Perl standard distribution.
2458 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2459 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2461 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2462 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2463 char *retspec, *cp1, *cp2, *lastdir;
2464 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2466 if (!dir || !*dir) {
2467 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2469 dirlen = strlen(dir);
2470 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2471 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2472 strcpy(trndir,"/sys$disk/000000");
2476 if (dirlen > NAM$C_MAXRSS) {
2477 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2479 if (!strpbrk(dir+1,"/]>:")) {
2480 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2481 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2483 dirlen = strlen(dir);
2486 strncpy(trndir,dir,dirlen);
2487 trndir[dirlen] = '\0';
2490 /* If we were handed a rooted logical name or spec, treat it like a
2491 * simple directory, so that
2492 * $ Define myroot dev:[dir.]
2493 * ... do_fileify_dirspec("myroot",buf,1) ...
2494 * does something useful.
2496 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2497 dir[--dirlen] = '\0';
2498 dir[dirlen-1] = ']';
2501 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2502 /* If we've got an explicit filename, we can just shuffle the string. */
2503 if (*(cp1+1)) hasfilename = 1;
2504 /* Similarly, we can just back up a level if we've got multiple levels
2505 of explicit directories in a VMS spec which ends with directories. */
2507 for (cp2 = cp1; cp2 > dir; cp2--) {
2509 *cp2 = *cp1; *cp1 = '\0';
2513 if (*cp2 == '[' || *cp2 == '<') break;
2518 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2519 if (dir[0] == '.') {
2520 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2521 return do_fileify_dirspec("[]",buf,ts);
2522 else if (dir[1] == '.' &&
2523 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2524 return do_fileify_dirspec("[-]",buf,ts);
2526 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2527 dirlen -= 1; /* to last element */
2528 lastdir = strrchr(dir,'/');
2530 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2531 /* If we have "/." or "/..", VMSify it and let the VMS code
2532 * below expand it, rather than repeating the code to handle
2533 * relative components of a filespec here */
2535 if (*(cp1+2) == '.') cp1++;
2536 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2537 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2538 if (strchr(vmsdir,'/') != NULL) {
2539 /* If do_tovmsspec() returned it, it must have VMS syntax
2540 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2541 * the time to check this here only so we avoid a recursion
2542 * loop; otherwise, gigo.
2544 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2546 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2547 return do_tounixspec(trndir,buf,ts);
2550 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2551 lastdir = strrchr(dir,'/');
2553 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2554 /* Ditto for specs that end in an MFD -- let the VMS code
2555 * figure out whether it's a real device or a rooted logical. */
2556 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2557 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2558 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2559 return do_tounixspec(trndir,buf,ts);
2562 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2563 !(lastdir = cp1 = strrchr(dir,']')) &&
2564 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2565 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2567 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2568 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2569 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2570 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2571 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2572 (ver || *cp3)))))) {
2574 set_vaxc_errno(RMS$_DIR);
2580 /* If we lead off with a device or rooted logical, add the MFD
2581 if we're specifying a top-level directory. */
2582 if (lastdir && *dir == '/') {
2584 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2591 retlen = dirlen + (addmfd ? 13 : 6);
2592 if (buf) retspec = buf;
2593 else if (ts) New(1309,retspec,retlen+1,char);
2594 else retspec = __fileify_retbuf;
2596 dirlen = lastdir - dir;
2597 memcpy(retspec,dir,dirlen);
2598 strcpy(&retspec[dirlen],"/000000");
2599 strcpy(&retspec[dirlen+7],lastdir);
2602 memcpy(retspec,dir,dirlen);
2603 retspec[dirlen] = '\0';
2605 /* We've picked up everything up to the directory file name.
2606 Now just add the type and version, and we're set. */
2607 strcat(retspec,".dir;1");
2610 else { /* VMS-style directory spec */
2611 char esa[NAM$C_MAXRSS+1], term, *cp;
2612 unsigned long int sts, cmplen, haslower = 0;
2613 struct FAB dirfab = cc$rms_fab;
2614 struct NAM savnam, dirnam = cc$rms_nam;
2616 dirfab.fab$b_fns = strlen(dir);
2617 dirfab.fab$l_fna = dir;
2618 dirfab.fab$l_nam = &dirnam;
2619 dirfab.fab$l_dna = ".DIR;1";
2620 dirfab.fab$b_dns = 6;
2621 dirnam.nam$b_ess = NAM$C_MAXRSS;
2622 dirnam.nam$l_esa = esa;
2624 for (cp = dir; *cp; cp++)
2625 if (islower(*cp)) { haslower = 1; break; }
2626 if (!((sts = sys$parse(&dirfab))&1)) {
2627 if (dirfab.fab$l_sts == RMS$_DIR) {
2628 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2629 sts = sys$parse(&dirfab) & 1;
2633 set_vaxc_errno(dirfab.fab$l_sts);
2639 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2640 /* Yes; fake the fnb bits so we'll check type below */
2641 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2643 else { /* No; just work with potential name */
2644 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2646 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2647 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2648 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2653 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2654 cp1 = strchr(esa,']');
2655 if (!cp1) cp1 = strchr(esa,'>');
2656 if (cp1) { /* Should always be true */
2657 dirnam.nam$b_esl -= cp1 - esa - 1;
2658 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2661 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2662 /* Yep; check version while we're at it, if it's there. */
2663 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2664 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2665 /* Something other than .DIR[;1]. Bzzt. */
2666 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2667 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2669 set_vaxc_errno(RMS$_DIR);
2673 esa[dirnam.nam$b_esl] = '\0';
2674 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2675 /* They provided at least the name; we added the type, if necessary, */
2676 if (buf) retspec = buf; /* in sys$parse() */
2677 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2678 else retspec = __fileify_retbuf;
2679 strcpy(retspec,esa);
2680 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2681 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2684 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2685 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2687 dirnam.nam$b_esl -= 9;
2689 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2690 if (cp1 == NULL) { /* should never happen */
2691 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2692 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2697 retlen = strlen(esa);
2698 if ((cp1 = strrchr(esa,'.')) != NULL) {
2699 /* There's more than one directory in the path. Just roll back. */
2701 if (buf) retspec = buf;
2702 else if (ts) New(1311,retspec,retlen+7,char);
2703 else retspec = __fileify_retbuf;
2704 strcpy(retspec,esa);
2707 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2708 /* Go back and expand rooted logical name */
2709 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2710 if (!(sys$parse(&dirfab) & 1)) {
2711 dirnam.nam$l_rlf = NULL;
2712 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2714 set_vaxc_errno(dirfab.fab$l_sts);
2717 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2718 if (buf) retspec = buf;
2719 else if (ts) New(1312,retspec,retlen+16,char);
2720 else retspec = __fileify_retbuf;
2721 cp1 = strstr(esa,"][");
2723 memcpy(retspec,esa,dirlen);
2724 if (!strncmp(cp1+2,"000000]",7)) {
2725 retspec[dirlen-1] = '\0';
2726 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2727 if (*cp1 == '.') *cp1 = ']';
2729 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2730 memcpy(cp1+1,"000000]",7);
2734 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2735 retspec[retlen] = '\0';
2736 /* Convert last '.' to ']' */
2737 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2738 if (*cp1 == '.') *cp1 = ']';
2740 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2741 memcpy(cp1+1,"000000]",7);
2745 else { /* This is a top-level dir. Add the MFD to the path. */
2746 if (buf) retspec = buf;
2747 else if (ts) New(1312,retspec,retlen+16,char);
2748 else retspec = __fileify_retbuf;
2751 while (*cp1 != ':') *(cp2++) = *(cp1++);
2752 strcpy(cp2,":[000000]");
2757 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2758 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2759 /* We've set up the string up through the filename. Add the
2760 type and version, and we're done. */
2761 strcat(retspec,".DIR;1");
2763 /* $PARSE may have upcased filespec, so convert output to lower
2764 * case if input contained any lowercase characters. */
2765 if (haslower) __mystrtolower(retspec);
2768 } /* end of do_fileify_dirspec() */
2770 /* External entry points */
2771 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2772 { return do_fileify_dirspec(dir,buf,0); }
2773 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2774 { return do_fileify_dirspec(dir,buf,1); }
2776 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2777 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2779 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2780 unsigned long int retlen;
2781 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2783 if (!dir || !*dir) {
2784 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2787 if (*dir) strcpy(trndir,dir);
2788 else getcwd(trndir,sizeof trndir - 1);
2790 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2791 && my_trnlnm(trndir,trndir,0)) {
2792 STRLEN trnlen = strlen(trndir);
2794 /* Trap simple rooted lnms, and return lnm:[000000] */
2795 if (!strcmp(trndir+trnlen-2,".]")) {
2796 if (buf) retpath = buf;
2797 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2798 else retpath = __pathify_retbuf;
2799 strcpy(retpath,dir);
2800 strcat(retpath,":[000000]");
2806 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2807 if (*dir == '.' && (*(dir+1) == '\0' ||
2808 (*(dir+1) == '.' && *(dir+2) == '\0')))
2809 retlen = 2 + (*(dir+1) != '\0');
2811 if ( !(cp1 = strrchr(dir,'/')) &&
2812 !(cp1 = strrchr(dir,']')) &&
2813 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2814 if ((cp2 = strchr(cp1,'.')) != NULL &&
2815 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2816 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2817 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2818 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2820 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2821 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2822 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2823 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2824 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2825 (ver || *cp3)))))) {
2827 set_vaxc_errno(RMS$_DIR);
2830 retlen = cp2 - dir + 1;
2832 else { /* No file type present. Treat the filename as a directory. */
2833 retlen = strlen(dir) + 1;
2836 if (buf) retpath = buf;
2837 else if (ts) New(1313,retpath,retlen+1,char);
2838 else retpath = __pathify_retbuf;
2839 strncpy(retpath,dir,retlen-1);
2840 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2841 retpath[retlen-1] = '/'; /* with '/', add it. */
2842 retpath[retlen] = '\0';
2844 else retpath[retlen-1] = '\0';
2846 else { /* VMS-style directory spec */
2847 char esa[NAM$C_MAXRSS+1], *cp;
2848 unsigned long int sts, cmplen, haslower;
2849 struct FAB dirfab = cc$rms_fab;
2850 struct NAM savnam, dirnam = cc$rms_nam;
2852 /* If we've got an explicit filename, we can just shuffle the string. */
2853 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2854 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2855 if ((cp2 = strchr(cp1,'.')) != NULL) {
2857 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2858 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2859 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2860 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2861 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2862 (ver || *cp3)))))) {
2864 set_vaxc_errno(RMS$_DIR);
2868 else { /* No file type, so just draw name into directory part */
2869 for (cp2 = cp1; *cp2; cp2++) ;
2872 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2874 /* We've now got a VMS 'path'; fall through */
2876 dirfab.fab$b_fns = strlen(dir);
2877 dirfab.fab$l_fna = dir;
2878 if (dir[dirfab.fab$b_fns-1] == ']' ||
2879 dir[dirfab.fab$b_fns-1] == '>' ||
2880 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2881 if (buf) retpath = buf;
2882 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2883 else retpath = __pathify_retbuf;
2884 strcpy(retpath,dir);
2887 dirfab.fab$l_dna = ".DIR;1";
2888 dirfab.fab$b_dns = 6;
2889 dirfab.fab$l_nam = &dirnam;
2890 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2891 dirnam.nam$l_esa = esa;
2893 for (cp = dir; *cp; cp++)
2894 if (islower(*cp)) { haslower = 1; break; }
2896 if (!(sts = (sys$parse(&dirfab)&1))) {
2897 if (dirfab.fab$l_sts == RMS$_DIR) {
2898 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2899 sts = sys$parse(&dirfab) & 1;
2903 set_vaxc_errno(dirfab.fab$l_sts);
2909 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
2910 if (dirfab.fab$l_sts != RMS$_FNF) {
2911 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2912 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2914 set_vaxc_errno(dirfab.fab$l_sts);
2917 dirnam = savnam; /* No; just work with potential name */
2920 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2921 /* Yep; check version while we're at it, if it's there. */
2922 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2923 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2924 /* Something other than .DIR[;1]. Bzzt. */
2925 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2926 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2928 set_vaxc_errno(RMS$_DIR);
2932 /* OK, the type was fine. Now pull any file name into the
2934 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
2936 cp1 = strrchr(esa,'>');
2937 *dirnam.nam$l_type = '>';
2940 *(dirnam.nam$l_type + 1) = '\0';
2941 retlen = dirnam.nam$l_type - esa + 2;
2942 if (buf) retpath = buf;
2943 else if (ts) New(1314,retpath,retlen,char);
2944 else retpath = __pathify_retbuf;
2945 strcpy(retpath,esa);
2946 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2947 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2948 /* $PARSE may have upcased filespec, so convert output to lower
2949 * case if input contained any lowercase characters. */
2950 if (haslower) __mystrtolower(retpath);
2954 } /* end of do_pathify_dirspec() */
2956 /* External entry points */
2957 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2958 { return do_pathify_dirspec(dir,buf,0); }
2959 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
2960 { return do_pathify_dirspec(dir,buf,1); }
2962 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
2963 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
2965 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
2966 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
2967 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
2969 if (spec == NULL) return NULL;
2970 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
2971 if (buf) rslt = buf;
2973 retlen = strlen(spec);
2974 cp1 = strchr(spec,'[');
2975 if (!cp1) cp1 = strchr(spec,'<');
2977 for (cp1++; *cp1; cp1++) {
2978 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
2979 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2980 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2983 New(1315,rslt,retlen+2+2*expand,char);
2985 else rslt = __tounixspec_retbuf;
2986 if (strchr(spec,'/') != NULL) {
2993 dirend = strrchr(spec,']');
2994 if (dirend == NULL) dirend = strrchr(spec,'>');
2995 if (dirend == NULL) dirend = strchr(spec,':');
2996 if (dirend == NULL) {
3000 if (*cp2 != '[' && *cp2 != '<') {
3003 else { /* the VMS spec begins with directories */
3005 if (*cp2 == ']' || *cp2 == '>') {
3006 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3009 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3010 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3011 if (ts) Safefree(rslt);
3016 while (*cp3 != ':' && *cp3) cp3++;
3018 if (strchr(cp3,']') != NULL) break;
3019 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3021 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3022 retlen = devlen + dirlen;
3023 Renew(rslt,retlen+1+2*expand,char);
3029 *(cp1++) = *(cp3++);
3030 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3034 else if ( *cp2 == '.') {
3035 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3036 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3042 for (; cp2 <= dirend; cp2++) {
3045 if (*(cp2+1) == '[') cp2++;
3047 else if (*cp2 == ']' || *cp2 == '>') {
3048 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3050 else if (*cp2 == '.') {
3052 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3053 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3054 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3055 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3056 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3058 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3059 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3063 else if (*cp2 == '-') {
3064 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3065 while (*cp2 == '-') {
3067 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3069 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3070 if (ts) Safefree(rslt); /* filespecs like */
3071 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3075 else *(cp1++) = *cp2;
3077 else *(cp1++) = *cp2;
3079 while (*cp2) *(cp1++) = *(cp2++);
3084 } /* end of do_tounixspec() */
3086 /* External entry points */
3087 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3088 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3090 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3091 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3092 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3093 char *rslt, *dirend;
3094 register char *cp1, *cp2;
3095 unsigned long int infront = 0, hasdir = 1;
3097 if (path == NULL) return NULL;
3098 if (buf) rslt = buf;
3099 else if (ts) New(1316,rslt,strlen(path)+9,char);
3100 else rslt = __tovmsspec_retbuf;
3101 if (strpbrk(path,"]:>") ||
3102 (dirend = strrchr(path,'/')) == NULL) {
3103 if (path[0] == '.') {
3104 if (path[1] == '\0') strcpy(rslt,"[]");
3105 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3106 else strcpy(rslt,path); /* probably garbage */
3108 else strcpy(rslt,path);
3111 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3112 if (!*(dirend+2)) dirend +=2;
3113 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3114 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3119 char trndev[NAM$C_MAXRSS+1];
3123 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3125 if (!buf & ts) Renew(rslt,18,char);
3126 strcpy(rslt,"sys$disk:[000000]");
3129 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3131 islnm = my_trnlnm(rslt,trndev,0);
3132 trnend = islnm ? strlen(trndev) - 1 : 0;
3133 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3134 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3135 /* If the first element of the path is a logical name, determine
3136 * whether it has to be translated so we can add more directories. */
3137 if (!islnm || rooted) {
3140 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3144 if (cp2 != dirend) {
3145 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3146 strcpy(rslt,trndev);
3147 cp1 = rslt + trnend;
3160 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3161 cp2 += 2; /* skip over "./" - it's redundant */
3162 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3164 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3165 *(cp1++) = '-'; /* "../" --> "-" */
3168 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3169 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3170 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3171 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3174 if (cp2 > dirend) cp2 = dirend;
3176 else *(cp1++) = '.';
3178 for (; cp2 < dirend; cp2++) {
3180 if (*(cp2-1) == '/') continue;
3181 if (*(cp1-1) != '.') *(cp1++) = '.';
3184 else if (!infront && *cp2 == '.') {
3185 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3186 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3187 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3188 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3189 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3190 else { /* back up over previous directory name */
3192 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3193 if (*(cp1-1) == '[') {
3194 memcpy(cp1,"000000.",7);
3199 if (cp2 == dirend) break;
3201 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3202 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3203 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3204 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3206 *(cp1++) = '.'; /* Simulate trailing '/' */
3207 cp2 += 2; /* for loop will incr this to == dirend */
3209 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3211 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3214 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3215 if (*cp2 == '.') *(cp1++) = '_';
3216 else *(cp1++) = *cp2;
3220 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3221 if (hasdir) *(cp1++) = ']';
3222 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3223 while (*cp2) *(cp1++) = *(cp2++);
3228 } /* end of do_tovmsspec() */
3230 /* External entry points */
3231 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3232 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3234 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3235 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3236 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3238 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3240 if (path == NULL) return NULL;
3241 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3242 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3243 if (buf) return buf;
3245 vmslen = strlen(vmsified);
3246 New(1317,cp,vmslen+1,char);
3247 memcpy(cp,vmsified,vmslen);
3252 strcpy(__tovmspath_retbuf,vmsified);
3253 return __tovmspath_retbuf;
3256 } /* end of do_tovmspath() */
3258 /* External entry points */
3259 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3260 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3263 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3264 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3265 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3267 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3269 if (path == NULL) return NULL;
3270 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3271 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3272 if (buf) return buf;
3274 unixlen = strlen(unixified);
3275 New(1317,cp,unixlen+1,char);
3276 memcpy(cp,unixified,unixlen);
3281 strcpy(__tounixpath_retbuf,unixified);
3282 return __tounixpath_retbuf;
3285 } /* end of do_tounixpath() */
3287 /* External entry points */
3288 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3289 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3292 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3294 *****************************************************************************
3296 * Copyright (C) 1989-1994 by *
3297 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3299 * Permission is hereby granted for the reproduction of this software, *
3300 * on condition that this copyright notice is included in the reproduction, *
3301 * and that such reproduction is not for purposes of profit or material *
3304 * 27-Aug-1994 Modified for inclusion in perl5 *
3305 * by Charles Bailey bailey@newman.upenn.edu *
3306 *****************************************************************************
3310 * getredirection() is intended to aid in porting C programs
3311 * to VMS (Vax-11 C). The native VMS environment does not support
3312 * '>' and '<' I/O redirection, or command line wild card expansion,
3313 * or a command line pipe mechanism using the '|' AND background
3314 * command execution '&'. All of these capabilities are provided to any
3315 * C program which calls this procedure as the first thing in the
3317 * The piping mechanism will probably work with almost any 'filter' type
3318 * of program. With suitable modification, it may useful for other
3319 * portability problems as well.
3321 * Author: Mark Pizzolato mark@infocomm.com
3325 struct list_item *next;
3329 static void add_item(struct list_item **head,
3330 struct list_item **tail,
3334 static void mp_expand_wild_cards(pTHX_ char *item,
3335 struct list_item **head,
3336 struct list_item **tail,
3339 static int background_process(int argc, char **argv);
3341 static void pipe_and_fork(char **cmargv);
3343 /*{{{ void getredirection(int *ac, char ***av)*/
3345 mp_getredirection(pTHX_ int *ac, char ***av)
3347 * Process vms redirection arg's. Exit if any error is seen.
3348 * If getredirection() processes an argument, it is erased
3349 * from the vector. getredirection() returns a new argc and argv value.
3350 * In the event that a background command is requested (by a trailing "&"),
3351 * this routine creates a background subprocess, and simply exits the program.
3353 * Warning: do not try to simplify the code for vms. The code
3354 * presupposes that getredirection() is called before any data is
3355 * read from stdin or written to stdout.
3357 * Normal usage is as follows:
3363 * getredirection(&argc, &argv);
3367 int argc = *ac; /* Argument Count */
3368 char **argv = *av; /* Argument Vector */
3369 char *ap; /* Argument pointer */
3370 int j; /* argv[] index */
3371 int item_count = 0; /* Count of Items in List */
3372 struct list_item *list_head = 0; /* First Item in List */
3373 struct list_item *list_tail; /* Last Item in List */
3374 char *in = NULL; /* Input File Name */
3375 char *out = NULL; /* Output File Name */
3376 char *outmode = "w"; /* Mode to Open Output File */
3377 char *err = NULL; /* Error File Name */
3378 char *errmode = "w"; /* Mode to Open Error File */
3379 int cmargc = 0; /* Piped Command Arg Count */
3380 char **cmargv = NULL;/* Piped Command Arg Vector */
3383 * First handle the case where the last thing on the line ends with
3384 * a '&'. This indicates the desire for the command to be run in a
3385 * subprocess, so we satisfy that desire.
3388 if (0 == strcmp("&", ap))
3389 exit(background_process(--argc, argv));
3390 if (*ap && '&' == ap[strlen(ap)-1])
3392 ap[strlen(ap)-1] = '\0';
3393 exit(background_process(argc, argv));
3396 * Now we handle the general redirection cases that involve '>', '>>',
3397 * '<', and pipes '|'.
3399 for (j = 0; j < argc; ++j)
3401 if (0 == strcmp("<", argv[j]))
3405 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3406 exit(LIB$_WRONUMARG);
3411 if ('<' == *(ap = argv[j]))
3416 if (0 == strcmp(">", ap))
3420 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3421 exit(LIB$_WRONUMARG);
3440 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3441 exit(LIB$_WRONUMARG);
3445 if (('2' == *ap) && ('>' == ap[1]))
3462 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3463 exit(LIB$_WRONUMARG);
3467 if (0 == strcmp("|", argv[j]))
3471 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3472 exit(LIB$_WRONUMARG);
3474 cmargc = argc-(j+1);
3475 cmargv = &argv[j+1];
3479 if ('|' == *(ap = argv[j]))
3487 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3490 * Allocate and fill in the new argument vector, Some Unix's terminate
3491 * the list with an extra null pointer.
3493 New(1302, argv, item_count+1, char *);
3495 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3496 argv[j] = list_head->value;
3502 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3503 exit(LIB$_INVARGORD);
3505 pipe_and_fork(cmargv);
3508 /* Check for input from a pipe (mailbox) */
3510 if (in == NULL && 1 == isapipe(0))
3512 char mbxname[L_tmpnam];
3514 long int dvi_item = DVI$_DEVBUFSIZ;
3515 $DESCRIPTOR(mbxnam, "");
3516 $DESCRIPTOR(mbxdevnam, "");
3518 /* Input from a pipe, reopen it in binary mode to disable */
3519 /* carriage control processing. */
3521 PerlIO_getname(stdin, mbxname);
3522 mbxnam.dsc$a_pointer = mbxname;
3523 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3524 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3525 mbxdevnam.dsc$a_pointer = mbxname;
3526 mbxdevnam.dsc$w_length = sizeof(mbxname);
3527 dvi_item = DVI$_DEVNAM;
3528 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3529 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3532 freopen(mbxname, "rb", stdin);
3535 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3539 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3541 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3544 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3546 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3550 if (strcmp(err,"&1") == 0) {
3551 dup2(fileno(stdout), fileno(Perl_debug_log));
3554 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3556 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3560 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3566 #ifdef ARGPROC_DEBUG
3567 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3568 for (j = 0; j < *ac; ++j)
3569 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3571 /* Clear errors we may have hit expanding wildcards, so they don't
3572 show up in Perl's $! later */
3573 set_errno(0); set_vaxc_errno(1);
3574 } /* end of getredirection() */
3577 static void add_item(struct list_item **head,
3578 struct list_item **tail,
3584 New(1303,*head,1,struct list_item);
3588 New(1304,(*tail)->next,1,struct list_item);
3589 *tail = (*tail)->next;
3591 (*tail)->value = value;
3595 static void mp_expand_wild_cards(pTHX_ char *item,
3596 struct list_item **head,
3597 struct list_item **tail,
3601 unsigned long int context = 0;
3607 char vmsspec[NAM$C_MAXRSS+1];
3608 $DESCRIPTOR(filespec, "");
3609 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3610 $DESCRIPTOR(resultspec, "");
3611 unsigned long int zero = 0, sts;
3613 for (cp = item; *cp; cp++) {
3614 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3615 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3617 if (!*cp || isspace(*cp))
3619 add_item(head, tail, item, count);
3622 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3623 resultspec.dsc$b_class = DSC$K_CLASS_D;
3624 resultspec.dsc$a_pointer = NULL;
3625 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3626 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3627 if (!isunix || !filespec.dsc$a_pointer)
3628 filespec.dsc$a_pointer = item;
3629 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3631 * Only return version specs, if the caller specified a version
3633 had_version = strchr(item, ';');
3635 * Only return device and directory specs, if the caller specifed either.
3637 had_device = strchr(item, ':');
3638 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3640 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3641 &defaultspec, 0, 0, &zero))))
3646 New(1305,string,resultspec.dsc$w_length+1,char);
3647 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3648 string[resultspec.dsc$w_length] = '\0';
3649 if (NULL == had_version)
3650 *((char *)strrchr(string, ';')) = '\0';
3651 if ((!had_directory) && (had_device == NULL))
3653 if (NULL == (devdir = strrchr(string, ']')))
3654 devdir = strrchr(string, '>');
3655 strcpy(string, devdir + 1);
3658 * Be consistent with what the C RTL has already done to the rest of
3659 * the argv items and lowercase all of these names.
3661 for (c = string; *c; ++c)
3664 if (isunix) trim_unixpath(string,item,1);
3665 add_item(head, tail, string, count);
3668 if (sts != RMS$_NMF)
3670 set_vaxc_errno(sts);
3673 case RMS$_FNF: case RMS$_DNF:
3674 set_errno(ENOENT); break;
3676 set_errno(ENOTDIR); break;
3678 set_errno(ENODEV); break;
3679 case RMS$_FNM: case RMS$_SYN:
3680 set_errno(EINVAL); break;
3682 set_errno(EACCES); break;
3684 _ckvmssts_noperl(sts);
3688 add_item(head, tail, item, count);
3689 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3690 _ckvmssts_noperl(lib$find_file_end(&context));
3693 static int child_st[2];/* Event Flag set when child process completes */
3695 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3697 static unsigned long int exit_handler(int *status)
3701 if (0 == child_st[0])
3703 #ifdef ARGPROC_DEBUG
3704 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3706 fflush(stdout); /* Have to flush pipe for binary data to */
3707 /* terminate properly -- <tp@mccall.com> */
3708 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3709 sys$dassgn(child_chan);
3711 sys$synch(0, child_st);
3716 static void sig_child(int chan)
3718 #ifdef ARGPROC_DEBUG
3719 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3721 if (child_st[0] == 0)
3725 static struct exit_control_block exit_block =
3730 &exit_block.exit_status,
3734 static void pipe_and_fork(char **cmargv)
3737 $DESCRIPTOR(cmddsc, "");
3738 static char mbxname[64];
3739 $DESCRIPTOR(mbxdsc, mbxname);
3741 unsigned long int zero = 0, one = 1;
3743 strcpy(subcmd, cmargv[0]);
3744 for (j = 1; NULL != cmargv[j]; ++j)
3746 strcat(subcmd, " \"");
3747 strcat(subcmd, cmargv[j]);
3748 strcat(subcmd, "\"");
3750 cmddsc.dsc$a_pointer = subcmd;
3751 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3753 create_mbx(&child_chan,&mbxdsc);
3754 #ifdef ARGPROC_DEBUG
3755 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3756 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3758 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3759 0, &pid, child_st, &zero, sig_child,
3761 #ifdef ARGPROC_DEBUG
3762 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3764 sys$dclexh(&exit_block);
3765 if (NULL == freopen(mbxname, "wb", stdout))
3767 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3771 static int background_process(int argc, char **argv)
3773 char command[2048] = "$";
3774 $DESCRIPTOR(value, "");
3775 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3776 static $DESCRIPTOR(null, "NLA0:");
3777 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3779 $DESCRIPTOR(pidstr, "");
3781 unsigned long int flags = 17, one = 1, retsts;
3783 strcat(command, argv[0]);
3786 strcat(command, " \"");
3787 strcat(command, *(++argv));
3788 strcat(command, "\"");
3790 value.dsc$a_pointer = command;
3791 value.dsc$w_length = strlen(value.dsc$a_pointer);
3792 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3793 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3794 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3795 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3798 _ckvmssts_noperl(retsts);
3800 #ifdef ARGPROC_DEBUG
3801 PerlIO_printf(Perl_debug_log, "%s\n", command);
3803 sprintf(pidstring, "%08X", pid);
3804 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3805 pidstr.dsc$a_pointer = pidstring;
3806 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3807 lib$set_symbol(&pidsymbol, &pidstr);
3811 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3814 /* OS-specific initialization at image activation (not thread startup) */
3815 /* Older VAXC header files lack these constants */
3816 #ifndef JPI$_RIGHTS_SIZE
3817 # define JPI$_RIGHTS_SIZE 817
3819 #ifndef KGB$M_SUBSYSTEM
3820 # define KGB$M_SUBSYSTEM 0x8
3823 /*{{{void vms_image_init(int *, char ***)*/
3825 vms_image_init(int *argcp, char ***argvp)
3827 char eqv[LNM$C_NAMLENGTH+1] = "";
3828 unsigned int len, tabct = 8, tabidx = 0;
3829 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3830 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3831 unsigned short int dummy, rlen;
3832 struct dsc$descriptor_s **tabvec;
3834 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3835 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3836 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3839 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3841 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3842 if (iprv[i]) { /* Running image installed with privs? */
3843 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3848 /* Rights identifiers might trigger tainting as well. */
3849 if (!will_taint && (rlen || rsz)) {
3850 while (rlen < rsz) {
3851 /* We didn't get all the identifiers on the first pass. Allocate a
3852 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3853 * were needed to hold all identifiers at time of last call; we'll
3854 * allocate that many unsigned long ints), and go back and get 'em.
3855 * If it gave us less than it wanted to despite ample buffer space,
3856 * something's broken. Is your system missing a system identifier?
3858 if (rsz <= jpilist[1].buflen) {
3859 /* Perl_croak accvios when used this early in startup. */
3860 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3861 rsz, (unsigned long) jpilist[1].buflen,
3862 "Check your rights database for corruption.\n");
3865 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3866 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3867 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3868 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3871 mask = jpilist[1].bufadr;
3872 /* Check attribute flags for each identifier (2nd longword); protected
3873 * subsystem identifiers trigger tainting.
3875 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3876 if (mask[i] & KGB$M_SUBSYSTEM) {
3881 if (mask != rlst) Safefree(mask);
3883 /* We need to use this hack to tell Perl it should run with tainting,
3884 * since its tainting flag may be part of the PL_curinterp struct, which
3885 * hasn't been allocated when vms_image_init() is called.
3889 New(1320,newap,*argcp+2,char **);
3890 newap[0] = argvp[0];
3892 Copy(argvp[1],newap[2],*argcp-1,char **);
3893 /* We orphan the old argv, since we don't know where it's come from,
3894 * so we don't know how to free it.
3896 *argcp++; argvp = newap;
3898 else { /* Did user explicitly request tainting? */
3900 char *cp, **av = *argvp;
3901 for (i = 1; i < *argcp; i++) {
3902 if (*av[i] != '-') break;
3903 for (cp = av[i]+1; *cp; cp++) {
3904 if (*cp == 'T') { will_taint = 1; break; }
3905 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3906 strchr("DFIiMmx",*cp)) break;
3908 if (will_taint) break;
3913 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3915 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3916 else if (tabidx >= tabct) {
3918 Renew(tabvec,tabct,struct dsc$descriptor_s *);
3920 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3921 tabvec[tabidx]->dsc$w_length = 0;
3922 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
3923 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
3924 tabvec[tabidx]->dsc$a_pointer = NULL;
3925 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3927 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
3929 getredirection(argcp,argvp);
3930 #if defined(USE_THREADS) && defined(__DECC)
3932 # include <reentrancy.h>
3933 (void) decc$set_reentrancy(C$C_MULTITHREAD);
3942 * Trim Unix-style prefix off filespec, so it looks like what a shell
3943 * glob expansion would return (i.e. from specified prefix on, not
3944 * full path). Note that returned filespec is Unix-style, regardless
3945 * of whether input filespec was VMS-style or Unix-style.
3947 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
3948 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
3949 * vector of options; at present, only bit 0 is used, and if set tells
3950 * trim unixpath to try the current default directory as a prefix when
3951 * presented with a possibly ambiguous ... wildcard.
3953 * Returns !=0 on success, with trimmed filespec replacing contents of
3954 * fspec, and 0 on failure, with contents of fpsec unchanged.
3956 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
3958 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
3960 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3961 *template, *base, *end, *cp1, *cp2;
3962 register int tmplen, reslen = 0, dirs = 0;
3964 if (!wildspec || !fspec) return 0;
3965 if (strpbrk(wildspec,"]>:") != NULL) {
3966 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3967 else template = unixwild;
3969 else template = wildspec;
3970 if (strpbrk(fspec,"]>:") != NULL) {
3971 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3972 else base = unixified;
3973 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
3974 * check to see that final result fits into (isn't longer than) fspec */
3975 reslen = strlen(fspec);
3979 /* No prefix or absolute path on wildcard, so nothing to remove */
3980 if (!*template || *template == '/') {
3981 if (base == fspec) return 1;
3982 tmplen = strlen(unixified);
3983 if (tmplen > reslen) return 0; /* not enough space */
3984 /* Copy unixified resultant, including trailing NUL */
3985 memmove(fspec,unixified,tmplen+1);
3989 for (end = base; *end; end++) ; /* Find end of resultant filespec */
3990 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3991 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3992 for (cp1 = end ;cp1 >= base; cp1--)
3993 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3995 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3999 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4000 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4001 int ells = 1, totells, segdirs, match;
4002 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4003 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4005 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4007 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4008 if (ellipsis == template && opts & 1) {
4009 /* Template begins with an ellipsis. Since we can't tell how many
4010 * directory names at the front of the resultant to keep for an
4011 * arbitrary starting point, we arbitrarily choose the current
4012 * default directory as a starting point. If it's there as a prefix,
4013 * clip it off. If not, fall through and act as if the leading
4014 * ellipsis weren't there (i.e. return shortest possible path that
4015 * could match template).
4017 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4018 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4019 if (_tolower(*cp1) != _tolower(*cp2)) break;
4020 segdirs = dirs - totells; /* Min # of dirs we must have left */
4021 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4022 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4023 memcpy(fspec,cp2+1,end - cp2);
4027 /* First off, back up over constant elements at end of path */
4029 for (front = end ; front >= base; front--)
4030 if (*front == '/' && !dirs--) { front++; break; }
4032 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4033 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4034 if (cp1 != '\0') return 0; /* Path too long. */
4036 *cp2 = '\0'; /* Pick up with memcpy later */
4037 lcfront = lcres + (front - base);
4038 /* Now skip over each ellipsis and try to match the path in front of it. */
4040 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4041 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4042 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4043 if (cp1 < template) break; /* template started with an ellipsis */
4044 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4045 ellipsis = cp1; continue;
4047 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4049 for (segdirs = 0, cp2 = tpl;
4050 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4052 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4053 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4054 if (*cp2 == '/') segdirs++;
4056 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4057 /* Back up at least as many dirs as in template before matching */
4058 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4059 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4060 for (match = 0; cp1 > lcres;) {
4061 resdsc.dsc$a_pointer = cp1;
4062 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4064 if (match == 1) lcfront = cp1;
4066 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4068 if (!match) return 0; /* Can't find prefix ??? */
4069 if (match > 1 && opts & 1) {
4070 /* This ... wildcard could cover more than one set of dirs (i.e.
4071 * a set of similar dir names is repeated). If the template
4072 * contains more than 1 ..., upstream elements could resolve the
4073 * ambiguity, but it's not worth a full backtracking setup here.
4074 * As a quick heuristic, clip off the current default directory
4075 * if it's present to find the trimmed spec, else use the
4076 * shortest string that this ... could cover.
4078 char def[NAM$C_MAXRSS+1], *st;
4080 if (getcwd(def, sizeof def,0) == NULL) return 0;
4081 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4082 if (_tolower(*cp1) != _tolower(*cp2)) break;
4083 segdirs = dirs - totells; /* Min # of dirs we must have left */
4084 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4085 if (*cp1 == '\0' && *cp2 == '/') {
4086 memcpy(fspec,cp2+1,end - cp2);
4089 /* Nope -- stick with lcfront from above and keep going. */
4092 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4097 } /* end of trim_unixpath() */
4102 * VMS readdir() routines.
4103 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4105 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4106 * Minor modifications to original routines.
4109 /* Number of elements in vms_versions array */
4110 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4113 * Open a directory, return a handle for later use.
4115 /*{{{ DIR *opendir(char*name) */
4117 Perl_opendir(pTHX_ char *name)
4120 char dir[NAM$C_MAXRSS+1];
4123 if (do_tovmspath(name,dir,0) == NULL) {
4126 if (flex_stat(dir,&sb) == -1) return NULL;
4127 if (!S_ISDIR(sb.st_mode)) {
4128 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4131 if (!cando_by_name(S_IRUSR,0,dir)) {
4132 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4135 /* Get memory for the handle, and the pattern. */
4137 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4139 /* Fill in the fields; mainly playing with the descriptor. */
4140 (void)sprintf(dd->pattern, "%s*.*",dir);
4143 dd->vms_wantversions = 0;
4144 dd->pat.dsc$a_pointer = dd->pattern;
4145 dd->pat.dsc$w_length = strlen(dd->pattern);
4146 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4147 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4150 } /* end of opendir() */
4154 * Set the flag to indicate we want versions or not.
4156 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4158 vmsreaddirversions(DIR *dd, int flag)
4160 dd->vms_wantversions = flag;
4165 * Free up an opened directory.
4167 /*{{{ void closedir(DIR *dd)*/
4171 (void)lib$find_file_end(&dd->context);
4172 Safefree(dd->pattern);
4173 Safefree((char *)dd);
4178 * Collect all the version numbers for the current file.
4184 struct dsc$descriptor_s pat;
4185 struct dsc$descriptor_s res;
4187 char *p, *text, buff[sizeof dd->entry.d_name];
4189 unsigned long context, tmpsts;
4192 /* Convenient shorthand. */
4195 /* Add the version wildcard, ignoring the "*.*" put on before */
4196 i = strlen(dd->pattern);
4197 New(1308,text,i + e->d_namlen + 3,char);
4198 (void)strcpy(text, dd->pattern);
4199 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4201 /* Set up the pattern descriptor. */
4202 pat.dsc$a_pointer = text;
4203 pat.dsc$w_length = i + e->d_namlen - 1;
4204 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4205 pat.dsc$b_class = DSC$K_CLASS_S;
4207 /* Set up result descriptor. */
4208 res.dsc$a_pointer = buff;
4209 res.dsc$w_length = sizeof buff - 2;
4210 res.dsc$b_dtype = DSC$K_DTYPE_T;
4211 res.dsc$b_class = DSC$K_CLASS_S;
4213 /* Read files, collecting versions. */
4214 for (context = 0, e->vms_verscount = 0;
4215 e->vms_verscount < VERSIZE(e);
4216 e->vms_verscount++) {
4217 tmpsts = lib$find_file(&pat, &res, &context);
4218 if (tmpsts == RMS$_NMF || context == 0) break;
4220 buff[sizeof buff - 1] = '\0';
4221 if ((p = strchr(buff, ';')))
4222 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4224 e->vms_versions[e->vms_verscount] = -1;
4227 _ckvmssts(lib$find_file_end(&context));
4230 } /* end of collectversions() */
4233 * Read the next entry from the directory.
4235 /*{{{ struct dirent *readdir(DIR *dd)*/
4239 struct dsc$descriptor_s res;
4240 char *p, buff[sizeof dd->entry.d_name];
4241 unsigned long int tmpsts;
4243 /* Set up result descriptor, and get next file. */
4244 res.dsc$a_pointer = buff;
4245 res.dsc$w_length = sizeof buff - 2;
4246 res.dsc$b_dtype = DSC$K_DTYPE_T;
4247 res.dsc$b_class = DSC$K_CLASS_S;
4248 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4249 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4250 if (!(tmpsts & 1)) {
4251 set_vaxc_errno(tmpsts);
4254 set_errno(EACCES); break;
4256 set_errno(ENODEV); break;
4258 set_errno(ENOTDIR); break;
4259 case RMS$_FNF: case RMS$_DNF:
4260 set_errno(ENOENT); break;
4267 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4268 buff[sizeof buff - 1] = '\0';
4269 for (p = buff; *p; p++) *p = _tolower(*p);
4270 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4273 /* Skip any directory component and just copy the name. */
4274 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4275 else (void)strcpy(dd->entry.d_name, buff);
4277 /* Clobber the version. */
4278 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4280 dd->entry.d_namlen = strlen(dd->entry.d_name);
4281 dd->entry.vms_verscount = 0;
4282 if (dd->vms_wantversions) collectversions(dd);
4285 } /* end of readdir() */
4289 * Return something that can be used in a seekdir later.
4291 /*{{{ long telldir(DIR *dd)*/
4300 * Return to a spot where we used to be. Brute force.
4302 /*{{{ void seekdir(DIR *dd,long count)*/
4304 seekdir(DIR *dd, long count)
4306 int vms_wantversions;
4309 /* If we haven't done anything yet... */
4313 /* Remember some state, and clear it. */
4314 vms_wantversions = dd->vms_wantversions;
4315 dd->vms_wantversions = 0;
4316 _ckvmssts(lib$find_file_end(&dd->context));
4319 /* The increment is in readdir(). */
4320 for (dd->count = 0; dd->count < count; )
4323 dd->vms_wantversions = vms_wantversions;
4325 } /* end of seekdir() */
4328 /* VMS subprocess management
4330 * my_vfork() - just a vfork(), after setting a flag to record that
4331 * the current script is trying a Unix-style fork/exec.
4333 * vms_do_aexec() and vms_do_exec() are called in response to the
4334 * perl 'exec' function. If this follows a vfork call, then they
4335 * call out the the regular perl routines in doio.c which do an
4336 * execvp (for those who really want to try this under VMS).
4337 * Otherwise, they do exactly what the perl docs say exec should
4338 * do - terminate the current script and invoke a new command
4339 * (See below for notes on command syntax.)
4341 * do_aspawn() and do_spawn() implement the VMS side of the perl
4342 * 'system' function.
4344 * Note on command arguments to perl 'exec' and 'system': When handled
4345 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4346 * are concatenated to form a DCL command string. If the first arg
4347 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4348 * the the command string is handed off to DCL directly. Otherwise,
4349 * the first token of the command is taken as the filespec of an image
4350 * to run. The filespec is expanded using a default type of '.EXE' and
4351 * the process defaults for device, directory, etc., and if found, the resultant
4352 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4353 * the command string as parameters. This is perhaps a bit complicated,
4354 * but I hope it will form a happy medium between what VMS folks expect
4355 * from lib$spawn and what Unix folks expect from exec.
4358 static int vfork_called;
4360 /*{{{int my_vfork()*/
4371 vms_execfree(pTHX) {
4373 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4376 if (VMScmd.dsc$a_pointer) {
4377 Safefree(VMScmd.dsc$a_pointer);
4378 VMScmd.dsc$w_length = 0;
4379 VMScmd.dsc$a_pointer = Nullch;
4384 setup_argstr(SV *really, SV **mark, SV **sp)
4387 char *junk, *tmps = Nullch;
4388 register size_t cmdlen = 0;
4395 tmps = SvPV(really,rlen);
4402 for (idx++; idx <= sp; idx++) {
4404 junk = SvPVx(*idx,rlen);
4405 cmdlen += rlen ? rlen + 1 : 0;
4408 New(401,PL_Cmd,cmdlen+1,char);
4410 if (tmps && *tmps) {
4411 strcpy(PL_Cmd,tmps);
4414 else *PL_Cmd = '\0';
4415 while (++mark <= sp) {
4417 char *s = SvPVx(*mark,n_a);
4419 if (*PL_Cmd) strcat(PL_Cmd," ");
4425 } /* end of setup_argstr() */
4428 static unsigned long int
4429 setup_cmddsc(char *cmd, int check_img)
4431 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4432 $DESCRIPTOR(defdsc,".EXE");
4433 $DESCRIPTOR(defdsc2,".");
4434 $DESCRIPTOR(resdsc,resspec);
4435 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4436 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4437 register char *s, *rest, *cp, *wordbreak;
4442 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4445 while (*s && isspace(*s)) s++;
4447 if (*s == '@' || *s == '$') {
4448 vmsspec[0] = *s; rest = s + 1;
4449 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4451 else { cp = vmsspec; rest = s; }
4452 if (*rest == '.' || *rest == '/') {
4455 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4456 rest++, cp2++) *cp2 = *rest;
4458 if (do_tovmsspec(resspec,cp,0)) {
4461 for (cp2 = vmsspec + strlen(vmsspec);
4462 *rest && cp2 - vmsspec < sizeof vmsspec;
4463 rest++, cp2++) *cp2 = *rest;
4468 /* Intuit whether verb (first word of cmd) is a DCL command:
4469 * - if first nonspace char is '@', it's a DCL indirection
4471 * - if verb contains a filespec separator, it's not a DCL command
4472 * - if it doesn't, caller tells us whether to default to a DCL
4473 * command, or to a local image unless told it's DCL (by leading '$')
4475 if (*s == '@') isdcl = 1;
4477 register char *filespec = strpbrk(s,":<[.;");
4478 rest = wordbreak = strpbrk(s," \"\t/");
4479 if (!wordbreak) wordbreak = s + strlen(s);
4480 if (*s == '$') check_img = 0;
4481 if (filespec && (filespec < wordbreak)) isdcl = 0;
4482 else isdcl = !check_img;
4486 imgdsc.dsc$a_pointer = s;
4487 imgdsc.dsc$w_length = wordbreak - s;
4488 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4490 _ckvmssts(lib$find_file_end(&cxt));
4491 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4492 if (!(retsts & 1) && *s == '$') {
4493 _ckvmssts(lib$find_file_end(&cxt));
4494 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4495 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4497 _ckvmssts(lib$find_file_end(&cxt));
4498 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4502 _ckvmssts(lib$find_file_end(&cxt));
4507 while (*s && !isspace(*s)) s++;
4510 /* check that it's really not DCL with no file extension */
4511 fp = fopen(resspec,"r","ctx=bin,shr=get");
4513 char b[4] = {0,0,0,0};
4514 read(fileno(fp),b,4);
4515 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4518 if (check_img && isdcl) return RMS$_FNF;
4520 if (cando_by_name(S_IXUSR,0,resspec)) {
4521 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4523 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4525 strcpy(VMScmd.dsc$a_pointer,"@");
4527 strcat(VMScmd.dsc$a_pointer,resspec);
4528 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4529 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4532 else retsts = RMS$_PRV;
4535 /* It's either a DCL command or we couldn't find a suitable image */
4536 VMScmd.dsc$w_length = strlen(cmd);
4537 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4538 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4539 if (!(retsts & 1)) {
4540 /* just hand off status values likely to be due to user error */
4541 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4542 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4543 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4544 else { _ckvmssts(retsts); }
4547 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4549 } /* end of setup_cmddsc() */
4552 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4554 vms_do_aexec(SV *really,SV **mark,SV **sp)
4558 if (vfork_called) { /* this follows a vfork - act Unixish */
4560 if (vfork_called < 0) {
4561 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4564 else return do_aexec(really,mark,sp);
4566 /* no vfork - act VMSish */
4567 return vms_do_exec(setup_argstr(really,mark,sp));
4572 } /* end of vms_do_aexec() */
4575 /* {{{bool vms_do_exec(char *cmd) */
4577 vms_do_exec(char *cmd)
4581 if (vfork_called) { /* this follows a vfork - act Unixish */
4583 if (vfork_called < 0) {
4584 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4587 else return do_exec(cmd);
4590 { /* no vfork - act VMSish */
4591 unsigned long int retsts;
4594 TAINT_PROPER("exec");
4595 if ((retsts = setup_cmddsc(cmd,1)) & 1)
4596 retsts = lib$do_command(&VMScmd);
4599 case RMS$_FNF: case RMS$_DNF:
4600 set_errno(ENOENT); break;
4602 set_errno(ENOTDIR); break;
4604 set_errno(ENODEV); break;
4606 set_errno(EACCES); break;
4608 set_errno(EINVAL); break;
4610 set_errno(E2BIG); break;
4611 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4612 _ckvmssts(retsts); /* fall through */
4613 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4616 set_vaxc_errno(retsts);
4617 if (ckWARN(WARN_EXEC)) {
4618 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4619 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4626 } /* end of vms_do_exec() */
4629 unsigned long int do_spawn(char *);
4631 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4633 do_aspawn(void *really,void **mark,void **sp)
4636 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4639 } /* end of do_aspawn() */
4642 /* {{{unsigned long int do_spawn(char *cmd) */
4646 unsigned long int sts, substs, hadcmd = 1;
4650 TAINT_PROPER("spawn");
4651 if (!cmd || !*cmd) {
4653 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4655 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4656 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4661 case RMS$_FNF: case RMS$_DNF:
4662 set_errno(ENOENT); break;
4664 set_errno(ENOTDIR); break;
4666 set_errno(ENODEV); break;
4668 set_errno(EACCES); break;
4670 set_errno(EINVAL); break;
4672 set_errno(E2BIG); break;
4673 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4674 _ckvmssts(sts); /* fall through */
4675 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4678 set_vaxc_errno(sts);
4679 if (ckWARN(WARN_EXEC)) {
4680 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4681 hadcmd ? VMScmd.dsc$w_length : 0,
4682 hadcmd ? VMScmd.dsc$a_pointer : "",
4689 } /* end of do_spawn() */
4693 * A simple fwrite replacement which outputs itmsz*nitm chars without
4694 * introducing record boundaries every itmsz chars.
4696 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4698 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4700 register char *cp, *end;
4702 end = (char *)src + itmsz * nitm;
4704 while ((char *)src <= end) {
4705 for (cp = src; cp <= end; cp++) if (!*cp) break;
4706 if (fputs(src,dest) == EOF) return EOF;
4708 if (fputc('\0',dest) == EOF) return EOF;
4714 } /* end of my_fwrite() */
4717 /*{{{ int my_flush(FILE *fp)*/
4722 if ((res = fflush(fp)) == 0 && fp) {
4723 #ifdef VMS_DO_SOCKETS
4725 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4727 res = fsync(fileno(fp));
4734 * Here are replacements for the following Unix routines in the VMS environment:
4735 * getpwuid Get information for a particular UIC or UID
4736 * getpwnam Get information for a named user
4737 * getpwent Get information for each user in the rights database
4738 * setpwent Reset search to the start of the rights database
4739 * endpwent Finish searching for users in the rights database
4741 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4742 * (defined in pwd.h), which contains the following fields:-
4744 * char *pw_name; Username (in lower case)
4745 * char *pw_passwd; Hashed password
4746 * unsigned int pw_uid; UIC
4747 * unsigned int pw_gid; UIC group number
4748 * char *pw_unixdir; Default device/directory (VMS-style)
4749 * char *pw_gecos; Owner name
4750 * char *pw_dir; Default device/directory (Unix-style)
4751 * char *pw_shell; Default CLI name (eg. DCL)
4753 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4755 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4756 * not the UIC member number (eg. what's returned by getuid()),
4757 * getpwuid() can accept either as input (if uid is specified, the caller's
4758 * UIC group is used), though it won't recognise gid=0.
4760 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4761 * information about other users in your group or in other groups, respectively.
4762 * If the required privilege is not available, then these routines fill only
4763 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4766 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4769 /* sizes of various UAF record fields */
4770 #define UAI$S_USERNAME 12
4771 #define UAI$S_IDENT 31
4772 #define UAI$S_OWNER 31
4773 #define UAI$S_DEFDEV 31
4774 #define UAI$S_DEFDIR 63
4775 #define UAI$S_DEFCLI 31
4778 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4779 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4780 (uic).uic$v_group != UIC$K_WILD_GROUP)
4782 static char __empty[]= "";
4783 static struct passwd __passwd_empty=
4784 {(char *) __empty, (char *) __empty, 0, 0,
4785 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4786 static int contxt= 0;
4787 static struct passwd __pwdcache;
4788 static char __pw_namecache[UAI$S_IDENT+1];
4791 * This routine does most of the work extracting the user information.
4793 static int fillpasswd (const char *name, struct passwd *pwd)
4797 unsigned char length;
4798 char pw_gecos[UAI$S_OWNER+1];
4800 static union uicdef uic;
4802 unsigned char length;
4803 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4806 unsigned char length;
4807 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4810 unsigned char length;
4811 char pw_shell[UAI$S_DEFCLI+1];
4813 static char pw_passwd[UAI$S_PWD+1];
4815 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4816 struct dsc$descriptor_s name_desc;
4817 unsigned long int sts;
4819 static struct itmlst_3 itmlst[]= {
4820 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4821 {sizeof(uic), UAI$_UIC, &uic, &luic},
4822 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
4823 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
4824 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
4825 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
4826 {0, 0, NULL, NULL}};
4828 name_desc.dsc$w_length= strlen(name);
4829 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4830 name_desc.dsc$b_class= DSC$K_CLASS_S;
4831 name_desc.dsc$a_pointer= (char *) name;
4833 /* Note that sys$getuai returns many fields as counted strings. */
4834 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4835 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4836 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4838 else { _ckvmssts(sts); }
4839 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
4841 if ((int) owner.length < lowner) lowner= (int) owner.length;
4842 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4843 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4844 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4845 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4846 owner.pw_gecos[lowner]= '\0';
4847 defdev.pw_dir[ldefdev+ldefdir]= '\0';
4848 defcli.pw_shell[ldefcli]= '\0';
4849 if (valid_uic(uic)) {
4850 pwd->pw_uid= uic.uic$l_uic;
4851 pwd->pw_gid= uic.uic$v_group;
4854 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
4855 pwd->pw_passwd= pw_passwd;
4856 pwd->pw_gecos= owner.pw_gecos;
4857 pwd->pw_dir= defdev.pw_dir;
4858 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
4859 pwd->pw_shell= defcli.pw_shell;
4860 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
4862 ldir= strlen(pwd->pw_unixdir) - 1;
4863 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
4866 strcpy(pwd->pw_unixdir, pwd->pw_dir);
4867 __mystrtolower(pwd->pw_unixdir);
4872 * Get information for a named user.
4874 /*{{{struct passwd *getpwnam(char *name)*/
4875 struct passwd *my_getpwnam(char *name)
4877 struct dsc$descriptor_s name_desc;
4879 unsigned long int status, sts;
4882 __pwdcache = __passwd_empty;
4883 if (!fillpasswd(name, &__pwdcache)) {
4884 /* We still may be able to determine pw_uid and pw_gid */
4885 name_desc.dsc$w_length= strlen(name);
4886 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4887 name_desc.dsc$b_class= DSC$K_CLASS_S;
4888 name_desc.dsc$a_pointer= (char *) name;
4889 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
4890 __pwdcache.pw_uid= uic.uic$l_uic;
4891 __pwdcache.pw_gid= uic.uic$v_group;
4894 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
4895 set_vaxc_errno(sts);
4896 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
4899 else { _ckvmssts(sts); }
4902 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
4903 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
4904 __pwdcache.pw_name= __pw_namecache;
4906 } /* end of my_getpwnam() */
4910 * Get information for a particular UIC or UID.
4911 * Called by my_getpwent with uid=-1 to list all users.
4913 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
4914 struct passwd *my_getpwuid(Uid_t uid)
4916 const $DESCRIPTOR(name_desc,__pw_namecache);
4917 unsigned short lname;
4919 unsigned long int status;
4922 if (uid == (unsigned int) -1) {
4924 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
4925 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
4926 set_vaxc_errno(status);
4927 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4931 else { _ckvmssts(status); }
4932 } while (!valid_uic (uic));
4936 if (!uic.uic$v_group)
4937 uic.uic$v_group= PerlProc_getgid();
4939 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
4940 else status = SS$_IVIDENT;
4941 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
4942 status == RMS$_PRV) {
4943 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4946 else { _ckvmssts(status); }
4948 __pw_namecache[lname]= '\0';
4949 __mystrtolower(__pw_namecache);
4951 __pwdcache = __passwd_empty;
4952 __pwdcache.pw_name = __pw_namecache;
4954 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
4955 The identifier's value is usually the UIC, but it doesn't have to be,
4956 so if we can, we let fillpasswd update this. */
4957 __pwdcache.pw_uid = uic.uic$l_uic;
4958 __pwdcache.pw_gid = uic.uic$v_group;
4960 fillpasswd(__pw_namecache, &__pwdcache);
4963 } /* end of my_getpwuid() */
4967 * Get information for next user.
4969 /*{{{struct passwd *my_getpwent()*/
4970 struct passwd *my_getpwent()
4972 return (my_getpwuid((unsigned int) -1));
4977 * Finish searching rights database for users.
4979 /*{{{void my_endpwent()*/
4984 _ckvmssts(sys$finish_rdb(&contxt));
4990 #ifdef HOMEGROWN_POSIX_SIGNALS
4991 /* Signal handling routines, pulled into the core from POSIX.xs.
4993 * We need these for threads, so they've been rolled into the core,
4994 * rather than left in POSIX.xs.
4996 * (DRS, Oct 23, 1997)
4999 /* sigset_t is atomic under VMS, so these routines are easy */
5000 /*{{{int my_sigemptyset(sigset_t *) */
5001 int my_sigemptyset(sigset_t *set) {
5002 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5008 /*{{{int my_sigfillset(sigset_t *)*/
5009 int my_sigfillset(sigset_t *set) {
5011 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5012 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5018 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5019 int my_sigaddset(sigset_t *set, int sig) {
5020 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5021 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5022 *set |= (1 << (sig - 1));
5028 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5029 int my_sigdelset(sigset_t *set, int sig) {
5030 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5031 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5032 *set &= ~(1 << (sig - 1));
5038 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5039 int my_sigismember(sigset_t *set, int sig) {
5040 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5041 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5042 *set & (1 << (sig - 1));
5047 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5048 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5051 /* If set and oset are both null, then things are badly wrong. Bail out. */
5052 if ((oset == NULL) && (set == NULL)) {
5053 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5057 /* If set's null, then we're just handling a fetch. */
5059 tempmask = sigblock(0);
5064 tempmask = sigsetmask(*set);
5067 tempmask = sigblock(*set);
5070 tempmask = sigblock(0);
5071 sigsetmask(*oset & ~tempmask);
5074 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5079 /* Did they pass us an oset? If so, stick our holding mask into it */
5086 #endif /* HOMEGROWN_POSIX_SIGNALS */
5089 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5090 * my_utime(), and flex_stat(), all of which operate on UTC unless
5091 * VMSISH_TIMES is true.
5093 /* method used to handle UTC conversions:
5094 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5096 static int gmtime_emulation_type;
5097 /* number of secs to add to UTC POSIX-style time to get local time */
5098 static long int utc_offset_secs;
5100 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5101 * in vmsish.h. #undef them here so we can call the CRTL routines
5108 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
5109 # define RTL_USES_UTC 1
5113 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5114 * qualifier with the extern prefix pragma. This provisional
5115 * hack circumvents this prefix pragma problem in previous
5118 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5119 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5120 # pragma __extern_prefix save
5121 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5122 # define gmtime decc$__utctz_gmtime
5123 # define localtime decc$__utctz_localtime
5124 # define time decc$__utc_time
5125 # pragma __extern_prefix restore
5127 struct tm *gmtime(), *localtime();
5133 static time_t toutc_dst(time_t loc) {
5136 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5137 loc -= utc_offset_secs;
5138 if (rsltmp->tm_isdst) loc -= 3600;
5141 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5142 ((gmtime_emulation_type || my_time(NULL)), \
5143 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5144 ((secs) - utc_offset_secs))))
5146 static time_t toloc_dst(time_t utc) {
5149 utc += utc_offset_secs;
5150 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5151 if (rsltmp->tm_isdst) utc += 3600;
5154 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5155 ((gmtime_emulation_type || my_time(NULL)), \
5156 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5157 ((secs) + utc_offset_secs))))
5160 /* my_time(), my_localtime(), my_gmtime()
5161 * By default traffic in UTC time values, using CRTL gmtime() or
5162 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5163 * Note: We need to use these functions even when the CRTL has working
5164 * UTC support, since they also handle C<use vmsish qw(times);>
5166 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5167 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5170 /*{{{time_t my_time(time_t *timep)*/
5171 time_t my_time(time_t *timep)
5177 if (gmtime_emulation_type == 0) {
5179 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5180 /* results of calls to gmtime() and localtime() */
5181 /* for same &base */
5183 gmtime_emulation_type++;
5184 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5185 char off[LNM$C_NAMLENGTH+1];;
5187 gmtime_emulation_type++;
5188 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5189 gmtime_emulation_type++;
5190 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5192 else { utc_offset_secs = atol(off); }
5194 else { /* We've got a working gmtime() */
5195 struct tm gmt, local;
5198 tm_p = localtime(&base);
5200 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5201 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5202 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5203 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5209 # ifdef RTL_USES_UTC
5210 if (VMSISH_TIME) when = _toloc(when);
5212 if (!VMSISH_TIME) when = _toutc(when);
5215 if (timep != NULL) *timep = when;
5218 } /* end of my_time() */
5222 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5224 my_gmtime(const time_t *timep)
5231 if (timep == NULL) {
5232 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5235 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5239 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5241 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5242 return gmtime(&when);
5244 /* CRTL localtime() wants local time as input, so does no tz correction */
5245 rsltmp = localtime(&when);
5246 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5249 } /* end of my_gmtime() */
5253 /*{{{struct tm *my_localtime(const time_t *timep)*/
5255 my_localtime(const time_t *timep)
5261 if (timep == NULL) {
5262 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5265 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5266 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5269 # ifdef RTL_USES_UTC
5271 if (VMSISH_TIME) when = _toutc(when);
5273 /* CRTL localtime() wants UTC as input, does tz correction itself */
5274 return localtime(&when);
5277 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
5280 /* CRTL localtime() wants local time as input, so does no tz correction */
5281 rsltmp = localtime(&when);
5282 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
5285 } /* end of my_localtime() */
5288 /* Reset definitions for later calls */
5289 #define gmtime(t) my_gmtime(t)
5290 #define localtime(t) my_localtime(t)
5291 #define time(t) my_time(t)
5294 /* my_utime - update modification time of a file
5295 * calling sequence is identical to POSIX utime(), but under
5296 * VMS only the modification time is changed; ODS-2 does not
5297 * maintain access times. Restrictions differ from the POSIX
5298 * definition in that the time can be changed as long as the
5299 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5300 * no separate checks are made to insure that the caller is the
5301 * owner of the file or has special privs enabled.
5302 * Code here is based on Joe Meadows' FILE utility.
5305 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5306 * to VMS epoch (01-JAN-1858 00:00:00.00)
5307 * in 100 ns intervals.
5309 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5311 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5312 int my_utime(char *file, struct utimbuf *utimes)
5316 long int bintime[2], len = 2, lowbit, unixtime,
5317 secscale = 10000000; /* seconds --> 100 ns intervals */
5318 unsigned long int chan, iosb[2], retsts;
5319 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5320 struct FAB myfab = cc$rms_fab;
5321 struct NAM mynam = cc$rms_nam;
5322 #if defined (__DECC) && defined (__VAX)
5323 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5324 * at least through VMS V6.1, which causes a type-conversion warning.
5326 # pragma message save
5327 # pragma message disable cvtdiftypes
5329 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5330 struct fibdef myfib;
5331 #if defined (__DECC) && defined (__VAX)
5332 /* This should be right after the declaration of myatr, but due
5333 * to a bug in VAX DEC C, this takes effect a statement early.
5335 # pragma message restore
5337 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5338 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5339 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5341 if (file == NULL || *file == '\0') {
5343 set_vaxc_errno(LIB$_INVARG);
5346 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5348 if (utimes != NULL) {
5349 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5350 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5351 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5352 * as input, we force the sign bit to be clear by shifting unixtime right
5353 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5355 lowbit = (utimes->modtime & 1) ? secscale : 0;
5356 unixtime = (long int) utimes->modtime;
5358 /* If input was UTC; convert to local for sys svc */
5359 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5361 unixtime >>= 1; secscale <<= 1;
5362 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5363 if (!(retsts & 1)) {
5365 set_vaxc_errno(retsts);
5368 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5369 if (!(retsts & 1)) {
5371 set_vaxc_errno(retsts);
5376 /* Just get the current time in VMS format directly */
5377 retsts = sys$gettim(bintime);
5378 if (!(retsts & 1)) {
5380 set_vaxc_errno(retsts);
5385 myfab.fab$l_fna = vmsspec;
5386 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5387 myfab.fab$l_nam = &mynam;
5388 mynam.nam$l_esa = esa;
5389 mynam.nam$b_ess = (unsigned char) sizeof esa;
5390 mynam.nam$l_rsa = rsa;
5391 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5393 /* Look for the file to be affected, letting RMS parse the file
5394 * specification for us as well. I have set errno using only
5395 * values documented in the utime() man page for VMS POSIX.
5397 retsts = sys$parse(&myfab,0,0);
5398 if (!(retsts & 1)) {
5399 set_vaxc_errno(retsts);
5400 if (retsts == RMS$_PRV) set_errno(EACCES);
5401 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5402 else set_errno(EVMSERR);
5405 retsts = sys$search(&myfab,0,0);
5406 if (!(retsts & 1)) {
5407 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5408 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5409 set_vaxc_errno(retsts);
5410 if (retsts == RMS$_PRV) set_errno(EACCES);
5411 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5412 else set_errno(EVMSERR);
5416 devdsc.dsc$w_length = mynam.nam$b_dev;
5417 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5419 retsts = sys$assign(&devdsc,&chan,0,0);
5420 if (!(retsts & 1)) {
5421 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5422 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5423 set_vaxc_errno(retsts);
5424 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5425 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5426 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5427 else set_errno(EVMSERR);
5431 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5432 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5434 memset((void *) &myfib, 0, sizeof myfib);
5436 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5437 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5438 /* This prevents the revision time of the file being reset to the current
5439 * time as a result of our IO$_MODIFY $QIO. */
5440 myfib.fib$l_acctl = FIB$M_NORECORD;
5442 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5443 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5444 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5446 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5447 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5448 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5449 _ckvmssts(sys$dassgn(chan));
5450 if (retsts & 1) retsts = iosb[0];
5451 if (!(retsts & 1)) {
5452 set_vaxc_errno(retsts);
5453 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5454 else set_errno(EVMSERR);
5459 } /* end of my_utime() */
5463 * flex_stat, flex_fstat
5464 * basic stat, but gets it right when asked to stat
5465 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5468 /* encode_dev packs a VMS device name string into an integer to allow
5469 * simple comparisons. This can be used, for example, to check whether two
5470 * files are located on the same device, by comparing their encoded device
5471 * names. Even a string comparison would not do, because stat() reuses the
5472 * device name buffer for each call; so without encode_dev, it would be
5473 * necessary to save the buffer and use strcmp (this would mean a number of
5474 * changes to the standard Perl code, to say nothing of what a Perl script
5477 * The device lock id, if it exists, should be unique (unless perhaps compared
5478 * with lock ids transferred from other nodes). We have a lock id if the disk is
5479 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5480 * device names. Thus we use the lock id in preference, and only if that isn't
5481 * available, do we try to pack the device name into an integer (flagged by
5482 * the sign bit (LOCKID_MASK) being set).
5484 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5485 * name and its encoded form, but it seems very unlikely that we will find
5486 * two files on different disks that share the same encoded device names,
5487 * and even more remote that they will share the same file id (if the test
5488 * is to check for the same file).
5490 * A better method might be to use sys$device_scan on the first call, and to
5491 * search for the device, returning an index into the cached array.
5492 * The number returned would be more intelligable.
5493 * This is probably not worth it, and anyway would take quite a bit longer
5494 * on the first call.
5496 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5497 static mydev_t encode_dev (const char *dev)
5500 unsigned long int f;
5506 if (!dev || !dev[0]) return 0;
5510 struct dsc$descriptor_s dev_desc;
5511 unsigned long int status, lockid, item = DVI$_LOCKID;
5513 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5514 can try that first. */
5515 dev_desc.dsc$w_length = strlen (dev);
5516 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5517 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5518 dev_desc.dsc$a_pointer = (char *) dev;
5519 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5520 if (lockid) return (lockid & ~LOCKID_MASK);
5524 /* Otherwise we try to encode the device name */
5528 for (q = dev + strlen(dev); q--; q >= dev) {
5531 else if (isalpha (toupper (*q)))
5532 c= toupper (*q) - 'A' + (char)10;
5534 continue; /* Skip '$'s */
5536 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5538 enc += f * (unsigned long int) c;
5540 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
5542 } /* end of encode_dev() */
5544 static char namecache[NAM$C_MAXRSS+1];
5547 is_null_device(name)
5551 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5552 The underscore prefix, controller letter, and unit number are
5553 independently optional; for our purposes, the colon punctuation
5554 is not. The colon can be trailed by optional directory and/or
5555 filename, but two consecutive colons indicates a nodename rather
5556 than a device. [pr] */
5557 if (*name == '_') ++name;
5558 if (tolower(*name++) != 'n') return 0;
5559 if (tolower(*name++) != 'l') return 0;
5560 if (tolower(*name) == 'a') ++name;
5561 if (*name == '0') ++name;
5562 return (*name++ == ':') && (*name != ':');
5565 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
5566 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
5567 * subset of the applicable information.
5570 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
5572 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
5574 char fname[NAM$C_MAXRSS+1];
5575 unsigned long int retsts;
5576 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5577 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5579 /* If the struct mystat is stale, we're OOL; stat() overwrites the
5580 device name on successive calls */
5581 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
5582 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
5583 namdsc.dsc$a_pointer = fname;
5584 namdsc.dsc$w_length = sizeof fname - 1;
5586 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
5587 &namdsc,&namdsc.dsc$w_length,0,0);
5589 fname[namdsc.dsc$w_length] = '\0';
5590 return cando_by_name(bit,effective,fname);
5592 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5593 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
5597 return FALSE; /* Should never get to here */
5599 } /* end of cando() */
5603 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
5605 cando_by_name(I32 bit, Uid_t effective, char *fname)
5607 static char usrname[L_cuserid];
5608 static struct dsc$descriptor_s usrdsc =
5609 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
5610 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
5611 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
5612 unsigned short int retlen;
5614 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5615 union prvdef curprv;
5616 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
5617 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
5618 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
5621 if (!fname || !*fname) return FALSE;
5622 /* Make sure we expand logical names, since sys$check_access doesn't */
5623 if (!strpbrk(fname,"/]>:")) {
5624 strcpy(fileified,fname);
5625 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
5628 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
5629 retlen = namdsc.dsc$w_length = strlen(vmsname);
5630 namdsc.dsc$a_pointer = vmsname;
5631 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
5632 vmsname[retlen-1] == ':') {
5633 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
5634 namdsc.dsc$w_length = strlen(fileified);
5635 namdsc.dsc$a_pointer = fileified;
5638 if (!usrdsc.dsc$w_length) {
5640 usrdsc.dsc$w_length = strlen(usrname);
5644 case S_IXUSR: case S_IXGRP: case S_IXOTH:
5645 access = ARM$M_EXECUTE; break;
5646 case S_IRUSR: case S_IRGRP: case S_IROTH:
5647 access = ARM$M_READ; break;
5648 case S_IWUSR: case S_IWGRP: case S_IWOTH:
5649 access = ARM$M_WRITE; break;
5650 case S_IDUSR: case S_IDGRP: case S_IDOTH:
5651 access = ARM$M_DELETE; break;
5656 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
5657 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
5658 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
5659 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
5660 set_vaxc_errno(retsts);
5661 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5662 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
5663 else set_errno(ENOENT);
5666 if (retsts == SS$_NORMAL) {
5667 if (!privused) return TRUE;
5668 /* We can get access, but only by using privs. Do we have the
5669 necessary privs currently enabled? */
5670 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
5671 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
5672 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
5673 !curprv.prv$v_bypass) return FALSE;
5674 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
5675 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
5676 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
5679 if (retsts == SS$_ACCONFLICT) {
5683 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001
5684 /* XXX Hideous kluge to accomodate error in specific version of RTL;
5685 we hope it'll be buried soon */
5686 if (retsts == 114762) return TRUE;
5690 return FALSE; /* Should never get here */
5692 } /* end of cando_by_name() */
5696 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
5698 flex_fstat(int fd, Stat_t *statbufp)
5701 if (!fstat(fd,(stat_t *) statbufp)) {
5702 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
5703 statbufp->st_dev = encode_dev(statbufp->st_devnam);
5704 # ifdef RTL_USES_UTC
5707 statbufp->st_mtime = _toloc(statbufp->st_mtime);
5708 statbufp->st_atime = _toloc(statbufp->st_atime);
5709 statbufp->st_ctime = _toloc(statbufp->st_ctime);
5714 if (!VMSISH_TIME) { /* Return UTC instead of local time */
5718 statbufp->st_mtime = _toutc(statbufp->st_mtime);
5719 statbufp->st_atime = _toutc(statbufp->st_atime);
5720 statbufp->st_ctime = _toutc(statbufp->st_ctime);
5727 } /* end of flex_fstat() */
5730 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
5732 flex_stat(const char *fspec, Stat_t *statbufp)
5735 char fileified[NAM$C_MAXRSS+1];
5736 char temp_fspec[NAM$C_MAXRSS+300];
5739 strcpy(temp_fspec, fspec);
5740 if (statbufp == (Stat_t *) &PL_statcache)
5741 do_tovmsspec(temp_fspec,namecache,0);
5742 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
5743 memset(statbufp,0,sizeof *statbufp);
5744 statbufp->st_dev = encode_dev("_NLA0:");
5745 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
5746 statbufp->st_uid = 0x00010001;
5747 statbufp->st_gid = 0x0001;
5748 time((time_t *)&statbufp->st_mtime);
5749 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
5753 /* Try for a directory name first. If fspec contains a filename without
5754 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
5755 * and sea:[wine.dark]water. exist, we prefer the directory here.
5756 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
5757 * not sea:[wine.dark]., if the latter exists. If the intended target is
5758 * the file with null type, specify this by calling flex_stat() with
5759 * a '.' at the end of fspec.
5761 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
5762 retval = stat(fileified,(stat_t *) statbufp);
5763 if (!retval && statbufp == (Stat_t *) &PL_statcache)
5764 strcpy(namecache,fileified);
5766 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
5768 statbufp->st_dev = encode_dev(statbufp->st_devnam);
5769 # ifdef RTL_USES_UTC
5772 statbufp->st_mtime = _toloc(statbufp->st_mtime);
5773 statbufp->st_atime = _toloc(statbufp->st_atime);
5774 statbufp->st_ctime = _toloc(statbufp->st_ctime);
5779 if (!VMSISH_TIME) { /* Return UTC instead of local time */
5783 statbufp->st_mtime = _toutc(statbufp->st_mtime);
5784 statbufp->st_atime = _toutc(statbufp->st_atime);
5785 statbufp->st_ctime = _toutc(statbufp->st_ctime);
5791 } /* end of flex_stat() */
5795 /*{{{char *my_getlogin()*/
5796 /* VMS cuserid == Unix getlogin, except calling sequence */
5800 static char user[L_cuserid];
5801 return cuserid(user);
5806 /* rmscopy - copy a file using VMS RMS routines
5808 * Copies contents and attributes of spec_in to spec_out, except owner
5809 * and protection information. Name and type of spec_in are used as
5810 * defaults for spec_out. The third parameter specifies whether rmscopy()
5811 * should try to propagate timestamps from the input file to the output file.
5812 * If it is less than 0, no timestamps are preserved. If it is 0, then
5813 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
5814 * propagated to the output file at creation iff the output file specification
5815 * did not contain an explicit name or type, and the revision date is always
5816 * updated at the end of the copy operation. If it is greater than 0, then
5817 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
5818 * other than the revision date should be propagated, and bit 1 indicates
5819 * that the revision date should be propagated.
5821 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
5823 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
5824 * Incorporates, with permission, some code from EZCOPY by Tim Adye
5825 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
5826 * as part of the Perl standard distribution under the terms of the
5827 * GNU General Public License or the Perl Artistic License. Copies
5828 * of each may be found in the Perl standard distribution.
5830 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
5832 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
5834 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
5835 rsa[NAM$C_MAXRSS], ubf[32256];
5836 unsigned long int i, sts, sts2;
5837 struct FAB fab_in, fab_out;
5838 struct RAB rab_in, rab_out;
5840 struct XABDAT xabdat;
5841 struct XABFHC xabfhc;
5842 struct XABRDT xabrdt;
5843 struct XABSUM xabsum;
5845 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
5846 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
5847 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5851 fab_in = cc$rms_fab;
5852 fab_in.fab$l_fna = vmsin;
5853 fab_in.fab$b_fns = strlen(vmsin);
5854 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
5855 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
5856 fab_in.fab$l_fop = FAB$M_SQO;
5857 fab_in.fab$l_nam = &nam;
5858 fab_in.fab$l_xab = (void *) &xabdat;
5861 nam.nam$l_rsa = rsa;
5862 nam.nam$b_rss = sizeof(rsa);
5863 nam.nam$l_esa = esa;
5864 nam.nam$b_ess = sizeof (esa);
5865 nam.nam$b_esl = nam.nam$b_rsl = 0;
5867 xabdat = cc$rms_xabdat; /* To get creation date */
5868 xabdat.xab$l_nxt = (void *) &xabfhc;
5870 xabfhc = cc$rms_xabfhc; /* To get record length */
5871 xabfhc.xab$l_nxt = (void *) &xabsum;
5873 xabsum = cc$rms_xabsum; /* To get key and area information */
5875 if (!((sts = sys$open(&fab_in)) & 1)) {
5876 set_vaxc_errno(sts);
5878 case RMS$_FNF: case RMS$_DNF:
5879 set_errno(ENOENT); break;
5881 set_errno(ENOTDIR); break;
5883 set_errno(ENODEV); break;
5885 set_errno(EINVAL); break;
5887 set_errno(EACCES); break;
5895 fab_out.fab$w_ifi = 0;
5896 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
5897 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
5898 fab_out.fab$l_fop = FAB$M_SQO;
5899 fab_out.fab$l_fna = vmsout;
5900 fab_out.fab$b_fns = strlen(vmsout);
5901 fab_out.fab$l_dna = nam.nam$l_name;
5902 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
5904 if (preserve_dates == 0) { /* Act like DCL COPY */
5905 nam.nam$b_nop = NAM$M_SYNCHK;
5906 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
5907 if (!((sts = sys$parse(&fab_out)) & 1)) {
5908 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
5909 set_vaxc_errno(sts);
5912 fab_out.fab$l_xab = (void *) &xabdat;
5913 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
5915 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
5916 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
5917 preserve_dates =0; /* bitmask from this point forward */
5919 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
5920 if (!((sts = sys$create(&fab_out)) & 1)) {
5921 set_vaxc_errno(sts);
5924 set_errno(ENOENT); break;
5926 set_errno(ENOTDIR); break;
5928 set_errno(ENODEV); break;
5930 set_errno(EINVAL); break;
5932 set_errno(EACCES); break;
5938 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
5939 if (preserve_dates & 2) {
5940 /* sys$close() will process xabrdt, not xabdat */
5941 xabrdt = cc$rms_xabrdt;
5943 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
5945 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
5946 * is unsigned long[2], while DECC & VAXC use a struct */
5947 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
5949 fab_out.fab$l_xab = (void *) &xabrdt;
5952 rab_in = cc$rms_rab;
5953 rab_in.rab$l_fab = &fab_in;
5954 rab_in.rab$l_rop = RAB$M_BIO;
5955 rab_in.rab$l_ubf = ubf;
5956 rab_in.rab$w_usz = sizeof ubf;
5957 if (!((sts = sys$connect(&rab_in)) & 1)) {
5958 sys$close(&fab_in); sys$close(&fab_out);
5959 set_errno(EVMSERR); set_vaxc_errno(sts);
5963 rab_out = cc$rms_rab;
5964 rab_out.rab$l_fab = &fab_out;
5965 rab_out.rab$l_rbf = ubf;
5966 if (!((sts = sys$connect(&rab_out)) & 1)) {
5967 sys$close(&fab_in); sys$close(&fab_out);
5968 set_errno(EVMSERR); set_vaxc_errno(sts);
5972 while ((sts = sys$read(&rab_in))) { /* always true */
5973 if (sts == RMS$_EOF) break;
5974 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
5975 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
5976 sys$close(&fab_in); sys$close(&fab_out);
5977 set_errno(EVMSERR); set_vaxc_errno(sts);
5982 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
5983 sys$close(&fab_in); sys$close(&fab_out);
5984 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5986 set_errno(EVMSERR); set_vaxc_errno(sts);
5992 } /* end of rmscopy() */
5996 /*** The following glue provides 'hooks' to make some of the routines
5997 * from this file available from Perl. These routines are sufficiently
5998 * basic, and are required sufficiently early in the build process,
5999 * that's it's nice to have them available to miniperl as well as the
6000 * full Perl, so they're set up here instead of in an extension. The
6001 * Perl code which handles importation of these names into a given
6002 * package lives in [.VMS]Filespec.pm in @INC.
6006 rmsexpand_fromperl(pTHX_ CV *cv)
6009 char *fspec, *defspec = NULL, *rslt;
6012 if (!items || items > 2)
6013 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6014 fspec = SvPV(ST(0),n_a);
6015 if (!fspec || !*fspec) XSRETURN_UNDEF;
6016 if (items == 2) defspec = SvPV(ST(1),n_a);
6018 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6019 ST(0) = sv_newmortal();
6020 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6025 vmsify_fromperl(pTHX_ CV *cv)
6031 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6032 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6033 ST(0) = sv_newmortal();
6034 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6039 unixify_fromperl(pTHX_ CV *cv)
6045 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6046 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6047 ST(0) = sv_newmortal();
6048 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6053 fileify_fromperl(pTHX_ CV *cv)
6059 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6060 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6061 ST(0) = sv_newmortal();
6062 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6067 pathify_fromperl(pTHX_ CV *cv)
6073 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6074 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6075 ST(0) = sv_newmortal();
6076 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6081 vmspath_fromperl(pTHX_ CV *cv)
6087 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6088 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6089 ST(0) = sv_newmortal();
6090 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6095 unixpath_fromperl(pTHX_ CV *cv)
6101 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6102 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6103 ST(0) = sv_newmortal();
6104 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6109 candelete_fromperl(pTHX_ CV *cv)
6112 char fspec[NAM$C_MAXRSS+1], *fsp;
6117 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6119 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6120 if (SvTYPE(mysv) == SVt_PVGV) {
6121 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6122 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6129 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6130 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6136 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6141 rmscopy_fromperl(pTHX_ CV *cv)
6144 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6146 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6147 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6148 unsigned long int sts;
6153 if (items < 2 || items > 3)
6154 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6156 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6157 if (SvTYPE(mysv) == SVt_PVGV) {
6158 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6159 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6166 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6167 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6172 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6173 if (SvTYPE(mysv) == SVt_PVGV) {
6174 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6175 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6182 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6183 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6188 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6190 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6199 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6200 workbuff[NAM$C_MAXRSS*1 + 1];
6201 int total_namelen = 3, counter, num_entries;
6202 /* ODS-5 ups this, but we want to be consistent, so... */
6203 int max_name_len = 39;
6204 AV *in_array = (AV *)SvRV(ST(0));
6206 num_entries = av_len(in_array);
6208 /* All the names start with PL_. */
6209 strcpy(ultimate_name, "PL_");
6211 /* Clean up our working buffer */
6212 Zero(work_name, sizeof(work_name), char);
6214 /* Run through the entries and build up a working name */
6215 for(counter = 0; counter <= num_entries; counter++) {
6216 /* If it's not the first name then tack on a __ */
6218 strcat(work_name, "__");
6220 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6224 /* Check to see if we actually have to bother...*/
6225 if (strlen(work_name) + 3 <= max_name_len) {
6226 strcat(ultimate_name, work_name);
6228 /* It's too darned big, so we need to go strip. We use the same */
6229 /* algorithm as xsubpp does. First, strip out doubled __ */
6230 char *source, *dest, last;
6233 for (source = work_name; *source; source++) {
6234 if (last == *source && last == '_') {
6240 /* Go put it back */
6241 strcpy(work_name, workbuff);
6242 /* Is it still too big? */
6243 if (strlen(work_name) + 3 > max_name_len) {
6244 /* Strip duplicate letters */
6247 for (source = work_name; *source; source++) {
6248 if (last == toupper(*source)) {
6252 last = toupper(*source);
6254 strcpy(work_name, workbuff);
6257 /* Is it *still* too big? */
6258 if (strlen(work_name) + 3 > max_name_len) {
6259 /* Too bad, we truncate */
6260 work_name[max_name_len - 2] = 0;
6262 strcat(ultimate_name, work_name);
6265 /* Okay, return it */
6266 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6273 char* file = __FILE__;
6275 char temp_buff[512];
6276 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6277 no_translate_barewords = TRUE;
6279 no_translate_barewords = FALSE;
6282 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6283 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6284 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6285 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6286 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6287 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6288 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6289 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6290 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6291 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);