3 * VMS-specific routines for perl5
5 * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
73 unsigned short int buflen;
74 unsigned short int itmcode;
76 unsigned short int *retlen;
79 static char *__mystrtolower(char *str)
81 if (str) for (; *str; ++str) *str= tolower(*str);
85 static struct dsc$descriptor_s fildevdsc =
86 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
87 static struct dsc$descriptor_s crtlenvdsc =
88 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
89 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
90 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
91 static struct dsc$descriptor_s **env_tables = defenv;
92 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
94 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
96 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
97 struct dsc$descriptor_s **tabvec, unsigned long int flags)
99 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
100 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
101 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
102 unsigned char acmode;
103 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
104 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
105 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
106 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
108 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
109 #if defined(USE_THREADS)
110 /* We jump through these hoops because we can be called at */
111 /* platform-specific initialization time, which is before anything is */
112 /* set up--we can't even do a plain dTHR since that relies on the */
113 /* interpreter structure to be initialized */
114 struct perl_thread *thr;
116 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
122 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
123 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
125 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
126 *cp2 = _toupper(*cp1);
127 if (cp1 - lnm > LNM$C_NAMLENGTH) {
128 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
132 lnmdsc.dsc$w_length = cp1 - lnm;
133 lnmdsc.dsc$a_pointer = uplnm;
134 secure = flags & PERL__TRNENV_SECURE;
135 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
136 if (!tabvec || !*tabvec) tabvec = env_tables;
138 for (curtab = 0; tabvec[curtab]; curtab++) {
139 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
140 if (!ivenv && !secure) {
145 warn("Can't read CRTL environ\n");
148 retsts = SS$_NOLOGNAM;
149 for (i = 0; environ[i]; i++) {
150 if ((eq = strchr(environ[i],'=')) &&
151 !strncmp(environ[i],uplnm,eq - environ[i])) {
153 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
154 if (!eqvlen) continue;
159 if (retsts != SS$_NOLOGNAM) break;
162 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
163 !str$case_blind_compare(&tmpdsc,&clisym)) {
164 if (!ivsym && !secure) {
165 unsigned short int deflen = LNM$C_NAMLENGTH;
166 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
167 /* dynamic dsc to accomodate possible long value */
168 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
169 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
172 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
174 /* Special hack--we might be called before the interpreter's */
175 /* fully initialized, in which case either thr or PL_curcop */
176 /* might be bogus. We have to check, since ckWARN needs them */
177 /* both to be valid if running threaded */
178 #if defined(USE_THREADS)
179 if (thr && PL_curcop) {
181 if (ckWARN(WARN_MISC)) {
182 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
184 #if defined(USE_THREADS)
186 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
191 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
193 _ckvmssts(lib$sfree1_dd(&eqvdsc));
194 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
195 if (retsts == LIB$_NOSUCHSYM) continue;
200 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
201 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
202 if (retsts == SS$_NOLOGNAM) continue;
206 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
207 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
208 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
209 retsts == SS$_NOLOGNAM) {
210 set_errno(EINVAL); set_vaxc_errno(retsts);
212 else _ckvmssts(retsts);
214 } /* end of vmstrnenv */
217 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
218 /* Define as a function so we can access statics. */
219 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
221 return vmstrnenv(lnm,eqv,idx,fildev,
222 #ifdef SECURE_INTERNAL_GETENV
223 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
232 * Note: Uses Perl temp to store result so char * can be returned to
233 * caller; this pointer will be invalidated at next Perl statement
235 * We define this as a function rather than a macro in terms of my_getenv_len()
236 * so that it'll work when PL_curinterp is undefined (and we therefore can't
239 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
241 my_getenv(const char *lnm, bool sys)
243 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
244 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
245 unsigned long int idx = 0;
249 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
250 /* Set up a temporary buffer for the return value; Perl will
251 * clean it up at the next statement transition */
252 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
253 if (!tmpsv) return NULL;
256 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
257 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
258 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
259 getcwd(eqv,LNM$C_NAMLENGTH);
263 if ((cp2 = strchr(lnm,';')) != NULL) {
265 uplnm[cp2-lnm] = '\0';
266 idx = strtoul(cp2+1,NULL,0);
269 if (vmstrnenv(lnm,eqv,idx,
271 #ifdef SECURE_INTERNAL_GETENV
272 sys ? PERL__TRNENV_SECURE : 0
280 } /* end of my_getenv() */
284 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
286 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
288 char *buf, *cp1, *cp2;
289 unsigned long idx = 0;
290 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
293 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
294 /* Set up a temporary buffer for the return value; Perl will
295 * clean it up at the next statement transition */
296 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
297 if (!tmpsv) return NULL;
300 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
301 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
302 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
303 getcwd(buf,LNM$C_NAMLENGTH);
308 if ((cp2 = strchr(lnm,';')) != NULL) {
311 idx = strtoul(cp2+1,NULL,0);
314 if ((*len = vmstrnenv(lnm,buf,idx,
316 #ifdef SECURE_INTERNAL_GETENV
317 sys ? PERL__TRNENV_SECURE : 0
327 } /* end of my_getenv_len() */
330 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
332 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
334 /*{{{ void prime_env_iter() */
337 /* Fill the %ENV associative array with all logical names we can
338 * find, in preparation for iterating over it.
342 static int primed = 0;
343 HV *seenhv = NULL, *envhv;
344 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
345 unsigned short int chan;
346 #ifndef CLI$M_TRUSTED
347 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
349 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
350 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
352 bool have_sym = FALSE, have_lnm = FALSE;
353 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
354 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
355 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
356 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
357 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
359 static perl_mutex primenv_mutex;
360 MUTEX_INIT(&primenv_mutex);
363 if (primed || !PL_envgv) return;
364 MUTEX_LOCK(&primenv_mutex);
365 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
366 envhv = GvHVn(PL_envgv);
367 /* Perform a dummy fetch as an lval to insure that the hash table is
368 * set up. Otherwise, the hv_store() will turn into a nullop. */
369 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
371 for (i = 0; env_tables[i]; i++) {
372 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
373 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
374 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
376 if (have_sym || have_lnm) {
377 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
378 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
379 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
380 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
383 for (i--; i >= 0; i--) {
384 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
387 for (j = 0; environ[j]; j++) {
388 if (!(start = strchr(environ[j],'='))) {
389 if (ckWARN(WARN_INTERNAL))
390 warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
394 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
400 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
401 !str$case_blind_compare(&tmpdsc,&clisym)) {
402 strcpy(cmd,"Show Symbol/Global *");
403 cmddsc.dsc$w_length = 20;
404 if (env_tables[i]->dsc$w_length == 12 &&
405 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
406 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
407 flags = defflags | CLI$M_NOLOGNAM;
410 strcpy(cmd,"Show Logical *");
411 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
412 strcat(cmd," /Table=");
413 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
414 cmddsc.dsc$w_length = strlen(cmd);
416 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
417 flags = defflags | CLI$M_NOCLISYM;
420 /* Create a new subprocess to execute each command, to exclude the
421 * remote possibility that someone could subvert a mbx or file used
422 * to write multiple commands to a single subprocess.
425 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
426 0,&riseandshine,0,0,&clidsc,&clitabdsc);
427 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
428 defflags &= ~CLI$M_TRUSTED;
429 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
431 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
432 if (seenhv) SvREFCNT_dec(seenhv);
435 char *cp1, *cp2, *key;
436 unsigned long int sts, iosb[2], retlen, keylen;
439 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
440 if (sts & 1) sts = iosb[0] & 0xffff;
441 if (sts == SS$_ENDOFFILE) {
443 while (substs == 0) { sys$hiber(); wakect++;}
444 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
449 retlen = iosb[0] >> 16;
450 if (!retlen) continue; /* blank line */
452 if (iosb[1] != subpid) {
454 croak("Unknown process %x sent message to prime_env_iter: %s",buf);
458 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
459 warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
461 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
462 if (*cp1 == '(' || /* Logical name table name */
463 *cp1 == '=' /* Next eqv of searchlist */) continue;
464 if (*cp1 == '"') cp1++;
465 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
466 key = cp1; keylen = cp2 - cp1;
467 if (keylen && hv_exists(seenhv,key,keylen)) continue;
468 while (*cp2 && *cp2 != '=') cp2++;
469 while (*cp2 && *cp2 == '=') cp2++;
470 while (*cp2 && *cp2 == ' ') cp2++;
471 if (*cp2 == '"') { /* String translation; may embed "" */
472 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
473 cp2++; cp1--; /* Skip "" surrounding translation */
475 else { /* Numeric translation */
476 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
477 cp1--; /* stop on last non-space char */
479 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
480 warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
483 PERL_HASH(hash,key,keylen);
484 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
485 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
487 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
488 /* get the PPFs for this process, not the subprocess */
489 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
490 char eqv[LNM$C_NAMLENGTH+1];
492 for (i = 0; ppfs[i]; i++) {
493 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
494 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
499 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
500 if (buf) Safefree(buf);
501 if (seenhv) SvREFCNT_dec(seenhv);
502 MUTEX_UNLOCK(&primenv_mutex);
505 } /* end of prime_env_iter */
509 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
510 /* Define or delete an element in the same "environment" as
511 * vmstrnenv(). If an element is to be deleted, it's removed from
512 * the first place it's found. If it's to be set, it's set in the
513 * place designated by the first element of the table vector.
514 * Like setenv() returns 0 for success, non-zero on error.
517 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
519 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
520 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
521 unsigned long int retsts, usermode = PSL$C_USER;
522 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
523 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
524 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
525 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
526 $DESCRIPTOR(local,"_LOCAL");
528 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
529 *cp2 = _toupper(*cp1);
530 if (cp1 - lnm > LNM$C_NAMLENGTH) {
531 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
535 lnmdsc.dsc$w_length = cp1 - lnm;
536 if (!tabvec || !*tabvec) tabvec = env_tables;
538 if (!eqv) { /* we're deleting n element */
539 for (curtab = 0; tabvec[curtab]; curtab++) {
540 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
542 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
543 if ((cp1 = strchr(environ[i],'=')) &&
544 !strncmp(environ[i],lnm,cp1 - environ[i])) {
546 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
549 ivenv = 1; retsts = SS$_NOLOGNAM;
551 if (ckWARN(WARN_INTERNAL))
552 warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
553 ivenv = 1; retsts = SS$_NOSUCHPGM;
559 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
560 !str$case_blind_compare(&tmpdsc,&clisym)) {
561 unsigned int symtype;
562 if (tabvec[curtab]->dsc$w_length == 12 &&
563 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
564 !str$case_blind_compare(&tmpdsc,&local))
565 symtype = LIB$K_CLI_LOCAL_SYM;
566 else symtype = LIB$K_CLI_GLOBAL_SYM;
567 retsts = lib$delete_symbol(&lnmdsc,&symtype);
568 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
569 if (retsts == LIB$_NOSUCHSYM) continue;
573 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
574 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
575 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
576 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
577 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
581 else { /* we're defining a value */
582 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
584 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
586 if (ckWARN(WARN_INTERNAL))
587 warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
588 retsts = SS$_NOSUCHPGM;
592 eqvdsc.dsc$a_pointer = eqv;
593 eqvdsc.dsc$w_length = strlen(eqv);
594 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
595 !str$case_blind_compare(&tmpdsc,&clisym)) {
596 unsigned int symtype;
597 if (tabvec[0]->dsc$w_length == 12 &&
598 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
599 !str$case_blind_compare(&tmpdsc,&local))
600 symtype = LIB$K_CLI_LOCAL_SYM;
601 else symtype = LIB$K_CLI_GLOBAL_SYM;
602 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
605 if (!*eqv) eqvdsc.dsc$w_length = 1;
606 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
612 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
613 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
614 set_errno(EVMSERR); break;
615 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
616 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
617 set_errno(EINVAL); break;
624 set_vaxc_errno(retsts);
625 return (int) retsts || 44; /* retsts should never be 0, but just in case */
628 /* We reset error values on success because Perl does an hv_fetch()
629 * before each hv_store(), and if the thing we're setting didn't
630 * previously exist, we've got a leftover error message. (Of course,
631 * this fails in the face of
632 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
633 * in that the error reported in $! isn't spurious,
634 * but it's right more often than not.)
636 set_errno(0); set_vaxc_errno(retsts);
640 } /* end of vmssetenv() */
643 /*{{{ void my_setenv(char *lnm, char *eqv)*/
644 /* This has to be a function since there's a prototype for it in proto.h */
646 my_setenv(char *lnm,char *eqv)
648 if (lnm && *lnm && strlen(lnm) == 7) {
651 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
652 if (!strcmp(uplnm,"DEFAULT")) {
653 if (eqv && *eqv) chdir(eqv);
657 (void) vmssetenv(lnm,eqv,NULL);
663 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
664 /* my_crypt - VMS password hashing
665 * my_crypt() provides an interface compatible with the Unix crypt()
666 * C library function, and uses sys$hash_password() to perform VMS
667 * password hashing. The quadword hashed password value is returned
668 * as a NUL-terminated 8 character string. my_crypt() does not change
669 * the case of its string arguments; in order to match the behavior
670 * of LOGINOUT et al., alphabetic characters in both arguments must
671 * be upcased by the caller.
674 my_crypt(const char *textpasswd, const char *usrname)
676 # ifndef UAI$C_PREFERRED_ALGORITHM
677 # define UAI$C_PREFERRED_ALGORITHM 127
679 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
680 unsigned short int salt = 0;
681 unsigned long int sts;
683 unsigned short int dsc$w_length;
684 unsigned char dsc$b_type;
685 unsigned char dsc$b_class;
686 const char * dsc$a_pointer;
687 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
688 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
689 struct itmlst_3 uailst[3] = {
690 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
691 { sizeof salt, UAI$_SALT, &salt, 0},
692 { 0, 0, NULL, NULL}};
695 usrdsc.dsc$w_length = strlen(usrname);
696 usrdsc.dsc$a_pointer = usrname;
697 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
704 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
710 if (sts != RMS$_RNF) return NULL;
713 txtdsc.dsc$w_length = strlen(textpasswd);
714 txtdsc.dsc$a_pointer = textpasswd;
715 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
716 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
719 return (char *) hash;
721 } /* end of my_crypt() */
725 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
726 static char *do_fileify_dirspec(char *, char *, int);
727 static char *do_tovmsspec(char *, char *, int);
729 /*{{{int do_rmdir(char *name)*/
733 char dirfile[NAM$C_MAXRSS+1];
737 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
738 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
739 else retval = kill_file(dirfile);
742 } /* end of do_rmdir */
746 * Delete any file to which user has control access, regardless of whether
747 * delete access is explicitly allowed.
748 * Limitations: User must have write access to parent directory.
749 * Does not block signals or ASTs; if interrupted in midstream
750 * may leave file with an altered ACL.
753 /*{{{int kill_file(char *name)*/
755 kill_file(char *name)
757 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
758 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
759 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
760 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
762 unsigned char myace$b_length;
763 unsigned char myace$b_type;
764 unsigned short int myace$w_flags;
765 unsigned long int myace$l_access;
766 unsigned long int myace$l_ident;
767 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
768 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
769 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
771 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
772 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
773 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
774 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
775 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
776 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
778 /* Expand the input spec using RMS, since the CRTL remove() and
779 * system services won't do this by themselves, so we may miss
780 * a file "hiding" behind a logical name or search list. */
781 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
782 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
783 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
784 /* If not, can changing protections help? */
785 if (vaxc$errno != RMS$_PRV) return -1;
787 /* No, so we get our own UIC to use as a rights identifier,
788 * and the insert an ACE at the head of the ACL which allows us
789 * to delete the file.
791 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
792 fildsc.dsc$w_length = strlen(rspec);
793 fildsc.dsc$a_pointer = rspec;
795 newace.myace$l_ident = oldace.myace$l_ident;
796 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
801 case SS$_NOSUCHOBJECT:
802 set_errno(ENOENT); break;
804 set_errno(ENODEV); break;
806 case SS$_INVFILFOROP:
807 set_errno(EINVAL); break;
809 set_errno(EACCES); break;
813 set_vaxc_errno(aclsts);
816 /* Grab any existing ACEs with this identifier in case we fail */
817 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
818 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
819 || fndsts == SS$_NOMOREACE ) {
820 /* Add the new ACE . . . */
821 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
823 if ((rmsts = remove(name))) {
824 /* We blew it - dir with files in it, no write priv for
825 * parent directory, etc. Put things back the way they were. */
826 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
829 addlst[0].bufadr = &oldace;
830 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
837 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
838 /* We just deleted it, so of course it's not there. Some versions of
839 * VMS seem to return success on the unlock operation anyhow (after all
840 * the unlock is successful), but others don't.
842 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
843 if (aclsts & 1) aclsts = fndsts;
846 set_vaxc_errno(aclsts);
852 } /* end of kill_file() */
856 /*{{{int my_mkdir(char *,Mode_t)*/
858 my_mkdir(char *dir, Mode_t mode)
860 STRLEN dirlen = strlen(dir);
862 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
863 * null file name/type. However, it's commonplace under Unix,
864 * so we'll allow it for a gain in portability.
866 if (dir[dirlen-1] == '/') {
867 char *newdir = savepvn(dir,dirlen-1);
868 int ret = mkdir(newdir,mode);
872 else return mkdir(dir,mode);
873 } /* end of my_mkdir */
878 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
880 static unsigned long int mbxbufsiz;
881 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
885 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
886 * preprocessor consant BUFSIZ from stdio.h as the size of the
889 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
890 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
892 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
894 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
895 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
897 } /* end of create_mbx() */
899 /*{{{ my_popen and my_pclose*/
902 struct pipe_details *next;
903 PerlIO *fp; /* stdio file pointer to pipe mailbox */
904 int pid; /* PID of subprocess */
905 int mode; /* == 'r' if pipe open for reading */
906 int done; /* subprocess has completed */
907 unsigned long int completion; /* termination status of subprocess */
910 struct exit_control_block
912 struct exit_control_block *flink;
913 unsigned long int (*exit_routine)();
914 unsigned long int arg_count;
915 unsigned long int *status_address;
916 unsigned long int exit_status;
919 static struct pipe_details *open_pipes = NULL;
920 static $DESCRIPTOR(nl_desc, "NL:");
921 static int waitpid_asleep = 0;
923 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
924 * to a mbx; that's the caller's responsibility.
926 static unsigned long int
927 pipe_eof(FILE *fp, int immediate)
929 char devnam[NAM$C_MAXRSS+1], *cp;
930 unsigned long int chan, iosb[2], retsts, retsts2;
931 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
933 if (fgetname(fp,devnam,1)) {
934 /* It oughta be a mailbox, so fgetname should give just the device
935 * name, but just in case . . . */
936 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
937 devdsc.dsc$w_length = strlen(devnam);
938 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
939 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
940 iosb,0,0,0,0,0,0,0,0);
941 if (retsts & 1) retsts = iosb[0];
942 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
943 if (retsts & 1) retsts = retsts2;
947 else _ckvmssts(vaxc$errno); /* Should never happen */
948 return (unsigned long int) vaxc$errno;
951 static unsigned long int
954 struct pipe_details *info;
955 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
959 first we try sending an EOF...ignore if doesn't work, make sure we
966 if (info->mode != 'r' && !info->done) {
967 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
971 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
976 if (!info->done) { /* Tap them gently on the shoulder . . .*/
977 sts = sys$forcex(&info->pid,0,&abort);
978 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
983 if (did_stuff) sleep(1); /* wait for them to respond */
987 if (!info->done) { /* We tried to be nice . . . */
988 sts = sys$delprc(&info->pid,0);
989 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
990 info->done = 1; /* so my_pclose doesn't try to write EOF */
996 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
997 else if (!(sts & 1)) retsts = sts;
1002 static struct exit_control_block pipe_exitblock =
1003 {(struct exit_control_block *) 0,
1004 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1008 popen_completion_ast(struct pipe_details *thispipe)
1010 thispipe->done = TRUE;
1011 if (waitpid_asleep) {
1018 safe_popen(char *cmd, char *mode)
1020 static int handler_set_up = FALSE;
1022 unsigned short int chan;
1023 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
1024 struct pipe_details *info;
1025 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1026 DSC$K_CLASS_S, mbxname},
1027 cmddsc = {0, DSC$K_DTYPE_T,
1031 cmddsc.dsc$w_length=strlen(cmd);
1032 cmddsc.dsc$a_pointer=cmd;
1033 if (cmddsc.dsc$w_length > 255) {
1034 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
1038 New(1301,info,1,struct pipe_details);
1040 /* create mailbox */
1041 create_mbx(&chan,&namdsc);
1043 /* open a FILE* onto it */
1044 info->fp = PerlIO_open(mbxname, mode);
1046 /* give up other channel onto it */
1047 _ckvmssts(sys$dassgn(chan));
1057 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1058 0 /* name */, &info->pid, &info->completion,
1059 0, popen_completion_ast,info,0,0,0));
1062 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1063 0 /* name */, &info->pid, &info->completion,
1064 0, popen_completion_ast,info,0,0,0));
1067 if (!handler_set_up) {
1068 _ckvmssts(sys$dclexh(&pipe_exitblock));
1069 handler_set_up = TRUE;
1071 info->next=open_pipes; /* prepend to list */
1074 PL_forkprocess = info->pid;
1076 } /* end of safe_popen */
1079 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1081 my_popen(char *cmd, char *mode)
1084 TAINT_PROPER("popen");
1085 PERL_FLUSHALL_FOR_CHILD;
1086 return safe_popen(cmd,mode);
1091 /*{{{ I32 my_pclose(FILE *fp)*/
1092 I32 my_pclose(FILE *fp)
1094 struct pipe_details *info, *last = NULL;
1095 unsigned long int retsts;
1097 for (info = open_pipes; info != NULL; last = info, info = info->next)
1098 if (info->fp == fp) break;
1100 if (info == NULL) { /* no such pipe open */
1101 set_errno(ECHILD); /* quoth POSIX */
1102 set_vaxc_errno(SS$_NONEXPR);
1106 /* If we were writing to a subprocess, insure that someone reading from
1107 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1108 * produce an EOF record in the mailbox. */
1109 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
1110 PerlIO_close(info->fp);
1112 if (info->done) retsts = info->completion;
1113 else waitpid(info->pid,(int *) &retsts,0);
1115 /* remove from list of open pipes */
1116 if (last) last->next = info->next;
1117 else open_pipes = info->next;
1122 } /* end of my_pclose() */
1124 /* sort-of waitpid; use only with popen() */
1125 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1127 my_waitpid(Pid_t pid, int *statusp, int flags)
1129 struct pipe_details *info;
1132 for (info = open_pipes; info != NULL; info = info->next)
1133 if (info->pid == pid) break;
1135 if (info != NULL) { /* we know about this child */
1136 while (!info->done) {
1141 *statusp = info->completion;
1144 else { /* we haven't heard of this child */
1145 $DESCRIPTOR(intdsc,"0 00:00:01");
1146 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1147 unsigned long int interval[2],sts;
1149 if (ckWARN(WARN_EXEC)) {
1150 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1151 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1152 if (ownerpid != mypid)
1153 warner(WARN_EXEC,"pid %x not a child",pid);
1156 _ckvmssts(sys$bintim(&intdsc,interval));
1157 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1158 _ckvmssts(sys$schdwk(0,0,interval,0));
1159 _ckvmssts(sys$hiber());
1163 /* There's no easy way to find the termination status a child we're
1164 * not aware of beforehand. If we're really interested in the future,
1165 * we can go looking for a termination mailbox, or chase after the
1166 * accounting record for the process.
1172 } /* end of waitpid() */
1177 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1179 my_gconvert(double val, int ndig, int trail, char *buf)
1181 static char __gcvtbuf[DBL_DIG+1];
1184 loc = buf ? buf : __gcvtbuf;
1186 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1188 sprintf(loc,"%.*g",ndig,val);
1194 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1195 return gcvt(val,ndig,loc);
1198 loc[0] = '0'; loc[1] = '\0';
1206 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1207 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1208 * to expand file specification. Allows for a single default file
1209 * specification and a simple mask of options. If outbuf is non-NULL,
1210 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1211 * the resultant file specification is placed. If outbuf is NULL, the
1212 * resultant file specification is placed into a static buffer.
1213 * The third argument, if non-NULL, is taken to be a default file
1214 * specification string. The fourth argument is unused at present.
1215 * rmesexpand() returns the address of the resultant string if
1216 * successful, and NULL on error.
1218 static char *do_tounixspec(char *, char *, int);
1221 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1223 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1224 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1225 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1226 struct FAB myfab = cc$rms_fab;
1227 struct NAM mynam = cc$rms_nam;
1229 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1231 if (!filespec || !*filespec) {
1232 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1236 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1237 else outbuf = __rmsexpand_retbuf;
1239 if ((isunix = (strchr(filespec,'/') != NULL))) {
1240 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1241 filespec = vmsfspec;
1244 myfab.fab$l_fna = filespec;
1245 myfab.fab$b_fns = strlen(filespec);
1246 myfab.fab$l_nam = &mynam;
1248 if (defspec && *defspec) {
1249 if (strchr(defspec,'/') != NULL) {
1250 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1253 myfab.fab$l_dna = defspec;
1254 myfab.fab$b_dns = strlen(defspec);
1257 mynam.nam$l_esa = esa;
1258 mynam.nam$b_ess = sizeof esa;
1259 mynam.nam$l_rsa = outbuf;
1260 mynam.nam$b_rss = NAM$C_MAXRSS;
1262 retsts = sys$parse(&myfab,0,0);
1263 if (!(retsts & 1)) {
1264 mynam.nam$b_nop |= NAM$M_SYNCHK;
1265 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1266 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1267 retsts = sys$parse(&myfab,0,0);
1268 if (retsts & 1) goto expanded;
1270 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1271 (void) sys$parse(&myfab,0,0); /* Free search context */
1272 if (out) Safefree(out);
1273 set_vaxc_errno(retsts);
1274 if (retsts == RMS$_PRV) set_errno(EACCES);
1275 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1276 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1277 else set_errno(EVMSERR);
1280 retsts = sys$search(&myfab,0,0);
1281 if (!(retsts & 1) && retsts != RMS$_FNF) {
1282 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1283 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1284 if (out) Safefree(out);
1285 set_vaxc_errno(retsts);
1286 if (retsts == RMS$_PRV) set_errno(EACCES);
1287 else set_errno(EVMSERR);
1291 /* If the input filespec contained any lowercase characters,
1292 * downcase the result for compatibility with Unix-minded code. */
1294 for (out = myfab.fab$l_fna; *out; out++)
1295 if (islower(*out)) { haslower = 1; break; }
1296 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1297 else { out = esa; speclen = mynam.nam$b_esl; }
1298 /* Trim off null fields added by $PARSE
1299 * If type > 1 char, must have been specified in original or default spec
1300 * (not true for version; $SEARCH may have added version of existing file).
1302 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1303 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1304 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1305 if (trimver || trimtype) {
1306 if (defspec && *defspec) {
1307 char defesa[NAM$C_MAXRSS];
1308 struct FAB deffab = cc$rms_fab;
1309 struct NAM defnam = cc$rms_nam;
1311 deffab.fab$l_nam = &defnam;
1312 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1313 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1314 defnam.nam$b_nop = NAM$M_SYNCHK;
1315 if (sys$parse(&deffab,0,0) & 1) {
1316 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1317 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1320 if (trimver) speclen = mynam.nam$l_ver - out;
1322 /* If we didn't already trim version, copy down */
1323 if (speclen > mynam.nam$l_ver - out)
1324 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1325 speclen - (mynam.nam$l_ver - out));
1326 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1329 /* If we just had a directory spec on input, $PARSE "helpfully"
1330 * adds an empty name and type for us */
1331 if (mynam.nam$l_name == mynam.nam$l_type &&
1332 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1333 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1334 speclen = mynam.nam$l_name - out;
1335 out[speclen] = '\0';
1336 if (haslower) __mystrtolower(out);
1338 /* Have we been working with an expanded, but not resultant, spec? */
1339 /* Also, convert back to Unix syntax if necessary. */
1340 if (!mynam.nam$b_rsl) {
1342 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1344 else strcpy(outbuf,esa);
1347 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1348 strcpy(outbuf,tmpfspec);
1350 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1351 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1352 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1356 /* External entry points */
1357 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1358 { return do_rmsexpand(spec,buf,0,def,opt); }
1359 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1360 { return do_rmsexpand(spec,buf,1,def,opt); }
1364 ** The following routines are provided to make life easier when
1365 ** converting among VMS-style and Unix-style directory specifications.
1366 ** All will take input specifications in either VMS or Unix syntax. On
1367 ** failure, all return NULL. If successful, the routines listed below
1368 ** return a pointer to a buffer containing the appropriately
1369 ** reformatted spec (and, therefore, subsequent calls to that routine
1370 ** will clobber the result), while the routines of the same names with
1371 ** a _ts suffix appended will return a pointer to a mallocd string
1372 ** containing the appropriately reformatted spec.
1373 ** In all cases, only explicit syntax is altered; no check is made that
1374 ** the resulting string is valid or that the directory in question
1377 ** fileify_dirspec() - convert a directory spec into the name of the
1378 ** directory file (i.e. what you can stat() to see if it's a dir).
1379 ** The style (VMS or Unix) of the result is the same as the style
1380 ** of the parameter passed in.
1381 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1382 ** what you prepend to a filename to indicate what directory it's in).
1383 ** The style (VMS or Unix) of the result is the same as the style
1384 ** of the parameter passed in.
1385 ** tounixpath() - convert a directory spec into a Unix-style path.
1386 ** tovmspath() - convert a directory spec into a VMS-style path.
1387 ** tounixspec() - convert any file spec into a Unix-style file spec.
1388 ** tovmsspec() - convert any file spec into a VMS-style spec.
1390 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1391 ** Permission is given to distribute this code as part of the Perl
1392 ** standard distribution under the terms of the GNU General Public
1393 ** License or the Perl Artistic License. Copies of each may be
1394 ** found in the Perl standard distribution.
1397 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1398 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1400 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1401 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1402 char *retspec, *cp1, *cp2, *lastdir;
1403 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1405 if (!dir || !*dir) {
1406 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1408 dirlen = strlen(dir);
1409 while (dir[dirlen-1] == '/') --dirlen;
1410 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1411 strcpy(trndir,"/sys$disk/000000");
1415 if (dirlen > NAM$C_MAXRSS) {
1416 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1418 if (!strpbrk(dir+1,"/]>:")) {
1419 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1420 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1422 dirlen = strlen(dir);
1425 strncpy(trndir,dir,dirlen);
1426 trndir[dirlen] = '\0';
1429 /* If we were handed a rooted logical name or spec, treat it like a
1430 * simple directory, so that
1431 * $ Define myroot dev:[dir.]
1432 * ... do_fileify_dirspec("myroot",buf,1) ...
1433 * does something useful.
1435 if (!strcmp(dir+dirlen-2,".]")) {
1436 dir[--dirlen] = '\0';
1437 dir[dirlen-1] = ']';
1440 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1441 /* If we've got an explicit filename, we can just shuffle the string. */
1442 if (*(cp1+1)) hasfilename = 1;
1443 /* Similarly, we can just back up a level if we've got multiple levels
1444 of explicit directories in a VMS spec which ends with directories. */
1446 for (cp2 = cp1; cp2 > dir; cp2--) {
1448 *cp2 = *cp1; *cp1 = '\0';
1452 if (*cp2 == '[' || *cp2 == '<') break;
1457 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1458 if (dir[0] == '.') {
1459 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1460 return do_fileify_dirspec("[]",buf,ts);
1461 else if (dir[1] == '.' &&
1462 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1463 return do_fileify_dirspec("[-]",buf,ts);
1465 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1466 dirlen -= 1; /* to last element */
1467 lastdir = strrchr(dir,'/');
1469 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1470 /* If we have "/." or "/..", VMSify it and let the VMS code
1471 * below expand it, rather than repeating the code to handle
1472 * relative components of a filespec here */
1474 if (*(cp1+2) == '.') cp1++;
1475 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1476 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1477 if (strchr(vmsdir,'/') != NULL) {
1478 /* If do_tovmsspec() returned it, it must have VMS syntax
1479 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1480 * the time to check this here only so we avoid a recursion
1481 * loop; otherwise, gigo.
1483 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1485 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1486 return do_tounixspec(trndir,buf,ts);
1489 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1490 lastdir = strrchr(dir,'/');
1492 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1493 /* Ditto for specs that end in an MFD -- let the VMS code
1494 * figure out whether it's a real device or a rooted logical. */
1495 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1496 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1497 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1498 return do_tounixspec(trndir,buf,ts);
1501 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1502 !(lastdir = cp1 = strrchr(dir,']')) &&
1503 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1504 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1506 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1507 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1508 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1509 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1510 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1511 (ver || *cp3)))))) {
1513 set_vaxc_errno(RMS$_DIR);
1519 /* If we lead off with a device or rooted logical, add the MFD
1520 if we're specifying a top-level directory. */
1521 if (lastdir && *dir == '/') {
1523 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1530 retlen = dirlen + (addmfd ? 13 : 6);
1531 if (buf) retspec = buf;
1532 else if (ts) New(1309,retspec,retlen+1,char);
1533 else retspec = __fileify_retbuf;
1535 dirlen = lastdir - dir;
1536 memcpy(retspec,dir,dirlen);
1537 strcpy(&retspec[dirlen],"/000000");
1538 strcpy(&retspec[dirlen+7],lastdir);
1541 memcpy(retspec,dir,dirlen);
1542 retspec[dirlen] = '\0';
1544 /* We've picked up everything up to the directory file name.
1545 Now just add the type and version, and we're set. */
1546 strcat(retspec,".dir;1");
1549 else { /* VMS-style directory spec */
1550 char esa[NAM$C_MAXRSS+1], term, *cp;
1551 unsigned long int sts, cmplen, haslower = 0;
1552 struct FAB dirfab = cc$rms_fab;
1553 struct NAM savnam, dirnam = cc$rms_nam;
1555 dirfab.fab$b_fns = strlen(dir);
1556 dirfab.fab$l_fna = dir;
1557 dirfab.fab$l_nam = &dirnam;
1558 dirfab.fab$l_dna = ".DIR;1";
1559 dirfab.fab$b_dns = 6;
1560 dirnam.nam$b_ess = NAM$C_MAXRSS;
1561 dirnam.nam$l_esa = esa;
1563 for (cp = dir; *cp; cp++)
1564 if (islower(*cp)) { haslower = 1; break; }
1565 if (!((sts = sys$parse(&dirfab))&1)) {
1566 if (dirfab.fab$l_sts == RMS$_DIR) {
1567 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1568 sts = sys$parse(&dirfab) & 1;
1572 set_vaxc_errno(dirfab.fab$l_sts);
1578 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1579 /* Yes; fake the fnb bits so we'll check type below */
1580 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1583 if (dirfab.fab$l_sts != RMS$_FNF) {
1585 set_vaxc_errno(dirfab.fab$l_sts);
1588 dirnam = savnam; /* No; just work with potential name */
1591 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1592 cp1 = strchr(esa,']');
1593 if (!cp1) cp1 = strchr(esa,'>');
1594 if (cp1) { /* Should always be true */
1595 dirnam.nam$b_esl -= cp1 - esa - 1;
1596 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1599 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1600 /* Yep; check version while we're at it, if it's there. */
1601 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1602 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1603 /* Something other than .DIR[;1]. Bzzt. */
1605 set_vaxc_errno(RMS$_DIR);
1609 esa[dirnam.nam$b_esl] = '\0';
1610 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1611 /* They provided at least the name; we added the type, if necessary, */
1612 if (buf) retspec = buf; /* in sys$parse() */
1613 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1614 else retspec = __fileify_retbuf;
1615 strcpy(retspec,esa);
1618 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1619 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1621 dirnam.nam$b_esl -= 9;
1623 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1624 if (cp1 == NULL) return NULL; /* should never happen */
1627 retlen = strlen(esa);
1628 if ((cp1 = strrchr(esa,'.')) != NULL) {
1629 /* There's more than one directory in the path. Just roll back. */
1631 if (buf) retspec = buf;
1632 else if (ts) New(1311,retspec,retlen+7,char);
1633 else retspec = __fileify_retbuf;
1634 strcpy(retspec,esa);
1637 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1638 /* Go back and expand rooted logical name */
1639 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1640 if (!(sys$parse(&dirfab) & 1)) {
1642 set_vaxc_errno(dirfab.fab$l_sts);
1645 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1646 if (buf) retspec = buf;
1647 else if (ts) New(1312,retspec,retlen+16,char);
1648 else retspec = __fileify_retbuf;
1649 cp1 = strstr(esa,"][");
1651 memcpy(retspec,esa,dirlen);
1652 if (!strncmp(cp1+2,"000000]",7)) {
1653 retspec[dirlen-1] = '\0';
1654 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1655 if (*cp1 == '.') *cp1 = ']';
1657 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1658 memcpy(cp1+1,"000000]",7);
1662 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1663 retspec[retlen] = '\0';
1664 /* Convert last '.' to ']' */
1665 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1666 if (*cp1 == '.') *cp1 = ']';
1668 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1669 memcpy(cp1+1,"000000]",7);
1673 else { /* This is a top-level dir. Add the MFD to the path. */
1674 if (buf) retspec = buf;
1675 else if (ts) New(1312,retspec,retlen+16,char);
1676 else retspec = __fileify_retbuf;
1679 while (*cp1 != ':') *(cp2++) = *(cp1++);
1680 strcpy(cp2,":[000000]");
1685 /* We've set up the string up through the filename. Add the
1686 type and version, and we're done. */
1687 strcat(retspec,".DIR;1");
1689 /* $PARSE may have upcased filespec, so convert output to lower
1690 * case if input contained any lowercase characters. */
1691 if (haslower) __mystrtolower(retspec);
1694 } /* end of do_fileify_dirspec() */
1696 /* External entry points */
1697 char *fileify_dirspec(char *dir, char *buf)
1698 { return do_fileify_dirspec(dir,buf,0); }
1699 char *fileify_dirspec_ts(char *dir, char *buf)
1700 { return do_fileify_dirspec(dir,buf,1); }
1702 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1703 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1705 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1706 unsigned long int retlen;
1707 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1709 if (!dir || !*dir) {
1710 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1713 if (*dir) strcpy(trndir,dir);
1714 else getcwd(trndir,sizeof trndir - 1);
1716 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1717 STRLEN trnlen = strlen(trndir);
1719 /* Trap simple rooted lnms, and return lnm:[000000] */
1720 if (!strcmp(trndir+trnlen-2,".]")) {
1721 if (buf) retpath = buf;
1722 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1723 else retpath = __pathify_retbuf;
1724 strcpy(retpath,dir);
1725 strcat(retpath,":[000000]");
1731 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1732 if (*dir == '.' && (*(dir+1) == '\0' ||
1733 (*(dir+1) == '.' && *(dir+2) == '\0')))
1734 retlen = 2 + (*(dir+1) != '\0');
1736 if ( !(cp1 = strrchr(dir,'/')) &&
1737 !(cp1 = strrchr(dir,']')) &&
1738 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1739 if ((cp2 = strchr(cp1,'.')) != NULL &&
1740 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1741 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1742 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1743 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1745 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1746 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1747 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1748 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1749 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1750 (ver || *cp3)))))) {
1752 set_vaxc_errno(RMS$_DIR);
1755 retlen = cp2 - dir + 1;
1757 else { /* No file type present. Treat the filename as a directory. */
1758 retlen = strlen(dir) + 1;
1761 if (buf) retpath = buf;
1762 else if (ts) New(1313,retpath,retlen+1,char);
1763 else retpath = __pathify_retbuf;
1764 strncpy(retpath,dir,retlen-1);
1765 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1766 retpath[retlen-1] = '/'; /* with '/', add it. */
1767 retpath[retlen] = '\0';
1769 else retpath[retlen-1] = '\0';
1771 else { /* VMS-style directory spec */
1772 char esa[NAM$C_MAXRSS+1], *cp;
1773 unsigned long int sts, cmplen, haslower;
1774 struct FAB dirfab = cc$rms_fab;
1775 struct NAM savnam, dirnam = cc$rms_nam;
1777 /* If we've got an explicit filename, we can just shuffle the string. */
1778 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1779 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1780 if ((cp2 = strchr(cp1,'.')) != NULL) {
1782 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1783 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1784 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1785 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1786 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1787 (ver || *cp3)))))) {
1789 set_vaxc_errno(RMS$_DIR);
1793 else { /* No file type, so just draw name into directory part */
1794 for (cp2 = cp1; *cp2; cp2++) ;
1797 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1799 /* We've now got a VMS 'path'; fall through */
1801 dirfab.fab$b_fns = strlen(dir);
1802 dirfab.fab$l_fna = dir;
1803 if (dir[dirfab.fab$b_fns-1] == ']' ||
1804 dir[dirfab.fab$b_fns-1] == '>' ||
1805 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1806 if (buf) retpath = buf;
1807 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1808 else retpath = __pathify_retbuf;
1809 strcpy(retpath,dir);
1812 dirfab.fab$l_dna = ".DIR;1";
1813 dirfab.fab$b_dns = 6;
1814 dirfab.fab$l_nam = &dirnam;
1815 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1816 dirnam.nam$l_esa = esa;
1818 for (cp = dir; *cp; cp++)
1819 if (islower(*cp)) { haslower = 1; break; }
1821 if (!(sts = (sys$parse(&dirfab)&1))) {
1822 if (dirfab.fab$l_sts == RMS$_DIR) {
1823 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1824 sts = sys$parse(&dirfab) & 1;
1828 set_vaxc_errno(dirfab.fab$l_sts);
1834 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1835 if (dirfab.fab$l_sts != RMS$_FNF) {
1837 set_vaxc_errno(dirfab.fab$l_sts);
1840 dirnam = savnam; /* No; just work with potential name */
1843 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1844 /* Yep; check version while we're at it, if it's there. */
1845 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1846 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1847 /* Something other than .DIR[;1]. Bzzt. */
1849 set_vaxc_errno(RMS$_DIR);
1853 /* OK, the type was fine. Now pull any file name into the
1855 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1857 cp1 = strrchr(esa,'>');
1858 *dirnam.nam$l_type = '>';
1861 *(dirnam.nam$l_type + 1) = '\0';
1862 retlen = dirnam.nam$l_type - esa + 2;
1863 if (buf) retpath = buf;
1864 else if (ts) New(1314,retpath,retlen,char);
1865 else retpath = __pathify_retbuf;
1866 strcpy(retpath,esa);
1867 /* $PARSE may have upcased filespec, so convert output to lower
1868 * case if input contained any lowercase characters. */
1869 if (haslower) __mystrtolower(retpath);
1873 } /* end of do_pathify_dirspec() */
1875 /* External entry points */
1876 char *pathify_dirspec(char *dir, char *buf)
1877 { return do_pathify_dirspec(dir,buf,0); }
1878 char *pathify_dirspec_ts(char *dir, char *buf)
1879 { return do_pathify_dirspec(dir,buf,1); }
1881 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1882 static char *do_tounixspec(char *spec, char *buf, int ts)
1884 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1885 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1886 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1888 if (spec == NULL) return NULL;
1889 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1890 if (buf) rslt = buf;
1892 retlen = strlen(spec);
1893 cp1 = strchr(spec,'[');
1894 if (!cp1) cp1 = strchr(spec,'<');
1896 for (cp1++; *cp1; cp1++) {
1897 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1898 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1899 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1902 New(1315,rslt,retlen+2+2*expand,char);
1904 else rslt = __tounixspec_retbuf;
1905 if (strchr(spec,'/') != NULL) {
1912 dirend = strrchr(spec,']');
1913 if (dirend == NULL) dirend = strrchr(spec,'>');
1914 if (dirend == NULL) dirend = strchr(spec,':');
1915 if (dirend == NULL) {
1919 if (*cp2 != '[' && *cp2 != '<') {
1922 else { /* the VMS spec begins with directories */
1924 if (*cp2 == ']' || *cp2 == '>') {
1925 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1928 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1929 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1930 if (ts) Safefree(rslt);
1935 while (*cp3 != ':' && *cp3) cp3++;
1937 if (strchr(cp3,']') != NULL) break;
1938 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1940 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1941 retlen = devlen + dirlen;
1942 Renew(rslt,retlen+1+2*expand,char);
1948 *(cp1++) = *(cp3++);
1949 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1953 else if ( *cp2 == '.') {
1954 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1955 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1961 for (; cp2 <= dirend; cp2++) {
1964 if (*(cp2+1) == '[') cp2++;
1966 else if (*cp2 == ']' || *cp2 == '>') {
1967 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1969 else if (*cp2 == '.') {
1971 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1972 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1973 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1974 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1975 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1977 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1978 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1982 else if (*cp2 == '-') {
1983 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1984 while (*cp2 == '-') {
1986 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1988 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1989 if (ts) Safefree(rslt); /* filespecs like */
1990 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1994 else *(cp1++) = *cp2;
1996 else *(cp1++) = *cp2;
1998 while (*cp2) *(cp1++) = *(cp2++);
2003 } /* end of do_tounixspec() */
2005 /* External entry points */
2006 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2007 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2009 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2010 static char *do_tovmsspec(char *path, char *buf, int ts) {
2011 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2012 char *rslt, *dirend;
2013 register char *cp1, *cp2;
2014 unsigned long int infront = 0, hasdir = 1;
2016 if (path == NULL) return NULL;
2017 if (buf) rslt = buf;
2018 else if (ts) New(1316,rslt,strlen(path)+9,char);
2019 else rslt = __tovmsspec_retbuf;
2020 if (strpbrk(path,"]:>") ||
2021 (dirend = strrchr(path,'/')) == NULL) {
2022 if (path[0] == '.') {
2023 if (path[1] == '\0') strcpy(rslt,"[]");
2024 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2025 else strcpy(rslt,path); /* probably garbage */
2027 else strcpy(rslt,path);
2030 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2031 if (!*(dirend+2)) dirend +=2;
2032 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2033 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2038 char trndev[NAM$C_MAXRSS+1];
2042 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2044 if (!buf & ts) Renew(rslt,18,char);
2045 strcpy(rslt,"sys$disk:[000000]");
2048 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2050 islnm = my_trnlnm(rslt,trndev,0);
2051 trnend = islnm ? strlen(trndev) - 1 : 0;
2052 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2053 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2054 /* If the first element of the path is a logical name, determine
2055 * whether it has to be translated so we can add more directories. */
2056 if (!islnm || rooted) {
2059 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2063 if (cp2 != dirend) {
2064 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2065 strcpy(rslt,trndev);
2066 cp1 = rslt + trnend;
2079 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2080 cp2 += 2; /* skip over "./" - it's redundant */
2081 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2083 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2084 *(cp1++) = '-'; /* "../" --> "-" */
2087 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2088 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2089 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2090 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2093 if (cp2 > dirend) cp2 = dirend;
2095 else *(cp1++) = '.';
2097 for (; cp2 < dirend; cp2++) {
2099 if (*(cp2-1) == '/') continue;
2100 if (*(cp1-1) != '.') *(cp1++) = '.';
2103 else if (!infront && *cp2 == '.') {
2104 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2105 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2106 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2107 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2108 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2109 else { /* back up over previous directory name */
2111 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2112 if (*(cp1-1) == '[') {
2113 memcpy(cp1,"000000.",7);
2118 if (cp2 == dirend) break;
2120 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2121 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2122 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2123 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2125 *(cp1++) = '.'; /* Simulate trailing '/' */
2126 cp2 += 2; /* for loop will incr this to == dirend */
2128 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2130 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2133 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2134 if (*cp2 == '.') *(cp1++) = '_';
2135 else *(cp1++) = *cp2;
2139 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2140 if (hasdir) *(cp1++) = ']';
2141 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2142 while (*cp2) *(cp1++) = *(cp2++);
2147 } /* end of do_tovmsspec() */
2149 /* External entry points */
2150 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2151 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2153 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2154 static char *do_tovmspath(char *path, char *buf, int ts) {
2155 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2157 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2159 if (path == NULL) return NULL;
2160 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2161 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2162 if (buf) return buf;
2164 vmslen = strlen(vmsified);
2165 New(1317,cp,vmslen+1,char);
2166 memcpy(cp,vmsified,vmslen);
2171 strcpy(__tovmspath_retbuf,vmsified);
2172 return __tovmspath_retbuf;
2175 } /* end of do_tovmspath() */
2177 /* External entry points */
2178 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2179 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2182 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2183 static char *do_tounixpath(char *path, char *buf, int ts) {
2184 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2186 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2188 if (path == NULL) return NULL;
2189 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2190 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2191 if (buf) return buf;
2193 unixlen = strlen(unixified);
2194 New(1317,cp,unixlen+1,char);
2195 memcpy(cp,unixified,unixlen);
2200 strcpy(__tounixpath_retbuf,unixified);
2201 return __tounixpath_retbuf;
2204 } /* end of do_tounixpath() */
2206 /* External entry points */
2207 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2208 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2211 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2213 *****************************************************************************
2215 * Copyright (C) 1989-1994 by *
2216 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2218 * Permission is hereby granted for the reproduction of this software, *
2219 * on condition that this copyright notice is included in the reproduction, *
2220 * and that such reproduction is not for purposes of profit or material *
2223 * 27-Aug-1994 Modified for inclusion in perl5 *
2224 * by Charles Bailey bailey@newman.upenn.edu *
2225 *****************************************************************************
2229 * getredirection() is intended to aid in porting C programs
2230 * to VMS (Vax-11 C). The native VMS environment does not support
2231 * '>' and '<' I/O redirection, or command line wild card expansion,
2232 * or a command line pipe mechanism using the '|' AND background
2233 * command execution '&'. All of these capabilities are provided to any
2234 * C program which calls this procedure as the first thing in the
2236 * The piping mechanism will probably work with almost any 'filter' type
2237 * of program. With suitable modification, it may useful for other
2238 * portability problems as well.
2240 * Author: Mark Pizzolato mark@infocomm.com
2244 struct list_item *next;
2248 static void add_item(struct list_item **head,
2249 struct list_item **tail,
2253 static void expand_wild_cards(char *item,
2254 struct list_item **head,
2255 struct list_item **tail,
2258 static int background_process(int argc, char **argv);
2260 static void pipe_and_fork(char **cmargv);
2262 /*{{{ void getredirection(int *ac, char ***av)*/
2264 getredirection(int *ac, char ***av)
2266 * Process vms redirection arg's. Exit if any error is seen.
2267 * If getredirection() processes an argument, it is erased
2268 * from the vector. getredirection() returns a new argc and argv value.
2269 * In the event that a background command is requested (by a trailing "&"),
2270 * this routine creates a background subprocess, and simply exits the program.
2272 * Warning: do not try to simplify the code for vms. The code
2273 * presupposes that getredirection() is called before any data is
2274 * read from stdin or written to stdout.
2276 * Normal usage is as follows:
2282 * getredirection(&argc, &argv);
2286 int argc = *ac; /* Argument Count */
2287 char **argv = *av; /* Argument Vector */
2288 char *ap; /* Argument pointer */
2289 int j; /* argv[] index */
2290 int item_count = 0; /* Count of Items in List */
2291 struct list_item *list_head = 0; /* First Item in List */
2292 struct list_item *list_tail; /* Last Item in List */
2293 char *in = NULL; /* Input File Name */
2294 char *out = NULL; /* Output File Name */
2295 char *outmode = "w"; /* Mode to Open Output File */
2296 char *err = NULL; /* Error File Name */
2297 char *errmode = "w"; /* Mode to Open Error File */
2298 int cmargc = 0; /* Piped Command Arg Count */
2299 char **cmargv = NULL;/* Piped Command Arg Vector */
2302 * First handle the case where the last thing on the line ends with
2303 * a '&'. This indicates the desire for the command to be run in a
2304 * subprocess, so we satisfy that desire.
2307 if (0 == strcmp("&", ap))
2308 exit(background_process(--argc, argv));
2309 if (*ap && '&' == ap[strlen(ap)-1])
2311 ap[strlen(ap)-1] = '\0';
2312 exit(background_process(argc, argv));
2315 * Now we handle the general redirection cases that involve '>', '>>',
2316 * '<', and pipes '|'.
2318 for (j = 0; j < argc; ++j)
2320 if (0 == strcmp("<", argv[j]))
2324 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2325 exit(LIB$_WRONUMARG);
2330 if ('<' == *(ap = argv[j]))
2335 if (0 == strcmp(">", ap))
2339 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2340 exit(LIB$_WRONUMARG);
2359 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2360 exit(LIB$_WRONUMARG);
2364 if (('2' == *ap) && ('>' == ap[1]))
2381 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2382 exit(LIB$_WRONUMARG);
2386 if (0 == strcmp("|", argv[j]))
2390 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2391 exit(LIB$_WRONUMARG);
2393 cmargc = argc-(j+1);
2394 cmargv = &argv[j+1];
2398 if ('|' == *(ap = argv[j]))
2406 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2409 * Allocate and fill in the new argument vector, Some Unix's terminate
2410 * the list with an extra null pointer.
2412 New(1302, argv, item_count+1, char *);
2414 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2415 argv[j] = list_head->value;
2421 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2422 exit(LIB$_INVARGORD);
2424 pipe_and_fork(cmargv);
2427 /* Check for input from a pipe (mailbox) */
2429 if (in == NULL && 1 == isapipe(0))
2431 char mbxname[L_tmpnam];
2433 long int dvi_item = DVI$_DEVBUFSIZ;
2434 $DESCRIPTOR(mbxnam, "");
2435 $DESCRIPTOR(mbxdevnam, "");
2437 /* Input from a pipe, reopen it in binary mode to disable */
2438 /* carriage control processing. */
2440 PerlIO_getname(stdin, mbxname);
2441 mbxnam.dsc$a_pointer = mbxname;
2442 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2443 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2444 mbxdevnam.dsc$a_pointer = mbxname;
2445 mbxdevnam.dsc$w_length = sizeof(mbxname);
2446 dvi_item = DVI$_DEVNAM;
2447 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2448 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2451 freopen(mbxname, "rb", stdin);
2454 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2458 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2460 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2463 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2465 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2470 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2472 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2476 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2481 #ifdef ARGPROC_DEBUG
2482 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2483 for (j = 0; j < *ac; ++j)
2484 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2486 /* Clear errors we may have hit expanding wildcards, so they don't
2487 show up in Perl's $! later */
2488 set_errno(0); set_vaxc_errno(1);
2489 } /* end of getredirection() */
2492 static void add_item(struct list_item **head,
2493 struct list_item **tail,
2499 New(1303,*head,1,struct list_item);
2503 New(1304,(*tail)->next,1,struct list_item);
2504 *tail = (*tail)->next;
2506 (*tail)->value = value;
2510 static void expand_wild_cards(char *item,
2511 struct list_item **head,
2512 struct list_item **tail,
2516 unsigned long int context = 0;
2522 char vmsspec[NAM$C_MAXRSS+1];
2523 $DESCRIPTOR(filespec, "");
2524 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2525 $DESCRIPTOR(resultspec, "");
2526 unsigned long int zero = 0, sts;
2528 for (cp = item; *cp; cp++) {
2529 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2530 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2532 if (!*cp || isspace(*cp))
2534 add_item(head, tail, item, count);
2537 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2538 resultspec.dsc$b_class = DSC$K_CLASS_D;
2539 resultspec.dsc$a_pointer = NULL;
2540 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2541 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2542 if (!isunix || !filespec.dsc$a_pointer)
2543 filespec.dsc$a_pointer = item;
2544 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2546 * Only return version specs, if the caller specified a version
2548 had_version = strchr(item, ';');
2550 * Only return device and directory specs, if the caller specifed either.
2552 had_device = strchr(item, ':');
2553 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2555 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2556 &defaultspec, 0, 0, &zero))))
2561 New(1305,string,resultspec.dsc$w_length+1,char);
2562 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2563 string[resultspec.dsc$w_length] = '\0';
2564 if (NULL == had_version)
2565 *((char *)strrchr(string, ';')) = '\0';
2566 if ((!had_directory) && (had_device == NULL))
2568 if (NULL == (devdir = strrchr(string, ']')))
2569 devdir = strrchr(string, '>');
2570 strcpy(string, devdir + 1);
2573 * Be consistent with what the C RTL has already done to the rest of
2574 * the argv items and lowercase all of these names.
2576 for (c = string; *c; ++c)
2579 if (isunix) trim_unixpath(string,item,1);
2580 add_item(head, tail, string, count);
2583 if (sts != RMS$_NMF)
2585 set_vaxc_errno(sts);
2591 set_errno(ENOENT); break;
2593 set_errno(ENODEV); break;
2596 set_errno(EINVAL); break;
2598 set_errno(EACCES); break;
2600 _ckvmssts_noperl(sts);
2604 add_item(head, tail, item, count);
2605 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2606 _ckvmssts_noperl(lib$find_file_end(&context));
2609 static int child_st[2];/* Event Flag set when child process completes */
2611 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2613 static unsigned long int exit_handler(int *status)
2617 if (0 == child_st[0])
2619 #ifdef ARGPROC_DEBUG
2620 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2622 fflush(stdout); /* Have to flush pipe for binary data to */
2623 /* terminate properly -- <tp@mccall.com> */
2624 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2625 sys$dassgn(child_chan);
2627 sys$synch(0, child_st);
2632 static void sig_child(int chan)
2634 #ifdef ARGPROC_DEBUG
2635 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2637 if (child_st[0] == 0)
2641 static struct exit_control_block exit_block =
2646 &exit_block.exit_status,
2650 static void pipe_and_fork(char **cmargv)
2653 $DESCRIPTOR(cmddsc, "");
2654 static char mbxname[64];
2655 $DESCRIPTOR(mbxdsc, mbxname);
2657 unsigned long int zero = 0, one = 1;
2659 strcpy(subcmd, cmargv[0]);
2660 for (j = 1; NULL != cmargv[j]; ++j)
2662 strcat(subcmd, " \"");
2663 strcat(subcmd, cmargv[j]);
2664 strcat(subcmd, "\"");
2666 cmddsc.dsc$a_pointer = subcmd;
2667 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2669 create_mbx(&child_chan,&mbxdsc);
2670 #ifdef ARGPROC_DEBUG
2671 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2672 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2674 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2675 0, &pid, child_st, &zero, sig_child,
2677 #ifdef ARGPROC_DEBUG
2678 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2680 sys$dclexh(&exit_block);
2681 if (NULL == freopen(mbxname, "wb", stdout))
2683 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2687 static int background_process(int argc, char **argv)
2689 char command[2048] = "$";
2690 $DESCRIPTOR(value, "");
2691 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2692 static $DESCRIPTOR(null, "NLA0:");
2693 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2695 $DESCRIPTOR(pidstr, "");
2697 unsigned long int flags = 17, one = 1, retsts;
2699 strcat(command, argv[0]);
2702 strcat(command, " \"");
2703 strcat(command, *(++argv));
2704 strcat(command, "\"");
2706 value.dsc$a_pointer = command;
2707 value.dsc$w_length = strlen(value.dsc$a_pointer);
2708 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2709 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2710 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2711 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2714 _ckvmssts_noperl(retsts);
2716 #ifdef ARGPROC_DEBUG
2717 PerlIO_printf(Perl_debug_log, "%s\n", command);
2719 sprintf(pidstring, "%08X", pid);
2720 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2721 pidstr.dsc$a_pointer = pidstring;
2722 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2723 lib$set_symbol(&pidsymbol, &pidstr);
2727 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2730 /* OS-specific initialization at image activation (not thread startup) */
2731 /* Older VAXC header files lack these constants */
2732 #ifndef JPI$_RIGHTS_SIZE
2733 # define JPI$_RIGHTS_SIZE 817
2735 #ifndef KGB$M_SUBSYSTEM
2736 # define KGB$M_SUBSYSTEM 0x8
2739 /*{{{void vms_image_init(int *, char ***)*/
2741 vms_image_init(int *argcp, char ***argvp)
2743 char eqv[LNM$C_NAMLENGTH+1] = "";
2744 unsigned int len, tabct = 8, tabidx = 0;
2745 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2746 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2747 unsigned short int dummy, rlen;
2748 struct dsc$descriptor_s **tabvec;
2749 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2750 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2751 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2754 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2756 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2757 if (iprv[i]) { /* Running image installed with privs? */
2758 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2763 /* Rights identifiers might trigger tainting as well. */
2764 if (!will_taint && (rlen || rsz)) {
2765 while (rlen < rsz) {
2766 /* We didn't get all the identifiers on the first pass. Allocate a
2767 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2768 * were needed to hold all identifiers at time of last call; we'll
2769 * allocate that many unsigned long ints), and go back and get 'em.
2771 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2772 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2773 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2774 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2777 mask = jpilist[1].bufadr;
2778 /* Check attribute flags for each identifier (2nd longword); protected
2779 * subsystem identifiers trigger tainting.
2781 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2782 if (mask[i] & KGB$M_SUBSYSTEM) {
2787 if (mask != rlst) Safefree(mask);
2789 /* We need to use this hack to tell Perl it should run with tainting,
2790 * since its tainting flag may be part of the PL_curinterp struct, which
2791 * hasn't been allocated when vms_image_init() is called.
2795 New(1320,newap,*argcp+2,char **);
2796 newap[0] = argvp[0];
2798 Copy(argvp[1],newap[2],*argcp-1,char **);
2799 /* We orphan the old argv, since we don't know where it's come from,
2800 * so we don't know how to free it.
2802 *argcp++; argvp = newap;
2804 else { /* Did user explicitly request tainting? */
2806 char *cp, **av = *argvp;
2807 for (i = 1; i < *argcp; i++) {
2808 if (*av[i] != '-') break;
2809 for (cp = av[i]+1; *cp; cp++) {
2810 if (*cp == 'T') { will_taint = 1; break; }
2811 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2812 strchr("DFIiMmx",*cp)) break;
2814 if (will_taint) break;
2819 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2821 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2822 else if (tabidx >= tabct) {
2824 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2826 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2827 tabvec[tabidx]->dsc$w_length = 0;
2828 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2829 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2830 tabvec[tabidx]->dsc$a_pointer = NULL;
2831 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2833 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2835 getredirection(argcp,argvp);
2836 #if defined(USE_THREADS) && defined(__DECC)
2838 # include <reentrancy.h>
2839 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2848 * Trim Unix-style prefix off filespec, so it looks like what a shell
2849 * glob expansion would return (i.e. from specified prefix on, not
2850 * full path). Note that returned filespec is Unix-style, regardless
2851 * of whether input filespec was VMS-style or Unix-style.
2853 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2854 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2855 * vector of options; at present, only bit 0 is used, and if set tells
2856 * trim unixpath to try the current default directory as a prefix when
2857 * presented with a possibly ambiguous ... wildcard.
2859 * Returns !=0 on success, with trimmed filespec replacing contents of
2860 * fspec, and 0 on failure, with contents of fpsec unchanged.
2862 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2864 trim_unixpath(char *fspec, char *wildspec, int opts)
2866 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2867 *template, *base, *end, *cp1, *cp2;
2868 register int tmplen, reslen = 0, dirs = 0;
2870 if (!wildspec || !fspec) return 0;
2871 if (strpbrk(wildspec,"]>:") != NULL) {
2872 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2873 else template = unixwild;
2875 else template = wildspec;
2876 if (strpbrk(fspec,"]>:") != NULL) {
2877 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2878 else base = unixified;
2879 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2880 * check to see that final result fits into (isn't longer than) fspec */
2881 reslen = strlen(fspec);
2885 /* No prefix or absolute path on wildcard, so nothing to remove */
2886 if (!*template || *template == '/') {
2887 if (base == fspec) return 1;
2888 tmplen = strlen(unixified);
2889 if (tmplen > reslen) return 0; /* not enough space */
2890 /* Copy unixified resultant, including trailing NUL */
2891 memmove(fspec,unixified,tmplen+1);
2895 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2896 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2897 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2898 for (cp1 = end ;cp1 >= base; cp1--)
2899 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2901 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2905 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2906 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2907 int ells = 1, totells, segdirs, match;
2908 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2909 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2911 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2913 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2914 if (ellipsis == template && opts & 1) {
2915 /* Template begins with an ellipsis. Since we can't tell how many
2916 * directory names at the front of the resultant to keep for an
2917 * arbitrary starting point, we arbitrarily choose the current
2918 * default directory as a starting point. If it's there as a prefix,
2919 * clip it off. If not, fall through and act as if the leading
2920 * ellipsis weren't there (i.e. return shortest possible path that
2921 * could match template).
2923 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2924 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2925 if (_tolower(*cp1) != _tolower(*cp2)) break;
2926 segdirs = dirs - totells; /* Min # of dirs we must have left */
2927 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2928 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2929 memcpy(fspec,cp2+1,end - cp2);
2933 /* First off, back up over constant elements at end of path */
2935 for (front = end ; front >= base; front--)
2936 if (*front == '/' && !dirs--) { front++; break; }
2938 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2939 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2940 if (cp1 != '\0') return 0; /* Path too long. */
2942 *cp2 = '\0'; /* Pick up with memcpy later */
2943 lcfront = lcres + (front - base);
2944 /* Now skip over each ellipsis and try to match the path in front of it. */
2946 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2947 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2948 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2949 if (cp1 < template) break; /* template started with an ellipsis */
2950 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2951 ellipsis = cp1; continue;
2953 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2955 for (segdirs = 0, cp2 = tpl;
2956 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2958 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2959 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2960 if (*cp2 == '/') segdirs++;
2962 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2963 /* Back up at least as many dirs as in template before matching */
2964 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2965 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2966 for (match = 0; cp1 > lcres;) {
2967 resdsc.dsc$a_pointer = cp1;
2968 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2970 if (match == 1) lcfront = cp1;
2972 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2974 if (!match) return 0; /* Can't find prefix ??? */
2975 if (match > 1 && opts & 1) {
2976 /* This ... wildcard could cover more than one set of dirs (i.e.
2977 * a set of similar dir names is repeated). If the template
2978 * contains more than 1 ..., upstream elements could resolve the
2979 * ambiguity, but it's not worth a full backtracking setup here.
2980 * As a quick heuristic, clip off the current default directory
2981 * if it's present to find the trimmed spec, else use the
2982 * shortest string that this ... could cover.
2984 char def[NAM$C_MAXRSS+1], *st;
2986 if (getcwd(def, sizeof def,0) == NULL) return 0;
2987 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2988 if (_tolower(*cp1) != _tolower(*cp2)) break;
2989 segdirs = dirs - totells; /* Min # of dirs we must have left */
2990 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2991 if (*cp1 == '\0' && *cp2 == '/') {
2992 memcpy(fspec,cp2+1,end - cp2);
2995 /* Nope -- stick with lcfront from above and keep going. */
2998 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3003 } /* end of trim_unixpath() */
3008 * VMS readdir() routines.
3009 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3011 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3012 * Minor modifications to original routines.
3015 /* Number of elements in vms_versions array */
3016 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3019 * Open a directory, return a handle for later use.
3021 /*{{{ DIR *opendir(char*name) */
3026 char dir[NAM$C_MAXRSS+1];
3029 if (do_tovmspath(name,dir,0) == NULL) {
3032 if (flex_stat(dir,&sb) == -1) return NULL;
3033 if (!S_ISDIR(sb.st_mode)) {
3034 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3037 if (!cando_by_name(S_IRUSR,0,dir)) {
3038 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3041 /* Get memory for the handle, and the pattern. */
3043 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3045 /* Fill in the fields; mainly playing with the descriptor. */
3046 (void)sprintf(dd->pattern, "%s*.*",dir);
3049 dd->vms_wantversions = 0;
3050 dd->pat.dsc$a_pointer = dd->pattern;
3051 dd->pat.dsc$w_length = strlen(dd->pattern);
3052 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3053 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3056 } /* end of opendir() */
3060 * Set the flag to indicate we want versions or not.
3062 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3064 vmsreaddirversions(DIR *dd, int flag)
3066 dd->vms_wantversions = flag;
3071 * Free up an opened directory.
3073 /*{{{ void closedir(DIR *dd)*/
3077 (void)lib$find_file_end(&dd->context);
3078 Safefree(dd->pattern);
3079 Safefree((char *)dd);
3084 * Collect all the version numbers for the current file.
3090 struct dsc$descriptor_s pat;
3091 struct dsc$descriptor_s res;
3093 char *p, *text, buff[sizeof dd->entry.d_name];
3095 unsigned long context, tmpsts;
3097 /* Convenient shorthand. */
3100 /* Add the version wildcard, ignoring the "*.*" put on before */
3101 i = strlen(dd->pattern);
3102 New(1308,text,i + e->d_namlen + 3,char);
3103 (void)strcpy(text, dd->pattern);
3104 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3106 /* Set up the pattern descriptor. */
3107 pat.dsc$a_pointer = text;
3108 pat.dsc$w_length = i + e->d_namlen - 1;
3109 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3110 pat.dsc$b_class = DSC$K_CLASS_S;
3112 /* Set up result descriptor. */
3113 res.dsc$a_pointer = buff;
3114 res.dsc$w_length = sizeof buff - 2;
3115 res.dsc$b_dtype = DSC$K_DTYPE_T;
3116 res.dsc$b_class = DSC$K_CLASS_S;
3118 /* Read files, collecting versions. */
3119 for (context = 0, e->vms_verscount = 0;
3120 e->vms_verscount < VERSIZE(e);
3121 e->vms_verscount++) {
3122 tmpsts = lib$find_file(&pat, &res, &context);
3123 if (tmpsts == RMS$_NMF || context == 0) break;
3125 buff[sizeof buff - 1] = '\0';
3126 if ((p = strchr(buff, ';')))
3127 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3129 e->vms_versions[e->vms_verscount] = -1;
3132 _ckvmssts(lib$find_file_end(&context));
3135 } /* end of collectversions() */
3138 * Read the next entry from the directory.
3140 /*{{{ struct dirent *readdir(DIR *dd)*/
3144 struct dsc$descriptor_s res;
3145 char *p, buff[sizeof dd->entry.d_name];
3146 unsigned long int tmpsts;
3148 /* Set up result descriptor, and get next file. */
3149 res.dsc$a_pointer = buff;
3150 res.dsc$w_length = sizeof buff - 2;
3151 res.dsc$b_dtype = DSC$K_DTYPE_T;
3152 res.dsc$b_class = DSC$K_CLASS_S;
3153 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3154 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3155 if (!(tmpsts & 1)) {
3156 set_vaxc_errno(tmpsts);
3159 set_errno(EACCES); break;
3161 set_errno(ENODEV); break;
3164 set_errno(ENOENT); break;
3171 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3172 buff[sizeof buff - 1] = '\0';
3173 for (p = buff; *p; p++) *p = _tolower(*p);
3174 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3177 /* Skip any directory component and just copy the name. */
3178 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3179 else (void)strcpy(dd->entry.d_name, buff);
3181 /* Clobber the version. */
3182 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3184 dd->entry.d_namlen = strlen(dd->entry.d_name);
3185 dd->entry.vms_verscount = 0;
3186 if (dd->vms_wantversions) collectversions(dd);
3189 } /* end of readdir() */
3193 * Return something that can be used in a seekdir later.
3195 /*{{{ long telldir(DIR *dd)*/
3204 * Return to a spot where we used to be. Brute force.
3206 /*{{{ void seekdir(DIR *dd,long count)*/
3208 seekdir(DIR *dd, long count)
3210 int vms_wantversions;
3212 /* If we haven't done anything yet... */
3216 /* Remember some state, and clear it. */
3217 vms_wantversions = dd->vms_wantversions;
3218 dd->vms_wantversions = 0;
3219 _ckvmssts(lib$find_file_end(&dd->context));
3222 /* The increment is in readdir(). */
3223 for (dd->count = 0; dd->count < count; )
3226 dd->vms_wantversions = vms_wantversions;
3228 } /* end of seekdir() */
3231 /* VMS subprocess management
3233 * my_vfork() - just a vfork(), after setting a flag to record that
3234 * the current script is trying a Unix-style fork/exec.
3236 * vms_do_aexec() and vms_do_exec() are called in response to the
3237 * perl 'exec' function. If this follows a vfork call, then they
3238 * call out the the regular perl routines in doio.c which do an
3239 * execvp (for those who really want to try this under VMS).
3240 * Otherwise, they do exactly what the perl docs say exec should
3241 * do - terminate the current script and invoke a new command
3242 * (See below for notes on command syntax.)
3244 * do_aspawn() and do_spawn() implement the VMS side of the perl
3245 * 'system' function.
3247 * Note on command arguments to perl 'exec' and 'system': When handled
3248 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3249 * are concatenated to form a DCL command string. If the first arg
3250 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3251 * the the command string is handed off to DCL directly. Otherwise,
3252 * the first token of the command is taken as the filespec of an image
3253 * to run. The filespec is expanded using a default type of '.EXE' and
3254 * the process defaults for device, directory, etc., and if found, the resultant
3255 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3256 * the command string as parameters. This is perhaps a bit complicated,
3257 * but I hope it will form a happy medium between what VMS folks expect
3258 * from lib$spawn and what Unix folks expect from exec.
3261 static int vfork_called;
3263 /*{{{int my_vfork()*/
3273 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3281 if (VMScmd.dsc$a_pointer) {
3282 Safefree(VMScmd.dsc$a_pointer);
3283 VMScmd.dsc$w_length = 0;
3284 VMScmd.dsc$a_pointer = Nullch;
3289 setup_argstr(SV *really, SV **mark, SV **sp)
3292 char *junk, *tmps = Nullch;
3293 register size_t cmdlen = 0;
3300 tmps = SvPV(really,rlen);
3307 for (idx++; idx <= sp; idx++) {
3309 junk = SvPVx(*idx,rlen);
3310 cmdlen += rlen ? rlen + 1 : 0;
3313 New(401,PL_Cmd,cmdlen+1,char);
3315 if (tmps && *tmps) {
3316 strcpy(PL_Cmd,tmps);
3319 else *PL_Cmd = '\0';
3320 while (++mark <= sp) {
3322 char *s = SvPVx(*mark,n_a);
3324 if (*PL_Cmd) strcat(PL_Cmd," ");
3330 } /* end of setup_argstr() */
3333 static unsigned long int
3334 setup_cmddsc(char *cmd, int check_img)
3336 char resspec[NAM$C_MAXRSS+1];
3337 $DESCRIPTOR(defdsc,".EXE");
3338 $DESCRIPTOR(resdsc,resspec);
3339 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3340 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3341 register char *s, *rest, *cp;
3342 register int isdcl = 0;
3345 while (*s && isspace(*s)) s++;
3347 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3348 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3349 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3350 if (*cp == ':' || *cp == '[' || *cp == '<') {
3360 while (*s && !isspace(*s)) s++;
3362 imgdsc.dsc$a_pointer = cmd;
3363 imgdsc.dsc$w_length = s - cmd;
3364 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3366 _ckvmssts(lib$find_file_end(&cxt));
3368 while (*s && !isspace(*s)) s++;
3370 if (cando_by_name(S_IXUSR,0,resspec)) {
3371 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3372 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3373 strcat(VMScmd.dsc$a_pointer,resspec);
3374 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3375 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3378 else retsts = RMS$_PRV;
3381 /* It's either a DCL command or we couldn't find a suitable image */
3382 VMScmd.dsc$w_length = strlen(cmd);
3383 if (cmd == PL_Cmd) {
3384 VMScmd.dsc$a_pointer = PL_Cmd;
3385 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3387 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3388 if (!(retsts & 1)) {
3389 /* just hand off status values likely to be due to user error */
3390 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3391 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3392 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3393 else { _ckvmssts(retsts); }
3396 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3398 } /* end of setup_cmddsc() */
3401 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3403 vms_do_aexec(SV *really,SV **mark,SV **sp)
3407 if (vfork_called) { /* this follows a vfork - act Unixish */
3409 if (vfork_called < 0) {
3410 warn("Internal inconsistency in tracking vforks");
3413 else return do_aexec(really,mark,sp);
3415 /* no vfork - act VMSish */
3416 return vms_do_exec(setup_argstr(really,mark,sp));
3421 } /* end of vms_do_aexec() */
3424 /* {{{bool vms_do_exec(char *cmd) */
3426 vms_do_exec(char *cmd)
3430 if (vfork_called) { /* this follows a vfork - act Unixish */
3432 if (vfork_called < 0) {
3433 warn("Internal inconsistency in tracking vforks");
3436 else return do_exec(cmd);
3439 { /* no vfork - act VMSish */
3440 unsigned long int retsts;
3443 TAINT_PROPER("exec");
3444 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3445 retsts = lib$do_command(&VMScmd);
3449 set_errno(ENOENT); break;
3450 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3451 set_errno(ENOTDIR); break;
3453 set_errno(EACCES); break;
3455 set_errno(EINVAL); break;
3457 set_errno(E2BIG); break;
3458 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3459 _ckvmssts(retsts); /* fall through */
3460 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3463 set_vaxc_errno(retsts);
3464 if (ckWARN(WARN_EXEC)) {
3465 warner(WARN_EXEC,"Can't exec \"%*s\": %s",
3466 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3473 } /* end of vms_do_exec() */
3476 unsigned long int do_spawn(char *);
3478 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3480 do_aspawn(void *really,void **mark,void **sp)
3483 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3486 } /* end of do_aspawn() */
3489 /* {{{unsigned long int do_spawn(char *cmd) */
3493 unsigned long int sts, substs, hadcmd = 1;
3497 TAINT_PROPER("spawn");
3498 if (!cmd || !*cmd) {
3500 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3502 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3503 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3509 set_errno(ENOENT); break;
3510 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3511 set_errno(ENOTDIR); break;
3513 set_errno(EACCES); break;
3515 set_errno(EINVAL); break;
3517 set_errno(E2BIG); break;
3518 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3519 _ckvmssts(sts); /* fall through */
3520 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3523 set_vaxc_errno(sts);
3524 if (ckWARN(WARN_EXEC)) {
3525 warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
3526 hadcmd ? VMScmd.dsc$w_length : 0,
3527 hadcmd ? VMScmd.dsc$a_pointer : "",
3534 } /* end of do_spawn() */
3538 * A simple fwrite replacement which outputs itmsz*nitm chars without
3539 * introducing record boundaries every itmsz chars.
3541 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3543 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3545 register char *cp, *end;
3547 end = (char *)src + itmsz * nitm;
3549 while ((char *)src <= end) {
3550 for (cp = src; cp <= end; cp++) if (!*cp) break;
3551 if (fputs(src,dest) == EOF) return EOF;
3553 if (fputc('\0',dest) == EOF) return EOF;
3559 } /* end of my_fwrite() */
3562 /*{{{ int my_flush(FILE *fp)*/
3567 if ((res = fflush(fp)) == 0) {
3568 #ifdef VMS_DO_SOCKETS
3570 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3572 res = fsync(fileno(fp));
3579 * Here are replacements for the following Unix routines in the VMS environment:
3580 * getpwuid Get information for a particular UIC or UID
3581 * getpwnam Get information for a named user
3582 * getpwent Get information for each user in the rights database
3583 * setpwent Reset search to the start of the rights database
3584 * endpwent Finish searching for users in the rights database
3586 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3587 * (defined in pwd.h), which contains the following fields:-
3589 * char *pw_name; Username (in lower case)
3590 * char *pw_passwd; Hashed password
3591 * unsigned int pw_uid; UIC
3592 * unsigned int pw_gid; UIC group number
3593 * char *pw_unixdir; Default device/directory (VMS-style)
3594 * char *pw_gecos; Owner name
3595 * char *pw_dir; Default device/directory (Unix-style)
3596 * char *pw_shell; Default CLI name (eg. DCL)
3598 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3600 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3601 * not the UIC member number (eg. what's returned by getuid()),
3602 * getpwuid() can accept either as input (if uid is specified, the caller's
3603 * UIC group is used), though it won't recognise gid=0.
3605 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3606 * information about other users in your group or in other groups, respectively.
3607 * If the required privilege is not available, then these routines fill only
3608 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3611 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3614 /* sizes of various UAF record fields */
3615 #define UAI$S_USERNAME 12
3616 #define UAI$S_IDENT 31
3617 #define UAI$S_OWNER 31
3618 #define UAI$S_DEFDEV 31
3619 #define UAI$S_DEFDIR 63
3620 #define UAI$S_DEFCLI 31
3623 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3624 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3625 (uic).uic$v_group != UIC$K_WILD_GROUP)
3627 static char __empty[]= "";
3628 static struct passwd __passwd_empty=
3629 {(char *) __empty, (char *) __empty, 0, 0,
3630 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3631 static int contxt= 0;
3632 static struct passwd __pwdcache;
3633 static char __pw_namecache[UAI$S_IDENT+1];
3636 * This routine does most of the work extracting the user information.
3638 static int fillpasswd (const char *name, struct passwd *pwd)
3641 unsigned char length;
3642 char pw_gecos[UAI$S_OWNER+1];
3644 static union uicdef uic;
3646 unsigned char length;
3647 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3650 unsigned char length;
3651 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3654 unsigned char length;
3655 char pw_shell[UAI$S_DEFCLI+1];
3657 static char pw_passwd[UAI$S_PWD+1];
3659 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3660 struct dsc$descriptor_s name_desc;
3661 unsigned long int sts;
3663 static struct itmlst_3 itmlst[]= {
3664 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3665 {sizeof(uic), UAI$_UIC, &uic, &luic},
3666 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3667 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3668 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3669 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3670 {0, 0, NULL, NULL}};
3672 name_desc.dsc$w_length= strlen(name);
3673 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3674 name_desc.dsc$b_class= DSC$K_CLASS_S;
3675 name_desc.dsc$a_pointer= (char *) name;
3677 /* Note that sys$getuai returns many fields as counted strings. */
3678 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3679 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3680 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3682 else { _ckvmssts(sts); }
3683 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3685 if ((int) owner.length < lowner) lowner= (int) owner.length;
3686 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3687 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3688 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3689 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3690 owner.pw_gecos[lowner]= '\0';
3691 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3692 defcli.pw_shell[ldefcli]= '\0';
3693 if (valid_uic(uic)) {
3694 pwd->pw_uid= uic.uic$l_uic;
3695 pwd->pw_gid= uic.uic$v_group;
3698 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3699 pwd->pw_passwd= pw_passwd;
3700 pwd->pw_gecos= owner.pw_gecos;
3701 pwd->pw_dir= defdev.pw_dir;
3702 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3703 pwd->pw_shell= defcli.pw_shell;
3704 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3706 ldir= strlen(pwd->pw_unixdir) - 1;
3707 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3710 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3711 __mystrtolower(pwd->pw_unixdir);
3716 * Get information for a named user.
3718 /*{{{struct passwd *getpwnam(char *name)*/
3719 struct passwd *my_getpwnam(char *name)
3721 struct dsc$descriptor_s name_desc;
3723 unsigned long int status, sts;
3725 __pwdcache = __passwd_empty;
3726 if (!fillpasswd(name, &__pwdcache)) {
3727 /* We still may be able to determine pw_uid and pw_gid */
3728 name_desc.dsc$w_length= strlen(name);
3729 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3730 name_desc.dsc$b_class= DSC$K_CLASS_S;
3731 name_desc.dsc$a_pointer= (char *) name;
3732 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3733 __pwdcache.pw_uid= uic.uic$l_uic;
3734 __pwdcache.pw_gid= uic.uic$v_group;
3737 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3738 set_vaxc_errno(sts);
3739 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3742 else { _ckvmssts(sts); }
3745 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3746 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3747 __pwdcache.pw_name= __pw_namecache;
3749 } /* end of my_getpwnam() */
3753 * Get information for a particular UIC or UID.
3754 * Called by my_getpwent with uid=-1 to list all users.
3756 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3757 struct passwd *my_getpwuid(Uid_t uid)
3759 const $DESCRIPTOR(name_desc,__pw_namecache);
3760 unsigned short lname;
3762 unsigned long int status;
3764 if (uid == (unsigned int) -1) {
3766 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3767 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3768 set_vaxc_errno(status);
3769 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3773 else { _ckvmssts(status); }
3774 } while (!valid_uic (uic));
3778 if (!uic.uic$v_group)
3779 uic.uic$v_group= PerlProc_getgid();
3781 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3782 else status = SS$_IVIDENT;
3783 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3784 status == RMS$_PRV) {
3785 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3788 else { _ckvmssts(status); }
3790 __pw_namecache[lname]= '\0';
3791 __mystrtolower(__pw_namecache);
3793 __pwdcache = __passwd_empty;
3794 __pwdcache.pw_name = __pw_namecache;
3796 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3797 The identifier's value is usually the UIC, but it doesn't have to be,
3798 so if we can, we let fillpasswd update this. */
3799 __pwdcache.pw_uid = uic.uic$l_uic;
3800 __pwdcache.pw_gid = uic.uic$v_group;
3802 fillpasswd(__pw_namecache, &__pwdcache);
3805 } /* end of my_getpwuid() */
3809 * Get information for next user.
3811 /*{{{struct passwd *my_getpwent()*/
3812 struct passwd *my_getpwent()
3814 return (my_getpwuid((unsigned int) -1));
3819 * Finish searching rights database for users.
3821 /*{{{void my_endpwent()*/
3825 _ckvmssts(sys$finish_rdb(&contxt));
3831 #ifdef HOMEGROWN_POSIX_SIGNALS
3832 /* Signal handling routines, pulled into the core from POSIX.xs.
3834 * We need these for threads, so they've been rolled into the core,
3835 * rather than left in POSIX.xs.
3837 * (DRS, Oct 23, 1997)
3840 /* sigset_t is atomic under VMS, so these routines are easy */
3841 /*{{{int my_sigemptyset(sigset_t *) */
3842 int my_sigemptyset(sigset_t *set) {
3843 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3849 /*{{{int my_sigfillset(sigset_t *)*/
3850 int my_sigfillset(sigset_t *set) {
3852 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3853 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3859 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3860 int my_sigaddset(sigset_t *set, int sig) {
3861 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3862 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3863 *set |= (1 << (sig - 1));
3869 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3870 int my_sigdelset(sigset_t *set, int sig) {
3871 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3872 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3873 *set &= ~(1 << (sig - 1));
3879 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3880 int my_sigismember(sigset_t *set, int sig) {
3881 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3882 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3883 *set & (1 << (sig - 1));
3888 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3889 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3892 /* If set and oset are both null, then things are badly wrong. Bail out. */
3893 if ((oset == NULL) && (set == NULL)) {
3894 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3898 /* If set's null, then we're just handling a fetch. */
3900 tempmask = sigblock(0);
3905 tempmask = sigsetmask(*set);
3908 tempmask = sigblock(*set);
3911 tempmask = sigblock(0);
3912 sigsetmask(*oset & ~tempmask);
3915 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3920 /* Did they pass us an oset? If so, stick our holding mask into it */
3927 #endif /* HOMEGROWN_POSIX_SIGNALS */
3930 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3931 * my_utime(), and flex_stat(), all of which operate on UTC unless
3932 * VMSISH_TIMES is true.
3934 /* method used to handle UTC conversions:
3935 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3937 static int gmtime_emulation_type;
3938 /* number of secs to add to UTC POSIX-style time to get local time */
3939 static long int utc_offset_secs;
3941 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3942 * in vmsish.h. #undef them here so we can call the CRTL routines
3949 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3950 # define RTL_USES_UTC 1
3953 static time_t toutc_dst(time_t loc) {
3956 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3957 loc -= utc_offset_secs;
3958 if (rsltmp->tm_isdst) loc -= 3600;
3961 #define _toutc(secs) ((secs) == -1 ? -1 : \
3962 ((gmtime_emulation_type || my_time(NULL)), \
3963 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3964 ((secs) - utc_offset_secs))))
3966 static time_t toloc_dst(time_t utc) {
3969 utc += utc_offset_secs;
3970 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3971 if (rsltmp->tm_isdst) utc += 3600;
3974 #define _toloc(secs) ((secs) == -1 ? -1 : \
3975 ((gmtime_emulation_type || my_time(NULL)), \
3976 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3977 ((secs) + utc_offset_secs))))
3980 /* my_time(), my_localtime(), my_gmtime()
3981 * By default traffic in UTC time values, using CRTL gmtime() or
3982 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3983 * Note: We need to use these functions even when the CRTL has working
3984 * UTC support, since they also handle C<use vmsish qw(times);>
3986 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3987 * Modified by Charles Bailey <bailey@newman.upenn.edu>
3990 /*{{{time_t my_time(time_t *timep)*/
3991 time_t my_time(time_t *timep)
3997 if (gmtime_emulation_type == 0) {
3999 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4000 /* results of calls to gmtime() and localtime() */
4001 /* for same &base */
4003 gmtime_emulation_type++;
4004 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4005 char off[LNM$C_NAMLENGTH+1];;
4007 gmtime_emulation_type++;
4008 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4009 gmtime_emulation_type++;
4010 warn("no UTC offset information; assuming local time is UTC");
4012 else { utc_offset_secs = atol(off); }
4014 else { /* We've got a working gmtime() */
4015 struct tm gmt, local;
4018 tm_p = localtime(&base);
4020 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4021 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4022 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4023 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4029 # ifdef RTL_USES_UTC
4030 if (VMSISH_TIME) when = _toloc(when);
4032 if (!VMSISH_TIME) when = _toutc(when);
4035 if (timep != NULL) *timep = when;
4038 } /* end of my_time() */
4042 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4044 my_gmtime(const time_t *timep)
4051 if (timep == NULL) {
4052 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4055 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4059 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4061 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4062 return gmtime(&when);
4064 /* CRTL localtime() wants local time as input, so does no tz correction */
4065 rsltmp = localtime(&when);
4066 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4069 } /* end of my_gmtime() */
4073 /*{{{struct tm *my_localtime(const time_t *timep)*/
4075 my_localtime(const time_t *timep)
4081 if (timep == NULL) {
4082 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4085 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4086 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4089 # ifdef RTL_USES_UTC
4091 if (VMSISH_TIME) when = _toutc(when);
4093 /* CRTL localtime() wants UTC as input, does tz correction itself */
4094 return localtime(&when);
4097 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4100 /* CRTL localtime() wants local time as input, so does no tz correction */
4101 rsltmp = localtime(&when);
4102 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4105 } /* end of my_localtime() */
4108 /* Reset definitions for later calls */
4109 #define gmtime(t) my_gmtime(t)
4110 #define localtime(t) my_localtime(t)
4111 #define time(t) my_time(t)
4114 /* my_utime - update modification time of a file
4115 * calling sequence is identical to POSIX utime(), but under
4116 * VMS only the modification time is changed; ODS-2 does not
4117 * maintain access times. Restrictions differ from the POSIX
4118 * definition in that the time can be changed as long as the
4119 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4120 * no separate checks are made to insure that the caller is the
4121 * owner of the file or has special privs enabled.
4122 * Code here is based on Joe Meadows' FILE utility.
4125 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4126 * to VMS epoch (01-JAN-1858 00:00:00.00)
4127 * in 100 ns intervals.
4129 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4131 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4132 int my_utime(char *file, struct utimbuf *utimes)
4136 long int bintime[2], len = 2, lowbit, unixtime,
4137 secscale = 10000000; /* seconds --> 100 ns intervals */
4138 unsigned long int chan, iosb[2], retsts;
4139 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4140 struct FAB myfab = cc$rms_fab;
4141 struct NAM mynam = cc$rms_nam;
4142 #if defined (__DECC) && defined (__VAX)
4143 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4144 * at least through VMS V6.1, which causes a type-conversion warning.
4146 # pragma message save
4147 # pragma message disable cvtdiftypes
4149 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4150 struct fibdef myfib;
4151 #if defined (__DECC) && defined (__VAX)
4152 /* This should be right after the declaration of myatr, but due
4153 * to a bug in VAX DEC C, this takes effect a statement early.
4155 # pragma message restore
4157 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4158 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4159 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4161 if (file == NULL || *file == '\0') {
4163 set_vaxc_errno(LIB$_INVARG);
4166 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4168 if (utimes != NULL) {
4169 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4170 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4171 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4172 * as input, we force the sign bit to be clear by shifting unixtime right
4173 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4175 lowbit = (utimes->modtime & 1) ? secscale : 0;
4176 unixtime = (long int) utimes->modtime;
4178 /* If input was UTC; convert to local for sys svc */
4179 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4181 unixtime >> 1; secscale << 1;
4182 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4183 if (!(retsts & 1)) {
4185 set_vaxc_errno(retsts);
4188 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4189 if (!(retsts & 1)) {
4191 set_vaxc_errno(retsts);
4196 /* Just get the current time in VMS format directly */
4197 retsts = sys$gettim(bintime);
4198 if (!(retsts & 1)) {
4200 set_vaxc_errno(retsts);
4205 myfab.fab$l_fna = vmsspec;
4206 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4207 myfab.fab$l_nam = &mynam;
4208 mynam.nam$l_esa = esa;
4209 mynam.nam$b_ess = (unsigned char) sizeof esa;
4210 mynam.nam$l_rsa = rsa;
4211 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4213 /* Look for the file to be affected, letting RMS parse the file
4214 * specification for us as well. I have set errno using only
4215 * values documented in the utime() man page for VMS POSIX.
4217 retsts = sys$parse(&myfab,0,0);
4218 if (!(retsts & 1)) {
4219 set_vaxc_errno(retsts);
4220 if (retsts == RMS$_PRV) set_errno(EACCES);
4221 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4222 else set_errno(EVMSERR);
4225 retsts = sys$search(&myfab,0,0);
4226 if (!(retsts & 1)) {
4227 set_vaxc_errno(retsts);
4228 if (retsts == RMS$_PRV) set_errno(EACCES);
4229 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4230 else set_errno(EVMSERR);
4234 devdsc.dsc$w_length = mynam.nam$b_dev;
4235 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4237 retsts = sys$assign(&devdsc,&chan,0,0);
4238 if (!(retsts & 1)) {
4239 set_vaxc_errno(retsts);
4240 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4241 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4242 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4243 else set_errno(EVMSERR);
4247 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4248 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4250 memset((void *) &myfib, 0, sizeof myfib);
4252 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4253 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4254 /* This prevents the revision time of the file being reset to the current
4255 * time as a result of our IO$_MODIFY $QIO. */
4256 myfib.fib$l_acctl = FIB$M_NORECORD;
4258 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4259 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4260 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4262 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4263 _ckvmssts(sys$dassgn(chan));
4264 if (retsts & 1) retsts = iosb[0];
4265 if (!(retsts & 1)) {
4266 set_vaxc_errno(retsts);
4267 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4268 else set_errno(EVMSERR);
4273 } /* end of my_utime() */
4277 * flex_stat, flex_fstat
4278 * basic stat, but gets it right when asked to stat
4279 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4282 /* encode_dev packs a VMS device name string into an integer to allow
4283 * simple comparisons. This can be used, for example, to check whether two
4284 * files are located on the same device, by comparing their encoded device
4285 * names. Even a string comparison would not do, because stat() reuses the
4286 * device name buffer for each call; so without encode_dev, it would be
4287 * necessary to save the buffer and use strcmp (this would mean a number of
4288 * changes to the standard Perl code, to say nothing of what a Perl script
4291 * The device lock id, if it exists, should be unique (unless perhaps compared
4292 * with lock ids transferred from other nodes). We have a lock id if the disk is
4293 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4294 * device names. Thus we use the lock id in preference, and only if that isn't
4295 * available, do we try to pack the device name into an integer (flagged by
4296 * the sign bit (LOCKID_MASK) being set).
4298 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4299 * name and its encoded form, but it seems very unlikely that we will find
4300 * two files on different disks that share the same encoded device names,
4301 * and even more remote that they will share the same file id (if the test
4302 * is to check for the same file).
4304 * A better method might be to use sys$device_scan on the first call, and to
4305 * search for the device, returning an index into the cached array.
4306 * The number returned would be more intelligable.
4307 * This is probably not worth it, and anyway would take quite a bit longer
4308 * on the first call.
4310 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4311 static mydev_t encode_dev (const char *dev)
4314 unsigned long int f;
4319 if (!dev || !dev[0]) return 0;
4323 struct dsc$descriptor_s dev_desc;
4324 unsigned long int status, lockid, item = DVI$_LOCKID;
4326 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4327 can try that first. */
4328 dev_desc.dsc$w_length = strlen (dev);
4329 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4330 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4331 dev_desc.dsc$a_pointer = (char *) dev;
4332 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4333 if (lockid) return (lockid & ~LOCKID_MASK);
4337 /* Otherwise we try to encode the device name */
4341 for (q = dev + strlen(dev); q--; q >= dev) {
4344 else if (isalpha (toupper (*q)))
4345 c= toupper (*q) - 'A' + (char)10;
4347 continue; /* Skip '$'s */
4349 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4351 enc += f * (unsigned long int) c;
4353 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4355 } /* end of encode_dev() */
4357 static char namecache[NAM$C_MAXRSS+1];
4360 is_null_device(name)
4363 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4364 The underscore prefix, controller letter, and unit number are
4365 independently optional; for our purposes, the colon punctuation
4366 is not. The colon can be trailed by optional directory and/or
4367 filename, but two consecutive colons indicates a nodename rather
4368 than a device. [pr] */
4369 if (*name == '_') ++name;
4370 if (tolower(*name++) != 'n') return 0;
4371 if (tolower(*name++) != 'l') return 0;
4372 if (tolower(*name) == 'a') ++name;
4373 if (*name == '0') ++name;
4374 return (*name++ == ':') && (*name != ':');
4377 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4378 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4379 * subset of the applicable information.
4381 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4383 cando(I32 bit, I32 effective, Stat_t *statbufp)
4386 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4388 char fname[NAM$C_MAXRSS+1];
4389 unsigned long int retsts;
4390 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4391 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4393 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4394 device name on successive calls */
4395 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4396 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4397 namdsc.dsc$a_pointer = fname;
4398 namdsc.dsc$w_length = sizeof fname - 1;
4400 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4401 &namdsc,&namdsc.dsc$w_length,0,0);
4403 fname[namdsc.dsc$w_length] = '\0';
4404 return cando_by_name(bit,effective,fname);
4406 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4407 warn("Can't get filespec - stale stat buffer?\n");
4411 return FALSE; /* Should never get to here */
4413 } /* end of cando() */
4417 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4419 cando_by_name(I32 bit, I32 effective, char *fname)
4421 static char usrname[L_cuserid];
4422 static struct dsc$descriptor_s usrdsc =
4423 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4424 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4425 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4426 unsigned short int retlen;
4427 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4428 union prvdef curprv;
4429 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4430 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4431 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4434 if (!fname || !*fname) return FALSE;
4435 /* Make sure we expand logical names, since sys$check_access doesn't */
4436 if (!strpbrk(fname,"/]>:")) {
4437 strcpy(fileified,fname);
4438 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4441 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4442 retlen = namdsc.dsc$w_length = strlen(vmsname);
4443 namdsc.dsc$a_pointer = vmsname;
4444 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4445 vmsname[retlen-1] == ':') {
4446 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4447 namdsc.dsc$w_length = strlen(fileified);
4448 namdsc.dsc$a_pointer = fileified;
4451 if (!usrdsc.dsc$w_length) {
4453 usrdsc.dsc$w_length = strlen(usrname);
4460 access = ARM$M_EXECUTE;
4465 access = ARM$M_READ;
4470 access = ARM$M_WRITE;
4475 access = ARM$M_DELETE;
4481 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4482 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4483 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4484 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4485 set_vaxc_errno(retsts);
4486 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4487 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4488 else set_errno(ENOENT);
4491 if (retsts == SS$_NORMAL) {
4492 if (!privused) return TRUE;
4493 /* We can get access, but only by using privs. Do we have the
4494 necessary privs currently enabled? */
4495 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4496 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4497 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4498 !curprv.prv$v_bypass) return FALSE;
4499 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4500 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4501 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4504 if (retsts == SS$_ACCONFLICT) {
4509 return FALSE; /* Should never get here */
4511 } /* end of cando_by_name() */
4515 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4517 flex_fstat(int fd, Stat_t *statbufp)
4520 if (!fstat(fd,(stat_t *) statbufp)) {
4521 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4522 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4523 # ifdef RTL_USES_UTC
4526 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4527 statbufp->st_atime = _toloc(statbufp->st_atime);
4528 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4533 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4537 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4538 statbufp->st_atime = _toutc(statbufp->st_atime);
4539 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4546 } /* end of flex_fstat() */
4549 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4551 flex_stat(const char *fspec, Stat_t *statbufp)
4554 char fileified[NAM$C_MAXRSS+1];
4555 char temp_fspec[NAM$C_MAXRSS+300];
4558 strcpy(temp_fspec, fspec);
4559 if (statbufp == (Stat_t *) &PL_statcache)
4560 do_tovmsspec(temp_fspec,namecache,0);
4561 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4562 memset(statbufp,0,sizeof *statbufp);
4563 statbufp->st_dev = encode_dev("_NLA0:");
4564 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4565 statbufp->st_uid = 0x00010001;
4566 statbufp->st_gid = 0x0001;
4567 time((time_t *)&statbufp->st_mtime);
4568 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4572 /* Try for a directory name first. If fspec contains a filename without
4573 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4574 * and sea:[wine.dark]water. exist, we prefer the directory here.
4575 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4576 * not sea:[wine.dark]., if the latter exists. If the intended target is
4577 * the file with null type, specify this by calling flex_stat() with
4578 * a '.' at the end of fspec.
4580 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4581 retval = stat(fileified,(stat_t *) statbufp);
4582 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4583 strcpy(namecache,fileified);
4585 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4587 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4588 # ifdef RTL_USES_UTC
4591 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4592 statbufp->st_atime = _toloc(statbufp->st_atime);
4593 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4598 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4602 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4603 statbufp->st_atime = _toutc(statbufp->st_atime);
4604 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4610 } /* end of flex_stat() */
4614 /*{{{char *my_getlogin()*/
4615 /* VMS cuserid == Unix getlogin, except calling sequence */
4619 static char user[L_cuserid];
4620 return cuserid(user);
4625 /* rmscopy - copy a file using VMS RMS routines
4627 * Copies contents and attributes of spec_in to spec_out, except owner
4628 * and protection information. Name and type of spec_in are used as
4629 * defaults for spec_out. The third parameter specifies whether rmscopy()
4630 * should try to propagate timestamps from the input file to the output file.
4631 * If it is less than 0, no timestamps are preserved. If it is 0, then
4632 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4633 * propagated to the output file at creation iff the output file specification
4634 * did not contain an explicit name or type, and the revision date is always
4635 * updated at the end of the copy operation. If it is greater than 0, then
4636 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4637 * other than the revision date should be propagated, and bit 1 indicates
4638 * that the revision date should be propagated.
4640 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4642 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4643 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4644 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4645 * as part of the Perl standard distribution under the terms of the
4646 * GNU General Public License or the Perl Artistic License. Copies
4647 * of each may be found in the Perl standard distribution.
4649 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4651 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4653 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4654 rsa[NAM$C_MAXRSS], ubf[32256];
4655 unsigned long int i, sts, sts2;
4656 struct FAB fab_in, fab_out;
4657 struct RAB rab_in, rab_out;
4659 struct XABDAT xabdat;
4660 struct XABFHC xabfhc;
4661 struct XABRDT xabrdt;
4662 struct XABSUM xabsum;
4664 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4665 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4666 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4670 fab_in = cc$rms_fab;
4671 fab_in.fab$l_fna = vmsin;
4672 fab_in.fab$b_fns = strlen(vmsin);
4673 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4674 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4675 fab_in.fab$l_fop = FAB$M_SQO;
4676 fab_in.fab$l_nam = &nam;
4677 fab_in.fab$l_xab = (void *) &xabdat;
4680 nam.nam$l_rsa = rsa;
4681 nam.nam$b_rss = sizeof(rsa);
4682 nam.nam$l_esa = esa;
4683 nam.nam$b_ess = sizeof (esa);
4684 nam.nam$b_esl = nam.nam$b_rsl = 0;
4686 xabdat = cc$rms_xabdat; /* To get creation date */
4687 xabdat.xab$l_nxt = (void *) &xabfhc;
4689 xabfhc = cc$rms_xabfhc; /* To get record length */
4690 xabfhc.xab$l_nxt = (void *) &xabsum;
4692 xabsum = cc$rms_xabsum; /* To get key and area information */
4694 if (!((sts = sys$open(&fab_in)) & 1)) {
4695 set_vaxc_errno(sts);
4699 set_errno(ENOENT); break;
4701 set_errno(ENODEV); break;
4703 set_errno(EINVAL); break;
4705 set_errno(EACCES); break;
4713 fab_out.fab$w_ifi = 0;
4714 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4715 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4716 fab_out.fab$l_fop = FAB$M_SQO;
4717 fab_out.fab$l_fna = vmsout;
4718 fab_out.fab$b_fns = strlen(vmsout);
4719 fab_out.fab$l_dna = nam.nam$l_name;
4720 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4722 if (preserve_dates == 0) { /* Act like DCL COPY */
4723 nam.nam$b_nop = NAM$M_SYNCHK;
4724 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4725 if (!((sts = sys$parse(&fab_out)) & 1)) {
4726 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4727 set_vaxc_errno(sts);
4730 fab_out.fab$l_xab = (void *) &xabdat;
4731 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4733 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4734 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4735 preserve_dates =0; /* bitmask from this point forward */
4737 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4738 if (!((sts = sys$create(&fab_out)) & 1)) {
4739 set_vaxc_errno(sts);
4742 set_errno(ENOENT); break;
4744 set_errno(ENODEV); break;
4746 set_errno(EINVAL); break;
4748 set_errno(EACCES); break;
4754 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4755 if (preserve_dates & 2) {
4756 /* sys$close() will process xabrdt, not xabdat */
4757 xabrdt = cc$rms_xabrdt;
4759 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4761 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4762 * is unsigned long[2], while DECC & VAXC use a struct */
4763 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4765 fab_out.fab$l_xab = (void *) &xabrdt;
4768 rab_in = cc$rms_rab;
4769 rab_in.rab$l_fab = &fab_in;
4770 rab_in.rab$l_rop = RAB$M_BIO;
4771 rab_in.rab$l_ubf = ubf;
4772 rab_in.rab$w_usz = sizeof ubf;
4773 if (!((sts = sys$connect(&rab_in)) & 1)) {
4774 sys$close(&fab_in); sys$close(&fab_out);
4775 set_errno(EVMSERR); set_vaxc_errno(sts);
4779 rab_out = cc$rms_rab;
4780 rab_out.rab$l_fab = &fab_out;
4781 rab_out.rab$l_rbf = ubf;
4782 if (!((sts = sys$connect(&rab_out)) & 1)) {
4783 sys$close(&fab_in); sys$close(&fab_out);
4784 set_errno(EVMSERR); set_vaxc_errno(sts);
4788 while ((sts = sys$read(&rab_in))) { /* always true */
4789 if (sts == RMS$_EOF) break;
4790 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4791 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4792 sys$close(&fab_in); sys$close(&fab_out);
4793 set_errno(EVMSERR); set_vaxc_errno(sts);
4798 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4799 sys$close(&fab_in); sys$close(&fab_out);
4800 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4802 set_errno(EVMSERR); set_vaxc_errno(sts);
4808 } /* end of rmscopy() */
4812 /*** The following glue provides 'hooks' to make some of the routines
4813 * from this file available from Perl. These routines are sufficiently
4814 * basic, and are required sufficiently early in the build process,
4815 * that's it's nice to have them available to miniperl as well as the
4816 * full Perl, so they're set up here instead of in an extension. The
4817 * Perl code which handles importation of these names into a given
4818 * package lives in [.VMS]Filespec.pm in @INC.
4822 rmsexpand_fromperl(CV *cv)
4825 char *fspec, *defspec = NULL, *rslt;
4828 if (!items || items > 2)
4829 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4830 fspec = SvPV(ST(0),n_a);
4831 if (!fspec || !*fspec) XSRETURN_UNDEF;
4832 if (items == 2) defspec = SvPV(ST(1),n_a);
4834 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4835 ST(0) = sv_newmortal();
4836 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4841 vmsify_fromperl(CV *cv)
4847 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4848 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4849 ST(0) = sv_newmortal();
4850 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4855 unixify_fromperl(CV *cv)
4861 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4862 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4863 ST(0) = sv_newmortal();
4864 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4869 fileify_fromperl(CV *cv)
4875 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4876 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4877 ST(0) = sv_newmortal();
4878 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4883 pathify_fromperl(CV *cv)
4889 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4890 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4891 ST(0) = sv_newmortal();
4892 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4897 vmspath_fromperl(CV *cv)
4903 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4904 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4905 ST(0) = sv_newmortal();
4906 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4911 unixpath_fromperl(CV *cv)
4917 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4918 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4919 ST(0) = sv_newmortal();
4920 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4925 candelete_fromperl(CV *cv)
4928 char fspec[NAM$C_MAXRSS+1], *fsp;
4933 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4935 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4936 if (SvTYPE(mysv) == SVt_PVGV) {
4937 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4938 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4945 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4946 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4952 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4957 rmscopy_fromperl(CV *cv)
4960 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4962 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4963 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4964 unsigned long int sts;
4969 if (items < 2 || items > 3)
4970 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4972 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4973 if (SvTYPE(mysv) == SVt_PVGV) {
4974 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4975 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4982 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
4983 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4988 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4989 if (SvTYPE(mysv) == SVt_PVGV) {
4990 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
4991 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4998 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
4999 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5004 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5006 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5013 char* file = __FILE__;
5015 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5016 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5017 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5018 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5019 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5020 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5021 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5022 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5023 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);