3 * VMS-specific routines for perl5
5 * Last revised: 15-Aug-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 /* True if we shouldn't treat barewords as logicals during directory */
96 static int no_translate_barewords;
98 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
100 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
101 struct dsc$descriptor_s **tabvec, unsigned long int flags)
103 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
104 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
105 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
106 unsigned char acmode;
107 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
108 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
109 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
110 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
112 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
113 #if defined(USE_THREADS)
114 /* We jump through these hoops because we can be called at */
115 /* platform-specific initialization time, which is before anything is */
116 /* set up--we can't even do a plain dTHX since that relies on the */
117 /* interpreter structure to be initialized */
118 struct perl_thread *thr;
120 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
126 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
127 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
129 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
130 *cp2 = _toupper(*cp1);
131 if (cp1 - lnm > LNM$C_NAMLENGTH) {
132 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
136 lnmdsc.dsc$w_length = cp1 - lnm;
137 lnmdsc.dsc$a_pointer = uplnm;
138 secure = flags & PERL__TRNENV_SECURE;
139 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
140 if (!tabvec || !*tabvec) tabvec = env_tables;
142 for (curtab = 0; tabvec[curtab]; curtab++) {
143 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
144 if (!ivenv && !secure) {
149 Perl_warn(aTHX_ "Can't read CRTL environ\n");
152 retsts = SS$_NOLOGNAM;
153 for (i = 0; environ[i]; i++) {
154 if ((eq = strchr(environ[i],'=')) &&
155 !strncmp(environ[i],uplnm,eq - environ[i])) {
157 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
158 if (!eqvlen) continue;
163 if (retsts != SS$_NOLOGNAM) break;
166 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
167 !str$case_blind_compare(&tmpdsc,&clisym)) {
168 if (!ivsym && !secure) {
169 unsigned short int deflen = LNM$C_NAMLENGTH;
170 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
171 /* dynamic dsc to accomodate possible long value */
172 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
173 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
176 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
178 /* Special hack--we might be called before the interpreter's */
179 /* fully initialized, in which case either thr or PL_curcop */
180 /* might be bogus. We have to check, since ckWARN needs them */
181 /* both to be valid if running threaded */
182 #if defined(USE_THREADS)
183 if (thr && PL_curcop) {
185 if (ckWARN(WARN_MISC)) {
186 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
188 #if defined(USE_THREADS)
190 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
195 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
197 _ckvmssts(lib$sfree1_dd(&eqvdsc));
198 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
199 if (retsts == LIB$_NOSUCHSYM) continue;
204 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
205 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
206 if (retsts == SS$_NOLOGNAM) continue;
210 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
211 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
212 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
213 retsts == SS$_NOLOGNAM) {
214 set_errno(EINVAL); set_vaxc_errno(retsts);
216 else _ckvmssts(retsts);
218 } /* end of vmstrnenv */
221 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
222 /* Define as a function so we can access statics. */
223 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
225 return vmstrnenv(lnm,eqv,idx,fildev,
226 #ifdef SECURE_INTERNAL_GETENV
227 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
236 * Note: Uses Perl temp to store result so char * can be returned to
237 * caller; this pointer will be invalidated at next Perl statement
239 * We define this as a function rather than a macro in terms of my_getenv_len()
240 * so that it'll work when PL_curinterp is undefined (and we therefore can't
243 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
245 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
247 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
248 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
249 unsigned long int idx = 0;
253 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
254 /* Set up a temporary buffer for the return value; Perl will
255 * clean it up at the next statement transition */
256 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
257 if (!tmpsv) return NULL;
260 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
261 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
262 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
263 getcwd(eqv,LNM$C_NAMLENGTH);
267 if ((cp2 = strchr(lnm,';')) != NULL) {
269 uplnm[cp2-lnm] = '\0';
270 idx = strtoul(cp2+1,NULL,0);
273 if (vmstrnenv(lnm,eqv,idx,
275 #ifdef SECURE_INTERNAL_GETENV
276 sys ? PERL__TRNENV_SECURE : 0
284 } /* end of my_getenv() */
288 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
290 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
293 char *buf, *cp1, *cp2;
294 unsigned long idx = 0;
295 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
298 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
299 /* Set up a temporary buffer for the return value; Perl will
300 * clean it up at the next statement transition */
301 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
302 if (!tmpsv) return NULL;
305 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
306 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
307 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
308 getcwd(buf,LNM$C_NAMLENGTH);
313 if ((cp2 = strchr(lnm,';')) != NULL) {
316 idx = strtoul(cp2+1,NULL,0);
319 if ((*len = vmstrnenv(lnm,buf,idx,
321 #ifdef SECURE_INTERNAL_GETENV
322 sys ? PERL__TRNENV_SECURE : 0
332 } /* end of my_getenv_len() */
335 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
337 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
339 /*{{{ void prime_env_iter() */
342 /* Fill the %ENV associative array with all logical names we can
343 * find, in preparation for iterating over it.
347 static int primed = 0;
348 HV *seenhv = NULL, *envhv;
349 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
350 unsigned short int chan;
351 #ifndef CLI$M_TRUSTED
352 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
354 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
355 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
357 bool have_sym = FALSE, have_lnm = FALSE;
358 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
359 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
360 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
361 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
362 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
364 static perl_mutex primenv_mutex;
365 MUTEX_INIT(&primenv_mutex);
368 if (primed || !PL_envgv) return;
369 MUTEX_LOCK(&primenv_mutex);
370 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
371 envhv = GvHVn(PL_envgv);
372 /* Perform a dummy fetch as an lval to insure that the hash table is
373 * set up. Otherwise, the hv_store() will turn into a nullop. */
374 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
376 for (i = 0; env_tables[i]; i++) {
377 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
378 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
379 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
381 if (have_sym || have_lnm) {
382 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
383 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
384 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
385 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
388 for (i--; i >= 0; i--) {
389 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
392 for (j = 0; environ[j]; j++) {
393 if (!(start = strchr(environ[j],'='))) {
394 if (ckWARN(WARN_INTERNAL))
395 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
399 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
405 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
406 !str$case_blind_compare(&tmpdsc,&clisym)) {
407 strcpy(cmd,"Show Symbol/Global *");
408 cmddsc.dsc$w_length = 20;
409 if (env_tables[i]->dsc$w_length == 12 &&
410 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
411 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
412 flags = defflags | CLI$M_NOLOGNAM;
415 strcpy(cmd,"Show Logical *");
416 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
417 strcat(cmd," /Table=");
418 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
419 cmddsc.dsc$w_length = strlen(cmd);
421 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
422 flags = defflags | CLI$M_NOCLISYM;
425 /* Create a new subprocess to execute each command, to exclude the
426 * remote possibility that someone could subvert a mbx or file used
427 * to write multiple commands to a single subprocess.
430 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
431 0,&riseandshine,0,0,&clidsc,&clitabdsc);
432 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
433 defflags &= ~CLI$M_TRUSTED;
434 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
436 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
437 if (seenhv) SvREFCNT_dec(seenhv);
440 char *cp1, *cp2, *key;
441 unsigned long int sts, iosb[2], retlen, keylen;
444 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
445 if (sts & 1) sts = iosb[0] & 0xffff;
446 if (sts == SS$_ENDOFFILE) {
448 while (substs == 0) { sys$hiber(); wakect++;}
449 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
454 retlen = iosb[0] >> 16;
455 if (!retlen) continue; /* blank line */
457 if (iosb[1] != subpid) {
459 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
463 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
466 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
467 if (*cp1 == '(' || /* Logical name table name */
468 *cp1 == '=' /* Next eqv of searchlist */) continue;
469 if (*cp1 == '"') cp1++;
470 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
471 key = cp1; keylen = cp2 - cp1;
472 if (keylen && hv_exists(seenhv,key,keylen)) continue;
473 while (*cp2 && *cp2 != '=') cp2++;
474 while (*cp2 && *cp2 == '=') cp2++;
475 while (*cp2 && *cp2 == ' ') cp2++;
476 if (*cp2 == '"') { /* String translation; may embed "" */
477 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
478 cp2++; cp1--; /* Skip "" surrounding translation */
480 else { /* Numeric translation */
481 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
482 cp1--; /* stop on last non-space char */
484 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
485 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
488 PERL_HASH(hash,key,keylen);
489 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
490 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
492 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
493 /* get the PPFs for this process, not the subprocess */
494 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
495 char eqv[LNM$C_NAMLENGTH+1];
497 for (i = 0; ppfs[i]; i++) {
498 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
499 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
504 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
505 if (buf) Safefree(buf);
506 if (seenhv) SvREFCNT_dec(seenhv);
507 MUTEX_UNLOCK(&primenv_mutex);
510 } /* end of prime_env_iter */
514 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
515 /* Define or delete an element in the same "environment" as
516 * vmstrnenv(). If an element is to be deleted, it's removed from
517 * the first place it's found. If it's to be set, it's set in the
518 * place designated by the first element of the table vector.
519 * Like setenv() returns 0 for success, non-zero on error.
522 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
524 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
525 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
526 unsigned long int retsts, usermode = PSL$C_USER;
527 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
528 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
529 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
530 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
531 $DESCRIPTOR(local,"_LOCAL");
534 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
535 *cp2 = _toupper(*cp1);
536 if (cp1 - lnm > LNM$C_NAMLENGTH) {
537 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
541 lnmdsc.dsc$w_length = cp1 - lnm;
542 if (!tabvec || !*tabvec) tabvec = env_tables;
544 if (!eqv) { /* we're deleting n element */
545 for (curtab = 0; tabvec[curtab]; curtab++) {
546 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
548 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
549 if ((cp1 = strchr(environ[i],'=')) &&
550 !strncmp(environ[i],lnm,cp1 - environ[i])) {
552 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
555 ivenv = 1; retsts = SS$_NOLOGNAM;
557 if (ckWARN(WARN_INTERNAL))
558 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
559 ivenv = 1; retsts = SS$_NOSUCHPGM;
565 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
566 !str$case_blind_compare(&tmpdsc,&clisym)) {
567 unsigned int symtype;
568 if (tabvec[curtab]->dsc$w_length == 12 &&
569 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
570 !str$case_blind_compare(&tmpdsc,&local))
571 symtype = LIB$K_CLI_LOCAL_SYM;
572 else symtype = LIB$K_CLI_GLOBAL_SYM;
573 retsts = lib$delete_symbol(&lnmdsc,&symtype);
574 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
575 if (retsts == LIB$_NOSUCHSYM) continue;
579 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
580 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
581 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
582 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
583 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
587 else { /* we're defining a value */
588 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
590 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
592 if (ckWARN(WARN_INTERNAL))
593 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
594 retsts = SS$_NOSUCHPGM;
598 eqvdsc.dsc$a_pointer = eqv;
599 eqvdsc.dsc$w_length = strlen(eqv);
600 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
601 !str$case_blind_compare(&tmpdsc,&clisym)) {
602 unsigned int symtype;
603 if (tabvec[0]->dsc$w_length == 12 &&
604 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
605 !str$case_blind_compare(&tmpdsc,&local))
606 symtype = LIB$K_CLI_LOCAL_SYM;
607 else symtype = LIB$K_CLI_GLOBAL_SYM;
608 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
611 if (!*eqv) eqvdsc.dsc$w_length = 1;
612 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
618 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
619 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
620 set_errno(EVMSERR); break;
621 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
622 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
623 set_errno(EINVAL); break;
630 set_vaxc_errno(retsts);
631 return (int) retsts || 44; /* retsts should never be 0, but just in case */
634 /* We reset error values on success because Perl does an hv_fetch()
635 * before each hv_store(), and if the thing we're setting didn't
636 * previously exist, we've got a leftover error message. (Of course,
637 * this fails in the face of
638 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
639 * in that the error reported in $! isn't spurious,
640 * but it's right more often than not.)
642 set_errno(0); set_vaxc_errno(retsts);
646 } /* end of vmssetenv() */
649 /*{{{ void my_setenv(char *lnm, char *eqv)*/
650 /* This has to be a function since there's a prototype for it in proto.h */
652 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
654 if (lnm && *lnm && strlen(lnm) == 7) {
657 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
658 if (!strcmp(uplnm,"DEFAULT")) {
659 if (eqv && *eqv) chdir(eqv);
663 (void) vmssetenv(lnm,eqv,NULL);
669 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
670 /* my_crypt - VMS password hashing
671 * my_crypt() provides an interface compatible with the Unix crypt()
672 * C library function, and uses sys$hash_password() to perform VMS
673 * password hashing. The quadword hashed password value is returned
674 * as a NUL-terminated 8 character string. my_crypt() does not change
675 * the case of its string arguments; in order to match the behavior
676 * of LOGINOUT et al., alphabetic characters in both arguments must
677 * be upcased by the caller.
680 my_crypt(const char *textpasswd, const char *usrname)
682 # ifndef UAI$C_PREFERRED_ALGORITHM
683 # define UAI$C_PREFERRED_ALGORITHM 127
685 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
686 unsigned short int salt = 0;
687 unsigned long int sts;
689 unsigned short int dsc$w_length;
690 unsigned char dsc$b_type;
691 unsigned char dsc$b_class;
692 const char * dsc$a_pointer;
693 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
694 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
695 struct itmlst_3 uailst[3] = {
696 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
697 { sizeof salt, UAI$_SALT, &salt, 0},
698 { 0, 0, NULL, NULL}};
701 usrdsc.dsc$w_length = strlen(usrname);
702 usrdsc.dsc$a_pointer = usrname;
703 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
710 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
716 if (sts != RMS$_RNF) return NULL;
719 txtdsc.dsc$w_length = strlen(textpasswd);
720 txtdsc.dsc$a_pointer = textpasswd;
721 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
722 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
725 return (char *) hash;
727 } /* end of my_crypt() */
731 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
732 static char *do_fileify_dirspec(char *, char *, int);
733 static char *do_tovmsspec(char *, char *, int);
735 /*{{{int do_rmdir(char *name)*/
739 char dirfile[NAM$C_MAXRSS+1];
743 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
744 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
745 else retval = kill_file(dirfile);
748 } /* end of do_rmdir */
752 * Delete any file to which user has control access, regardless of whether
753 * delete access is explicitly allowed.
754 * Limitations: User must have write access to parent directory.
755 * Does not block signals or ASTs; if interrupted in midstream
756 * may leave file with an altered ACL.
759 /*{{{int kill_file(char *name)*/
761 kill_file(char *name)
763 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
764 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
765 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
767 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
769 unsigned char myace$b_length;
770 unsigned char myace$b_type;
771 unsigned short int myace$w_flags;
772 unsigned long int myace$l_access;
773 unsigned long int myace$l_ident;
774 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
775 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
776 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
778 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
779 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
780 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
781 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
782 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
783 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
785 /* Expand the input spec using RMS, since the CRTL remove() and
786 * system services won't do this by themselves, so we may miss
787 * a file "hiding" behind a logical name or search list. */
788 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
789 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
790 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
791 /* If not, can changing protections help? */
792 if (vaxc$errno != RMS$_PRV) return -1;
794 /* No, so we get our own UIC to use as a rights identifier,
795 * and the insert an ACE at the head of the ACL which allows us
796 * to delete the file.
798 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
799 fildsc.dsc$w_length = strlen(rspec);
800 fildsc.dsc$a_pointer = rspec;
802 newace.myace$l_ident = oldace.myace$l_ident;
803 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
808 case SS$_NOSUCHOBJECT:
809 set_errno(ENOENT); break;
811 set_errno(ENODEV); break;
813 case SS$_INVFILFOROP:
814 set_errno(EINVAL); break;
816 set_errno(EACCES); break;
820 set_vaxc_errno(aclsts);
823 /* Grab any existing ACEs with this identifier in case we fail */
824 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
825 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
826 || fndsts == SS$_NOMOREACE ) {
827 /* Add the new ACE . . . */
828 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
830 if ((rmsts = remove(name))) {
831 /* We blew it - dir with files in it, no write priv for
832 * parent directory, etc. Put things back the way they were. */
833 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
836 addlst[0].bufadr = &oldace;
837 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
844 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
845 /* We just deleted it, so of course it's not there. Some versions of
846 * VMS seem to return success on the unlock operation anyhow (after all
847 * the unlock is successful), but others don't.
849 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
850 if (aclsts & 1) aclsts = fndsts;
853 set_vaxc_errno(aclsts);
859 } /* end of kill_file() */
863 /*{{{int my_mkdir(char *,Mode_t)*/
865 my_mkdir(char *dir, Mode_t mode)
867 STRLEN dirlen = strlen(dir);
870 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
871 * null file name/type. However, it's commonplace under Unix,
872 * so we'll allow it for a gain in portability.
874 if (dir[dirlen-1] == '/') {
875 char *newdir = savepvn(dir,dirlen-1);
876 int ret = mkdir(newdir,mode);
880 else return mkdir(dir,mode);
881 } /* end of my_mkdir */
886 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
888 static unsigned long int mbxbufsiz;
889 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
894 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
895 * preprocessor consant BUFSIZ from stdio.h as the size of the
898 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
899 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
901 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
903 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
904 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
906 } /* end of create_mbx() */
908 /*{{{ my_popen and my_pclose*/
911 struct pipe_details *next;
912 PerlIO *fp; /* stdio file pointer to pipe mailbox */
913 int pid; /* PID of subprocess */
914 int mode; /* == 'r' if pipe open for reading */
915 int done; /* subprocess has completed */
916 unsigned long int completion; /* termination status of subprocess */
919 struct exit_control_block
921 struct exit_control_block *flink;
922 unsigned long int (*exit_routine)();
923 unsigned long int arg_count;
924 unsigned long int *status_address;
925 unsigned long int exit_status;
928 static struct pipe_details *open_pipes = NULL;
929 static $DESCRIPTOR(nl_desc, "NL:");
930 static int waitpid_asleep = 0;
932 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
933 * to a mbx; that's the caller's responsibility.
935 static unsigned long int
936 pipe_eof(FILE *fp, int immediate)
938 char devnam[NAM$C_MAXRSS+1], *cp;
939 unsigned long int chan, iosb[2], retsts, retsts2;
940 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
943 if (fgetname(fp,devnam,1)) {
944 /* It oughta be a mailbox, so fgetname should give just the device
945 * name, but just in case . . . */
946 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
947 devdsc.dsc$w_length = strlen(devnam);
948 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
949 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
950 iosb,0,0,0,0,0,0,0,0);
951 if (retsts & 1) retsts = iosb[0];
952 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
953 if (retsts & 1) retsts = retsts2;
957 else _ckvmssts(vaxc$errno); /* Should never happen */
958 return (unsigned long int) vaxc$errno;
961 static unsigned long int
964 struct pipe_details *info;
965 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
970 first we try sending an EOF...ignore if doesn't work, make sure we
977 if (info->mode != 'r' && !info->done) {
978 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
982 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
987 if (!info->done) { /* Tap them gently on the shoulder . . .*/
988 sts = sys$forcex(&info->pid,0,&abort);
989 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
994 if (did_stuff) sleep(1); /* wait for them to respond */
998 if (!info->done) { /* We tried to be nice . . . */
999 sts = sys$delprc(&info->pid,0);
1000 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1001 info->done = 1; /* so my_pclose doesn't try to write EOF */
1007 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1008 else if (!(sts & 1)) retsts = sts;
1013 static struct exit_control_block pipe_exitblock =
1014 {(struct exit_control_block *) 0,
1015 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1019 popen_completion_ast(struct pipe_details *thispipe)
1021 thispipe->done = TRUE;
1022 if (waitpid_asleep) {
1029 safe_popen(char *cmd, char *mode)
1031 static int handler_set_up = FALSE;
1033 unsigned short int chan;
1034 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
1036 struct pipe_details *info;
1037 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1038 DSC$K_CLASS_S, mbxname},
1039 cmddsc = {0, DSC$K_DTYPE_T,
1043 cmddsc.dsc$w_length=strlen(cmd);
1044 cmddsc.dsc$a_pointer=cmd;
1045 if (cmddsc.dsc$w_length > 255) {
1046 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
1050 New(1301,info,1,struct pipe_details);
1052 /* create mailbox */
1053 create_mbx(&chan,&namdsc);
1055 /* open a FILE* onto it */
1056 info->fp = PerlIO_open(mbxname, mode);
1058 /* give up other channel onto it */
1059 _ckvmssts(sys$dassgn(chan));
1069 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1070 0 /* name */, &info->pid, &info->completion,
1071 0, popen_completion_ast,info,0,0,0));
1074 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1075 0 /* name */, &info->pid, &info->completion,
1076 0, popen_completion_ast,info,0,0,0));
1079 if (!handler_set_up) {
1080 _ckvmssts(sys$dclexh(&pipe_exitblock));
1081 handler_set_up = TRUE;
1083 info->next=open_pipes; /* prepend to list */
1086 PL_forkprocess = info->pid;
1088 } /* end of safe_popen */
1091 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1093 Perl_my_popen(pTHX_ char *cmd, char *mode)
1096 TAINT_PROPER("popen");
1097 PERL_FLUSHALL_FOR_CHILD;
1098 return safe_popen(cmd,mode);
1103 /*{{{ I32 my_pclose(FILE *fp)*/
1104 I32 Perl_my_pclose(pTHX_ FILE *fp)
1106 struct pipe_details *info, *last = NULL;
1107 unsigned long int retsts;
1109 for (info = open_pipes; info != NULL; last = info, info = info->next)
1110 if (info->fp == fp) break;
1112 if (info == NULL) { /* no such pipe open */
1113 set_errno(ECHILD); /* quoth POSIX */
1114 set_vaxc_errno(SS$_NONEXPR);
1118 /* If we were writing to a subprocess, insure that someone reading from
1119 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1120 * produce an EOF record in the mailbox. */
1121 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
1122 PerlIO_close(info->fp);
1124 if (info->done) retsts = info->completion;
1125 else waitpid(info->pid,(int *) &retsts,0);
1127 /* remove from list of open pipes */
1128 if (last) last->next = info->next;
1129 else open_pipes = info->next;
1134 } /* end of my_pclose() */
1136 /* sort-of waitpid; use only with popen() */
1137 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1139 my_waitpid(Pid_t pid, int *statusp, int flags)
1141 struct pipe_details *info;
1144 for (info = open_pipes; info != NULL; info = info->next)
1145 if (info->pid == pid) break;
1147 if (info != NULL) { /* we know about this child */
1148 while (!info->done) {
1153 *statusp = info->completion;
1156 else { /* we haven't heard of this child */
1157 $DESCRIPTOR(intdsc,"0 00:00:01");
1158 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1159 unsigned long int interval[2],sts;
1161 if (ckWARN(WARN_EXEC)) {
1162 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1163 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1164 if (ownerpid != mypid)
1165 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1168 _ckvmssts(sys$bintim(&intdsc,interval));
1169 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1170 _ckvmssts(sys$schdwk(0,0,interval,0));
1171 _ckvmssts(sys$hiber());
1175 /* There's no easy way to find the termination status a child we're
1176 * not aware of beforehand. If we're really interested in the future,
1177 * we can go looking for a termination mailbox, or chase after the
1178 * accounting record for the process.
1184 } /* end of waitpid() */
1189 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1191 my_gconvert(double val, int ndig, int trail, char *buf)
1193 static char __gcvtbuf[DBL_DIG+1];
1196 loc = buf ? buf : __gcvtbuf;
1198 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1200 sprintf(loc,"%.*g",ndig,val);
1206 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1207 return gcvt(val,ndig,loc);
1210 loc[0] = '0'; loc[1] = '\0';
1218 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1219 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1220 * to expand file specification. Allows for a single default file
1221 * specification and a simple mask of options. If outbuf is non-NULL,
1222 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1223 * the resultant file specification is placed. If outbuf is NULL, the
1224 * resultant file specification is placed into a static buffer.
1225 * The third argument, if non-NULL, is taken to be a default file
1226 * specification string. The fourth argument is unused at present.
1227 * rmesexpand() returns the address of the resultant string if
1228 * successful, and NULL on error.
1230 static char *do_tounixspec(char *, char *, int);
1233 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1235 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1236 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1237 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1238 struct FAB myfab = cc$rms_fab;
1239 struct NAM mynam = cc$rms_nam;
1241 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1243 if (!filespec || !*filespec) {
1244 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1248 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1249 else outbuf = __rmsexpand_retbuf;
1251 if ((isunix = (strchr(filespec,'/') != NULL))) {
1252 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1253 filespec = vmsfspec;
1256 myfab.fab$l_fna = filespec;
1257 myfab.fab$b_fns = strlen(filespec);
1258 myfab.fab$l_nam = &mynam;
1260 if (defspec && *defspec) {
1261 if (strchr(defspec,'/') != NULL) {
1262 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1265 myfab.fab$l_dna = defspec;
1266 myfab.fab$b_dns = strlen(defspec);
1269 mynam.nam$l_esa = esa;
1270 mynam.nam$b_ess = sizeof esa;
1271 mynam.nam$l_rsa = outbuf;
1272 mynam.nam$b_rss = NAM$C_MAXRSS;
1274 retsts = sys$parse(&myfab,0,0);
1275 if (!(retsts & 1)) {
1276 mynam.nam$b_nop |= NAM$M_SYNCHK;
1277 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1278 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1279 retsts = sys$parse(&myfab,0,0);
1280 if (retsts & 1) goto expanded;
1282 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1283 (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 if (retsts == RMS$_DEV) set_errno(ENODEV);
1288 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1289 else set_errno(EVMSERR);
1292 retsts = sys$search(&myfab,0,0);
1293 if (!(retsts & 1) && retsts != RMS$_FNF) {
1294 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1295 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1296 if (out) Safefree(out);
1297 set_vaxc_errno(retsts);
1298 if (retsts == RMS$_PRV) set_errno(EACCES);
1299 else set_errno(EVMSERR);
1303 /* If the input filespec contained any lowercase characters,
1304 * downcase the result for compatibility with Unix-minded code. */
1306 for (out = myfab.fab$l_fna; *out; out++)
1307 if (islower(*out)) { haslower = 1; break; }
1308 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1309 else { out = esa; speclen = mynam.nam$b_esl; }
1310 /* Trim off null fields added by $PARSE
1311 * If type > 1 char, must have been specified in original or default spec
1312 * (not true for version; $SEARCH may have added version of existing file).
1314 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1315 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1316 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1317 if (trimver || trimtype) {
1318 if (defspec && *defspec) {
1319 char defesa[NAM$C_MAXRSS];
1320 struct FAB deffab = cc$rms_fab;
1321 struct NAM defnam = cc$rms_nam;
1323 deffab.fab$l_nam = &defnam;
1324 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1325 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1326 defnam.nam$b_nop = NAM$M_SYNCHK;
1327 if (sys$parse(&deffab,0,0) & 1) {
1328 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1329 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1332 if (trimver) speclen = mynam.nam$l_ver - out;
1334 /* If we didn't already trim version, copy down */
1335 if (speclen > mynam.nam$l_ver - out)
1336 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1337 speclen - (mynam.nam$l_ver - out));
1338 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1341 /* If we just had a directory spec on input, $PARSE "helpfully"
1342 * adds an empty name and type for us */
1343 if (mynam.nam$l_name == mynam.nam$l_type &&
1344 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1345 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1346 speclen = mynam.nam$l_name - out;
1347 out[speclen] = '\0';
1348 if (haslower) __mystrtolower(out);
1350 /* Have we been working with an expanded, but not resultant, spec? */
1351 /* Also, convert back to Unix syntax if necessary. */
1352 if (!mynam.nam$b_rsl) {
1354 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1356 else strcpy(outbuf,esa);
1359 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1360 strcpy(outbuf,tmpfspec);
1362 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1363 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1364 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1368 /* External entry points */
1369 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1370 { return do_rmsexpand(spec,buf,0,def,opt); }
1371 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1372 { return do_rmsexpand(spec,buf,1,def,opt); }
1376 ** The following routines are provided to make life easier when
1377 ** converting among VMS-style and Unix-style directory specifications.
1378 ** All will take input specifications in either VMS or Unix syntax. On
1379 ** failure, all return NULL. If successful, the routines listed below
1380 ** return a pointer to a buffer containing the appropriately
1381 ** reformatted spec (and, therefore, subsequent calls to that routine
1382 ** will clobber the result), while the routines of the same names with
1383 ** a _ts suffix appended will return a pointer to a mallocd string
1384 ** containing the appropriately reformatted spec.
1385 ** In all cases, only explicit syntax is altered; no check is made that
1386 ** the resulting string is valid or that the directory in question
1389 ** fileify_dirspec() - convert a directory spec into the name of the
1390 ** directory file (i.e. what you can stat() to see if it's a dir).
1391 ** The style (VMS or Unix) of the result is the same as the style
1392 ** of the parameter passed in.
1393 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1394 ** what you prepend to a filename to indicate what directory it's in).
1395 ** The style (VMS or Unix) of the result is the same as the style
1396 ** of the parameter passed in.
1397 ** tounixpath() - convert a directory spec into a Unix-style path.
1398 ** tovmspath() - convert a directory spec into a VMS-style path.
1399 ** tounixspec() - convert any file spec into a Unix-style file spec.
1400 ** tovmsspec() - convert any file spec into a VMS-style spec.
1402 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1403 ** Permission is given to distribute this code as part of the Perl
1404 ** standard distribution under the terms of the GNU General Public
1405 ** License or the Perl Artistic License. Copies of each may be
1406 ** found in the Perl standard distribution.
1409 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1410 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1412 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1413 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1414 char *retspec, *cp1, *cp2, *lastdir;
1415 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1417 if (!dir || !*dir) {
1418 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1420 dirlen = strlen(dir);
1421 while (dir[dirlen-1] == '/') --dirlen;
1422 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1423 strcpy(trndir,"/sys$disk/000000");
1427 if (dirlen > NAM$C_MAXRSS) {
1428 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1430 if (!strpbrk(dir+1,"/]>:")) {
1431 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1432 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1434 dirlen = strlen(dir);
1437 strncpy(trndir,dir,dirlen);
1438 trndir[dirlen] = '\0';
1441 /* If we were handed a rooted logical name or spec, treat it like a
1442 * simple directory, so that
1443 * $ Define myroot dev:[dir.]
1444 * ... do_fileify_dirspec("myroot",buf,1) ...
1445 * does something useful.
1447 if (!strcmp(dir+dirlen-2,".]")) {
1448 dir[--dirlen] = '\0';
1449 dir[dirlen-1] = ']';
1452 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1453 /* If we've got an explicit filename, we can just shuffle the string. */
1454 if (*(cp1+1)) hasfilename = 1;
1455 /* Similarly, we can just back up a level if we've got multiple levels
1456 of explicit directories in a VMS spec which ends with directories. */
1458 for (cp2 = cp1; cp2 > dir; cp2--) {
1460 *cp2 = *cp1; *cp1 = '\0';
1464 if (*cp2 == '[' || *cp2 == '<') break;
1469 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1470 if (dir[0] == '.') {
1471 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1472 return do_fileify_dirspec("[]",buf,ts);
1473 else if (dir[1] == '.' &&
1474 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1475 return do_fileify_dirspec("[-]",buf,ts);
1477 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1478 dirlen -= 1; /* to last element */
1479 lastdir = strrchr(dir,'/');
1481 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1482 /* If we have "/." or "/..", VMSify it and let the VMS code
1483 * below expand it, rather than repeating the code to handle
1484 * relative components of a filespec here */
1486 if (*(cp1+2) == '.') cp1++;
1487 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1488 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1489 if (strchr(vmsdir,'/') != NULL) {
1490 /* If do_tovmsspec() returned it, it must have VMS syntax
1491 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1492 * the time to check this here only so we avoid a recursion
1493 * loop; otherwise, gigo.
1495 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1497 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1498 return do_tounixspec(trndir,buf,ts);
1501 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1502 lastdir = strrchr(dir,'/');
1504 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1505 /* Ditto for specs that end in an MFD -- let the VMS code
1506 * figure out whether it's a real device or a rooted logical. */
1507 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1508 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1509 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1510 return do_tounixspec(trndir,buf,ts);
1513 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1514 !(lastdir = cp1 = strrchr(dir,']')) &&
1515 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1516 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1518 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1519 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1520 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1521 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1522 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1523 (ver || *cp3)))))) {
1525 set_vaxc_errno(RMS$_DIR);
1531 /* If we lead off with a device or rooted logical, add the MFD
1532 if we're specifying a top-level directory. */
1533 if (lastdir && *dir == '/') {
1535 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1542 retlen = dirlen + (addmfd ? 13 : 6);
1543 if (buf) retspec = buf;
1544 else if (ts) New(1309,retspec,retlen+1,char);
1545 else retspec = __fileify_retbuf;
1547 dirlen = lastdir - dir;
1548 memcpy(retspec,dir,dirlen);
1549 strcpy(&retspec[dirlen],"/000000");
1550 strcpy(&retspec[dirlen+7],lastdir);
1553 memcpy(retspec,dir,dirlen);
1554 retspec[dirlen] = '\0';
1556 /* We've picked up everything up to the directory file name.
1557 Now just add the type and version, and we're set. */
1558 strcat(retspec,".dir;1");
1561 else { /* VMS-style directory spec */
1562 char esa[NAM$C_MAXRSS+1], term, *cp;
1563 unsigned long int sts, cmplen, haslower = 0;
1564 struct FAB dirfab = cc$rms_fab;
1565 struct NAM savnam, dirnam = cc$rms_nam;
1567 dirfab.fab$b_fns = strlen(dir);
1568 dirfab.fab$l_fna = dir;
1569 dirfab.fab$l_nam = &dirnam;
1570 dirfab.fab$l_dna = ".DIR;1";
1571 dirfab.fab$b_dns = 6;
1572 dirnam.nam$b_ess = NAM$C_MAXRSS;
1573 dirnam.nam$l_esa = esa;
1575 for (cp = dir; *cp; cp++)
1576 if (islower(*cp)) { haslower = 1; break; }
1577 if (!((sts = sys$parse(&dirfab))&1)) {
1578 if (dirfab.fab$l_sts == RMS$_DIR) {
1579 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1580 sts = sys$parse(&dirfab) & 1;
1584 set_vaxc_errno(dirfab.fab$l_sts);
1590 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1591 /* Yes; fake the fnb bits so we'll check type below */
1592 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1595 if (dirfab.fab$l_sts != RMS$_FNF) {
1597 set_vaxc_errno(dirfab.fab$l_sts);
1600 dirnam = savnam; /* No; just work with potential name */
1603 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1604 cp1 = strchr(esa,']');
1605 if (!cp1) cp1 = strchr(esa,'>');
1606 if (cp1) { /* Should always be true */
1607 dirnam.nam$b_esl -= cp1 - esa - 1;
1608 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1611 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1612 /* Yep; check version while we're at it, if it's there. */
1613 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1614 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1615 /* Something other than .DIR[;1]. Bzzt. */
1617 set_vaxc_errno(RMS$_DIR);
1621 esa[dirnam.nam$b_esl] = '\0';
1622 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1623 /* They provided at least the name; we added the type, if necessary, */
1624 if (buf) retspec = buf; /* in sys$parse() */
1625 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1626 else retspec = __fileify_retbuf;
1627 strcpy(retspec,esa);
1630 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1631 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1633 dirnam.nam$b_esl -= 9;
1635 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1636 if (cp1 == NULL) return NULL; /* should never happen */
1639 retlen = strlen(esa);
1640 if ((cp1 = strrchr(esa,'.')) != NULL) {
1641 /* There's more than one directory in the path. Just roll back. */
1643 if (buf) retspec = buf;
1644 else if (ts) New(1311,retspec,retlen+7,char);
1645 else retspec = __fileify_retbuf;
1646 strcpy(retspec,esa);
1649 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1650 /* Go back and expand rooted logical name */
1651 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1652 if (!(sys$parse(&dirfab) & 1)) {
1654 set_vaxc_errno(dirfab.fab$l_sts);
1657 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1658 if (buf) retspec = buf;
1659 else if (ts) New(1312,retspec,retlen+16,char);
1660 else retspec = __fileify_retbuf;
1661 cp1 = strstr(esa,"][");
1663 memcpy(retspec,esa,dirlen);
1664 if (!strncmp(cp1+2,"000000]",7)) {
1665 retspec[dirlen-1] = '\0';
1666 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1667 if (*cp1 == '.') *cp1 = ']';
1669 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1670 memcpy(cp1+1,"000000]",7);
1674 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1675 retspec[retlen] = '\0';
1676 /* Convert last '.' to ']' */
1677 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1678 if (*cp1 == '.') *cp1 = ']';
1680 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1681 memcpy(cp1+1,"000000]",7);
1685 else { /* This is a top-level dir. Add the MFD to the path. */
1686 if (buf) retspec = buf;
1687 else if (ts) New(1312,retspec,retlen+16,char);
1688 else retspec = __fileify_retbuf;
1691 while (*cp1 != ':') *(cp2++) = *(cp1++);
1692 strcpy(cp2,":[000000]");
1697 /* We've set up the string up through the filename. Add the
1698 type and version, and we're done. */
1699 strcat(retspec,".DIR;1");
1701 /* $PARSE may have upcased filespec, so convert output to lower
1702 * case if input contained any lowercase characters. */
1703 if (haslower) __mystrtolower(retspec);
1706 } /* end of do_fileify_dirspec() */
1708 /* External entry points */
1709 char *fileify_dirspec(char *dir, char *buf)
1710 { return do_fileify_dirspec(dir,buf,0); }
1711 char *fileify_dirspec_ts(char *dir, char *buf)
1712 { return do_fileify_dirspec(dir,buf,1); }
1714 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1715 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1717 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1718 unsigned long int retlen;
1719 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1721 if (!dir || !*dir) {
1722 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1725 if (*dir) strcpy(trndir,dir);
1726 else getcwd(trndir,sizeof trndir - 1);
1728 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1729 && my_trnlnm(trndir,trndir,0)) {
1730 STRLEN trnlen = strlen(trndir);
1732 /* Trap simple rooted lnms, and return lnm:[000000] */
1733 if (!strcmp(trndir+trnlen-2,".]")) {
1734 if (buf) retpath = buf;
1735 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1736 else retpath = __pathify_retbuf;
1737 strcpy(retpath,dir);
1738 strcat(retpath,":[000000]");
1744 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1745 if (*dir == '.' && (*(dir+1) == '\0' ||
1746 (*(dir+1) == '.' && *(dir+2) == '\0')))
1747 retlen = 2 + (*(dir+1) != '\0');
1749 if ( !(cp1 = strrchr(dir,'/')) &&
1750 !(cp1 = strrchr(dir,']')) &&
1751 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1752 if ((cp2 = strchr(cp1,'.')) != NULL &&
1753 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1754 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1755 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1756 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1758 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1759 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1760 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1761 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1762 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1763 (ver || *cp3)))))) {
1765 set_vaxc_errno(RMS$_DIR);
1768 retlen = cp2 - dir + 1;
1770 else { /* No file type present. Treat the filename as a directory. */
1771 retlen = strlen(dir) + 1;
1774 if (buf) retpath = buf;
1775 else if (ts) New(1313,retpath,retlen+1,char);
1776 else retpath = __pathify_retbuf;
1777 strncpy(retpath,dir,retlen-1);
1778 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1779 retpath[retlen-1] = '/'; /* with '/', add it. */
1780 retpath[retlen] = '\0';
1782 else retpath[retlen-1] = '\0';
1784 else { /* VMS-style directory spec */
1785 char esa[NAM$C_MAXRSS+1], *cp;
1786 unsigned long int sts, cmplen, haslower;
1787 struct FAB dirfab = cc$rms_fab;
1788 struct NAM savnam, dirnam = cc$rms_nam;
1790 /* If we've got an explicit filename, we can just shuffle the string. */
1791 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1792 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1793 if ((cp2 = strchr(cp1,'.')) != NULL) {
1795 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1796 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1797 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1798 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1799 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1800 (ver || *cp3)))))) {
1802 set_vaxc_errno(RMS$_DIR);
1806 else { /* No file type, so just draw name into directory part */
1807 for (cp2 = cp1; *cp2; cp2++) ;
1810 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1812 /* We've now got a VMS 'path'; fall through */
1814 dirfab.fab$b_fns = strlen(dir);
1815 dirfab.fab$l_fna = dir;
1816 if (dir[dirfab.fab$b_fns-1] == ']' ||
1817 dir[dirfab.fab$b_fns-1] == '>' ||
1818 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1819 if (buf) retpath = buf;
1820 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1821 else retpath = __pathify_retbuf;
1822 strcpy(retpath,dir);
1825 dirfab.fab$l_dna = ".DIR;1";
1826 dirfab.fab$b_dns = 6;
1827 dirfab.fab$l_nam = &dirnam;
1828 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1829 dirnam.nam$l_esa = esa;
1831 for (cp = dir; *cp; cp++)
1832 if (islower(*cp)) { haslower = 1; break; }
1834 if (!(sts = (sys$parse(&dirfab)&1))) {
1835 if (dirfab.fab$l_sts == RMS$_DIR) {
1836 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1837 sts = sys$parse(&dirfab) & 1;
1841 set_vaxc_errno(dirfab.fab$l_sts);
1847 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1848 if (dirfab.fab$l_sts != RMS$_FNF) {
1850 set_vaxc_errno(dirfab.fab$l_sts);
1853 dirnam = savnam; /* No; just work with potential name */
1856 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1857 /* Yep; check version while we're at it, if it's there. */
1858 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1859 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1860 /* Something other than .DIR[;1]. Bzzt. */
1862 set_vaxc_errno(RMS$_DIR);
1866 /* OK, the type was fine. Now pull any file name into the
1868 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1870 cp1 = strrchr(esa,'>');
1871 *dirnam.nam$l_type = '>';
1874 *(dirnam.nam$l_type + 1) = '\0';
1875 retlen = dirnam.nam$l_type - esa + 2;
1876 if (buf) retpath = buf;
1877 else if (ts) New(1314,retpath,retlen,char);
1878 else retpath = __pathify_retbuf;
1879 strcpy(retpath,esa);
1880 /* $PARSE may have upcased filespec, so convert output to lower
1881 * case if input contained any lowercase characters. */
1882 if (haslower) __mystrtolower(retpath);
1886 } /* end of do_pathify_dirspec() */
1888 /* External entry points */
1889 char *pathify_dirspec(char *dir, char *buf)
1890 { return do_pathify_dirspec(dir,buf,0); }
1891 char *pathify_dirspec_ts(char *dir, char *buf)
1892 { return do_pathify_dirspec(dir,buf,1); }
1894 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1895 static char *do_tounixspec(char *spec, char *buf, int ts)
1897 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1898 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1899 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1901 if (spec == NULL) return NULL;
1902 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1903 if (buf) rslt = buf;
1905 retlen = strlen(spec);
1906 cp1 = strchr(spec,'[');
1907 if (!cp1) cp1 = strchr(spec,'<');
1909 for (cp1++; *cp1; cp1++) {
1910 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1911 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1912 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1915 New(1315,rslt,retlen+2+2*expand,char);
1917 else rslt = __tounixspec_retbuf;
1918 if (strchr(spec,'/') != NULL) {
1925 dirend = strrchr(spec,']');
1926 if (dirend == NULL) dirend = strrchr(spec,'>');
1927 if (dirend == NULL) dirend = strchr(spec,':');
1928 if (dirend == NULL) {
1932 if (*cp2 != '[' && *cp2 != '<') {
1935 else { /* the VMS spec begins with directories */
1937 if (*cp2 == ']' || *cp2 == '>') {
1938 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1941 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1942 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1943 if (ts) Safefree(rslt);
1948 while (*cp3 != ':' && *cp3) cp3++;
1950 if (strchr(cp3,']') != NULL) break;
1951 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1953 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1954 retlen = devlen + dirlen;
1955 Renew(rslt,retlen+1+2*expand,char);
1961 *(cp1++) = *(cp3++);
1962 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1966 else if ( *cp2 == '.') {
1967 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1968 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1974 for (; cp2 <= dirend; cp2++) {
1977 if (*(cp2+1) == '[') cp2++;
1979 else if (*cp2 == ']' || *cp2 == '>') {
1980 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1982 else if (*cp2 == '.') {
1984 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1985 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1986 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1987 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1988 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1990 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1991 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1995 else if (*cp2 == '-') {
1996 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1997 while (*cp2 == '-') {
1999 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2001 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2002 if (ts) Safefree(rslt); /* filespecs like */
2003 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2007 else *(cp1++) = *cp2;
2009 else *(cp1++) = *cp2;
2011 while (*cp2) *(cp1++) = *(cp2++);
2016 } /* end of do_tounixspec() */
2018 /* External entry points */
2019 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2020 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2022 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2023 static char *do_tovmsspec(char *path, char *buf, int ts) {
2024 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2025 char *rslt, *dirend;
2026 register char *cp1, *cp2;
2027 unsigned long int infront = 0, hasdir = 1;
2029 if (path == NULL) return NULL;
2030 if (buf) rslt = buf;
2031 else if (ts) New(1316,rslt,strlen(path)+9,char);
2032 else rslt = __tovmsspec_retbuf;
2033 if (strpbrk(path,"]:>") ||
2034 (dirend = strrchr(path,'/')) == NULL) {
2035 if (path[0] == '.') {
2036 if (path[1] == '\0') strcpy(rslt,"[]");
2037 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2038 else strcpy(rslt,path); /* probably garbage */
2040 else strcpy(rslt,path);
2043 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2044 if (!*(dirend+2)) dirend +=2;
2045 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2046 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2051 char trndev[NAM$C_MAXRSS+1];
2055 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2057 if (!buf & ts) Renew(rslt,18,char);
2058 strcpy(rslt,"sys$disk:[000000]");
2061 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2063 islnm = my_trnlnm(rslt,trndev,0);
2064 trnend = islnm ? strlen(trndev) - 1 : 0;
2065 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2066 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2067 /* If the first element of the path is a logical name, determine
2068 * whether it has to be translated so we can add more directories. */
2069 if (!islnm || rooted) {
2072 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2076 if (cp2 != dirend) {
2077 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2078 strcpy(rslt,trndev);
2079 cp1 = rslt + trnend;
2092 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2093 cp2 += 2; /* skip over "./" - it's redundant */
2094 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2096 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2097 *(cp1++) = '-'; /* "../" --> "-" */
2100 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2101 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2102 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2103 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2106 if (cp2 > dirend) cp2 = dirend;
2108 else *(cp1++) = '.';
2110 for (; cp2 < dirend; cp2++) {
2112 if (*(cp2-1) == '/') continue;
2113 if (*(cp1-1) != '.') *(cp1++) = '.';
2116 else if (!infront && *cp2 == '.') {
2117 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2118 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2119 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2120 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2121 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2122 else { /* back up over previous directory name */
2124 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2125 if (*(cp1-1) == '[') {
2126 memcpy(cp1,"000000.",7);
2131 if (cp2 == dirend) break;
2133 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2134 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2135 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2136 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2138 *(cp1++) = '.'; /* Simulate trailing '/' */
2139 cp2 += 2; /* for loop will incr this to == dirend */
2141 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2143 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2146 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2147 if (*cp2 == '.') *(cp1++) = '_';
2148 else *(cp1++) = *cp2;
2152 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2153 if (hasdir) *(cp1++) = ']';
2154 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2155 while (*cp2) *(cp1++) = *(cp2++);
2160 } /* end of do_tovmsspec() */
2162 /* External entry points */
2163 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2164 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2166 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2167 static char *do_tovmspath(char *path, char *buf, int ts) {
2168 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2170 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2172 if (path == NULL) return NULL;
2173 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2174 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2175 if (buf) return buf;
2177 vmslen = strlen(vmsified);
2178 New(1317,cp,vmslen+1,char);
2179 memcpy(cp,vmsified,vmslen);
2184 strcpy(__tovmspath_retbuf,vmsified);
2185 return __tovmspath_retbuf;
2188 } /* end of do_tovmspath() */
2190 /* External entry points */
2191 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2192 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2195 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2196 static char *do_tounixpath(char *path, char *buf, int ts) {
2197 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2199 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2201 if (path == NULL) return NULL;
2202 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2203 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2204 if (buf) return buf;
2206 unixlen = strlen(unixified);
2207 New(1317,cp,unixlen+1,char);
2208 memcpy(cp,unixified,unixlen);
2213 strcpy(__tounixpath_retbuf,unixified);
2214 return __tounixpath_retbuf;
2217 } /* end of do_tounixpath() */
2219 /* External entry points */
2220 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2221 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2224 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2226 *****************************************************************************
2228 * Copyright (C) 1989-1994 by *
2229 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2231 * Permission is hereby granted for the reproduction of this software, *
2232 * on condition that this copyright notice is included in the reproduction, *
2233 * and that such reproduction is not for purposes of profit or material *
2236 * 27-Aug-1994 Modified for inclusion in perl5 *
2237 * by Charles Bailey bailey@newman.upenn.edu *
2238 *****************************************************************************
2242 * getredirection() is intended to aid in porting C programs
2243 * to VMS (Vax-11 C). The native VMS environment does not support
2244 * '>' and '<' I/O redirection, or command line wild card expansion,
2245 * or a command line pipe mechanism using the '|' AND background
2246 * command execution '&'. All of these capabilities are provided to any
2247 * C program which calls this procedure as the first thing in the
2249 * The piping mechanism will probably work with almost any 'filter' type
2250 * of program. With suitable modification, it may useful for other
2251 * portability problems as well.
2253 * Author: Mark Pizzolato mark@infocomm.com
2257 struct list_item *next;
2261 static void add_item(struct list_item **head,
2262 struct list_item **tail,
2266 static void expand_wild_cards(char *item,
2267 struct list_item **head,
2268 struct list_item **tail,
2271 static int background_process(int argc, char **argv);
2273 static void pipe_and_fork(char **cmargv);
2275 /*{{{ void getredirection(int *ac, char ***av)*/
2277 getredirection(int *ac, char ***av)
2279 * Process vms redirection arg's. Exit if any error is seen.
2280 * If getredirection() processes an argument, it is erased
2281 * from the vector. getredirection() returns a new argc and argv value.
2282 * In the event that a background command is requested (by a trailing "&"),
2283 * this routine creates a background subprocess, and simply exits the program.
2285 * Warning: do not try to simplify the code for vms. The code
2286 * presupposes that getredirection() is called before any data is
2287 * read from stdin or written to stdout.
2289 * Normal usage is as follows:
2295 * getredirection(&argc, &argv);
2299 int argc = *ac; /* Argument Count */
2300 char **argv = *av; /* Argument Vector */
2301 char *ap; /* Argument pointer */
2302 int j; /* argv[] index */
2303 int item_count = 0; /* Count of Items in List */
2304 struct list_item *list_head = 0; /* First Item in List */
2305 struct list_item *list_tail; /* Last Item in List */
2306 char *in = NULL; /* Input File Name */
2307 char *out = NULL; /* Output File Name */
2308 char *outmode = "w"; /* Mode to Open Output File */
2309 char *err = NULL; /* Error File Name */
2310 char *errmode = "w"; /* Mode to Open Error File */
2311 int cmargc = 0; /* Piped Command Arg Count */
2312 char **cmargv = NULL;/* Piped Command Arg Vector */
2315 * First handle the case where the last thing on the line ends with
2316 * a '&'. This indicates the desire for the command to be run in a
2317 * subprocess, so we satisfy that desire.
2320 if (0 == strcmp("&", ap))
2321 exit(background_process(--argc, argv));
2322 if (*ap && '&' == ap[strlen(ap)-1])
2324 ap[strlen(ap)-1] = '\0';
2325 exit(background_process(argc, argv));
2328 * Now we handle the general redirection cases that involve '>', '>>',
2329 * '<', and pipes '|'.
2331 for (j = 0; j < argc; ++j)
2333 if (0 == strcmp("<", argv[j]))
2337 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2338 exit(LIB$_WRONUMARG);
2343 if ('<' == *(ap = argv[j]))
2348 if (0 == strcmp(">", ap))
2352 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2353 exit(LIB$_WRONUMARG);
2372 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2373 exit(LIB$_WRONUMARG);
2377 if (('2' == *ap) && ('>' == ap[1]))
2394 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2395 exit(LIB$_WRONUMARG);
2399 if (0 == strcmp("|", argv[j]))
2403 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2404 exit(LIB$_WRONUMARG);
2406 cmargc = argc-(j+1);
2407 cmargv = &argv[j+1];
2411 if ('|' == *(ap = argv[j]))
2419 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2422 * Allocate and fill in the new argument vector, Some Unix's terminate
2423 * the list with an extra null pointer.
2425 New(1302, argv, item_count+1, char *);
2427 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2428 argv[j] = list_head->value;
2434 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2435 exit(LIB$_INVARGORD);
2437 pipe_and_fork(cmargv);
2440 /* Check for input from a pipe (mailbox) */
2442 if (in == NULL && 1 == isapipe(0))
2444 char mbxname[L_tmpnam];
2446 long int dvi_item = DVI$_DEVBUFSIZ;
2447 $DESCRIPTOR(mbxnam, "");
2448 $DESCRIPTOR(mbxdevnam, "");
2450 /* Input from a pipe, reopen it in binary mode to disable */
2451 /* carriage control processing. */
2453 PerlIO_getname(stdin, mbxname);
2454 mbxnam.dsc$a_pointer = mbxname;
2455 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2456 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2457 mbxdevnam.dsc$a_pointer = mbxname;
2458 mbxdevnam.dsc$w_length = sizeof(mbxname);
2459 dvi_item = DVI$_DEVNAM;
2460 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2461 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2464 freopen(mbxname, "rb", stdin);
2467 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2471 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2473 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2476 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2478 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2483 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2485 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2489 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2494 #ifdef ARGPROC_DEBUG
2495 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2496 for (j = 0; j < *ac; ++j)
2497 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2499 /* Clear errors we may have hit expanding wildcards, so they don't
2500 show up in Perl's $! later */
2501 set_errno(0); set_vaxc_errno(1);
2502 } /* end of getredirection() */
2505 static void add_item(struct list_item **head,
2506 struct list_item **tail,
2512 New(1303,*head,1,struct list_item);
2516 New(1304,(*tail)->next,1,struct list_item);
2517 *tail = (*tail)->next;
2519 (*tail)->value = value;
2523 static void expand_wild_cards(char *item,
2524 struct list_item **head,
2525 struct list_item **tail,
2529 unsigned long int context = 0;
2535 char vmsspec[NAM$C_MAXRSS+1];
2536 $DESCRIPTOR(filespec, "");
2537 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2538 $DESCRIPTOR(resultspec, "");
2539 unsigned long int zero = 0, sts;
2541 for (cp = item; *cp; cp++) {
2542 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2543 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2545 if (!*cp || isspace(*cp))
2547 add_item(head, tail, item, count);
2550 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2551 resultspec.dsc$b_class = DSC$K_CLASS_D;
2552 resultspec.dsc$a_pointer = NULL;
2553 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2554 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2555 if (!isunix || !filespec.dsc$a_pointer)
2556 filespec.dsc$a_pointer = item;
2557 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2559 * Only return version specs, if the caller specified a version
2561 had_version = strchr(item, ';');
2563 * Only return device and directory specs, if the caller specifed either.
2565 had_device = strchr(item, ':');
2566 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2568 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2569 &defaultspec, 0, 0, &zero))))
2574 New(1305,string,resultspec.dsc$w_length+1,char);
2575 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2576 string[resultspec.dsc$w_length] = '\0';
2577 if (NULL == had_version)
2578 *((char *)strrchr(string, ';')) = '\0';
2579 if ((!had_directory) && (had_device == NULL))
2581 if (NULL == (devdir = strrchr(string, ']')))
2582 devdir = strrchr(string, '>');
2583 strcpy(string, devdir + 1);
2586 * Be consistent with what the C RTL has already done to the rest of
2587 * the argv items and lowercase all of these names.
2589 for (c = string; *c; ++c)
2592 if (isunix) trim_unixpath(string,item,1);
2593 add_item(head, tail, string, count);
2596 if (sts != RMS$_NMF)
2598 set_vaxc_errno(sts);
2604 set_errno(ENOENT); break;
2606 set_errno(ENODEV); break;
2609 set_errno(EINVAL); break;
2611 set_errno(EACCES); break;
2613 _ckvmssts_noperl(sts);
2617 add_item(head, tail, item, count);
2618 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2619 _ckvmssts_noperl(lib$find_file_end(&context));
2622 static int child_st[2];/* Event Flag set when child process completes */
2624 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2626 static unsigned long int exit_handler(int *status)
2630 if (0 == child_st[0])
2632 #ifdef ARGPROC_DEBUG
2633 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2635 fflush(stdout); /* Have to flush pipe for binary data to */
2636 /* terminate properly -- <tp@mccall.com> */
2637 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2638 sys$dassgn(child_chan);
2640 sys$synch(0, child_st);
2645 static void sig_child(int chan)
2647 #ifdef ARGPROC_DEBUG
2648 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2650 if (child_st[0] == 0)
2654 static struct exit_control_block exit_block =
2659 &exit_block.exit_status,
2663 static void pipe_and_fork(char **cmargv)
2666 $DESCRIPTOR(cmddsc, "");
2667 static char mbxname[64];
2668 $DESCRIPTOR(mbxdsc, mbxname);
2670 unsigned long int zero = 0, one = 1;
2672 strcpy(subcmd, cmargv[0]);
2673 for (j = 1; NULL != cmargv[j]; ++j)
2675 strcat(subcmd, " \"");
2676 strcat(subcmd, cmargv[j]);
2677 strcat(subcmd, "\"");
2679 cmddsc.dsc$a_pointer = subcmd;
2680 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2682 create_mbx(&child_chan,&mbxdsc);
2683 #ifdef ARGPROC_DEBUG
2684 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2685 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2687 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2688 0, &pid, child_st, &zero, sig_child,
2690 #ifdef ARGPROC_DEBUG
2691 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2693 sys$dclexh(&exit_block);
2694 if (NULL == freopen(mbxname, "wb", stdout))
2696 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2700 static int background_process(int argc, char **argv)
2702 char command[2048] = "$";
2703 $DESCRIPTOR(value, "");
2704 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2705 static $DESCRIPTOR(null, "NLA0:");
2706 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2708 $DESCRIPTOR(pidstr, "");
2710 unsigned long int flags = 17, one = 1, retsts;
2712 strcat(command, argv[0]);
2715 strcat(command, " \"");
2716 strcat(command, *(++argv));
2717 strcat(command, "\"");
2719 value.dsc$a_pointer = command;
2720 value.dsc$w_length = strlen(value.dsc$a_pointer);
2721 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2722 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2723 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2724 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2727 _ckvmssts_noperl(retsts);
2729 #ifdef ARGPROC_DEBUG
2730 PerlIO_printf(Perl_debug_log, "%s\n", command);
2732 sprintf(pidstring, "%08X", pid);
2733 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2734 pidstr.dsc$a_pointer = pidstring;
2735 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2736 lib$set_symbol(&pidsymbol, &pidstr);
2740 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2743 /* OS-specific initialization at image activation (not thread startup) */
2744 /* Older VAXC header files lack these constants */
2745 #ifndef JPI$_RIGHTS_SIZE
2746 # define JPI$_RIGHTS_SIZE 817
2748 #ifndef KGB$M_SUBSYSTEM
2749 # define KGB$M_SUBSYSTEM 0x8
2752 /*{{{void vms_image_init(int *, char ***)*/
2754 vms_image_init(int *argcp, char ***argvp)
2756 char eqv[LNM$C_NAMLENGTH+1] = "";
2757 unsigned int len, tabct = 8, tabidx = 0;
2758 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2759 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2760 unsigned short int dummy, rlen;
2761 struct dsc$descriptor_s **tabvec;
2763 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2764 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2765 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2768 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2770 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2771 if (iprv[i]) { /* Running image installed with privs? */
2772 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2777 /* Rights identifiers might trigger tainting as well. */
2778 if (!will_taint && (rlen || rsz)) {
2779 while (rlen < rsz) {
2780 /* We didn't get all the identifiers on the first pass. Allocate a
2781 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2782 * were needed to hold all identifiers at time of last call; we'll
2783 * allocate that many unsigned long ints), and go back and get 'em.
2785 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2786 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2787 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2788 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2791 mask = jpilist[1].bufadr;
2792 /* Check attribute flags for each identifier (2nd longword); protected
2793 * subsystem identifiers trigger tainting.
2795 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2796 if (mask[i] & KGB$M_SUBSYSTEM) {
2801 if (mask != rlst) Safefree(mask);
2803 /* We need to use this hack to tell Perl it should run with tainting,
2804 * since its tainting flag may be part of the PL_curinterp struct, which
2805 * hasn't been allocated when vms_image_init() is called.
2809 New(1320,newap,*argcp+2,char **);
2810 newap[0] = argvp[0];
2812 Copy(argvp[1],newap[2],*argcp-1,char **);
2813 /* We orphan the old argv, since we don't know where it's come from,
2814 * so we don't know how to free it.
2816 *argcp++; argvp = newap;
2818 else { /* Did user explicitly request tainting? */
2820 char *cp, **av = *argvp;
2821 for (i = 1; i < *argcp; i++) {
2822 if (*av[i] != '-') break;
2823 for (cp = av[i]+1; *cp; cp++) {
2824 if (*cp == 'T') { will_taint = 1; break; }
2825 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2826 strchr("DFIiMmx",*cp)) break;
2828 if (will_taint) break;
2833 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2835 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2836 else if (tabidx >= tabct) {
2838 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2840 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2841 tabvec[tabidx]->dsc$w_length = 0;
2842 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2843 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2844 tabvec[tabidx]->dsc$a_pointer = NULL;
2845 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2847 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2849 getredirection(argcp,argvp);
2850 #if defined(USE_THREADS) && defined(__DECC)
2852 # include <reentrancy.h>
2853 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2862 * Trim Unix-style prefix off filespec, so it looks like what a shell
2863 * glob expansion would return (i.e. from specified prefix on, not
2864 * full path). Note that returned filespec is Unix-style, regardless
2865 * of whether input filespec was VMS-style or Unix-style.
2867 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2868 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2869 * vector of options; at present, only bit 0 is used, and if set tells
2870 * trim unixpath to try the current default directory as a prefix when
2871 * presented with a possibly ambiguous ... wildcard.
2873 * Returns !=0 on success, with trimmed filespec replacing contents of
2874 * fspec, and 0 on failure, with contents of fpsec unchanged.
2876 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2878 trim_unixpath(char *fspec, char *wildspec, int opts)
2880 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2881 *template, *base, *end, *cp1, *cp2;
2882 register int tmplen, reslen = 0, dirs = 0;
2884 if (!wildspec || !fspec) return 0;
2885 if (strpbrk(wildspec,"]>:") != NULL) {
2886 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2887 else template = unixwild;
2889 else template = wildspec;
2890 if (strpbrk(fspec,"]>:") != NULL) {
2891 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2892 else base = unixified;
2893 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2894 * check to see that final result fits into (isn't longer than) fspec */
2895 reslen = strlen(fspec);
2899 /* No prefix or absolute path on wildcard, so nothing to remove */
2900 if (!*template || *template == '/') {
2901 if (base == fspec) return 1;
2902 tmplen = strlen(unixified);
2903 if (tmplen > reslen) return 0; /* not enough space */
2904 /* Copy unixified resultant, including trailing NUL */
2905 memmove(fspec,unixified,tmplen+1);
2909 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2910 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2911 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2912 for (cp1 = end ;cp1 >= base; cp1--)
2913 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2915 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2919 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2920 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2921 int ells = 1, totells, segdirs, match;
2922 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2923 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2925 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2927 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2928 if (ellipsis == template && opts & 1) {
2929 /* Template begins with an ellipsis. Since we can't tell how many
2930 * directory names at the front of the resultant to keep for an
2931 * arbitrary starting point, we arbitrarily choose the current
2932 * default directory as a starting point. If it's there as a prefix,
2933 * clip it off. If not, fall through and act as if the leading
2934 * ellipsis weren't there (i.e. return shortest possible path that
2935 * could match template).
2937 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2938 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2939 if (_tolower(*cp1) != _tolower(*cp2)) break;
2940 segdirs = dirs - totells; /* Min # of dirs we must have left */
2941 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2942 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2943 memcpy(fspec,cp2+1,end - cp2);
2947 /* First off, back up over constant elements at end of path */
2949 for (front = end ; front >= base; front--)
2950 if (*front == '/' && !dirs--) { front++; break; }
2952 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2953 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2954 if (cp1 != '\0') return 0; /* Path too long. */
2956 *cp2 = '\0'; /* Pick up with memcpy later */
2957 lcfront = lcres + (front - base);
2958 /* Now skip over each ellipsis and try to match the path in front of it. */
2960 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2961 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2962 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2963 if (cp1 < template) break; /* template started with an ellipsis */
2964 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2965 ellipsis = cp1; continue;
2967 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2969 for (segdirs = 0, cp2 = tpl;
2970 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2972 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2973 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2974 if (*cp2 == '/') segdirs++;
2976 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2977 /* Back up at least as many dirs as in template before matching */
2978 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2979 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2980 for (match = 0; cp1 > lcres;) {
2981 resdsc.dsc$a_pointer = cp1;
2982 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2984 if (match == 1) lcfront = cp1;
2986 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2988 if (!match) return 0; /* Can't find prefix ??? */
2989 if (match > 1 && opts & 1) {
2990 /* This ... wildcard could cover more than one set of dirs (i.e.
2991 * a set of similar dir names is repeated). If the template
2992 * contains more than 1 ..., upstream elements could resolve the
2993 * ambiguity, but it's not worth a full backtracking setup here.
2994 * As a quick heuristic, clip off the current default directory
2995 * if it's present to find the trimmed spec, else use the
2996 * shortest string that this ... could cover.
2998 char def[NAM$C_MAXRSS+1], *st;
3000 if (getcwd(def, sizeof def,0) == NULL) return 0;
3001 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3002 if (_tolower(*cp1) != _tolower(*cp2)) break;
3003 segdirs = dirs - totells; /* Min # of dirs we must have left */
3004 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3005 if (*cp1 == '\0' && *cp2 == '/') {
3006 memcpy(fspec,cp2+1,end - cp2);
3009 /* Nope -- stick with lcfront from above and keep going. */
3012 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3017 } /* end of trim_unixpath() */
3022 * VMS readdir() routines.
3023 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3025 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3026 * Minor modifications to original routines.
3029 /* Number of elements in vms_versions array */
3030 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3033 * Open a directory, return a handle for later use.
3035 /*{{{ DIR *opendir(char*name) */
3040 char dir[NAM$C_MAXRSS+1];
3043 if (do_tovmspath(name,dir,0) == NULL) {
3046 if (flex_stat(dir,&sb) == -1) return NULL;
3047 if (!S_ISDIR(sb.st_mode)) {
3048 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3051 if (!cando_by_name(S_IRUSR,0,dir)) {
3052 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3055 /* Get memory for the handle, and the pattern. */
3057 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3059 /* Fill in the fields; mainly playing with the descriptor. */
3060 (void)sprintf(dd->pattern, "%s*.*",dir);
3063 dd->vms_wantversions = 0;
3064 dd->pat.dsc$a_pointer = dd->pattern;
3065 dd->pat.dsc$w_length = strlen(dd->pattern);
3066 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3067 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3070 } /* end of opendir() */
3074 * Set the flag to indicate we want versions or not.
3076 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3078 vmsreaddirversions(DIR *dd, int flag)
3080 dd->vms_wantversions = flag;
3085 * Free up an opened directory.
3087 /*{{{ void closedir(DIR *dd)*/
3091 (void)lib$find_file_end(&dd->context);
3092 Safefree(dd->pattern);
3093 Safefree((char *)dd);
3098 * Collect all the version numbers for the current file.
3104 struct dsc$descriptor_s pat;
3105 struct dsc$descriptor_s res;
3107 char *p, *text, buff[sizeof dd->entry.d_name];
3109 unsigned long context, tmpsts;
3112 /* Convenient shorthand. */
3115 /* Add the version wildcard, ignoring the "*.*" put on before */
3116 i = strlen(dd->pattern);
3117 New(1308,text,i + e->d_namlen + 3,char);
3118 (void)strcpy(text, dd->pattern);
3119 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3121 /* Set up the pattern descriptor. */
3122 pat.dsc$a_pointer = text;
3123 pat.dsc$w_length = i + e->d_namlen - 1;
3124 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3125 pat.dsc$b_class = DSC$K_CLASS_S;
3127 /* Set up result descriptor. */
3128 res.dsc$a_pointer = buff;
3129 res.dsc$w_length = sizeof buff - 2;
3130 res.dsc$b_dtype = DSC$K_DTYPE_T;
3131 res.dsc$b_class = DSC$K_CLASS_S;
3133 /* Read files, collecting versions. */
3134 for (context = 0, e->vms_verscount = 0;
3135 e->vms_verscount < VERSIZE(e);
3136 e->vms_verscount++) {
3137 tmpsts = lib$find_file(&pat, &res, &context);
3138 if (tmpsts == RMS$_NMF || context == 0) break;
3140 buff[sizeof buff - 1] = '\0';
3141 if ((p = strchr(buff, ';')))
3142 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3144 e->vms_versions[e->vms_verscount] = -1;
3147 _ckvmssts(lib$find_file_end(&context));
3150 } /* end of collectversions() */
3153 * Read the next entry from the directory.
3155 /*{{{ struct dirent *readdir(DIR *dd)*/
3159 struct dsc$descriptor_s res;
3160 char *p, buff[sizeof dd->entry.d_name];
3161 unsigned long int tmpsts;
3163 /* Set up result descriptor, and get next file. */
3164 res.dsc$a_pointer = buff;
3165 res.dsc$w_length = sizeof buff - 2;
3166 res.dsc$b_dtype = DSC$K_DTYPE_T;
3167 res.dsc$b_class = DSC$K_CLASS_S;
3168 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3169 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3170 if (!(tmpsts & 1)) {
3171 set_vaxc_errno(tmpsts);
3174 set_errno(EACCES); break;
3176 set_errno(ENODEV); break;
3179 set_errno(ENOENT); break;
3186 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3187 buff[sizeof buff - 1] = '\0';
3188 for (p = buff; *p; p++) *p = _tolower(*p);
3189 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3192 /* Skip any directory component and just copy the name. */
3193 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3194 else (void)strcpy(dd->entry.d_name, buff);
3196 /* Clobber the version. */
3197 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3199 dd->entry.d_namlen = strlen(dd->entry.d_name);
3200 dd->entry.vms_verscount = 0;
3201 if (dd->vms_wantversions) collectversions(dd);
3204 } /* end of readdir() */
3208 * Return something that can be used in a seekdir later.
3210 /*{{{ long telldir(DIR *dd)*/
3219 * Return to a spot where we used to be. Brute force.
3221 /*{{{ void seekdir(DIR *dd,long count)*/
3223 seekdir(DIR *dd, long count)
3225 int vms_wantversions;
3228 /* If we haven't done anything yet... */
3232 /* Remember some state, and clear it. */
3233 vms_wantversions = dd->vms_wantversions;
3234 dd->vms_wantversions = 0;
3235 _ckvmssts(lib$find_file_end(&dd->context));
3238 /* The increment is in readdir(). */
3239 for (dd->count = 0; dd->count < count; )
3242 dd->vms_wantversions = vms_wantversions;
3244 } /* end of seekdir() */
3247 /* VMS subprocess management
3249 * my_vfork() - just a vfork(), after setting a flag to record that
3250 * the current script is trying a Unix-style fork/exec.
3252 * vms_do_aexec() and vms_do_exec() are called in response to the
3253 * perl 'exec' function. If this follows a vfork call, then they
3254 * call out the the regular perl routines in doio.c which do an
3255 * execvp (for those who really want to try this under VMS).
3256 * Otherwise, they do exactly what the perl docs say exec should
3257 * do - terminate the current script and invoke a new command
3258 * (See below for notes on command syntax.)
3260 * do_aspawn() and do_spawn() implement the VMS side of the perl
3261 * 'system' function.
3263 * Note on command arguments to perl 'exec' and 'system': When handled
3264 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3265 * are concatenated to form a DCL command string. If the first arg
3266 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3267 * the the command string is handed off to DCL directly. Otherwise,
3268 * the first token of the command is taken as the filespec of an image
3269 * to run. The filespec is expanded using a default type of '.EXE' and
3270 * the process defaults for device, directory, etc., and if found, the resultant
3271 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3272 * the command string as parameters. This is perhaps a bit complicated,
3273 * but I hope it will form a happy medium between what VMS folks expect
3274 * from lib$spawn and what Unix folks expect from exec.
3277 static int vfork_called;
3279 /*{{{int my_vfork()*/
3289 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3297 if (VMScmd.dsc$a_pointer) {
3298 Safefree(VMScmd.dsc$a_pointer);
3299 VMScmd.dsc$w_length = 0;
3300 VMScmd.dsc$a_pointer = Nullch;
3305 setup_argstr(SV *really, SV **mark, SV **sp)
3308 char *junk, *tmps = Nullch;
3309 register size_t cmdlen = 0;
3316 tmps = SvPV(really,rlen);
3323 for (idx++; idx <= sp; idx++) {
3325 junk = SvPVx(*idx,rlen);
3326 cmdlen += rlen ? rlen + 1 : 0;
3329 New(401,PL_Cmd,cmdlen+1,char);
3331 if (tmps && *tmps) {
3332 strcpy(PL_Cmd,tmps);
3335 else *PL_Cmd = '\0';
3336 while (++mark <= sp) {
3338 char *s = SvPVx(*mark,n_a);
3340 if (*PL_Cmd) strcat(PL_Cmd," ");
3346 } /* end of setup_argstr() */
3349 static unsigned long int
3350 setup_cmddsc(char *cmd, int check_img)
3352 char resspec[NAM$C_MAXRSS+1];
3353 $DESCRIPTOR(defdsc,".EXE");
3354 $DESCRIPTOR(resdsc,resspec);
3355 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3356 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3357 register char *s, *rest, *cp;
3358 register int isdcl = 0;
3362 while (*s && isspace(*s)) s++;
3364 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3365 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3366 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3367 if (*cp == ':' || *cp == '[' || *cp == '<') {
3377 while (*s && !isspace(*s)) s++;
3379 imgdsc.dsc$a_pointer = cmd;
3380 imgdsc.dsc$w_length = s - cmd;
3381 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3383 _ckvmssts(lib$find_file_end(&cxt));
3385 while (*s && !isspace(*s)) s++;
3387 if (cando_by_name(S_IXUSR,0,resspec)) {
3388 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3389 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3390 strcat(VMScmd.dsc$a_pointer,resspec);
3391 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3392 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3395 else retsts = RMS$_PRV;
3398 /* It's either a DCL command or we couldn't find a suitable image */
3399 VMScmd.dsc$w_length = strlen(cmd);
3400 if (cmd == PL_Cmd) {
3401 VMScmd.dsc$a_pointer = PL_Cmd;
3402 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3404 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3405 if (!(retsts & 1)) {
3406 /* just hand off status values likely to be due to user error */
3407 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3408 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3409 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3410 else { _ckvmssts(retsts); }
3413 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3415 } /* end of setup_cmddsc() */
3418 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3420 vms_do_aexec(SV *really,SV **mark,SV **sp)
3424 if (vfork_called) { /* this follows a vfork - act Unixish */
3426 if (vfork_called < 0) {
3427 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3430 else return do_aexec(really,mark,sp);
3432 /* no vfork - act VMSish */
3433 return vms_do_exec(setup_argstr(really,mark,sp));
3438 } /* end of vms_do_aexec() */
3441 /* {{{bool vms_do_exec(char *cmd) */
3443 vms_do_exec(char *cmd)
3447 if (vfork_called) { /* this follows a vfork - act Unixish */
3449 if (vfork_called < 0) {
3450 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3453 else return do_exec(cmd);
3456 { /* no vfork - act VMSish */
3457 unsigned long int retsts;
3460 TAINT_PROPER("exec");
3461 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3462 retsts = lib$do_command(&VMScmd);
3466 set_errno(ENOENT); break;
3467 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3468 set_errno(ENOTDIR); break;
3470 set_errno(EACCES); break;
3472 set_errno(EINVAL); break;
3474 set_errno(E2BIG); break;
3475 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3476 _ckvmssts(retsts); /* fall through */
3477 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3480 set_vaxc_errno(retsts);
3481 if (ckWARN(WARN_EXEC)) {
3482 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3483 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3490 } /* end of vms_do_exec() */
3493 unsigned long int do_spawn(char *);
3495 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3497 do_aspawn(void *really,void **mark,void **sp)
3500 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3503 } /* end of do_aspawn() */
3506 /* {{{unsigned long int do_spawn(char *cmd) */
3510 unsigned long int sts, substs, hadcmd = 1;
3514 TAINT_PROPER("spawn");
3515 if (!cmd || !*cmd) {
3517 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3519 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3520 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3526 set_errno(ENOENT); break;
3527 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3528 set_errno(ENOTDIR); break;
3530 set_errno(EACCES); break;
3532 set_errno(EINVAL); break;
3534 set_errno(E2BIG); break;
3535 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3536 _ckvmssts(sts); /* fall through */
3537 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3540 set_vaxc_errno(sts);
3541 if (ckWARN(WARN_EXEC)) {
3542 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3543 hadcmd ? VMScmd.dsc$w_length : 0,
3544 hadcmd ? VMScmd.dsc$a_pointer : "",
3551 } /* end of do_spawn() */
3555 * A simple fwrite replacement which outputs itmsz*nitm chars without
3556 * introducing record boundaries every itmsz chars.
3558 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3560 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3562 register char *cp, *end;
3564 end = (char *)src + itmsz * nitm;
3566 while ((char *)src <= end) {
3567 for (cp = src; cp <= end; cp++) if (!*cp) break;
3568 if (fputs(src,dest) == EOF) return EOF;
3570 if (fputc('\0',dest) == EOF) return EOF;
3576 } /* end of my_fwrite() */
3579 /*{{{ int my_flush(FILE *fp)*/
3584 if ((res = fflush(fp)) == 0 && fp) {
3585 #ifdef VMS_DO_SOCKETS
3587 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3589 res = fsync(fileno(fp));
3596 * Here are replacements for the following Unix routines in the VMS environment:
3597 * getpwuid Get information for a particular UIC or UID
3598 * getpwnam Get information for a named user
3599 * getpwent Get information for each user in the rights database
3600 * setpwent Reset search to the start of the rights database
3601 * endpwent Finish searching for users in the rights database
3603 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3604 * (defined in pwd.h), which contains the following fields:-
3606 * char *pw_name; Username (in lower case)
3607 * char *pw_passwd; Hashed password
3608 * unsigned int pw_uid; UIC
3609 * unsigned int pw_gid; UIC group number
3610 * char *pw_unixdir; Default device/directory (VMS-style)
3611 * char *pw_gecos; Owner name
3612 * char *pw_dir; Default device/directory (Unix-style)
3613 * char *pw_shell; Default CLI name (eg. DCL)
3615 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3617 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3618 * not the UIC member number (eg. what's returned by getuid()),
3619 * getpwuid() can accept either as input (if uid is specified, the caller's
3620 * UIC group is used), though it won't recognise gid=0.
3622 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3623 * information about other users in your group or in other groups, respectively.
3624 * If the required privilege is not available, then these routines fill only
3625 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3628 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3631 /* sizes of various UAF record fields */
3632 #define UAI$S_USERNAME 12
3633 #define UAI$S_IDENT 31
3634 #define UAI$S_OWNER 31
3635 #define UAI$S_DEFDEV 31
3636 #define UAI$S_DEFDIR 63
3637 #define UAI$S_DEFCLI 31
3640 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3641 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3642 (uic).uic$v_group != UIC$K_WILD_GROUP)
3644 static char __empty[]= "";
3645 static struct passwd __passwd_empty=
3646 {(char *) __empty, (char *) __empty, 0, 0,
3647 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3648 static int contxt= 0;
3649 static struct passwd __pwdcache;
3650 static char __pw_namecache[UAI$S_IDENT+1];
3653 * This routine does most of the work extracting the user information.
3655 static int fillpasswd (const char *name, struct passwd *pwd)
3659 unsigned char length;
3660 char pw_gecos[UAI$S_OWNER+1];
3662 static union uicdef uic;
3664 unsigned char length;
3665 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3668 unsigned char length;
3669 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3672 unsigned char length;
3673 char pw_shell[UAI$S_DEFCLI+1];
3675 static char pw_passwd[UAI$S_PWD+1];
3677 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3678 struct dsc$descriptor_s name_desc;
3679 unsigned long int sts;
3681 static struct itmlst_3 itmlst[]= {
3682 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3683 {sizeof(uic), UAI$_UIC, &uic, &luic},
3684 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3685 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3686 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3687 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3688 {0, 0, NULL, NULL}};
3690 name_desc.dsc$w_length= strlen(name);
3691 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3692 name_desc.dsc$b_class= DSC$K_CLASS_S;
3693 name_desc.dsc$a_pointer= (char *) name;
3695 /* Note that sys$getuai returns many fields as counted strings. */
3696 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3697 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3698 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3700 else { _ckvmssts(sts); }
3701 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3703 if ((int) owner.length < lowner) lowner= (int) owner.length;
3704 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3705 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3706 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3707 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3708 owner.pw_gecos[lowner]= '\0';
3709 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3710 defcli.pw_shell[ldefcli]= '\0';
3711 if (valid_uic(uic)) {
3712 pwd->pw_uid= uic.uic$l_uic;
3713 pwd->pw_gid= uic.uic$v_group;
3716 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3717 pwd->pw_passwd= pw_passwd;
3718 pwd->pw_gecos= owner.pw_gecos;
3719 pwd->pw_dir= defdev.pw_dir;
3720 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3721 pwd->pw_shell= defcli.pw_shell;
3722 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3724 ldir= strlen(pwd->pw_unixdir) - 1;
3725 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3728 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3729 __mystrtolower(pwd->pw_unixdir);
3734 * Get information for a named user.
3736 /*{{{struct passwd *getpwnam(char *name)*/
3737 struct passwd *my_getpwnam(char *name)
3739 struct dsc$descriptor_s name_desc;
3741 unsigned long int status, sts;
3744 __pwdcache = __passwd_empty;
3745 if (!fillpasswd(name, &__pwdcache)) {
3746 /* We still may be able to determine pw_uid and pw_gid */
3747 name_desc.dsc$w_length= strlen(name);
3748 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3749 name_desc.dsc$b_class= DSC$K_CLASS_S;
3750 name_desc.dsc$a_pointer= (char *) name;
3751 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3752 __pwdcache.pw_uid= uic.uic$l_uic;
3753 __pwdcache.pw_gid= uic.uic$v_group;
3756 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3757 set_vaxc_errno(sts);
3758 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3761 else { _ckvmssts(sts); }
3764 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3765 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3766 __pwdcache.pw_name= __pw_namecache;
3768 } /* end of my_getpwnam() */
3772 * Get information for a particular UIC or UID.
3773 * Called by my_getpwent with uid=-1 to list all users.
3775 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3776 struct passwd *my_getpwuid(Uid_t uid)
3778 const $DESCRIPTOR(name_desc,__pw_namecache);
3779 unsigned short lname;
3781 unsigned long int status;
3784 if (uid == (unsigned int) -1) {
3786 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3787 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3788 set_vaxc_errno(status);
3789 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3793 else { _ckvmssts(status); }
3794 } while (!valid_uic (uic));
3798 if (!uic.uic$v_group)
3799 uic.uic$v_group= PerlProc_getgid();
3801 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3802 else status = SS$_IVIDENT;
3803 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3804 status == RMS$_PRV) {
3805 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3808 else { _ckvmssts(status); }
3810 __pw_namecache[lname]= '\0';
3811 __mystrtolower(__pw_namecache);
3813 __pwdcache = __passwd_empty;
3814 __pwdcache.pw_name = __pw_namecache;
3816 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3817 The identifier's value is usually the UIC, but it doesn't have to be,
3818 so if we can, we let fillpasswd update this. */
3819 __pwdcache.pw_uid = uic.uic$l_uic;
3820 __pwdcache.pw_gid = uic.uic$v_group;
3822 fillpasswd(__pw_namecache, &__pwdcache);
3825 } /* end of my_getpwuid() */
3829 * Get information for next user.
3831 /*{{{struct passwd *my_getpwent()*/
3832 struct passwd *my_getpwent()
3834 return (my_getpwuid((unsigned int) -1));
3839 * Finish searching rights database for users.
3841 /*{{{void my_endpwent()*/
3846 _ckvmssts(sys$finish_rdb(&contxt));
3852 #ifdef HOMEGROWN_POSIX_SIGNALS
3853 /* Signal handling routines, pulled into the core from POSIX.xs.
3855 * We need these for threads, so they've been rolled into the core,
3856 * rather than left in POSIX.xs.
3858 * (DRS, Oct 23, 1997)
3861 /* sigset_t is atomic under VMS, so these routines are easy */
3862 /*{{{int my_sigemptyset(sigset_t *) */
3863 int my_sigemptyset(sigset_t *set) {
3864 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3870 /*{{{int my_sigfillset(sigset_t *)*/
3871 int my_sigfillset(sigset_t *set) {
3873 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3874 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3880 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3881 int my_sigaddset(sigset_t *set, int sig) {
3882 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3883 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3884 *set |= (1 << (sig - 1));
3890 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3891 int my_sigdelset(sigset_t *set, int sig) {
3892 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3893 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3894 *set &= ~(1 << (sig - 1));
3900 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3901 int my_sigismember(sigset_t *set, int sig) {
3902 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3903 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3904 *set & (1 << (sig - 1));
3909 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3910 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3913 /* If set and oset are both null, then things are badly wrong. Bail out. */
3914 if ((oset == NULL) && (set == NULL)) {
3915 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3919 /* If set's null, then we're just handling a fetch. */
3921 tempmask = sigblock(0);
3926 tempmask = sigsetmask(*set);
3929 tempmask = sigblock(*set);
3932 tempmask = sigblock(0);
3933 sigsetmask(*oset & ~tempmask);
3936 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3941 /* Did they pass us an oset? If so, stick our holding mask into it */
3948 #endif /* HOMEGROWN_POSIX_SIGNALS */
3951 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3952 * my_utime(), and flex_stat(), all of which operate on UTC unless
3953 * VMSISH_TIMES is true.
3955 /* method used to handle UTC conversions:
3956 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3958 static int gmtime_emulation_type;
3959 /* number of secs to add to UTC POSIX-style time to get local time */
3960 static long int utc_offset_secs;
3962 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3963 * in vmsish.h. #undef them here so we can call the CRTL routines
3970 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3971 # define RTL_USES_UTC 1
3974 static time_t toutc_dst(time_t loc) {
3977 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3978 loc -= utc_offset_secs;
3979 if (rsltmp->tm_isdst) loc -= 3600;
3982 #define _toutc(secs) ((secs) == -1 ? -1 : \
3983 ((gmtime_emulation_type || my_time(NULL)), \
3984 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3985 ((secs) - utc_offset_secs))))
3987 static time_t toloc_dst(time_t utc) {
3990 utc += utc_offset_secs;
3991 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3992 if (rsltmp->tm_isdst) utc += 3600;
3995 #define _toloc(secs) ((secs) == -1 ? -1 : \
3996 ((gmtime_emulation_type || my_time(NULL)), \
3997 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3998 ((secs) + utc_offset_secs))))
4001 /* my_time(), my_localtime(), my_gmtime()
4002 * By default traffic in UTC time values, using CRTL gmtime() or
4003 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4004 * Note: We need to use these functions even when the CRTL has working
4005 * UTC support, since they also handle C<use vmsish qw(times);>
4007 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4008 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4011 /*{{{time_t my_time(time_t *timep)*/
4012 time_t my_time(time_t *timep)
4018 if (gmtime_emulation_type == 0) {
4020 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4021 /* results of calls to gmtime() and localtime() */
4022 /* for same &base */
4024 gmtime_emulation_type++;
4025 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4026 char off[LNM$C_NAMLENGTH+1];;
4028 gmtime_emulation_type++;
4029 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4030 gmtime_emulation_type++;
4031 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4033 else { utc_offset_secs = atol(off); }
4035 else { /* We've got a working gmtime() */
4036 struct tm gmt, local;
4039 tm_p = localtime(&base);
4041 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4042 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4043 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4044 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4050 # ifdef RTL_USES_UTC
4051 if (VMSISH_TIME) when = _toloc(when);
4053 if (!VMSISH_TIME) when = _toutc(when);
4056 if (timep != NULL) *timep = when;
4059 } /* end of my_time() */
4063 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4065 my_gmtime(const time_t *timep)
4072 if (timep == NULL) {
4073 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4076 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4080 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4082 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4083 return gmtime(&when);
4085 /* CRTL localtime() wants local time as input, so does no tz correction */
4086 rsltmp = localtime(&when);
4087 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4090 } /* end of my_gmtime() */
4094 /*{{{struct tm *my_localtime(const time_t *timep)*/
4096 my_localtime(const time_t *timep)
4102 if (timep == NULL) {
4103 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4106 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4107 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4110 # ifdef RTL_USES_UTC
4112 if (VMSISH_TIME) when = _toutc(when);
4114 /* CRTL localtime() wants UTC as input, does tz correction itself */
4115 return localtime(&when);
4118 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4121 /* CRTL localtime() wants local time as input, so does no tz correction */
4122 rsltmp = localtime(&when);
4123 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4126 } /* end of my_localtime() */
4129 /* Reset definitions for later calls */
4130 #define gmtime(t) my_gmtime(t)
4131 #define localtime(t) my_localtime(t)
4132 #define time(t) my_time(t)
4135 /* my_utime - update modification time of a file
4136 * calling sequence is identical to POSIX utime(), but under
4137 * VMS only the modification time is changed; ODS-2 does not
4138 * maintain access times. Restrictions differ from the POSIX
4139 * definition in that the time can be changed as long as the
4140 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4141 * no separate checks are made to insure that the caller is the
4142 * owner of the file or has special privs enabled.
4143 * Code here is based on Joe Meadows' FILE utility.
4146 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4147 * to VMS epoch (01-JAN-1858 00:00:00.00)
4148 * in 100 ns intervals.
4150 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4152 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4153 int my_utime(char *file, struct utimbuf *utimes)
4157 long int bintime[2], len = 2, lowbit, unixtime,
4158 secscale = 10000000; /* seconds --> 100 ns intervals */
4159 unsigned long int chan, iosb[2], retsts;
4160 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4161 struct FAB myfab = cc$rms_fab;
4162 struct NAM mynam = cc$rms_nam;
4163 #if defined (__DECC) && defined (__VAX)
4164 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4165 * at least through VMS V6.1, which causes a type-conversion warning.
4167 # pragma message save
4168 # pragma message disable cvtdiftypes
4170 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4171 struct fibdef myfib;
4172 #if defined (__DECC) && defined (__VAX)
4173 /* This should be right after the declaration of myatr, but due
4174 * to a bug in VAX DEC C, this takes effect a statement early.
4176 # pragma message restore
4178 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4179 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4180 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4182 if (file == NULL || *file == '\0') {
4184 set_vaxc_errno(LIB$_INVARG);
4187 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4189 if (utimes != NULL) {
4190 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4191 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4192 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4193 * as input, we force the sign bit to be clear by shifting unixtime right
4194 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4196 lowbit = (utimes->modtime & 1) ? secscale : 0;
4197 unixtime = (long int) utimes->modtime;
4199 /* If input was UTC; convert to local for sys svc */
4200 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4202 unixtime >> 1; secscale << 1;
4203 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4204 if (!(retsts & 1)) {
4206 set_vaxc_errno(retsts);
4209 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4210 if (!(retsts & 1)) {
4212 set_vaxc_errno(retsts);
4217 /* Just get the current time in VMS format directly */
4218 retsts = sys$gettim(bintime);
4219 if (!(retsts & 1)) {
4221 set_vaxc_errno(retsts);
4226 myfab.fab$l_fna = vmsspec;
4227 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4228 myfab.fab$l_nam = &mynam;
4229 mynam.nam$l_esa = esa;
4230 mynam.nam$b_ess = (unsigned char) sizeof esa;
4231 mynam.nam$l_rsa = rsa;
4232 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4234 /* Look for the file to be affected, letting RMS parse the file
4235 * specification for us as well. I have set errno using only
4236 * values documented in the utime() man page for VMS POSIX.
4238 retsts = sys$parse(&myfab,0,0);
4239 if (!(retsts & 1)) {
4240 set_vaxc_errno(retsts);
4241 if (retsts == RMS$_PRV) set_errno(EACCES);
4242 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4243 else set_errno(EVMSERR);
4246 retsts = sys$search(&myfab,0,0);
4247 if (!(retsts & 1)) {
4248 set_vaxc_errno(retsts);
4249 if (retsts == RMS$_PRV) set_errno(EACCES);
4250 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4251 else set_errno(EVMSERR);
4255 devdsc.dsc$w_length = mynam.nam$b_dev;
4256 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4258 retsts = sys$assign(&devdsc,&chan,0,0);
4259 if (!(retsts & 1)) {
4260 set_vaxc_errno(retsts);
4261 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4262 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4263 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4264 else set_errno(EVMSERR);
4268 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4269 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4271 memset((void *) &myfib, 0, sizeof myfib);
4273 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4274 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4275 /* This prevents the revision time of the file being reset to the current
4276 * time as a result of our IO$_MODIFY $QIO. */
4277 myfib.fib$l_acctl = FIB$M_NORECORD;
4279 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4280 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4281 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4283 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4284 _ckvmssts(sys$dassgn(chan));
4285 if (retsts & 1) retsts = iosb[0];
4286 if (!(retsts & 1)) {
4287 set_vaxc_errno(retsts);
4288 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4289 else set_errno(EVMSERR);
4294 } /* end of my_utime() */
4298 * flex_stat, flex_fstat
4299 * basic stat, but gets it right when asked to stat
4300 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4303 /* encode_dev packs a VMS device name string into an integer to allow
4304 * simple comparisons. This can be used, for example, to check whether two
4305 * files are located on the same device, by comparing their encoded device
4306 * names. Even a string comparison would not do, because stat() reuses the
4307 * device name buffer for each call; so without encode_dev, it would be
4308 * necessary to save the buffer and use strcmp (this would mean a number of
4309 * changes to the standard Perl code, to say nothing of what a Perl script
4312 * The device lock id, if it exists, should be unique (unless perhaps compared
4313 * with lock ids transferred from other nodes). We have a lock id if the disk is
4314 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4315 * device names. Thus we use the lock id in preference, and only if that isn't
4316 * available, do we try to pack the device name into an integer (flagged by
4317 * the sign bit (LOCKID_MASK) being set).
4319 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4320 * name and its encoded form, but it seems very unlikely that we will find
4321 * two files on different disks that share the same encoded device names,
4322 * and even more remote that they will share the same file id (if the test
4323 * is to check for the same file).
4325 * A better method might be to use sys$device_scan on the first call, and to
4326 * search for the device, returning an index into the cached array.
4327 * The number returned would be more intelligable.
4328 * This is probably not worth it, and anyway would take quite a bit longer
4329 * on the first call.
4331 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4332 static mydev_t encode_dev (const char *dev)
4335 unsigned long int f;
4341 if (!dev || !dev[0]) return 0;
4345 struct dsc$descriptor_s dev_desc;
4346 unsigned long int status, lockid, item = DVI$_LOCKID;
4348 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4349 can try that first. */
4350 dev_desc.dsc$w_length = strlen (dev);
4351 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4352 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4353 dev_desc.dsc$a_pointer = (char *) dev;
4354 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4355 if (lockid) return (lockid & ~LOCKID_MASK);
4359 /* Otherwise we try to encode the device name */
4363 for (q = dev + strlen(dev); q--; q >= dev) {
4366 else if (isalpha (toupper (*q)))
4367 c= toupper (*q) - 'A' + (char)10;
4369 continue; /* Skip '$'s */
4371 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4373 enc += f * (unsigned long int) c;
4375 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4377 } /* end of encode_dev() */
4379 static char namecache[NAM$C_MAXRSS+1];
4382 is_null_device(name)
4386 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4387 The underscore prefix, controller letter, and unit number are
4388 independently optional; for our purposes, the colon punctuation
4389 is not. The colon can be trailed by optional directory and/or
4390 filename, but two consecutive colons indicates a nodename rather
4391 than a device. [pr] */
4392 if (*name == '_') ++name;
4393 if (tolower(*name++) != 'n') return 0;
4394 if (tolower(*name++) != 'l') return 0;
4395 if (tolower(*name) == 'a') ++name;
4396 if (*name == '0') ++name;
4397 return (*name++ == ':') && (*name != ':');
4400 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4401 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4402 * subset of the applicable information.
4405 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4407 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4409 char fname[NAM$C_MAXRSS+1];
4410 unsigned long int retsts;
4411 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4412 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4414 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4415 device name on successive calls */
4416 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4417 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4418 namdsc.dsc$a_pointer = fname;
4419 namdsc.dsc$w_length = sizeof fname - 1;
4421 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4422 &namdsc,&namdsc.dsc$w_length,0,0);
4424 fname[namdsc.dsc$w_length] = '\0';
4425 return cando_by_name(bit,effective,fname);
4427 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4428 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4432 return FALSE; /* Should never get to here */
4434 } /* end of cando() */
4438 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4440 cando_by_name(I32 bit, Uid_t effective, char *fname)
4442 static char usrname[L_cuserid];
4443 static struct dsc$descriptor_s usrdsc =
4444 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4445 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4446 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4447 unsigned short int retlen;
4449 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4450 union prvdef curprv;
4451 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4452 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4453 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4456 if (!fname || !*fname) return FALSE;
4457 /* Make sure we expand logical names, since sys$check_access doesn't */
4458 if (!strpbrk(fname,"/]>:")) {
4459 strcpy(fileified,fname);
4460 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4463 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4464 retlen = namdsc.dsc$w_length = strlen(vmsname);
4465 namdsc.dsc$a_pointer = vmsname;
4466 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4467 vmsname[retlen-1] == ':') {
4468 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4469 namdsc.dsc$w_length = strlen(fileified);
4470 namdsc.dsc$a_pointer = fileified;
4473 if (!usrdsc.dsc$w_length) {
4475 usrdsc.dsc$w_length = strlen(usrname);
4482 access = ARM$M_EXECUTE;
4487 access = ARM$M_READ;
4492 access = ARM$M_WRITE;
4497 access = ARM$M_DELETE;
4503 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4504 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4505 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4506 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4507 set_vaxc_errno(retsts);
4508 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4509 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4510 else set_errno(ENOENT);
4513 if (retsts == SS$_NORMAL) {
4514 if (!privused) return TRUE;
4515 /* We can get access, but only by using privs. Do we have the
4516 necessary privs currently enabled? */
4517 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4518 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4519 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4520 !curprv.prv$v_bypass) return FALSE;
4521 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4522 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4523 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4526 if (retsts == SS$_ACCONFLICT) {
4531 return FALSE; /* Should never get here */
4533 } /* end of cando_by_name() */
4537 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4539 flex_fstat(int fd, Stat_t *statbufp)
4542 if (!fstat(fd,(stat_t *) statbufp)) {
4543 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4544 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4545 # ifdef RTL_USES_UTC
4548 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4549 statbufp->st_atime = _toloc(statbufp->st_atime);
4550 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4555 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4559 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4560 statbufp->st_atime = _toutc(statbufp->st_atime);
4561 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4568 } /* end of flex_fstat() */
4571 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4573 flex_stat(const char *fspec, Stat_t *statbufp)
4576 char fileified[NAM$C_MAXRSS+1];
4577 char temp_fspec[NAM$C_MAXRSS+300];
4580 strcpy(temp_fspec, fspec);
4581 if (statbufp == (Stat_t *) &PL_statcache)
4582 do_tovmsspec(temp_fspec,namecache,0);
4583 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4584 memset(statbufp,0,sizeof *statbufp);
4585 statbufp->st_dev = encode_dev("_NLA0:");
4586 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4587 statbufp->st_uid = 0x00010001;
4588 statbufp->st_gid = 0x0001;
4589 time((time_t *)&statbufp->st_mtime);
4590 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4594 /* Try for a directory name first. If fspec contains a filename without
4595 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4596 * and sea:[wine.dark]water. exist, we prefer the directory here.
4597 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4598 * not sea:[wine.dark]., if the latter exists. If the intended target is
4599 * the file with null type, specify this by calling flex_stat() with
4600 * a '.' at the end of fspec.
4602 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4603 retval = stat(fileified,(stat_t *) statbufp);
4604 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4605 strcpy(namecache,fileified);
4607 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4609 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4610 # ifdef RTL_USES_UTC
4613 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4614 statbufp->st_atime = _toloc(statbufp->st_atime);
4615 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4620 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4624 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4625 statbufp->st_atime = _toutc(statbufp->st_atime);
4626 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4632 } /* end of flex_stat() */
4636 /*{{{char *my_getlogin()*/
4637 /* VMS cuserid == Unix getlogin, except calling sequence */
4641 static char user[L_cuserid];
4642 return cuserid(user);
4647 /* rmscopy - copy a file using VMS RMS routines
4649 * Copies contents and attributes of spec_in to spec_out, except owner
4650 * and protection information. Name and type of spec_in are used as
4651 * defaults for spec_out. The third parameter specifies whether rmscopy()
4652 * should try to propagate timestamps from the input file to the output file.
4653 * If it is less than 0, no timestamps are preserved. If it is 0, then
4654 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4655 * propagated to the output file at creation iff the output file specification
4656 * did not contain an explicit name or type, and the revision date is always
4657 * updated at the end of the copy operation. If it is greater than 0, then
4658 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4659 * other than the revision date should be propagated, and bit 1 indicates
4660 * that the revision date should be propagated.
4662 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4664 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4665 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4666 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4667 * as part of the Perl standard distribution under the terms of the
4668 * GNU General Public License or the Perl Artistic License. Copies
4669 * of each may be found in the Perl standard distribution.
4671 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4673 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4675 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4676 rsa[NAM$C_MAXRSS], ubf[32256];
4677 unsigned long int i, sts, sts2;
4678 struct FAB fab_in, fab_out;
4679 struct RAB rab_in, rab_out;
4681 struct XABDAT xabdat;
4682 struct XABFHC xabfhc;
4683 struct XABRDT xabrdt;
4684 struct XABSUM xabsum;
4686 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4687 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4688 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4692 fab_in = cc$rms_fab;
4693 fab_in.fab$l_fna = vmsin;
4694 fab_in.fab$b_fns = strlen(vmsin);
4695 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4696 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4697 fab_in.fab$l_fop = FAB$M_SQO;
4698 fab_in.fab$l_nam = &nam;
4699 fab_in.fab$l_xab = (void *) &xabdat;
4702 nam.nam$l_rsa = rsa;
4703 nam.nam$b_rss = sizeof(rsa);
4704 nam.nam$l_esa = esa;
4705 nam.nam$b_ess = sizeof (esa);
4706 nam.nam$b_esl = nam.nam$b_rsl = 0;
4708 xabdat = cc$rms_xabdat; /* To get creation date */
4709 xabdat.xab$l_nxt = (void *) &xabfhc;
4711 xabfhc = cc$rms_xabfhc; /* To get record length */
4712 xabfhc.xab$l_nxt = (void *) &xabsum;
4714 xabsum = cc$rms_xabsum; /* To get key and area information */
4716 if (!((sts = sys$open(&fab_in)) & 1)) {
4717 set_vaxc_errno(sts);
4721 set_errno(ENOENT); break;
4723 set_errno(ENODEV); break;
4725 set_errno(EINVAL); break;
4727 set_errno(EACCES); break;
4735 fab_out.fab$w_ifi = 0;
4736 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4737 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4738 fab_out.fab$l_fop = FAB$M_SQO;
4739 fab_out.fab$l_fna = vmsout;
4740 fab_out.fab$b_fns = strlen(vmsout);
4741 fab_out.fab$l_dna = nam.nam$l_name;
4742 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4744 if (preserve_dates == 0) { /* Act like DCL COPY */
4745 nam.nam$b_nop = NAM$M_SYNCHK;
4746 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4747 if (!((sts = sys$parse(&fab_out)) & 1)) {
4748 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4749 set_vaxc_errno(sts);
4752 fab_out.fab$l_xab = (void *) &xabdat;
4753 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4755 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4756 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4757 preserve_dates =0; /* bitmask from this point forward */
4759 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4760 if (!((sts = sys$create(&fab_out)) & 1)) {
4761 set_vaxc_errno(sts);
4764 set_errno(ENOENT); break;
4766 set_errno(ENODEV); break;
4768 set_errno(EINVAL); break;
4770 set_errno(EACCES); break;
4776 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4777 if (preserve_dates & 2) {
4778 /* sys$close() will process xabrdt, not xabdat */
4779 xabrdt = cc$rms_xabrdt;
4781 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4783 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4784 * is unsigned long[2], while DECC & VAXC use a struct */
4785 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4787 fab_out.fab$l_xab = (void *) &xabrdt;
4790 rab_in = cc$rms_rab;
4791 rab_in.rab$l_fab = &fab_in;
4792 rab_in.rab$l_rop = RAB$M_BIO;
4793 rab_in.rab$l_ubf = ubf;
4794 rab_in.rab$w_usz = sizeof ubf;
4795 if (!((sts = sys$connect(&rab_in)) & 1)) {
4796 sys$close(&fab_in); sys$close(&fab_out);
4797 set_errno(EVMSERR); set_vaxc_errno(sts);
4801 rab_out = cc$rms_rab;
4802 rab_out.rab$l_fab = &fab_out;
4803 rab_out.rab$l_rbf = ubf;
4804 if (!((sts = sys$connect(&rab_out)) & 1)) {
4805 sys$close(&fab_in); sys$close(&fab_out);
4806 set_errno(EVMSERR); set_vaxc_errno(sts);
4810 while ((sts = sys$read(&rab_in))) { /* always true */
4811 if (sts == RMS$_EOF) break;
4812 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4813 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4814 sys$close(&fab_in); sys$close(&fab_out);
4815 set_errno(EVMSERR); set_vaxc_errno(sts);
4820 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4821 sys$close(&fab_in); sys$close(&fab_out);
4822 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4824 set_errno(EVMSERR); set_vaxc_errno(sts);
4830 } /* end of rmscopy() */
4834 /*** The following glue provides 'hooks' to make some of the routines
4835 * from this file available from Perl. These routines are sufficiently
4836 * basic, and are required sufficiently early in the build process,
4837 * that's it's nice to have them available to miniperl as well as the
4838 * full Perl, so they're set up here instead of in an extension. The
4839 * Perl code which handles importation of these names into a given
4840 * package lives in [.VMS]Filespec.pm in @INC.
4844 rmsexpand_fromperl(pTHX_ CV *cv)
4847 char *fspec, *defspec = NULL, *rslt;
4850 if (!items || items > 2)
4851 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4852 fspec = SvPV(ST(0),n_a);
4853 if (!fspec || !*fspec) XSRETURN_UNDEF;
4854 if (items == 2) defspec = SvPV(ST(1),n_a);
4856 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4857 ST(0) = sv_newmortal();
4858 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4863 vmsify_fromperl(pTHX_ CV *cv)
4869 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4870 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4871 ST(0) = sv_newmortal();
4872 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4877 unixify_fromperl(pTHX_ CV *cv)
4883 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4884 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4885 ST(0) = sv_newmortal();
4886 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4891 fileify_fromperl(pTHX_ CV *cv)
4897 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4898 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4899 ST(0) = sv_newmortal();
4900 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4905 pathify_fromperl(pTHX_ CV *cv)
4911 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4912 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4913 ST(0) = sv_newmortal();
4914 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4919 vmspath_fromperl(pTHX_ CV *cv)
4925 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
4926 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4927 ST(0) = sv_newmortal();
4928 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4933 unixpath_fromperl(pTHX_ CV *cv)
4939 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
4940 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4941 ST(0) = sv_newmortal();
4942 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4947 candelete_fromperl(pTHX_ CV *cv)
4950 char fspec[NAM$C_MAXRSS+1], *fsp;
4955 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
4957 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4958 if (SvTYPE(mysv) == SVt_PVGV) {
4959 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4960 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4967 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4968 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4974 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4979 rmscopy_fromperl(pTHX_ CV *cv)
4982 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4984 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4985 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4986 unsigned long int sts;
4991 if (items < 2 || items > 3)
4992 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
4994 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4995 if (SvTYPE(mysv) == SVt_PVGV) {
4996 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4997 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5004 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5005 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5010 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5011 if (SvTYPE(mysv) == SVt_PVGV) {
5012 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5013 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5020 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5021 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5026 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5028 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5035 char* file = __FILE__;
5037 char temp_buff[512];
5038 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5039 no_translate_barewords = TRUE;
5041 no_translate_barewords = FALSE;
5044 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5045 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5046 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5047 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5048 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5049 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5050 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5051 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5052 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);