3 * VMS-specific routines for perl5
5 * Last revised: 20-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 /* Temp for subprocess commands */
99 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
101 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
103 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
104 struct dsc$descriptor_s **tabvec, unsigned long int flags)
106 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
107 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
108 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
109 unsigned char acmode;
110 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
111 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
112 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
113 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
115 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
116 #if defined(USE_THREADS)
117 /* We jump through these hoops because we can be called at */
118 /* platform-specific initialization time, which is before anything is */
119 /* set up--we can't even do a plain dTHX since that relies on the */
120 /* interpreter structure to be initialized */
121 struct perl_thread *thr;
123 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
129 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
130 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
132 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
133 *cp2 = _toupper(*cp1);
134 if (cp1 - lnm > LNM$C_NAMLENGTH) {
135 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
139 lnmdsc.dsc$w_length = cp1 - lnm;
140 lnmdsc.dsc$a_pointer = uplnm;
141 uplnm[lnmdsc.dsc$w_length] = '\0';
142 secure = flags & PERL__TRNENV_SECURE;
143 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
144 if (!tabvec || !*tabvec) tabvec = env_tables;
146 for (curtab = 0; tabvec[curtab]; curtab++) {
147 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
148 if (!ivenv && !secure) {
153 Perl_warn(aTHX_ "Can't read CRTL environ\n");
156 retsts = SS$_NOLOGNAM;
157 for (i = 0; environ[i]; i++) {
158 if ((eq = strchr(environ[i],'=')) &&
159 !strncmp(environ[i],uplnm,eq - environ[i])) {
161 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
162 if (!eqvlen) continue;
167 if (retsts != SS$_NOLOGNAM) break;
170 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
171 !str$case_blind_compare(&tmpdsc,&clisym)) {
172 if (!ivsym && !secure) {
173 unsigned short int deflen = LNM$C_NAMLENGTH;
174 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
175 /* dynamic dsc to accomodate possible long value */
176 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
177 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
180 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
182 /* Special hack--we might be called before the interpreter's */
183 /* fully initialized, in which case either thr or PL_curcop */
184 /* might be bogus. We have to check, since ckWARN needs them */
185 /* both to be valid if running threaded */
186 #if defined(USE_THREADS)
187 if (thr && PL_curcop) {
189 if (ckWARN(WARN_MISC)) {
190 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
192 #if defined(USE_THREADS)
194 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
199 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
201 _ckvmssts(lib$sfree1_dd(&eqvdsc));
202 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
203 if (retsts == LIB$_NOSUCHSYM) continue;
208 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
209 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
210 if (retsts == SS$_NOLOGNAM) continue;
211 /* PPFs have a prefix */
214 *((int *)uplnm) == *((int *)"SYS$") &&
216 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
217 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
218 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
219 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
220 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
221 memcpy(eqv,eqv+4,eqvlen-4);
227 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
228 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
229 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
230 retsts == SS$_NOLOGNAM) {
231 set_errno(EINVAL); set_vaxc_errno(retsts);
233 else _ckvmssts(retsts);
235 } /* end of vmstrnenv */
238 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
239 /* Define as a function so we can access statics. */
240 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
242 return vmstrnenv(lnm,eqv,idx,fildev,
243 #ifdef SECURE_INTERNAL_GETENV
244 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
253 * Note: Uses Perl temp to store result so char * can be returned to
254 * caller; this pointer will be invalidated at next Perl statement
256 * We define this as a function rather than a macro in terms of my_getenv_len()
257 * so that it'll work when PL_curinterp is undefined (and we therefore can't
260 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
262 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
264 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
265 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
266 unsigned long int idx = 0;
270 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
271 /* Set up a temporary buffer for the return value; Perl will
272 * clean it up at the next statement transition */
273 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
274 if (!tmpsv) return NULL;
277 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
278 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
279 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
280 getcwd(eqv,LNM$C_NAMLENGTH);
284 if ((cp2 = strchr(lnm,';')) != NULL) {
286 uplnm[cp2-lnm] = '\0';
287 idx = strtoul(cp2+1,NULL,0);
290 /* Impose security constraints only if tainting */
291 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
292 if (vmstrnenv(lnm,eqv,idx,
294 #ifdef SECURE_INTERNAL_GETENV
295 sys ? PERL__TRNENV_SECURE : 0
303 } /* end of my_getenv() */
307 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
309 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
312 char *buf, *cp1, *cp2;
313 unsigned long idx = 0;
314 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
317 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
318 /* Set up a temporary buffer for the return value; Perl will
319 * clean it up at the next statement transition */
320 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
321 if (!tmpsv) return NULL;
324 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
325 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
326 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
327 getcwd(buf,LNM$C_NAMLENGTH);
332 if ((cp2 = strchr(lnm,';')) != NULL) {
335 idx = strtoul(cp2+1,NULL,0);
338 /* Impose security constraints only if tainting */
339 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
340 if ((*len = vmstrnenv(lnm,buf,idx,
342 #ifdef SECURE_INTERNAL_GETENV
343 sys ? PERL__TRNENV_SECURE : 0
353 } /* end of my_getenv_len() */
356 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
358 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
360 /*{{{ void prime_env_iter() */
363 /* Fill the %ENV associative array with all logical names we can
364 * find, in preparation for iterating over it.
368 static int primed = 0;
369 HV *seenhv = NULL, *envhv;
370 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
371 unsigned short int chan;
372 #ifndef CLI$M_TRUSTED
373 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
375 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
376 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
378 bool have_sym = FALSE, have_lnm = FALSE;
379 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
380 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
381 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
382 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
383 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
385 static perl_mutex primenv_mutex;
386 MUTEX_INIT(&primenv_mutex);
389 if (primed || !PL_envgv) return;
390 MUTEX_LOCK(&primenv_mutex);
391 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
392 envhv = GvHVn(PL_envgv);
393 /* Perform a dummy fetch as an lval to insure that the hash table is
394 * set up. Otherwise, the hv_store() will turn into a nullop. */
395 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
397 for (i = 0; env_tables[i]; i++) {
398 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
399 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
400 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
402 if (have_sym || have_lnm) {
403 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
404 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
405 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
406 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
409 for (i--; i >= 0; i--) {
410 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
413 for (j = 0; environ[j]; j++) {
414 if (!(start = strchr(environ[j],'='))) {
415 if (ckWARN(WARN_INTERNAL))
416 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
420 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
426 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
427 !str$case_blind_compare(&tmpdsc,&clisym)) {
428 strcpy(cmd,"Show Symbol/Global *");
429 cmddsc.dsc$w_length = 20;
430 if (env_tables[i]->dsc$w_length == 12 &&
431 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
432 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
433 flags = defflags | CLI$M_NOLOGNAM;
436 strcpy(cmd,"Show Logical *");
437 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
438 strcat(cmd," /Table=");
439 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
440 cmddsc.dsc$w_length = strlen(cmd);
442 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
443 flags = defflags | CLI$M_NOCLISYM;
446 /* Create a new subprocess to execute each command, to exclude the
447 * remote possibility that someone could subvert a mbx or file used
448 * to write multiple commands to a single subprocess.
451 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
452 0,&riseandshine,0,0,&clidsc,&clitabdsc);
453 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
454 defflags &= ~CLI$M_TRUSTED;
455 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
457 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
458 if (seenhv) SvREFCNT_dec(seenhv);
461 char *cp1, *cp2, *key;
462 unsigned long int sts, iosb[2], retlen, keylen;
465 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
466 if (sts & 1) sts = iosb[0] & 0xffff;
467 if (sts == SS$_ENDOFFILE) {
469 while (substs == 0) { sys$hiber(); wakect++;}
470 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
475 retlen = iosb[0] >> 16;
476 if (!retlen) continue; /* blank line */
478 if (iosb[1] != subpid) {
480 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
484 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
485 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
487 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
488 if (*cp1 == '(' || /* Logical name table name */
489 *cp1 == '=' /* Next eqv of searchlist */) continue;
490 if (*cp1 == '"') cp1++;
491 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
492 key = cp1; keylen = cp2 - cp1;
493 if (keylen && hv_exists(seenhv,key,keylen)) continue;
494 while (*cp2 && *cp2 != '=') cp2++;
495 while (*cp2 && *cp2 == '=') cp2++;
496 while (*cp2 && *cp2 == ' ') cp2++;
497 if (*cp2 == '"') { /* String translation; may embed "" */
498 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
499 cp2++; cp1--; /* Skip "" surrounding translation */
501 else { /* Numeric translation */
502 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
503 cp1--; /* stop on last non-space char */
505 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
506 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
509 PERL_HASH(hash,key,keylen);
510 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
511 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
513 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
514 /* get the PPFs for this process, not the subprocess */
515 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
516 char eqv[LNM$C_NAMLENGTH+1];
518 for (i = 0; ppfs[i]; i++) {
519 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
520 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
525 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
526 if (buf) Safefree(buf);
527 if (seenhv) SvREFCNT_dec(seenhv);
528 MUTEX_UNLOCK(&primenv_mutex);
531 } /* end of prime_env_iter */
535 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
536 /* Define or delete an element in the same "environment" as
537 * vmstrnenv(). If an element is to be deleted, it's removed from
538 * the first place it's found. If it's to be set, it's set in the
539 * place designated by the first element of the table vector.
540 * Like setenv() returns 0 for success, non-zero on error.
543 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
545 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
546 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
547 unsigned long int retsts, usermode = PSL$C_USER;
548 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
549 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
550 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
551 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
552 $DESCRIPTOR(local,"_LOCAL");
555 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
556 *cp2 = _toupper(*cp1);
557 if (cp1 - lnm > LNM$C_NAMLENGTH) {
558 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
562 lnmdsc.dsc$w_length = cp1 - lnm;
563 if (!tabvec || !*tabvec) tabvec = env_tables;
565 if (!eqv) { /* we're deleting n element */
566 for (curtab = 0; tabvec[curtab]; curtab++) {
567 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
569 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
570 if ((cp1 = strchr(environ[i],'=')) &&
571 !strncmp(environ[i],lnm,cp1 - environ[i])) {
573 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
576 ivenv = 1; retsts = SS$_NOLOGNAM;
578 if (ckWARN(WARN_INTERNAL))
579 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
580 ivenv = 1; retsts = SS$_NOSUCHPGM;
586 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
587 !str$case_blind_compare(&tmpdsc,&clisym)) {
588 unsigned int symtype;
589 if (tabvec[curtab]->dsc$w_length == 12 &&
590 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
591 !str$case_blind_compare(&tmpdsc,&local))
592 symtype = LIB$K_CLI_LOCAL_SYM;
593 else symtype = LIB$K_CLI_GLOBAL_SYM;
594 retsts = lib$delete_symbol(&lnmdsc,&symtype);
595 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
596 if (retsts == LIB$_NOSUCHSYM) continue;
600 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
601 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
602 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
603 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
604 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
608 else { /* we're defining a value */
609 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
611 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
613 if (ckWARN(WARN_INTERNAL))
614 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
615 retsts = SS$_NOSUCHPGM;
619 eqvdsc.dsc$a_pointer = eqv;
620 eqvdsc.dsc$w_length = strlen(eqv);
621 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
622 !str$case_blind_compare(&tmpdsc,&clisym)) {
623 unsigned int symtype;
624 if (tabvec[0]->dsc$w_length == 12 &&
625 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
626 !str$case_blind_compare(&tmpdsc,&local))
627 symtype = LIB$K_CLI_LOCAL_SYM;
628 else symtype = LIB$K_CLI_GLOBAL_SYM;
629 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
632 if (!*eqv) eqvdsc.dsc$w_length = 1;
633 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
634 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
635 if (ckWARN(WARN_MISC)) {
636 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
639 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
645 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
646 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
647 set_errno(EVMSERR); break;
648 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
649 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
650 set_errno(EINVAL); break;
657 set_vaxc_errno(retsts);
658 return (int) retsts || 44; /* retsts should never be 0, but just in case */
661 /* We reset error values on success because Perl does an hv_fetch()
662 * before each hv_store(), and if the thing we're setting didn't
663 * previously exist, we've got a leftover error message. (Of course,
664 * this fails in the face of
665 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
666 * in that the error reported in $! isn't spurious,
667 * but it's right more often than not.)
669 set_errno(0); set_vaxc_errno(retsts);
673 } /* end of vmssetenv() */
676 /*{{{ void my_setenv(char *lnm, char *eqv)*/
677 /* This has to be a function since there's a prototype for it in proto.h */
679 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
681 if (lnm && *lnm && strlen(lnm) == 7) {
684 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
685 if (!strcmp(uplnm,"DEFAULT")) {
686 if (eqv && *eqv) chdir(eqv);
690 (void) vmssetenv(lnm,eqv,NULL);
696 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
697 /* my_crypt - VMS password hashing
698 * my_crypt() provides an interface compatible with the Unix crypt()
699 * C library function, and uses sys$hash_password() to perform VMS
700 * password hashing. The quadword hashed password value is returned
701 * as a NUL-terminated 8 character string. my_crypt() does not change
702 * the case of its string arguments; in order to match the behavior
703 * of LOGINOUT et al., alphabetic characters in both arguments must
704 * be upcased by the caller.
707 my_crypt(const char *textpasswd, const char *usrname)
709 # ifndef UAI$C_PREFERRED_ALGORITHM
710 # define UAI$C_PREFERRED_ALGORITHM 127
712 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
713 unsigned short int salt = 0;
714 unsigned long int sts;
716 unsigned short int dsc$w_length;
717 unsigned char dsc$b_type;
718 unsigned char dsc$b_class;
719 const char * dsc$a_pointer;
720 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
721 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
722 struct itmlst_3 uailst[3] = {
723 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
724 { sizeof salt, UAI$_SALT, &salt, 0},
725 { 0, 0, NULL, NULL}};
728 usrdsc.dsc$w_length = strlen(usrname);
729 usrdsc.dsc$a_pointer = usrname;
730 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
737 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
743 if (sts != RMS$_RNF) return NULL;
746 txtdsc.dsc$w_length = strlen(textpasswd);
747 txtdsc.dsc$a_pointer = textpasswd;
748 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
749 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
752 return (char *) hash;
754 } /* end of my_crypt() */
758 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
759 static char *do_fileify_dirspec(char *, char *, int);
760 static char *do_tovmsspec(char *, char *, int);
762 /*{{{int do_rmdir(char *name)*/
766 char dirfile[NAM$C_MAXRSS+1];
770 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
771 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
772 else retval = kill_file(dirfile);
775 } /* end of do_rmdir */
779 * Delete any file to which user has control access, regardless of whether
780 * delete access is explicitly allowed.
781 * Limitations: User must have write access to parent directory.
782 * Does not block signals or ASTs; if interrupted in midstream
783 * may leave file with an altered ACL.
786 /*{{{int kill_file(char *name)*/
788 kill_file(char *name)
790 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
791 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
792 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
794 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
796 unsigned char myace$b_length;
797 unsigned char myace$b_type;
798 unsigned short int myace$w_flags;
799 unsigned long int myace$l_access;
800 unsigned long int myace$l_ident;
801 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
802 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
803 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
805 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
806 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
807 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
808 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
809 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
810 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
812 /* Expand the input spec using RMS, since the CRTL remove() and
813 * system services won't do this by themselves, so we may miss
814 * a file "hiding" behind a logical name or search list. */
815 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
816 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
817 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
818 /* If not, can changing protections help? */
819 if (vaxc$errno != RMS$_PRV) return -1;
821 /* No, so we get our own UIC to use as a rights identifier,
822 * and the insert an ACE at the head of the ACL which allows us
823 * to delete the file.
825 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
826 fildsc.dsc$w_length = strlen(rspec);
827 fildsc.dsc$a_pointer = rspec;
829 newace.myace$l_ident = oldace.myace$l_ident;
830 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
835 case SS$_NOSUCHOBJECT:
836 set_errno(ENOENT); break;
838 set_errno(ENODEV); break;
840 case SS$_INVFILFOROP:
841 set_errno(EINVAL); break;
843 set_errno(EACCES); break;
847 set_vaxc_errno(aclsts);
850 /* Grab any existing ACEs with this identifier in case we fail */
851 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
852 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
853 || fndsts == SS$_NOMOREACE ) {
854 /* Add the new ACE . . . */
855 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
857 if ((rmsts = remove(name))) {
858 /* We blew it - dir with files in it, no write priv for
859 * parent directory, etc. Put things back the way they were. */
860 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
863 addlst[0].bufadr = &oldace;
864 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
871 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
872 /* We just deleted it, so of course it's not there. Some versions of
873 * VMS seem to return success on the unlock operation anyhow (after all
874 * the unlock is successful), but others don't.
876 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
877 if (aclsts & 1) aclsts = fndsts;
880 set_vaxc_errno(aclsts);
886 } /* end of kill_file() */
890 /*{{{int my_mkdir(char *,Mode_t)*/
892 my_mkdir(char *dir, Mode_t mode)
894 STRLEN dirlen = strlen(dir);
897 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
898 * null file name/type. However, it's commonplace under Unix,
899 * so we'll allow it for a gain in portability.
901 if (dir[dirlen-1] == '/') {
902 char *newdir = savepvn(dir,dirlen-1);
903 int ret = mkdir(newdir,mode);
907 else return mkdir(dir,mode);
908 } /* end of my_mkdir */
913 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
915 static unsigned long int mbxbufsiz;
916 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
921 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
922 * preprocessor consant BUFSIZ from stdio.h as the size of the
925 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
926 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
928 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
930 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
931 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
933 } /* end of create_mbx() */
935 /*{{{ my_popen and my_pclose*/
938 struct pipe_details *next;
939 PerlIO *fp; /* stdio file pointer to pipe mailbox */
940 int pid; /* PID of subprocess */
941 int mode; /* == 'r' if pipe open for reading */
942 int done; /* subprocess has completed */
943 unsigned long int completion; /* termination status of subprocess */
946 struct exit_control_block
948 struct exit_control_block *flink;
949 unsigned long int (*exit_routine)();
950 unsigned long int arg_count;
951 unsigned long int *status_address;
952 unsigned long int exit_status;
955 static struct pipe_details *open_pipes = NULL;
956 static $DESCRIPTOR(nl_desc, "NL:");
957 static int waitpid_asleep = 0;
959 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
960 * to a mbx; that's the caller's responsibility.
962 static unsigned long int
963 pipe_eof(FILE *fp, int immediate)
965 char devnam[NAM$C_MAXRSS+1], *cp;
966 unsigned long int chan, iosb[2], retsts, retsts2;
967 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
970 if (fgetname(fp,devnam,1)) {
971 /* It oughta be a mailbox, so fgetname should give just the device
972 * name, but just in case . . . */
973 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
974 devdsc.dsc$w_length = strlen(devnam);
975 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
976 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
977 iosb,0,0,0,0,0,0,0,0);
978 if (retsts & 1) retsts = iosb[0];
979 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
980 if (retsts & 1) retsts = retsts2;
984 else _ckvmssts(vaxc$errno); /* Should never happen */
985 return (unsigned long int) vaxc$errno;
988 static unsigned long int
991 struct pipe_details *info;
992 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
997 first we try sending an EOF...ignore if doesn't work, make sure we
1005 _ckvmssts(sys$setast(0));
1006 need_eof = info->mode != 'r' && !info->done;
1007 _ckvmssts(sys$setast(1));
1009 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1013 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1018 _ckvmssts(sys$setast(0));
1019 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1020 sts = sys$forcex(&info->pid,0,&abort);
1021 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1024 _ckvmssts(sys$setast(1));
1027 if (did_stuff) sleep(1); /* wait for them to respond */
1031 _ckvmssts(sys$setast(0));
1032 if (!info->done) { /* We tried to be nice . . . */
1033 sts = sys$delprc(&info->pid,0);
1034 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1035 info->done = 1; /* so my_pclose doesn't try to write EOF */
1037 _ckvmssts(sys$setast(1));
1042 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1043 else if (!(sts & 1)) retsts = sts;
1048 static struct exit_control_block pipe_exitblock =
1049 {(struct exit_control_block *) 0,
1050 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1054 popen_completion_ast(struct pipe_details *thispipe)
1056 thispipe->done = TRUE;
1057 if (waitpid_asleep) {
1063 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1064 static void vms_execfree();
1067 safe_popen(char *cmd, char *mode)
1069 static int handler_set_up = FALSE;
1071 unsigned short int chan;
1072 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1074 struct pipe_details *info;
1075 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1076 DSC$K_CLASS_S, mbxname},
1077 cmddsc = {0, DSC$K_DTYPE_T,
1081 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1082 New(1301,info,1,struct pipe_details);
1084 /* create mailbox */
1085 create_mbx(&chan,&namdsc);
1087 /* open a FILE* onto it */
1088 info->fp = PerlIO_open(mbxname, mode);
1090 /* give up other channel onto it */
1091 _ckvmssts(sys$dassgn(chan));
1101 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1102 0 /* name */, &info->pid, &info->completion,
1103 0, popen_completion_ast,info,0,0,0));
1106 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1107 0 /* name */, &info->pid, &info->completion,
1108 0, popen_completion_ast,info,0,0,0));
1112 if (!handler_set_up) {
1113 _ckvmssts(sys$dclexh(&pipe_exitblock));
1114 handler_set_up = TRUE;
1116 info->next=open_pipes; /* prepend to list */
1119 PL_forkprocess = info->pid;
1121 } /* end of safe_popen */
1124 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1126 Perl_my_popen(pTHX_ char *cmd, char *mode)
1129 TAINT_PROPER("popen");
1130 PERL_FLUSHALL_FOR_CHILD;
1131 return safe_popen(cmd,mode);
1136 /*{{{ I32 my_pclose(FILE *fp)*/
1137 I32 Perl_my_pclose(pTHX_ FILE *fp)
1139 struct pipe_details *info, *last = NULL;
1140 unsigned long int retsts;
1143 for (info = open_pipes; info != NULL; last = info, info = info->next)
1144 if (info->fp == fp) break;
1146 if (info == NULL) { /* no such pipe open */
1147 set_errno(ECHILD); /* quoth POSIX */
1148 set_vaxc_errno(SS$_NONEXPR);
1152 /* If we were writing to a subprocess, insure that someone reading from
1153 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1154 * produce an EOF record in the mailbox. */
1155 _ckvmssts(sys$setast(0));
1156 need_eof = info->mode != 'r' && !info->done;
1157 _ckvmssts(sys$setast(1));
1158 if (need_eof) pipe_eof(info->fp,0);
1159 PerlIO_close(info->fp);
1161 if (info->done) retsts = info->completion;
1162 else waitpid(info->pid,(int *) &retsts,0);
1164 /* remove from list of open pipes */
1165 _ckvmssts(sys$setast(0));
1166 if (last) last->next = info->next;
1167 else open_pipes = info->next;
1168 _ckvmssts(sys$setast(1));
1173 } /* end of my_pclose() */
1175 /* sort-of waitpid; use only with popen() */
1176 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1178 my_waitpid(Pid_t pid, int *statusp, int flags)
1180 struct pipe_details *info;
1183 for (info = open_pipes; info != NULL; info = info->next)
1184 if (info->pid == pid) break;
1186 if (info != NULL) { /* we know about this child */
1187 while (!info->done) {
1192 *statusp = info->completion;
1195 else { /* we haven't heard of this child */
1196 $DESCRIPTOR(intdsc,"0 00:00:01");
1197 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1198 unsigned long int interval[2],sts;
1200 if (ckWARN(WARN_EXEC)) {
1201 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1202 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1203 if (ownerpid != mypid)
1204 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1207 _ckvmssts(sys$bintim(&intdsc,interval));
1208 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1209 _ckvmssts(sys$schdwk(0,0,interval,0));
1210 _ckvmssts(sys$hiber());
1214 /* There's no easy way to find the termination status a child we're
1215 * not aware of beforehand. If we're really interested in the future,
1216 * we can go looking for a termination mailbox, or chase after the
1217 * accounting record for the process.
1223 } /* end of waitpid() */
1228 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1230 my_gconvert(double val, int ndig, int trail, char *buf)
1232 static char __gcvtbuf[DBL_DIG+1];
1235 loc = buf ? buf : __gcvtbuf;
1237 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1239 sprintf(loc,"%.*g",ndig,val);
1245 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1246 return gcvt(val,ndig,loc);
1249 loc[0] = '0'; loc[1] = '\0';
1257 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1258 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1259 * to expand file specification. Allows for a single default file
1260 * specification and a simple mask of options. If outbuf is non-NULL,
1261 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1262 * the resultant file specification is placed. If outbuf is NULL, the
1263 * resultant file specification is placed into a static buffer.
1264 * The third argument, if non-NULL, is taken to be a default file
1265 * specification string. The fourth argument is unused at present.
1266 * rmesexpand() returns the address of the resultant string if
1267 * successful, and NULL on error.
1269 static char *do_tounixspec(char *, char *, int);
1272 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1274 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1275 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1276 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1277 struct FAB myfab = cc$rms_fab;
1278 struct NAM mynam = cc$rms_nam;
1280 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1282 if (!filespec || !*filespec) {
1283 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1287 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1288 else outbuf = __rmsexpand_retbuf;
1290 if ((isunix = (strchr(filespec,'/') != NULL))) {
1291 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1292 filespec = vmsfspec;
1295 myfab.fab$l_fna = filespec;
1296 myfab.fab$b_fns = strlen(filespec);
1297 myfab.fab$l_nam = &mynam;
1299 if (defspec && *defspec) {
1300 if (strchr(defspec,'/') != NULL) {
1301 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1304 myfab.fab$l_dna = defspec;
1305 myfab.fab$b_dns = strlen(defspec);
1308 mynam.nam$l_esa = esa;
1309 mynam.nam$b_ess = sizeof esa;
1310 mynam.nam$l_rsa = outbuf;
1311 mynam.nam$b_rss = NAM$C_MAXRSS;
1313 retsts = sys$parse(&myfab,0,0);
1314 if (!(retsts & 1)) {
1315 mynam.nam$b_nop |= NAM$M_SYNCHK;
1316 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1317 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1318 retsts = sys$parse(&myfab,0,0);
1319 if (retsts & 1) goto expanded;
1321 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1322 (void) sys$parse(&myfab,0,0); /* Free search context */
1323 if (out) Safefree(out);
1324 set_vaxc_errno(retsts);
1325 if (retsts == RMS$_PRV) set_errno(EACCES);
1326 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1327 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1328 else set_errno(EVMSERR);
1331 retsts = sys$search(&myfab,0,0);
1332 if (!(retsts & 1) && retsts != RMS$_FNF) {
1333 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1334 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1335 if (out) Safefree(out);
1336 set_vaxc_errno(retsts);
1337 if (retsts == RMS$_PRV) set_errno(EACCES);
1338 else set_errno(EVMSERR);
1342 /* If the input filespec contained any lowercase characters,
1343 * downcase the result for compatibility with Unix-minded code. */
1345 for (out = myfab.fab$l_fna; *out; out++)
1346 if (islower(*out)) { haslower = 1; break; }
1347 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1348 else { out = esa; speclen = mynam.nam$b_esl; }
1349 /* Trim off null fields added by $PARSE
1350 * If type > 1 char, must have been specified in original or default spec
1351 * (not true for version; $SEARCH may have added version of existing file).
1353 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1354 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1355 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1356 if (trimver || trimtype) {
1357 if (defspec && *defspec) {
1358 char defesa[NAM$C_MAXRSS];
1359 struct FAB deffab = cc$rms_fab;
1360 struct NAM defnam = cc$rms_nam;
1362 deffab.fab$l_nam = &defnam;
1363 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1364 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1365 defnam.nam$b_nop = NAM$M_SYNCHK;
1366 if (sys$parse(&deffab,0,0) & 1) {
1367 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1368 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1371 if (trimver) speclen = mynam.nam$l_ver - out;
1373 /* If we didn't already trim version, copy down */
1374 if (speclen > mynam.nam$l_ver - out)
1375 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1376 speclen - (mynam.nam$l_ver - out));
1377 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1380 /* If we just had a directory spec on input, $PARSE "helpfully"
1381 * adds an empty name and type for us */
1382 if (mynam.nam$l_name == mynam.nam$l_type &&
1383 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1384 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1385 speclen = mynam.nam$l_name - out;
1386 out[speclen] = '\0';
1387 if (haslower) __mystrtolower(out);
1389 /* Have we been working with an expanded, but not resultant, spec? */
1390 /* Also, convert back to Unix syntax if necessary. */
1391 if (!mynam.nam$b_rsl) {
1393 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1395 else strcpy(outbuf,esa);
1398 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1399 strcpy(outbuf,tmpfspec);
1401 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1402 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1403 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1407 /* External entry points */
1408 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1409 { return do_rmsexpand(spec,buf,0,def,opt); }
1410 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1411 { return do_rmsexpand(spec,buf,1,def,opt); }
1415 ** The following routines are provided to make life easier when
1416 ** converting among VMS-style and Unix-style directory specifications.
1417 ** All will take input specifications in either VMS or Unix syntax. On
1418 ** failure, all return NULL. If successful, the routines listed below
1419 ** return a pointer to a buffer containing the appropriately
1420 ** reformatted spec (and, therefore, subsequent calls to that routine
1421 ** will clobber the result), while the routines of the same names with
1422 ** a _ts suffix appended will return a pointer to a mallocd string
1423 ** containing the appropriately reformatted spec.
1424 ** In all cases, only explicit syntax is altered; no check is made that
1425 ** the resulting string is valid or that the directory in question
1428 ** fileify_dirspec() - convert a directory spec into the name of the
1429 ** directory file (i.e. what you can stat() to see if it's a dir).
1430 ** The style (VMS or Unix) of the result is the same as the style
1431 ** of the parameter passed in.
1432 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1433 ** what you prepend to a filename to indicate what directory it's in).
1434 ** The style (VMS or Unix) of the result is the same as the style
1435 ** of the parameter passed in.
1436 ** tounixpath() - convert a directory spec into a Unix-style path.
1437 ** tovmspath() - convert a directory spec into a VMS-style path.
1438 ** tounixspec() - convert any file spec into a Unix-style file spec.
1439 ** tovmsspec() - convert any file spec into a VMS-style spec.
1441 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1442 ** Permission is given to distribute this code as part of the Perl
1443 ** standard distribution under the terms of the GNU General Public
1444 ** License or the Perl Artistic License. Copies of each may be
1445 ** found in the Perl standard distribution.
1448 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1449 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1451 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1452 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1453 char *retspec, *cp1, *cp2, *lastdir;
1454 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1456 if (!dir || !*dir) {
1457 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1459 dirlen = strlen(dir);
1460 while (dir[dirlen-1] == '/') --dirlen;
1461 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1462 strcpy(trndir,"/sys$disk/000000");
1466 if (dirlen > NAM$C_MAXRSS) {
1467 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1469 if (!strpbrk(dir+1,"/]>:")) {
1470 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1471 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1473 dirlen = strlen(dir);
1476 strncpy(trndir,dir,dirlen);
1477 trndir[dirlen] = '\0';
1480 /* If we were handed a rooted logical name or spec, treat it like a
1481 * simple directory, so that
1482 * $ Define myroot dev:[dir.]
1483 * ... do_fileify_dirspec("myroot",buf,1) ...
1484 * does something useful.
1486 if (!strcmp(dir+dirlen-2,".]")) {
1487 dir[--dirlen] = '\0';
1488 dir[dirlen-1] = ']';
1491 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1492 /* If we've got an explicit filename, we can just shuffle the string. */
1493 if (*(cp1+1)) hasfilename = 1;
1494 /* Similarly, we can just back up a level if we've got multiple levels
1495 of explicit directories in a VMS spec which ends with directories. */
1497 for (cp2 = cp1; cp2 > dir; cp2--) {
1499 *cp2 = *cp1; *cp1 = '\0';
1503 if (*cp2 == '[' || *cp2 == '<') break;
1508 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1509 if (dir[0] == '.') {
1510 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1511 return do_fileify_dirspec("[]",buf,ts);
1512 else if (dir[1] == '.' &&
1513 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1514 return do_fileify_dirspec("[-]",buf,ts);
1516 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1517 dirlen -= 1; /* to last element */
1518 lastdir = strrchr(dir,'/');
1520 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1521 /* If we have "/." or "/..", VMSify it and let the VMS code
1522 * below expand it, rather than repeating the code to handle
1523 * relative components of a filespec here */
1525 if (*(cp1+2) == '.') cp1++;
1526 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1527 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1528 if (strchr(vmsdir,'/') != NULL) {
1529 /* If do_tovmsspec() returned it, it must have VMS syntax
1530 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1531 * the time to check this here only so we avoid a recursion
1532 * loop; otherwise, gigo.
1534 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1536 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1537 return do_tounixspec(trndir,buf,ts);
1540 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1541 lastdir = strrchr(dir,'/');
1543 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1544 /* Ditto for specs that end in an MFD -- let the VMS code
1545 * figure out whether it's a real device or a rooted logical. */
1546 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1547 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1548 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1549 return do_tounixspec(trndir,buf,ts);
1552 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1553 !(lastdir = cp1 = strrchr(dir,']')) &&
1554 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1555 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1557 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1558 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1559 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1560 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1561 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1562 (ver || *cp3)))))) {
1564 set_vaxc_errno(RMS$_DIR);
1570 /* If we lead off with a device or rooted logical, add the MFD
1571 if we're specifying a top-level directory. */
1572 if (lastdir && *dir == '/') {
1574 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1581 retlen = dirlen + (addmfd ? 13 : 6);
1582 if (buf) retspec = buf;
1583 else if (ts) New(1309,retspec,retlen+1,char);
1584 else retspec = __fileify_retbuf;
1586 dirlen = lastdir - dir;
1587 memcpy(retspec,dir,dirlen);
1588 strcpy(&retspec[dirlen],"/000000");
1589 strcpy(&retspec[dirlen+7],lastdir);
1592 memcpy(retspec,dir,dirlen);
1593 retspec[dirlen] = '\0';
1595 /* We've picked up everything up to the directory file name.
1596 Now just add the type and version, and we're set. */
1597 strcat(retspec,".dir;1");
1600 else { /* VMS-style directory spec */
1601 char esa[NAM$C_MAXRSS+1], term, *cp;
1602 unsigned long int sts, cmplen, haslower = 0;
1603 struct FAB dirfab = cc$rms_fab;
1604 struct NAM savnam, dirnam = cc$rms_nam;
1606 dirfab.fab$b_fns = strlen(dir);
1607 dirfab.fab$l_fna = dir;
1608 dirfab.fab$l_nam = &dirnam;
1609 dirfab.fab$l_dna = ".DIR;1";
1610 dirfab.fab$b_dns = 6;
1611 dirnam.nam$b_ess = NAM$C_MAXRSS;
1612 dirnam.nam$l_esa = esa;
1614 for (cp = dir; *cp; cp++)
1615 if (islower(*cp)) { haslower = 1; break; }
1616 if (!((sts = sys$parse(&dirfab))&1)) {
1617 if (dirfab.fab$l_sts == RMS$_DIR) {
1618 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1619 sts = sys$parse(&dirfab) & 1;
1623 set_vaxc_errno(dirfab.fab$l_sts);
1629 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1630 /* Yes; fake the fnb bits so we'll check type below */
1631 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1633 else { /* No; just work with potential name */
1634 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1636 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1637 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1638 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1643 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1644 cp1 = strchr(esa,']');
1645 if (!cp1) cp1 = strchr(esa,'>');
1646 if (cp1) { /* Should always be true */
1647 dirnam.nam$b_esl -= cp1 - esa - 1;
1648 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1651 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1652 /* Yep; check version while we're at it, if it's there. */
1653 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1654 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1655 /* Something other than .DIR[;1]. Bzzt. */
1656 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1657 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1659 set_vaxc_errno(RMS$_DIR);
1663 esa[dirnam.nam$b_esl] = '\0';
1664 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1665 /* They provided at least the name; we added the type, if necessary, */
1666 if (buf) retspec = buf; /* in sys$parse() */
1667 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1668 else retspec = __fileify_retbuf;
1669 strcpy(retspec,esa);
1670 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1671 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1674 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1675 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1677 dirnam.nam$b_esl -= 9;
1679 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1680 if (cp1 == NULL) { /* should never happen */
1681 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1682 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1687 retlen = strlen(esa);
1688 if ((cp1 = strrchr(esa,'.')) != NULL) {
1689 /* There's more than one directory in the path. Just roll back. */
1691 if (buf) retspec = buf;
1692 else if (ts) New(1311,retspec,retlen+7,char);
1693 else retspec = __fileify_retbuf;
1694 strcpy(retspec,esa);
1697 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1698 /* Go back and expand rooted logical name */
1699 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1700 if (!(sys$parse(&dirfab) & 1)) {
1701 dirnam.nam$l_rlf = NULL;
1702 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1704 set_vaxc_errno(dirfab.fab$l_sts);
1707 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1708 if (buf) retspec = buf;
1709 else if (ts) New(1312,retspec,retlen+16,char);
1710 else retspec = __fileify_retbuf;
1711 cp1 = strstr(esa,"][");
1713 memcpy(retspec,esa,dirlen);
1714 if (!strncmp(cp1+2,"000000]",7)) {
1715 retspec[dirlen-1] = '\0';
1716 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1717 if (*cp1 == '.') *cp1 = ']';
1719 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1720 memcpy(cp1+1,"000000]",7);
1724 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1725 retspec[retlen] = '\0';
1726 /* Convert last '.' to ']' */
1727 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1728 if (*cp1 == '.') *cp1 = ']';
1730 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1731 memcpy(cp1+1,"000000]",7);
1735 else { /* This is a top-level dir. Add the MFD to the path. */
1736 if (buf) retspec = buf;
1737 else if (ts) New(1312,retspec,retlen+16,char);
1738 else retspec = __fileify_retbuf;
1741 while (*cp1 != ':') *(cp2++) = *(cp1++);
1742 strcpy(cp2,":[000000]");
1747 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1748 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1749 /* We've set up the string up through the filename. Add the
1750 type and version, and we're done. */
1751 strcat(retspec,".DIR;1");
1753 /* $PARSE may have upcased filespec, so convert output to lower
1754 * case if input contained any lowercase characters. */
1755 if (haslower) __mystrtolower(retspec);
1758 } /* end of do_fileify_dirspec() */
1760 /* External entry points */
1761 char *fileify_dirspec(char *dir, char *buf)
1762 { return do_fileify_dirspec(dir,buf,0); }
1763 char *fileify_dirspec_ts(char *dir, char *buf)
1764 { return do_fileify_dirspec(dir,buf,1); }
1766 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1767 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1769 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1770 unsigned long int retlen;
1771 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1773 if (!dir || !*dir) {
1774 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1777 if (*dir) strcpy(trndir,dir);
1778 else getcwd(trndir,sizeof trndir - 1);
1780 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1781 && my_trnlnm(trndir,trndir,0)) {
1782 STRLEN trnlen = strlen(trndir);
1784 /* Trap simple rooted lnms, and return lnm:[000000] */
1785 if (!strcmp(trndir+trnlen-2,".]")) {
1786 if (buf) retpath = buf;
1787 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1788 else retpath = __pathify_retbuf;
1789 strcpy(retpath,dir);
1790 strcat(retpath,":[000000]");
1796 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1797 if (*dir == '.' && (*(dir+1) == '\0' ||
1798 (*(dir+1) == '.' && *(dir+2) == '\0')))
1799 retlen = 2 + (*(dir+1) != '\0');
1801 if ( !(cp1 = strrchr(dir,'/')) &&
1802 !(cp1 = strrchr(dir,']')) &&
1803 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1804 if ((cp2 = strchr(cp1,'.')) != NULL &&
1805 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1806 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1807 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1808 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1810 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1811 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1812 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1813 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1814 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1815 (ver || *cp3)))))) {
1817 set_vaxc_errno(RMS$_DIR);
1820 retlen = cp2 - dir + 1;
1822 else { /* No file type present. Treat the filename as a directory. */
1823 retlen = strlen(dir) + 1;
1826 if (buf) retpath = buf;
1827 else if (ts) New(1313,retpath,retlen+1,char);
1828 else retpath = __pathify_retbuf;
1829 strncpy(retpath,dir,retlen-1);
1830 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1831 retpath[retlen-1] = '/'; /* with '/', add it. */
1832 retpath[retlen] = '\0';
1834 else retpath[retlen-1] = '\0';
1836 else { /* VMS-style directory spec */
1837 char esa[NAM$C_MAXRSS+1], *cp;
1838 unsigned long int sts, cmplen, haslower;
1839 struct FAB dirfab = cc$rms_fab;
1840 struct NAM savnam, dirnam = cc$rms_nam;
1842 /* If we've got an explicit filename, we can just shuffle the string. */
1843 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1844 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1845 if ((cp2 = strchr(cp1,'.')) != NULL) {
1847 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1848 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1849 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1850 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1851 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1852 (ver || *cp3)))))) {
1854 set_vaxc_errno(RMS$_DIR);
1858 else { /* No file type, so just draw name into directory part */
1859 for (cp2 = cp1; *cp2; cp2++) ;
1862 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1864 /* We've now got a VMS 'path'; fall through */
1866 dirfab.fab$b_fns = strlen(dir);
1867 dirfab.fab$l_fna = dir;
1868 if (dir[dirfab.fab$b_fns-1] == ']' ||
1869 dir[dirfab.fab$b_fns-1] == '>' ||
1870 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1871 if (buf) retpath = buf;
1872 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1873 else retpath = __pathify_retbuf;
1874 strcpy(retpath,dir);
1877 dirfab.fab$l_dna = ".DIR;1";
1878 dirfab.fab$b_dns = 6;
1879 dirfab.fab$l_nam = &dirnam;
1880 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1881 dirnam.nam$l_esa = esa;
1883 for (cp = dir; *cp; cp++)
1884 if (islower(*cp)) { haslower = 1; break; }
1886 if (!(sts = (sys$parse(&dirfab)&1))) {
1887 if (dirfab.fab$l_sts == RMS$_DIR) {
1888 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1889 sts = sys$parse(&dirfab) & 1;
1893 set_vaxc_errno(dirfab.fab$l_sts);
1899 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1900 if (dirfab.fab$l_sts != RMS$_FNF) {
1901 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1902 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1904 set_vaxc_errno(dirfab.fab$l_sts);
1907 dirnam = savnam; /* No; just work with potential name */
1910 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1911 /* Yep; check version while we're at it, if it's there. */
1912 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1913 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1914 /* Something other than .DIR[;1]. Bzzt. */
1915 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1916 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1918 set_vaxc_errno(RMS$_DIR);
1922 /* OK, the type was fine. Now pull any file name into the
1924 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1926 cp1 = strrchr(esa,'>');
1927 *dirnam.nam$l_type = '>';
1930 *(dirnam.nam$l_type + 1) = '\0';
1931 retlen = dirnam.nam$l_type - esa + 2;
1932 if (buf) retpath = buf;
1933 else if (ts) New(1314,retpath,retlen,char);
1934 else retpath = __pathify_retbuf;
1935 strcpy(retpath,esa);
1936 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1937 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1938 /* $PARSE may have upcased filespec, so convert output to lower
1939 * case if input contained any lowercase characters. */
1940 if (haslower) __mystrtolower(retpath);
1944 } /* end of do_pathify_dirspec() */
1946 /* External entry points */
1947 char *pathify_dirspec(char *dir, char *buf)
1948 { return do_pathify_dirspec(dir,buf,0); }
1949 char *pathify_dirspec_ts(char *dir, char *buf)
1950 { return do_pathify_dirspec(dir,buf,1); }
1952 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1953 static char *do_tounixspec(char *spec, char *buf, int ts)
1955 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1956 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1957 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1959 if (spec == NULL) return NULL;
1960 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1961 if (buf) rslt = buf;
1963 retlen = strlen(spec);
1964 cp1 = strchr(spec,'[');
1965 if (!cp1) cp1 = strchr(spec,'<');
1967 for (cp1++; *cp1; cp1++) {
1968 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1969 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1970 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1973 New(1315,rslt,retlen+2+2*expand,char);
1975 else rslt = __tounixspec_retbuf;
1976 if (strchr(spec,'/') != NULL) {
1983 dirend = strrchr(spec,']');
1984 if (dirend == NULL) dirend = strrchr(spec,'>');
1985 if (dirend == NULL) dirend = strchr(spec,':');
1986 if (dirend == NULL) {
1990 if (*cp2 != '[' && *cp2 != '<') {
1993 else { /* the VMS spec begins with directories */
1995 if (*cp2 == ']' || *cp2 == '>') {
1996 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1999 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2000 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2001 if (ts) Safefree(rslt);
2006 while (*cp3 != ':' && *cp3) cp3++;
2008 if (strchr(cp3,']') != NULL) break;
2009 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2011 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2012 retlen = devlen + dirlen;
2013 Renew(rslt,retlen+1+2*expand,char);
2019 *(cp1++) = *(cp3++);
2020 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2024 else if ( *cp2 == '.') {
2025 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2026 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2032 for (; cp2 <= dirend; cp2++) {
2035 if (*(cp2+1) == '[') cp2++;
2037 else if (*cp2 == ']' || *cp2 == '>') {
2038 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2040 else if (*cp2 == '.') {
2042 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2043 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2044 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2045 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2046 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2048 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2049 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2053 else if (*cp2 == '-') {
2054 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2055 while (*cp2 == '-') {
2057 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2059 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2060 if (ts) Safefree(rslt); /* filespecs like */
2061 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2065 else *(cp1++) = *cp2;
2067 else *(cp1++) = *cp2;
2069 while (*cp2) *(cp1++) = *(cp2++);
2074 } /* end of do_tounixspec() */
2076 /* External entry points */
2077 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2078 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2080 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2081 static char *do_tovmsspec(char *path, char *buf, int ts) {
2082 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2083 char *rslt, *dirend;
2084 register char *cp1, *cp2;
2085 unsigned long int infront = 0, hasdir = 1;
2087 if (path == NULL) return NULL;
2088 if (buf) rslt = buf;
2089 else if (ts) New(1316,rslt,strlen(path)+9,char);
2090 else rslt = __tovmsspec_retbuf;
2091 if (strpbrk(path,"]:>") ||
2092 (dirend = strrchr(path,'/')) == NULL) {
2093 if (path[0] == '.') {
2094 if (path[1] == '\0') strcpy(rslt,"[]");
2095 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2096 else strcpy(rslt,path); /* probably garbage */
2098 else strcpy(rslt,path);
2101 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2102 if (!*(dirend+2)) dirend +=2;
2103 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2104 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2109 char trndev[NAM$C_MAXRSS+1];
2113 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2115 if (!buf & ts) Renew(rslt,18,char);
2116 strcpy(rslt,"sys$disk:[000000]");
2119 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2121 islnm = my_trnlnm(rslt,trndev,0);
2122 trnend = islnm ? strlen(trndev) - 1 : 0;
2123 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2124 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2125 /* If the first element of the path is a logical name, determine
2126 * whether it has to be translated so we can add more directories. */
2127 if (!islnm || rooted) {
2130 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2134 if (cp2 != dirend) {
2135 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2136 strcpy(rslt,trndev);
2137 cp1 = rslt + trnend;
2150 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2151 cp2 += 2; /* skip over "./" - it's redundant */
2152 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2154 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2155 *(cp1++) = '-'; /* "../" --> "-" */
2158 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2159 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2160 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2161 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2164 if (cp2 > dirend) cp2 = dirend;
2166 else *(cp1++) = '.';
2168 for (; cp2 < dirend; cp2++) {
2170 if (*(cp2-1) == '/') continue;
2171 if (*(cp1-1) != '.') *(cp1++) = '.';
2174 else if (!infront && *cp2 == '.') {
2175 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2176 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2177 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2178 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2179 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2180 else { /* back up over previous directory name */
2182 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2183 if (*(cp1-1) == '[') {
2184 memcpy(cp1,"000000.",7);
2189 if (cp2 == dirend) break;
2191 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2192 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2193 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2194 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2196 *(cp1++) = '.'; /* Simulate trailing '/' */
2197 cp2 += 2; /* for loop will incr this to == dirend */
2199 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2201 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2204 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2205 if (*cp2 == '.') *(cp1++) = '_';
2206 else *(cp1++) = *cp2;
2210 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2211 if (hasdir) *(cp1++) = ']';
2212 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2213 while (*cp2) *(cp1++) = *(cp2++);
2218 } /* end of do_tovmsspec() */
2220 /* External entry points */
2221 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2222 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2224 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2225 static char *do_tovmspath(char *path, char *buf, int ts) {
2226 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2228 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2230 if (path == NULL) return NULL;
2231 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2232 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2233 if (buf) return buf;
2235 vmslen = strlen(vmsified);
2236 New(1317,cp,vmslen+1,char);
2237 memcpy(cp,vmsified,vmslen);
2242 strcpy(__tovmspath_retbuf,vmsified);
2243 return __tovmspath_retbuf;
2246 } /* end of do_tovmspath() */
2248 /* External entry points */
2249 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2250 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2253 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2254 static char *do_tounixpath(char *path, char *buf, int ts) {
2255 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2257 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2259 if (path == NULL) return NULL;
2260 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2261 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2262 if (buf) return buf;
2264 unixlen = strlen(unixified);
2265 New(1317,cp,unixlen+1,char);
2266 memcpy(cp,unixified,unixlen);
2271 strcpy(__tounixpath_retbuf,unixified);
2272 return __tounixpath_retbuf;
2275 } /* end of do_tounixpath() */
2277 /* External entry points */
2278 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2279 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2282 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2284 *****************************************************************************
2286 * Copyright (C) 1989-1994 by *
2287 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2289 * Permission is hereby granted for the reproduction of this software, *
2290 * on condition that this copyright notice is included in the reproduction, *
2291 * and that such reproduction is not for purposes of profit or material *
2294 * 27-Aug-1994 Modified for inclusion in perl5 *
2295 * by Charles Bailey bailey@newman.upenn.edu *
2296 *****************************************************************************
2300 * getredirection() is intended to aid in porting C programs
2301 * to VMS (Vax-11 C). The native VMS environment does not support
2302 * '>' and '<' I/O redirection, or command line wild card expansion,
2303 * or a command line pipe mechanism using the '|' AND background
2304 * command execution '&'. All of these capabilities are provided to any
2305 * C program which calls this procedure as the first thing in the
2307 * The piping mechanism will probably work with almost any 'filter' type
2308 * of program. With suitable modification, it may useful for other
2309 * portability problems as well.
2311 * Author: Mark Pizzolato mark@infocomm.com
2315 struct list_item *next;
2319 static void add_item(struct list_item **head,
2320 struct list_item **tail,
2324 static void expand_wild_cards(char *item,
2325 struct list_item **head,
2326 struct list_item **tail,
2329 static int background_process(int argc, char **argv);
2331 static void pipe_and_fork(char **cmargv);
2333 /*{{{ void getredirection(int *ac, char ***av)*/
2335 getredirection(int *ac, char ***av)
2337 * Process vms redirection arg's. Exit if any error is seen.
2338 * If getredirection() processes an argument, it is erased
2339 * from the vector. getredirection() returns a new argc and argv value.
2340 * In the event that a background command is requested (by a trailing "&"),
2341 * this routine creates a background subprocess, and simply exits the program.
2343 * Warning: do not try to simplify the code for vms. The code
2344 * presupposes that getredirection() is called before any data is
2345 * read from stdin or written to stdout.
2347 * Normal usage is as follows:
2353 * getredirection(&argc, &argv);
2357 int argc = *ac; /* Argument Count */
2358 char **argv = *av; /* Argument Vector */
2359 char *ap; /* Argument pointer */
2360 int j; /* argv[] index */
2361 int item_count = 0; /* Count of Items in List */
2362 struct list_item *list_head = 0; /* First Item in List */
2363 struct list_item *list_tail; /* Last Item in List */
2364 char *in = NULL; /* Input File Name */
2365 char *out = NULL; /* Output File Name */
2366 char *outmode = "w"; /* Mode to Open Output File */
2367 char *err = NULL; /* Error File Name */
2368 char *errmode = "w"; /* Mode to Open Error File */
2369 int cmargc = 0; /* Piped Command Arg Count */
2370 char **cmargv = NULL;/* Piped Command Arg Vector */
2373 * First handle the case where the last thing on the line ends with
2374 * a '&'. This indicates the desire for the command to be run in a
2375 * subprocess, so we satisfy that desire.
2378 if (0 == strcmp("&", ap))
2379 exit(background_process(--argc, argv));
2380 if (*ap && '&' == ap[strlen(ap)-1])
2382 ap[strlen(ap)-1] = '\0';
2383 exit(background_process(argc, argv));
2386 * Now we handle the general redirection cases that involve '>', '>>',
2387 * '<', and pipes '|'.
2389 for (j = 0; j < argc; ++j)
2391 if (0 == strcmp("<", argv[j]))
2395 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2396 exit(LIB$_WRONUMARG);
2401 if ('<' == *(ap = argv[j]))
2406 if (0 == strcmp(">", ap))
2410 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2411 exit(LIB$_WRONUMARG);
2430 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2431 exit(LIB$_WRONUMARG);
2435 if (('2' == *ap) && ('>' == ap[1]))
2452 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2453 exit(LIB$_WRONUMARG);
2457 if (0 == strcmp("|", argv[j]))
2461 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2462 exit(LIB$_WRONUMARG);
2464 cmargc = argc-(j+1);
2465 cmargv = &argv[j+1];
2469 if ('|' == *(ap = argv[j]))
2477 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2480 * Allocate and fill in the new argument vector, Some Unix's terminate
2481 * the list with an extra null pointer.
2483 New(1302, argv, item_count+1, char *);
2485 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2486 argv[j] = list_head->value;
2492 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2493 exit(LIB$_INVARGORD);
2495 pipe_and_fork(cmargv);
2498 /* Check for input from a pipe (mailbox) */
2500 if (in == NULL && 1 == isapipe(0))
2502 char mbxname[L_tmpnam];
2504 long int dvi_item = DVI$_DEVBUFSIZ;
2505 $DESCRIPTOR(mbxnam, "");
2506 $DESCRIPTOR(mbxdevnam, "");
2508 /* Input from a pipe, reopen it in binary mode to disable */
2509 /* carriage control processing. */
2511 PerlIO_getname(stdin, mbxname);
2512 mbxnam.dsc$a_pointer = mbxname;
2513 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2514 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2515 mbxdevnam.dsc$a_pointer = mbxname;
2516 mbxdevnam.dsc$w_length = sizeof(mbxname);
2517 dvi_item = DVI$_DEVNAM;
2518 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2519 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2522 freopen(mbxname, "rb", stdin);
2525 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2529 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2531 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2534 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2536 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2540 if (strcmp(err,"&1") == 0) {
2541 dup2(fileno(stdout), fileno(Perl_debug_log));
2544 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2546 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2550 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2556 #ifdef ARGPROC_DEBUG
2557 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2558 for (j = 0; j < *ac; ++j)
2559 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2561 /* Clear errors we may have hit expanding wildcards, so they don't
2562 show up in Perl's $! later */
2563 set_errno(0); set_vaxc_errno(1);
2564 } /* end of getredirection() */
2567 static void add_item(struct list_item **head,
2568 struct list_item **tail,
2574 New(1303,*head,1,struct list_item);
2578 New(1304,(*tail)->next,1,struct list_item);
2579 *tail = (*tail)->next;
2581 (*tail)->value = value;
2585 static void expand_wild_cards(char *item,
2586 struct list_item **head,
2587 struct list_item **tail,
2591 unsigned long int context = 0;
2597 char vmsspec[NAM$C_MAXRSS+1];
2598 $DESCRIPTOR(filespec, "");
2599 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2600 $DESCRIPTOR(resultspec, "");
2601 unsigned long int zero = 0, sts;
2603 for (cp = item; *cp; cp++) {
2604 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2605 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2607 if (!*cp || isspace(*cp))
2609 add_item(head, tail, item, count);
2612 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2613 resultspec.dsc$b_class = DSC$K_CLASS_D;
2614 resultspec.dsc$a_pointer = NULL;
2615 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2616 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2617 if (!isunix || !filespec.dsc$a_pointer)
2618 filespec.dsc$a_pointer = item;
2619 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2621 * Only return version specs, if the caller specified a version
2623 had_version = strchr(item, ';');
2625 * Only return device and directory specs, if the caller specifed either.
2627 had_device = strchr(item, ':');
2628 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2630 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2631 &defaultspec, 0, 0, &zero))))
2636 New(1305,string,resultspec.dsc$w_length+1,char);
2637 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2638 string[resultspec.dsc$w_length] = '\0';
2639 if (NULL == had_version)
2640 *((char *)strrchr(string, ';')) = '\0';
2641 if ((!had_directory) && (had_device == NULL))
2643 if (NULL == (devdir = strrchr(string, ']')))
2644 devdir = strrchr(string, '>');
2645 strcpy(string, devdir + 1);
2648 * Be consistent with what the C RTL has already done to the rest of
2649 * the argv items and lowercase all of these names.
2651 for (c = string; *c; ++c)
2654 if (isunix) trim_unixpath(string,item,1);
2655 add_item(head, tail, string, count);
2658 if (sts != RMS$_NMF)
2660 set_vaxc_errno(sts);
2666 set_errno(ENOENT); break;
2668 set_errno(ENODEV); break;
2671 set_errno(EINVAL); break;
2673 set_errno(EACCES); break;
2675 _ckvmssts_noperl(sts);
2679 add_item(head, tail, item, count);
2680 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2681 _ckvmssts_noperl(lib$find_file_end(&context));
2684 static int child_st[2];/* Event Flag set when child process completes */
2686 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2688 static unsigned long int exit_handler(int *status)
2692 if (0 == child_st[0])
2694 #ifdef ARGPROC_DEBUG
2695 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2697 fflush(stdout); /* Have to flush pipe for binary data to */
2698 /* terminate properly -- <tp@mccall.com> */
2699 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2700 sys$dassgn(child_chan);
2702 sys$synch(0, child_st);
2707 static void sig_child(int chan)
2709 #ifdef ARGPROC_DEBUG
2710 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2712 if (child_st[0] == 0)
2716 static struct exit_control_block exit_block =
2721 &exit_block.exit_status,
2725 static void pipe_and_fork(char **cmargv)
2728 $DESCRIPTOR(cmddsc, "");
2729 static char mbxname[64];
2730 $DESCRIPTOR(mbxdsc, mbxname);
2732 unsigned long int zero = 0, one = 1;
2734 strcpy(subcmd, cmargv[0]);
2735 for (j = 1; NULL != cmargv[j]; ++j)
2737 strcat(subcmd, " \"");
2738 strcat(subcmd, cmargv[j]);
2739 strcat(subcmd, "\"");
2741 cmddsc.dsc$a_pointer = subcmd;
2742 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2744 create_mbx(&child_chan,&mbxdsc);
2745 #ifdef ARGPROC_DEBUG
2746 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2747 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2749 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2750 0, &pid, child_st, &zero, sig_child,
2752 #ifdef ARGPROC_DEBUG
2753 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2755 sys$dclexh(&exit_block);
2756 if (NULL == freopen(mbxname, "wb", stdout))
2758 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2762 static int background_process(int argc, char **argv)
2764 char command[2048] = "$";
2765 $DESCRIPTOR(value, "");
2766 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2767 static $DESCRIPTOR(null, "NLA0:");
2768 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2770 $DESCRIPTOR(pidstr, "");
2772 unsigned long int flags = 17, one = 1, retsts;
2774 strcat(command, argv[0]);
2777 strcat(command, " \"");
2778 strcat(command, *(++argv));
2779 strcat(command, "\"");
2781 value.dsc$a_pointer = command;
2782 value.dsc$w_length = strlen(value.dsc$a_pointer);
2783 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2784 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2785 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2786 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2789 _ckvmssts_noperl(retsts);
2791 #ifdef ARGPROC_DEBUG
2792 PerlIO_printf(Perl_debug_log, "%s\n", command);
2794 sprintf(pidstring, "%08X", pid);
2795 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2796 pidstr.dsc$a_pointer = pidstring;
2797 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2798 lib$set_symbol(&pidsymbol, &pidstr);
2802 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2805 /* OS-specific initialization at image activation (not thread startup) */
2806 /* Older VAXC header files lack these constants */
2807 #ifndef JPI$_RIGHTS_SIZE
2808 # define JPI$_RIGHTS_SIZE 817
2810 #ifndef KGB$M_SUBSYSTEM
2811 # define KGB$M_SUBSYSTEM 0x8
2814 /*{{{void vms_image_init(int *, char ***)*/
2816 vms_image_init(int *argcp, char ***argvp)
2818 char eqv[LNM$C_NAMLENGTH+1] = "";
2819 unsigned int len, tabct = 8, tabidx = 0;
2820 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2821 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2822 unsigned short int dummy, rlen;
2823 struct dsc$descriptor_s **tabvec;
2825 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2826 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2827 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2830 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2832 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2833 if (iprv[i]) { /* Running image installed with privs? */
2834 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2839 /* Rights identifiers might trigger tainting as well. */
2840 if (!will_taint && (rlen || rsz)) {
2841 while (rlen < rsz) {
2842 /* We didn't get all the identifiers on the first pass. Allocate a
2843 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2844 * were needed to hold all identifiers at time of last call; we'll
2845 * allocate that many unsigned long ints), and go back and get 'em.
2847 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2848 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2849 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2850 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2853 mask = jpilist[1].bufadr;
2854 /* Check attribute flags for each identifier (2nd longword); protected
2855 * subsystem identifiers trigger tainting.
2857 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2858 if (mask[i] & KGB$M_SUBSYSTEM) {
2863 if (mask != rlst) Safefree(mask);
2865 /* We need to use this hack to tell Perl it should run with tainting,
2866 * since its tainting flag may be part of the PL_curinterp struct, which
2867 * hasn't been allocated when vms_image_init() is called.
2871 New(1320,newap,*argcp+2,char **);
2872 newap[0] = argvp[0];
2874 Copy(argvp[1],newap[2],*argcp-1,char **);
2875 /* We orphan the old argv, since we don't know where it's come from,
2876 * so we don't know how to free it.
2878 *argcp++; argvp = newap;
2880 else { /* Did user explicitly request tainting? */
2882 char *cp, **av = *argvp;
2883 for (i = 1; i < *argcp; i++) {
2884 if (*av[i] != '-') break;
2885 for (cp = av[i]+1; *cp; cp++) {
2886 if (*cp == 'T') { will_taint = 1; break; }
2887 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2888 strchr("DFIiMmx",*cp)) break;
2890 if (will_taint) break;
2895 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2897 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2898 else if (tabidx >= tabct) {
2900 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2902 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2903 tabvec[tabidx]->dsc$w_length = 0;
2904 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2905 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2906 tabvec[tabidx]->dsc$a_pointer = NULL;
2907 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2909 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2911 getredirection(argcp,argvp);
2912 #if defined(USE_THREADS) && defined(__DECC)
2914 # include <reentrancy.h>
2915 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2924 * Trim Unix-style prefix off filespec, so it looks like what a shell
2925 * glob expansion would return (i.e. from specified prefix on, not
2926 * full path). Note that returned filespec is Unix-style, regardless
2927 * of whether input filespec was VMS-style or Unix-style.
2929 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2930 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2931 * vector of options; at present, only bit 0 is used, and if set tells
2932 * trim unixpath to try the current default directory as a prefix when
2933 * presented with a possibly ambiguous ... wildcard.
2935 * Returns !=0 on success, with trimmed filespec replacing contents of
2936 * fspec, and 0 on failure, with contents of fpsec unchanged.
2938 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2940 trim_unixpath(char *fspec, char *wildspec, int opts)
2942 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2943 *template, *base, *end, *cp1, *cp2;
2944 register int tmplen, reslen = 0, dirs = 0;
2946 if (!wildspec || !fspec) return 0;
2947 if (strpbrk(wildspec,"]>:") != NULL) {
2948 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2949 else template = unixwild;
2951 else template = wildspec;
2952 if (strpbrk(fspec,"]>:") != NULL) {
2953 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2954 else base = unixified;
2955 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2956 * check to see that final result fits into (isn't longer than) fspec */
2957 reslen = strlen(fspec);
2961 /* No prefix or absolute path on wildcard, so nothing to remove */
2962 if (!*template || *template == '/') {
2963 if (base == fspec) return 1;
2964 tmplen = strlen(unixified);
2965 if (tmplen > reslen) return 0; /* not enough space */
2966 /* Copy unixified resultant, including trailing NUL */
2967 memmove(fspec,unixified,tmplen+1);
2971 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2972 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2973 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2974 for (cp1 = end ;cp1 >= base; cp1--)
2975 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2977 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2981 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2982 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2983 int ells = 1, totells, segdirs, match;
2984 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2985 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2987 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2989 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2990 if (ellipsis == template && opts & 1) {
2991 /* Template begins with an ellipsis. Since we can't tell how many
2992 * directory names at the front of the resultant to keep for an
2993 * arbitrary starting point, we arbitrarily choose the current
2994 * default directory as a starting point. If it's there as a prefix,
2995 * clip it off. If not, fall through and act as if the leading
2996 * ellipsis weren't there (i.e. return shortest possible path that
2997 * could match template).
2999 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3000 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3001 if (_tolower(*cp1) != _tolower(*cp2)) break;
3002 segdirs = dirs - totells; /* Min # of dirs we must have left */
3003 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3004 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3005 memcpy(fspec,cp2+1,end - cp2);
3009 /* First off, back up over constant elements at end of path */
3011 for (front = end ; front >= base; front--)
3012 if (*front == '/' && !dirs--) { front++; break; }
3014 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3015 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3016 if (cp1 != '\0') return 0; /* Path too long. */
3018 *cp2 = '\0'; /* Pick up with memcpy later */
3019 lcfront = lcres + (front - base);
3020 /* Now skip over each ellipsis and try to match the path in front of it. */
3022 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3023 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3024 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3025 if (cp1 < template) break; /* template started with an ellipsis */
3026 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3027 ellipsis = cp1; continue;
3029 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3031 for (segdirs = 0, cp2 = tpl;
3032 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3034 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3035 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3036 if (*cp2 == '/') segdirs++;
3038 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3039 /* Back up at least as many dirs as in template before matching */
3040 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3041 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3042 for (match = 0; cp1 > lcres;) {
3043 resdsc.dsc$a_pointer = cp1;
3044 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3046 if (match == 1) lcfront = cp1;
3048 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3050 if (!match) return 0; /* Can't find prefix ??? */
3051 if (match > 1 && opts & 1) {
3052 /* This ... wildcard could cover more than one set of dirs (i.e.
3053 * a set of similar dir names is repeated). If the template
3054 * contains more than 1 ..., upstream elements could resolve the
3055 * ambiguity, but it's not worth a full backtracking setup here.
3056 * As a quick heuristic, clip off the current default directory
3057 * if it's present to find the trimmed spec, else use the
3058 * shortest string that this ... could cover.
3060 char def[NAM$C_MAXRSS+1], *st;
3062 if (getcwd(def, sizeof def,0) == NULL) return 0;
3063 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3064 if (_tolower(*cp1) != _tolower(*cp2)) break;
3065 segdirs = dirs - totells; /* Min # of dirs we must have left */
3066 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3067 if (*cp1 == '\0' && *cp2 == '/') {
3068 memcpy(fspec,cp2+1,end - cp2);
3071 /* Nope -- stick with lcfront from above and keep going. */
3074 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3079 } /* end of trim_unixpath() */
3084 * VMS readdir() routines.
3085 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3087 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3088 * Minor modifications to original routines.
3091 /* Number of elements in vms_versions array */
3092 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3095 * Open a directory, return a handle for later use.
3097 /*{{{ DIR *opendir(char*name) */
3102 char dir[NAM$C_MAXRSS+1];
3105 if (do_tovmspath(name,dir,0) == NULL) {
3108 if (flex_stat(dir,&sb) == -1) return NULL;
3109 if (!S_ISDIR(sb.st_mode)) {
3110 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3113 if (!cando_by_name(S_IRUSR,0,dir)) {
3114 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3117 /* Get memory for the handle, and the pattern. */
3119 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3121 /* Fill in the fields; mainly playing with the descriptor. */
3122 (void)sprintf(dd->pattern, "%s*.*",dir);
3125 dd->vms_wantversions = 0;
3126 dd->pat.dsc$a_pointer = dd->pattern;
3127 dd->pat.dsc$w_length = strlen(dd->pattern);
3128 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3129 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3132 } /* end of opendir() */
3136 * Set the flag to indicate we want versions or not.
3138 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3140 vmsreaddirversions(DIR *dd, int flag)
3142 dd->vms_wantversions = flag;
3147 * Free up an opened directory.
3149 /*{{{ void closedir(DIR *dd)*/
3153 (void)lib$find_file_end(&dd->context);
3154 Safefree(dd->pattern);
3155 Safefree((char *)dd);
3160 * Collect all the version numbers for the current file.
3166 struct dsc$descriptor_s pat;
3167 struct dsc$descriptor_s res;
3169 char *p, *text, buff[sizeof dd->entry.d_name];
3171 unsigned long context, tmpsts;
3174 /* Convenient shorthand. */
3177 /* Add the version wildcard, ignoring the "*.*" put on before */
3178 i = strlen(dd->pattern);
3179 New(1308,text,i + e->d_namlen + 3,char);
3180 (void)strcpy(text, dd->pattern);
3181 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3183 /* Set up the pattern descriptor. */
3184 pat.dsc$a_pointer = text;
3185 pat.dsc$w_length = i + e->d_namlen - 1;
3186 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3187 pat.dsc$b_class = DSC$K_CLASS_S;
3189 /* Set up result descriptor. */
3190 res.dsc$a_pointer = buff;
3191 res.dsc$w_length = sizeof buff - 2;
3192 res.dsc$b_dtype = DSC$K_DTYPE_T;
3193 res.dsc$b_class = DSC$K_CLASS_S;
3195 /* Read files, collecting versions. */
3196 for (context = 0, e->vms_verscount = 0;
3197 e->vms_verscount < VERSIZE(e);
3198 e->vms_verscount++) {
3199 tmpsts = lib$find_file(&pat, &res, &context);
3200 if (tmpsts == RMS$_NMF || context == 0) break;
3202 buff[sizeof buff - 1] = '\0';
3203 if ((p = strchr(buff, ';')))
3204 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3206 e->vms_versions[e->vms_verscount] = -1;
3209 _ckvmssts(lib$find_file_end(&context));
3212 } /* end of collectversions() */
3215 * Read the next entry from the directory.
3217 /*{{{ struct dirent *readdir(DIR *dd)*/
3221 struct dsc$descriptor_s res;
3222 char *p, buff[sizeof dd->entry.d_name];
3223 unsigned long int tmpsts;
3225 /* Set up result descriptor, and get next file. */
3226 res.dsc$a_pointer = buff;
3227 res.dsc$w_length = sizeof buff - 2;
3228 res.dsc$b_dtype = DSC$K_DTYPE_T;
3229 res.dsc$b_class = DSC$K_CLASS_S;
3230 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3231 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3232 if (!(tmpsts & 1)) {
3233 set_vaxc_errno(tmpsts);
3236 set_errno(EACCES); break;
3238 set_errno(ENODEV); break;
3241 set_errno(ENOENT); break;
3248 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3249 buff[sizeof buff - 1] = '\0';
3250 for (p = buff; *p; p++) *p = _tolower(*p);
3251 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3254 /* Skip any directory component and just copy the name. */
3255 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3256 else (void)strcpy(dd->entry.d_name, buff);
3258 /* Clobber the version. */
3259 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3261 dd->entry.d_namlen = strlen(dd->entry.d_name);
3262 dd->entry.vms_verscount = 0;
3263 if (dd->vms_wantversions) collectversions(dd);
3266 } /* end of readdir() */
3270 * Return something that can be used in a seekdir later.
3272 /*{{{ long telldir(DIR *dd)*/
3281 * Return to a spot where we used to be. Brute force.
3283 /*{{{ void seekdir(DIR *dd,long count)*/
3285 seekdir(DIR *dd, long count)
3287 int vms_wantversions;
3290 /* If we haven't done anything yet... */
3294 /* Remember some state, and clear it. */
3295 vms_wantversions = dd->vms_wantversions;
3296 dd->vms_wantversions = 0;
3297 _ckvmssts(lib$find_file_end(&dd->context));
3300 /* The increment is in readdir(). */
3301 for (dd->count = 0; dd->count < count; )
3304 dd->vms_wantversions = vms_wantversions;
3306 } /* end of seekdir() */
3309 /* VMS subprocess management
3311 * my_vfork() - just a vfork(), after setting a flag to record that
3312 * the current script is trying a Unix-style fork/exec.
3314 * vms_do_aexec() and vms_do_exec() are called in response to the
3315 * perl 'exec' function. If this follows a vfork call, then they
3316 * call out the the regular perl routines in doio.c which do an
3317 * execvp (for those who really want to try this under VMS).
3318 * Otherwise, they do exactly what the perl docs say exec should
3319 * do - terminate the current script and invoke a new command
3320 * (See below for notes on command syntax.)
3322 * do_aspawn() and do_spawn() implement the VMS side of the perl
3323 * 'system' function.
3325 * Note on command arguments to perl 'exec' and 'system': When handled
3326 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3327 * are concatenated to form a DCL command string. If the first arg
3328 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3329 * the the command string is handed off to DCL directly. Otherwise,
3330 * the first token of the command is taken as the filespec of an image
3331 * to run. The filespec is expanded using a default type of '.EXE' and
3332 * the process defaults for device, directory, etc., and if found, the resultant
3333 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3334 * the command string as parameters. This is perhaps a bit complicated,
3335 * but I hope it will form a happy medium between what VMS folks expect
3336 * from lib$spawn and what Unix folks expect from exec.
3339 static int vfork_called;
3341 /*{{{int my_vfork()*/
3354 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3357 if (VMScmd.dsc$a_pointer) {
3358 Safefree(VMScmd.dsc$a_pointer);
3359 VMScmd.dsc$w_length = 0;
3360 VMScmd.dsc$a_pointer = Nullch;
3365 setup_argstr(SV *really, SV **mark, SV **sp)
3368 char *junk, *tmps = Nullch;
3369 register size_t cmdlen = 0;
3376 tmps = SvPV(really,rlen);
3383 for (idx++; idx <= sp; idx++) {
3385 junk = SvPVx(*idx,rlen);
3386 cmdlen += rlen ? rlen + 1 : 0;
3389 New(401,PL_Cmd,cmdlen+1,char);
3391 if (tmps && *tmps) {
3392 strcpy(PL_Cmd,tmps);
3395 else *PL_Cmd = '\0';
3396 while (++mark <= sp) {
3398 char *s = SvPVx(*mark,n_a);
3400 if (*PL_Cmd) strcat(PL_Cmd," ");
3406 } /* end of setup_argstr() */
3409 static unsigned long int
3410 setup_cmddsc(char *cmd, int check_img)
3412 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3413 $DESCRIPTOR(defdsc,".EXE");
3414 $DESCRIPTOR(defdsc2,".");
3415 $DESCRIPTOR(resdsc,resspec);
3416 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3417 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3418 register char *s, *rest, *cp, *wordbreak;
3423 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3426 while (*s && isspace(*s)) s++;
3428 if (*s == '@' || *s == '$') {
3429 vmsspec[0] = *s; rest = s + 1;
3430 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3432 else { cp = vmsspec; rest = s; }
3433 if (*rest == '.' || *rest == '/') {
3436 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3437 rest++, cp2++) *cp2 = *rest;
3439 if (do_tovmsspec(resspec,cp,0)) {
3442 for (cp2 = vmsspec + strlen(vmsspec);
3443 *rest && cp2 - vmsspec < sizeof vmsspec;
3444 rest++, cp2++) *cp2 = *rest;
3449 /* Intuit whether verb (first word of cmd) is a DCL command:
3450 * - if first nonspace char is '@', it's a DCL indirection
3452 * - if verb contains a filespec separator, it's not a DCL command
3453 * - if it doesn't, caller tells us whether to default to a DCL
3454 * command, or to a local image unless told it's DCL (by leading '$')
3456 if (*s == '@') isdcl = 1;
3458 register char *filespec = strpbrk(s,":<[.;");
3459 rest = wordbreak = strpbrk(s," \"\t/");
3460 if (!wordbreak) wordbreak = s + strlen(s);
3461 if (*s == '$') check_img = 0;
3462 if (filespec && (filespec < wordbreak)) isdcl = 0;
3463 else isdcl = !check_img;
3467 imgdsc.dsc$a_pointer = s;
3468 imgdsc.dsc$w_length = wordbreak - s;
3469 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3471 _ckvmssts(lib$find_file_end(&cxt));
3472 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3473 if (!(retsts & 1) && *s == '$') {
3474 _ckvmssts(lib$find_file_end(&cxt));
3475 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3476 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3478 _ckvmssts(lib$find_file_end(&cxt));
3479 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3483 _ckvmssts(lib$find_file_end(&cxt));
3488 while (*s && !isspace(*s)) s++;
3491 /* check that it's really not DCL with no file extension */
3492 fp = fopen(resspec,"r","ctx=bin,shr=get");
3494 char b[4] = {0,0,0,0};
3495 read(fileno(fp),b,4);
3496 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3499 if (check_img && isdcl) return RMS$_FNF;
3501 if (cando_by_name(S_IXUSR,0,resspec)) {
3502 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3504 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3506 strcpy(VMScmd.dsc$a_pointer,"@");
3508 strcat(VMScmd.dsc$a_pointer,resspec);
3509 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3510 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3513 else retsts = RMS$_PRV;
3516 /* It's either a DCL command or we couldn't find a suitable image */
3517 VMScmd.dsc$w_length = strlen(cmd);
3518 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3519 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3520 if (!(retsts & 1)) {
3521 /* just hand off status values likely to be due to user error */
3522 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3523 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3524 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3525 else { _ckvmssts(retsts); }
3528 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3530 } /* end of setup_cmddsc() */
3533 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3535 vms_do_aexec(SV *really,SV **mark,SV **sp)
3539 if (vfork_called) { /* this follows a vfork - act Unixish */
3541 if (vfork_called < 0) {
3542 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3545 else return do_aexec(really,mark,sp);
3547 /* no vfork - act VMSish */
3548 return vms_do_exec(setup_argstr(really,mark,sp));
3553 } /* end of vms_do_aexec() */
3556 /* {{{bool vms_do_exec(char *cmd) */
3558 vms_do_exec(char *cmd)
3562 if (vfork_called) { /* this follows a vfork - act Unixish */
3564 if (vfork_called < 0) {
3565 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3568 else return do_exec(cmd);
3571 { /* no vfork - act VMSish */
3572 unsigned long int retsts;
3575 TAINT_PROPER("exec");
3576 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3577 retsts = lib$do_command(&VMScmd);
3581 set_errno(ENOENT); break;
3582 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3583 set_errno(ENOTDIR); break;
3585 set_errno(EACCES); break;
3587 set_errno(EINVAL); break;
3589 set_errno(E2BIG); break;
3590 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3591 _ckvmssts(retsts); /* fall through */
3592 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3595 set_vaxc_errno(retsts);
3596 if (ckWARN(WARN_EXEC)) {
3597 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3598 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3605 } /* end of vms_do_exec() */
3608 unsigned long int do_spawn(char *);
3610 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3612 do_aspawn(void *really,void **mark,void **sp)
3615 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3618 } /* end of do_aspawn() */
3621 /* {{{unsigned long int do_spawn(char *cmd) */
3625 unsigned long int sts, substs, hadcmd = 1;
3629 TAINT_PROPER("spawn");
3630 if (!cmd || !*cmd) {
3632 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3634 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3635 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3641 set_errno(ENOENT); break;
3642 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3643 set_errno(ENOTDIR); break;
3645 set_errno(EACCES); break;
3647 set_errno(EINVAL); break;
3649 set_errno(E2BIG); break;
3650 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3651 _ckvmssts(sts); /* fall through */
3652 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3655 set_vaxc_errno(sts);
3656 if (ckWARN(WARN_EXEC)) {
3657 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3658 hadcmd ? VMScmd.dsc$w_length : 0,
3659 hadcmd ? VMScmd.dsc$a_pointer : "",
3666 } /* end of do_spawn() */
3670 * A simple fwrite replacement which outputs itmsz*nitm chars without
3671 * introducing record boundaries every itmsz chars.
3673 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3675 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3677 register char *cp, *end;
3679 end = (char *)src + itmsz * nitm;
3681 while ((char *)src <= end) {
3682 for (cp = src; cp <= end; cp++) if (!*cp) break;
3683 if (fputs(src,dest) == EOF) return EOF;
3685 if (fputc('\0',dest) == EOF) return EOF;
3691 } /* end of my_fwrite() */
3694 /*{{{ int my_flush(FILE *fp)*/
3699 if ((res = fflush(fp)) == 0 && fp) {
3700 #ifdef VMS_DO_SOCKETS
3702 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3704 res = fsync(fileno(fp));
3711 * Here are replacements for the following Unix routines in the VMS environment:
3712 * getpwuid Get information for a particular UIC or UID
3713 * getpwnam Get information for a named user
3714 * getpwent Get information for each user in the rights database
3715 * setpwent Reset search to the start of the rights database
3716 * endpwent Finish searching for users in the rights database
3718 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3719 * (defined in pwd.h), which contains the following fields:-
3721 * char *pw_name; Username (in lower case)
3722 * char *pw_passwd; Hashed password
3723 * unsigned int pw_uid; UIC
3724 * unsigned int pw_gid; UIC group number
3725 * char *pw_unixdir; Default device/directory (VMS-style)
3726 * char *pw_gecos; Owner name
3727 * char *pw_dir; Default device/directory (Unix-style)
3728 * char *pw_shell; Default CLI name (eg. DCL)
3730 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3732 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3733 * not the UIC member number (eg. what's returned by getuid()),
3734 * getpwuid() can accept either as input (if uid is specified, the caller's
3735 * UIC group is used), though it won't recognise gid=0.
3737 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3738 * information about other users in your group or in other groups, respectively.
3739 * If the required privilege is not available, then these routines fill only
3740 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3743 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3746 /* sizes of various UAF record fields */
3747 #define UAI$S_USERNAME 12
3748 #define UAI$S_IDENT 31
3749 #define UAI$S_OWNER 31
3750 #define UAI$S_DEFDEV 31
3751 #define UAI$S_DEFDIR 63
3752 #define UAI$S_DEFCLI 31
3755 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3756 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3757 (uic).uic$v_group != UIC$K_WILD_GROUP)
3759 static char __empty[]= "";
3760 static struct passwd __passwd_empty=
3761 {(char *) __empty, (char *) __empty, 0, 0,
3762 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3763 static int contxt= 0;
3764 static struct passwd __pwdcache;
3765 static char __pw_namecache[UAI$S_IDENT+1];
3768 * This routine does most of the work extracting the user information.
3770 static int fillpasswd (const char *name, struct passwd *pwd)
3774 unsigned char length;
3775 char pw_gecos[UAI$S_OWNER+1];
3777 static union uicdef uic;
3779 unsigned char length;
3780 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3783 unsigned char length;
3784 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3787 unsigned char length;
3788 char pw_shell[UAI$S_DEFCLI+1];
3790 static char pw_passwd[UAI$S_PWD+1];
3792 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3793 struct dsc$descriptor_s name_desc;
3794 unsigned long int sts;
3796 static struct itmlst_3 itmlst[]= {
3797 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3798 {sizeof(uic), UAI$_UIC, &uic, &luic},
3799 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3800 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3801 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3802 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3803 {0, 0, NULL, NULL}};
3805 name_desc.dsc$w_length= strlen(name);
3806 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3807 name_desc.dsc$b_class= DSC$K_CLASS_S;
3808 name_desc.dsc$a_pointer= (char *) name;
3810 /* Note that sys$getuai returns many fields as counted strings. */
3811 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3812 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3813 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3815 else { _ckvmssts(sts); }
3816 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3818 if ((int) owner.length < lowner) lowner= (int) owner.length;
3819 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3820 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3821 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3822 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3823 owner.pw_gecos[lowner]= '\0';
3824 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3825 defcli.pw_shell[ldefcli]= '\0';
3826 if (valid_uic(uic)) {
3827 pwd->pw_uid= uic.uic$l_uic;
3828 pwd->pw_gid= uic.uic$v_group;
3831 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3832 pwd->pw_passwd= pw_passwd;
3833 pwd->pw_gecos= owner.pw_gecos;
3834 pwd->pw_dir= defdev.pw_dir;
3835 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3836 pwd->pw_shell= defcli.pw_shell;
3837 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3839 ldir= strlen(pwd->pw_unixdir) - 1;
3840 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3843 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3844 __mystrtolower(pwd->pw_unixdir);
3849 * Get information for a named user.
3851 /*{{{struct passwd *getpwnam(char *name)*/
3852 struct passwd *my_getpwnam(char *name)
3854 struct dsc$descriptor_s name_desc;
3856 unsigned long int status, sts;
3859 __pwdcache = __passwd_empty;
3860 if (!fillpasswd(name, &__pwdcache)) {
3861 /* We still may be able to determine pw_uid and pw_gid */
3862 name_desc.dsc$w_length= strlen(name);
3863 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3864 name_desc.dsc$b_class= DSC$K_CLASS_S;
3865 name_desc.dsc$a_pointer= (char *) name;
3866 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3867 __pwdcache.pw_uid= uic.uic$l_uic;
3868 __pwdcache.pw_gid= uic.uic$v_group;
3871 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3872 set_vaxc_errno(sts);
3873 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3876 else { _ckvmssts(sts); }
3879 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3880 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3881 __pwdcache.pw_name= __pw_namecache;
3883 } /* end of my_getpwnam() */
3887 * Get information for a particular UIC or UID.
3888 * Called by my_getpwent with uid=-1 to list all users.
3890 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3891 struct passwd *my_getpwuid(Uid_t uid)
3893 const $DESCRIPTOR(name_desc,__pw_namecache);
3894 unsigned short lname;
3896 unsigned long int status;
3899 if (uid == (unsigned int) -1) {
3901 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3902 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3903 set_vaxc_errno(status);
3904 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3908 else { _ckvmssts(status); }
3909 } while (!valid_uic (uic));
3913 if (!uic.uic$v_group)
3914 uic.uic$v_group= PerlProc_getgid();
3916 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3917 else status = SS$_IVIDENT;
3918 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3919 status == RMS$_PRV) {
3920 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3923 else { _ckvmssts(status); }
3925 __pw_namecache[lname]= '\0';
3926 __mystrtolower(__pw_namecache);
3928 __pwdcache = __passwd_empty;
3929 __pwdcache.pw_name = __pw_namecache;
3931 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3932 The identifier's value is usually the UIC, but it doesn't have to be,
3933 so if we can, we let fillpasswd update this. */
3934 __pwdcache.pw_uid = uic.uic$l_uic;
3935 __pwdcache.pw_gid = uic.uic$v_group;
3937 fillpasswd(__pw_namecache, &__pwdcache);
3940 } /* end of my_getpwuid() */
3944 * Get information for next user.
3946 /*{{{struct passwd *my_getpwent()*/
3947 struct passwd *my_getpwent()
3949 return (my_getpwuid((unsigned int) -1));
3954 * Finish searching rights database for users.
3956 /*{{{void my_endpwent()*/
3961 _ckvmssts(sys$finish_rdb(&contxt));
3967 #ifdef HOMEGROWN_POSIX_SIGNALS
3968 /* Signal handling routines, pulled into the core from POSIX.xs.
3970 * We need these for threads, so they've been rolled into the core,
3971 * rather than left in POSIX.xs.
3973 * (DRS, Oct 23, 1997)
3976 /* sigset_t is atomic under VMS, so these routines are easy */
3977 /*{{{int my_sigemptyset(sigset_t *) */
3978 int my_sigemptyset(sigset_t *set) {
3979 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3985 /*{{{int my_sigfillset(sigset_t *)*/
3986 int my_sigfillset(sigset_t *set) {
3988 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3989 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3995 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3996 int my_sigaddset(sigset_t *set, int sig) {
3997 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3998 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3999 *set |= (1 << (sig - 1));
4005 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4006 int my_sigdelset(sigset_t *set, int sig) {
4007 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4008 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4009 *set &= ~(1 << (sig - 1));
4015 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4016 int my_sigismember(sigset_t *set, int sig) {
4017 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4018 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4019 *set & (1 << (sig - 1));
4024 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4025 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4028 /* If set and oset are both null, then things are badly wrong. Bail out. */
4029 if ((oset == NULL) && (set == NULL)) {
4030 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4034 /* If set's null, then we're just handling a fetch. */
4036 tempmask = sigblock(0);
4041 tempmask = sigsetmask(*set);
4044 tempmask = sigblock(*set);
4047 tempmask = sigblock(0);
4048 sigsetmask(*oset & ~tempmask);
4051 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4056 /* Did they pass us an oset? If so, stick our holding mask into it */
4063 #endif /* HOMEGROWN_POSIX_SIGNALS */
4066 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4067 * my_utime(), and flex_stat(), all of which operate on UTC unless
4068 * VMSISH_TIMES is true.
4070 /* method used to handle UTC conversions:
4071 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4073 static int gmtime_emulation_type;
4074 /* number of secs to add to UTC POSIX-style time to get local time */
4075 static long int utc_offset_secs;
4077 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4078 * in vmsish.h. #undef them here so we can call the CRTL routines
4085 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4086 # define RTL_USES_UTC 1
4090 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4091 * qualifier with the extern prefix pragma. This provisional
4092 * hack circumvents this prefix pragma problem in previous
4095 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4096 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4097 # pragma __extern_prefix save
4098 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4099 # define gmtime decc$__utctz_gmtime
4100 # define localtime decc$__utctz_localtime
4101 # define time decc$__utc_time
4102 # pragma __extern_prefix restore
4104 struct tm *gmtime(), *localtime();
4110 static time_t toutc_dst(time_t loc) {
4113 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4114 loc -= utc_offset_secs;
4115 if (rsltmp->tm_isdst) loc -= 3600;
4118 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4119 ((gmtime_emulation_type || my_time(NULL)), \
4120 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4121 ((secs) - utc_offset_secs))))
4123 static time_t toloc_dst(time_t utc) {
4126 utc += utc_offset_secs;
4127 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4128 if (rsltmp->tm_isdst) utc += 3600;
4131 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4132 ((gmtime_emulation_type || my_time(NULL)), \
4133 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4134 ((secs) + utc_offset_secs))))
4137 /* my_time(), my_localtime(), my_gmtime()
4138 * By default traffic in UTC time values, using CRTL gmtime() or
4139 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4140 * Note: We need to use these functions even when the CRTL has working
4141 * UTC support, since they also handle C<use vmsish qw(times);>
4143 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4144 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4147 /*{{{time_t my_time(time_t *timep)*/
4148 time_t my_time(time_t *timep)
4154 if (gmtime_emulation_type == 0) {
4156 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4157 /* results of calls to gmtime() and localtime() */
4158 /* for same &base */
4160 gmtime_emulation_type++;
4161 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4162 char off[LNM$C_NAMLENGTH+1];;
4164 gmtime_emulation_type++;
4165 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4166 gmtime_emulation_type++;
4167 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4169 else { utc_offset_secs = atol(off); }
4171 else { /* We've got a working gmtime() */
4172 struct tm gmt, local;
4175 tm_p = localtime(&base);
4177 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4178 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4179 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4180 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4186 # ifdef RTL_USES_UTC
4187 if (VMSISH_TIME) when = _toloc(when);
4189 if (!VMSISH_TIME) when = _toutc(when);
4192 if (timep != NULL) *timep = when;
4195 } /* end of my_time() */
4199 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4201 my_gmtime(const time_t *timep)
4208 if (timep == NULL) {
4209 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4212 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4216 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4218 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4219 return gmtime(&when);
4221 /* CRTL localtime() wants local time as input, so does no tz correction */
4222 rsltmp = localtime(&when);
4223 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4226 } /* end of my_gmtime() */
4230 /*{{{struct tm *my_localtime(const time_t *timep)*/
4232 my_localtime(const time_t *timep)
4238 if (timep == NULL) {
4239 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4242 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4243 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4246 # ifdef RTL_USES_UTC
4248 if (VMSISH_TIME) when = _toutc(when);
4250 /* CRTL localtime() wants UTC as input, does tz correction itself */
4251 return localtime(&when);
4254 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4257 /* CRTL localtime() wants local time as input, so does no tz correction */
4258 rsltmp = localtime(&when);
4259 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4262 } /* end of my_localtime() */
4265 /* Reset definitions for later calls */
4266 #define gmtime(t) my_gmtime(t)
4267 #define localtime(t) my_localtime(t)
4268 #define time(t) my_time(t)
4271 /* my_utime - update modification time of a file
4272 * calling sequence is identical to POSIX utime(), but under
4273 * VMS only the modification time is changed; ODS-2 does not
4274 * maintain access times. Restrictions differ from the POSIX
4275 * definition in that the time can be changed as long as the
4276 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4277 * no separate checks are made to insure that the caller is the
4278 * owner of the file or has special privs enabled.
4279 * Code here is based on Joe Meadows' FILE utility.
4282 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4283 * to VMS epoch (01-JAN-1858 00:00:00.00)
4284 * in 100 ns intervals.
4286 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4288 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4289 int my_utime(char *file, struct utimbuf *utimes)
4293 long int bintime[2], len = 2, lowbit, unixtime,
4294 secscale = 10000000; /* seconds --> 100 ns intervals */
4295 unsigned long int chan, iosb[2], retsts;
4296 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4297 struct FAB myfab = cc$rms_fab;
4298 struct NAM mynam = cc$rms_nam;
4299 #if defined (__DECC) && defined (__VAX)
4300 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4301 * at least through VMS V6.1, which causes a type-conversion warning.
4303 # pragma message save
4304 # pragma message disable cvtdiftypes
4306 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4307 struct fibdef myfib;
4308 #if defined (__DECC) && defined (__VAX)
4309 /* This should be right after the declaration of myatr, but due
4310 * to a bug in VAX DEC C, this takes effect a statement early.
4312 # pragma message restore
4314 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4315 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4316 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4318 if (file == NULL || *file == '\0') {
4320 set_vaxc_errno(LIB$_INVARG);
4323 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4325 if (utimes != NULL) {
4326 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4327 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4328 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4329 * as input, we force the sign bit to be clear by shifting unixtime right
4330 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4332 lowbit = (utimes->modtime & 1) ? secscale : 0;
4333 unixtime = (long int) utimes->modtime;
4335 /* If input was UTC; convert to local for sys svc */
4336 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4338 unixtime >>= 1; secscale <<= 1;
4339 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4340 if (!(retsts & 1)) {
4342 set_vaxc_errno(retsts);
4345 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4346 if (!(retsts & 1)) {
4348 set_vaxc_errno(retsts);
4353 /* Just get the current time in VMS format directly */
4354 retsts = sys$gettim(bintime);
4355 if (!(retsts & 1)) {
4357 set_vaxc_errno(retsts);
4362 myfab.fab$l_fna = vmsspec;
4363 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4364 myfab.fab$l_nam = &mynam;
4365 mynam.nam$l_esa = esa;
4366 mynam.nam$b_ess = (unsigned char) sizeof esa;
4367 mynam.nam$l_rsa = rsa;
4368 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4370 /* Look for the file to be affected, letting RMS parse the file
4371 * specification for us as well. I have set errno using only
4372 * values documented in the utime() man page for VMS POSIX.
4374 retsts = sys$parse(&myfab,0,0);
4375 if (!(retsts & 1)) {
4376 set_vaxc_errno(retsts);
4377 if (retsts == RMS$_PRV) set_errno(EACCES);
4378 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4379 else set_errno(EVMSERR);
4382 retsts = sys$search(&myfab,0,0);
4383 if (!(retsts & 1)) {
4384 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4385 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4386 set_vaxc_errno(retsts);
4387 if (retsts == RMS$_PRV) set_errno(EACCES);
4388 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4389 else set_errno(EVMSERR);
4393 devdsc.dsc$w_length = mynam.nam$b_dev;
4394 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4396 retsts = sys$assign(&devdsc,&chan,0,0);
4397 if (!(retsts & 1)) {
4398 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4399 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4400 set_vaxc_errno(retsts);
4401 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4402 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4403 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4404 else set_errno(EVMSERR);
4408 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4409 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4411 memset((void *) &myfib, 0, sizeof myfib);
4413 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4414 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4415 /* This prevents the revision time of the file being reset to the current
4416 * time as a result of our IO$_MODIFY $QIO. */
4417 myfib.fib$l_acctl = FIB$M_NORECORD;
4419 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4420 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4421 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4423 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4424 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4425 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4426 _ckvmssts(sys$dassgn(chan));
4427 if (retsts & 1) retsts = iosb[0];
4428 if (!(retsts & 1)) {
4429 set_vaxc_errno(retsts);
4430 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4431 else set_errno(EVMSERR);
4436 } /* end of my_utime() */
4440 * flex_stat, flex_fstat
4441 * basic stat, but gets it right when asked to stat
4442 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4445 /* encode_dev packs a VMS device name string into an integer to allow
4446 * simple comparisons. This can be used, for example, to check whether two
4447 * files are located on the same device, by comparing their encoded device
4448 * names. Even a string comparison would not do, because stat() reuses the
4449 * device name buffer for each call; so without encode_dev, it would be
4450 * necessary to save the buffer and use strcmp (this would mean a number of
4451 * changes to the standard Perl code, to say nothing of what a Perl script
4454 * The device lock id, if it exists, should be unique (unless perhaps compared
4455 * with lock ids transferred from other nodes). We have a lock id if the disk is
4456 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4457 * device names. Thus we use the lock id in preference, and only if that isn't
4458 * available, do we try to pack the device name into an integer (flagged by
4459 * the sign bit (LOCKID_MASK) being set).
4461 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4462 * name and its encoded form, but it seems very unlikely that we will find
4463 * two files on different disks that share the same encoded device names,
4464 * and even more remote that they will share the same file id (if the test
4465 * is to check for the same file).
4467 * A better method might be to use sys$device_scan on the first call, and to
4468 * search for the device, returning an index into the cached array.
4469 * The number returned would be more intelligable.
4470 * This is probably not worth it, and anyway would take quite a bit longer
4471 * on the first call.
4473 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4474 static mydev_t encode_dev (const char *dev)
4477 unsigned long int f;
4483 if (!dev || !dev[0]) return 0;
4487 struct dsc$descriptor_s dev_desc;
4488 unsigned long int status, lockid, item = DVI$_LOCKID;
4490 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4491 can try that first. */
4492 dev_desc.dsc$w_length = strlen (dev);
4493 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4494 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4495 dev_desc.dsc$a_pointer = (char *) dev;
4496 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4497 if (lockid) return (lockid & ~LOCKID_MASK);
4501 /* Otherwise we try to encode the device name */
4505 for (q = dev + strlen(dev); q--; q >= dev) {
4508 else if (isalpha (toupper (*q)))
4509 c= toupper (*q) - 'A' + (char)10;
4511 continue; /* Skip '$'s */
4513 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4515 enc += f * (unsigned long int) c;
4517 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4519 } /* end of encode_dev() */
4521 static char namecache[NAM$C_MAXRSS+1];
4524 is_null_device(name)
4528 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4529 The underscore prefix, controller letter, and unit number are
4530 independently optional; for our purposes, the colon punctuation
4531 is not. The colon can be trailed by optional directory and/or
4532 filename, but two consecutive colons indicates a nodename rather
4533 than a device. [pr] */
4534 if (*name == '_') ++name;
4535 if (tolower(*name++) != 'n') return 0;
4536 if (tolower(*name++) != 'l') return 0;
4537 if (tolower(*name) == 'a') ++name;
4538 if (*name == '0') ++name;
4539 return (*name++ == ':') && (*name != ':');
4542 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4543 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4544 * subset of the applicable information.
4547 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4549 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4551 char fname[NAM$C_MAXRSS+1];
4552 unsigned long int retsts;
4553 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4554 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4556 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4557 device name on successive calls */
4558 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4559 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4560 namdsc.dsc$a_pointer = fname;
4561 namdsc.dsc$w_length = sizeof fname - 1;
4563 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4564 &namdsc,&namdsc.dsc$w_length,0,0);
4566 fname[namdsc.dsc$w_length] = '\0';
4567 return cando_by_name(bit,effective,fname);
4569 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4570 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4574 return FALSE; /* Should never get to here */
4576 } /* end of cando() */
4580 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4582 cando_by_name(I32 bit, Uid_t effective, char *fname)
4584 static char usrname[L_cuserid];
4585 static struct dsc$descriptor_s usrdsc =
4586 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4587 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4588 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4589 unsigned short int retlen;
4591 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4592 union prvdef curprv;
4593 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4594 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4595 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4598 if (!fname || !*fname) return FALSE;
4599 /* Make sure we expand logical names, since sys$check_access doesn't */
4600 if (!strpbrk(fname,"/]>:")) {
4601 strcpy(fileified,fname);
4602 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4605 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4606 retlen = namdsc.dsc$w_length = strlen(vmsname);
4607 namdsc.dsc$a_pointer = vmsname;
4608 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4609 vmsname[retlen-1] == ':') {
4610 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4611 namdsc.dsc$w_length = strlen(fileified);
4612 namdsc.dsc$a_pointer = fileified;
4615 if (!usrdsc.dsc$w_length) {
4617 usrdsc.dsc$w_length = strlen(usrname);
4624 access = ARM$M_EXECUTE;
4629 access = ARM$M_READ;
4634 access = ARM$M_WRITE;
4639 access = ARM$M_DELETE;
4645 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4646 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4647 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4648 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4649 set_vaxc_errno(retsts);
4650 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4651 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4652 else set_errno(ENOENT);
4655 if (retsts == SS$_NORMAL) {
4656 if (!privused) return TRUE;
4657 /* We can get access, but only by using privs. Do we have the
4658 necessary privs currently enabled? */
4659 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4660 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4661 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4662 !curprv.prv$v_bypass) return FALSE;
4663 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4664 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4665 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4668 if (retsts == SS$_ACCONFLICT) {
4673 return FALSE; /* Should never get here */
4675 } /* end of cando_by_name() */
4679 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4681 flex_fstat(int fd, Stat_t *statbufp)
4684 if (!fstat(fd,(stat_t *) statbufp)) {
4685 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4686 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4687 # ifdef RTL_USES_UTC
4690 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4691 statbufp->st_atime = _toloc(statbufp->st_atime);
4692 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4697 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4701 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4702 statbufp->st_atime = _toutc(statbufp->st_atime);
4703 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4710 } /* end of flex_fstat() */
4713 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4715 flex_stat(const char *fspec, Stat_t *statbufp)
4718 char fileified[NAM$C_MAXRSS+1];
4719 char temp_fspec[NAM$C_MAXRSS+300];
4722 strcpy(temp_fspec, fspec);
4723 if (statbufp == (Stat_t *) &PL_statcache)
4724 do_tovmsspec(temp_fspec,namecache,0);
4725 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4726 memset(statbufp,0,sizeof *statbufp);
4727 statbufp->st_dev = encode_dev("_NLA0:");
4728 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4729 statbufp->st_uid = 0x00010001;
4730 statbufp->st_gid = 0x0001;
4731 time((time_t *)&statbufp->st_mtime);
4732 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4736 /* Try for a directory name first. If fspec contains a filename without
4737 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4738 * and sea:[wine.dark]water. exist, we prefer the directory here.
4739 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4740 * not sea:[wine.dark]., if the latter exists. If the intended target is
4741 * the file with null type, specify this by calling flex_stat() with
4742 * a '.' at the end of fspec.
4744 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4745 retval = stat(fileified,(stat_t *) statbufp);
4746 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4747 strcpy(namecache,fileified);
4749 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4751 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4752 # ifdef RTL_USES_UTC
4755 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4756 statbufp->st_atime = _toloc(statbufp->st_atime);
4757 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4762 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4766 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4767 statbufp->st_atime = _toutc(statbufp->st_atime);
4768 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4774 } /* end of flex_stat() */
4778 /*{{{char *my_getlogin()*/
4779 /* VMS cuserid == Unix getlogin, except calling sequence */
4783 static char user[L_cuserid];
4784 return cuserid(user);
4789 /* rmscopy - copy a file using VMS RMS routines
4791 * Copies contents and attributes of spec_in to spec_out, except owner
4792 * and protection information. Name and type of spec_in are used as
4793 * defaults for spec_out. The third parameter specifies whether rmscopy()
4794 * should try to propagate timestamps from the input file to the output file.
4795 * If it is less than 0, no timestamps are preserved. If it is 0, then
4796 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4797 * propagated to the output file at creation iff the output file specification
4798 * did not contain an explicit name or type, and the revision date is always
4799 * updated at the end of the copy operation. If it is greater than 0, then
4800 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4801 * other than the revision date should be propagated, and bit 1 indicates
4802 * that the revision date should be propagated.
4804 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4806 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4807 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4808 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4809 * as part of the Perl standard distribution under the terms of the
4810 * GNU General Public License or the Perl Artistic License. Copies
4811 * of each may be found in the Perl standard distribution.
4813 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4815 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4817 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4818 rsa[NAM$C_MAXRSS], ubf[32256];
4819 unsigned long int i, sts, sts2;
4820 struct FAB fab_in, fab_out;
4821 struct RAB rab_in, rab_out;
4823 struct XABDAT xabdat;
4824 struct XABFHC xabfhc;
4825 struct XABRDT xabrdt;
4826 struct XABSUM xabsum;
4828 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4829 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4830 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4834 fab_in = cc$rms_fab;
4835 fab_in.fab$l_fna = vmsin;
4836 fab_in.fab$b_fns = strlen(vmsin);
4837 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4838 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4839 fab_in.fab$l_fop = FAB$M_SQO;
4840 fab_in.fab$l_nam = &nam;
4841 fab_in.fab$l_xab = (void *) &xabdat;
4844 nam.nam$l_rsa = rsa;
4845 nam.nam$b_rss = sizeof(rsa);
4846 nam.nam$l_esa = esa;
4847 nam.nam$b_ess = sizeof (esa);
4848 nam.nam$b_esl = nam.nam$b_rsl = 0;
4850 xabdat = cc$rms_xabdat; /* To get creation date */
4851 xabdat.xab$l_nxt = (void *) &xabfhc;
4853 xabfhc = cc$rms_xabfhc; /* To get record length */
4854 xabfhc.xab$l_nxt = (void *) &xabsum;
4856 xabsum = cc$rms_xabsum; /* To get key and area information */
4858 if (!((sts = sys$open(&fab_in)) & 1)) {
4859 set_vaxc_errno(sts);
4863 set_errno(ENOENT); break;
4865 set_errno(ENODEV); break;
4867 set_errno(EINVAL); break;
4869 set_errno(EACCES); break;
4877 fab_out.fab$w_ifi = 0;
4878 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4879 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4880 fab_out.fab$l_fop = FAB$M_SQO;
4881 fab_out.fab$l_fna = vmsout;
4882 fab_out.fab$b_fns = strlen(vmsout);
4883 fab_out.fab$l_dna = nam.nam$l_name;
4884 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4886 if (preserve_dates == 0) { /* Act like DCL COPY */
4887 nam.nam$b_nop = NAM$M_SYNCHK;
4888 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4889 if (!((sts = sys$parse(&fab_out)) & 1)) {
4890 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4891 set_vaxc_errno(sts);
4894 fab_out.fab$l_xab = (void *) &xabdat;
4895 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4897 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4898 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4899 preserve_dates =0; /* bitmask from this point forward */
4901 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4902 if (!((sts = sys$create(&fab_out)) & 1)) {
4903 set_vaxc_errno(sts);
4906 set_errno(ENOENT); break;
4908 set_errno(ENODEV); break;
4910 set_errno(EINVAL); break;
4912 set_errno(EACCES); break;
4918 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4919 if (preserve_dates & 2) {
4920 /* sys$close() will process xabrdt, not xabdat */
4921 xabrdt = cc$rms_xabrdt;
4923 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4925 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4926 * is unsigned long[2], while DECC & VAXC use a struct */
4927 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4929 fab_out.fab$l_xab = (void *) &xabrdt;
4932 rab_in = cc$rms_rab;
4933 rab_in.rab$l_fab = &fab_in;
4934 rab_in.rab$l_rop = RAB$M_BIO;
4935 rab_in.rab$l_ubf = ubf;
4936 rab_in.rab$w_usz = sizeof ubf;
4937 if (!((sts = sys$connect(&rab_in)) & 1)) {
4938 sys$close(&fab_in); sys$close(&fab_out);
4939 set_errno(EVMSERR); set_vaxc_errno(sts);
4943 rab_out = cc$rms_rab;
4944 rab_out.rab$l_fab = &fab_out;
4945 rab_out.rab$l_rbf = ubf;
4946 if (!((sts = sys$connect(&rab_out)) & 1)) {
4947 sys$close(&fab_in); sys$close(&fab_out);
4948 set_errno(EVMSERR); set_vaxc_errno(sts);
4952 while ((sts = sys$read(&rab_in))) { /* always true */
4953 if (sts == RMS$_EOF) break;
4954 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4955 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4956 sys$close(&fab_in); sys$close(&fab_out);
4957 set_errno(EVMSERR); set_vaxc_errno(sts);
4962 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4963 sys$close(&fab_in); sys$close(&fab_out);
4964 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4966 set_errno(EVMSERR); set_vaxc_errno(sts);
4972 } /* end of rmscopy() */
4976 /*** The following glue provides 'hooks' to make some of the routines
4977 * from this file available from Perl. These routines are sufficiently
4978 * basic, and are required sufficiently early in the build process,
4979 * that's it's nice to have them available to miniperl as well as the
4980 * full Perl, so they're set up here instead of in an extension. The
4981 * Perl code which handles importation of these names into a given
4982 * package lives in [.VMS]Filespec.pm in @INC.
4986 rmsexpand_fromperl(pTHX_ CV *cv)
4989 char *fspec, *defspec = NULL, *rslt;
4992 if (!items || items > 2)
4993 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4994 fspec = SvPV(ST(0),n_a);
4995 if (!fspec || !*fspec) XSRETURN_UNDEF;
4996 if (items == 2) defspec = SvPV(ST(1),n_a);
4998 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4999 ST(0) = sv_newmortal();
5000 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5005 vmsify_fromperl(pTHX_ CV *cv)
5011 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5012 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5013 ST(0) = sv_newmortal();
5014 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5019 unixify_fromperl(pTHX_ CV *cv)
5025 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5026 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5027 ST(0) = sv_newmortal();
5028 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5033 fileify_fromperl(pTHX_ CV *cv)
5039 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5040 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5041 ST(0) = sv_newmortal();
5042 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5047 pathify_fromperl(pTHX_ CV *cv)
5053 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5054 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5055 ST(0) = sv_newmortal();
5056 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5061 vmspath_fromperl(pTHX_ CV *cv)
5067 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5068 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5069 ST(0) = sv_newmortal();
5070 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5075 unixpath_fromperl(pTHX_ CV *cv)
5081 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5082 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5083 ST(0) = sv_newmortal();
5084 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5089 candelete_fromperl(pTHX_ CV *cv)
5092 char fspec[NAM$C_MAXRSS+1], *fsp;
5097 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5099 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5100 if (SvTYPE(mysv) == SVt_PVGV) {
5101 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5102 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5109 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5110 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5116 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5121 rmscopy_fromperl(pTHX_ CV *cv)
5124 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5126 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5127 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5128 unsigned long int sts;
5133 if (items < 2 || items > 3)
5134 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5136 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5137 if (SvTYPE(mysv) == SVt_PVGV) {
5138 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5139 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5146 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5147 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5152 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5153 if (SvTYPE(mysv) == SVt_PVGV) {
5154 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5155 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5162 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5163 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5168 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5170 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5177 char* file = __FILE__;
5179 char temp_buff[512];
5180 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5181 no_translate_barewords = TRUE;
5183 no_translate_barewords = FALSE;
5186 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5187 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5188 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5189 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5190 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5191 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5192 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5193 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5194 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);