3 * VMS-specific routines for perl5
5 * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
73 unsigned short int buflen;
74 unsigned short int itmcode;
76 unsigned short int *retlen;
79 static char *__mystrtolower(char *str)
81 if (str) for (; *str; ++str) *str= tolower(*str);
85 static struct dsc$descriptor_s fildevdsc =
86 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
87 static struct dsc$descriptor_s crtlenvdsc =
88 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
89 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
90 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
91 static struct dsc$descriptor_s **env_tables = defenv;
92 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
94 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
96 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
97 struct dsc$descriptor_s **tabvec, unsigned long int flags)
99 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
100 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
101 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
102 unsigned char acmode;
103 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
104 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
105 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
106 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
108 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
110 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
111 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
113 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
114 *cp2 = _toupper(*cp1);
115 if (cp1 - lnm > LNM$C_NAMLENGTH) {
116 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
120 lnmdsc.dsc$w_length = cp1 - lnm;
121 lnmdsc.dsc$a_pointer = uplnm;
122 secure = flags & PERL__TRNENV_SECURE;
123 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
124 if (!tabvec || !*tabvec) tabvec = env_tables;
126 for (curtab = 0; tabvec[curtab]; curtab++) {
127 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
128 if (!ivenv && !secure) {
133 warn("Can't read CRTL environ\n");
136 retsts = SS$_NOLOGNAM;
137 for (i = 0; environ[i]; i++) {
138 if ((eq = strchr(environ[i],'=')) &&
139 !strncmp(environ[i],uplnm,eq - environ[i])) {
141 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
142 if (!eqvlen) continue;
147 if (retsts != SS$_NOLOGNAM) break;
150 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
151 !str$case_blind_compare(&tmpdsc,&clisym)) {
152 if (!ivsym && !secure) {
153 unsigned short int deflen = LNM$C_NAMLENGTH;
154 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
155 /* dynamic dsc to accomodate possible long value */
156 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
157 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
160 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
162 if (ckWARN(WARN_MISC))
163 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
165 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
167 _ckvmssts(lib$sfree1_dd(&eqvdsc));
168 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
169 if (retsts == LIB$_NOSUCHSYM) continue;
174 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
175 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
176 if (retsts == SS$_NOLOGNAM) continue;
180 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
181 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
182 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
183 retsts == SS$_NOLOGNAM) {
184 set_errno(EINVAL); set_vaxc_errno(retsts);
186 else _ckvmssts(retsts);
188 } /* end of vmstrnenv */
192 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
193 /* Define as a function so we can access statics. */
194 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
196 return vmstrnenv(lnm,eqv,idx,fildev,
197 #ifdef SECURE_INTERNAL_GETENV
198 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
207 * Note: Uses Perl temp to store result so char * can be returned to
208 * caller; this pointer will be invalidated at next Perl statement
210 * We define this as a function rather than a macro in terms of my_getenv_sv()
211 * so that it'll work when PL_curinterp is undefined (and we therefore can't
214 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
216 my_getenv(const char *lnm, bool sys)
218 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
219 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
220 unsigned long int idx = 0;
224 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
225 /* Set up a temporary buffer for the return value; Perl will
226 * clean it up at the next statement transition */
227 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
228 if (!tmpsv) return NULL;
231 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
232 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
233 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
234 getcwd(eqv,LNM$C_NAMLENGTH);
238 if ((cp2 = strchr(lnm,';')) != NULL) {
240 uplnm[cp2-lnm] = '\0';
241 idx = strtoul(cp2+1,NULL,0);
244 if (vmstrnenv(lnm,eqv,idx,
246 #ifdef SECURE_INTERNAL_GETENV
247 sys ? PERL__TRNENV_SECURE : 0
255 } /* end of my_getenv() */
259 /*{{{ SV *my_getenv_sv(const char *lnm, bool sys)*/
261 my_getenv_sv(const char *lnm, bool sys)
263 char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
264 unsigned long int len, idx = 0;
266 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
267 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
268 getcwd(buf,LNM$C_NAMLENGTH);
269 return newSVpv(buf,0);
272 if ((cp2 = strchr(lnm,';')) != NULL) {
275 idx = strtoul(cp2+1,NULL,0);
278 if ((len = vmstrnenv(lnm,buf,idx,
280 #ifdef SECURE_INTERNAL_GETENV
281 sys ? PERL__TRNENV_SECURE : 0
285 ))) return newSVpv(buf,len);
286 else return &PL_sv_undef;
289 } /* end of my_getenv_sv() */
292 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
294 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
296 /*{{{ void prime_env_iter() */
299 /* Fill the %ENV associative array with all logical names we can
300 * find, in preparation for iterating over it.
304 static int primed = 0;
305 HV *seenhv = NULL, *envhv;
306 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
307 unsigned short int chan;
308 #ifndef CLI$M_TRUSTED
309 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
311 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
312 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
314 bool have_sym = FALSE, have_lnm = FALSE;
315 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
316 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
317 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
318 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
319 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
321 static perl_mutex primenv_mutex;
322 MUTEX_INIT(&primenv_mutex);
325 if (primed || !PL_envgv) return;
326 MUTEX_LOCK(&primenv_mutex);
327 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
328 envhv = GvHVn(PL_envgv);
329 /* Perform a dummy fetch as an lval to insure that the hash table is
330 * set up. Otherwise, the hv_store() will turn into a nullop. */
331 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
333 for (i = 0; env_tables[i]; i++) {
334 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
335 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
336 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
338 if (have_sym || have_lnm) {
339 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
340 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
341 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
342 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
345 for (i--; i >= 0; i--) {
346 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
349 for (j = 0; environ[j]; j++) {
350 if (!(start = strchr(environ[j],'='))) {
351 if (ckWARN(WARN_INTERNAL))
352 warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
356 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
362 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
363 !str$case_blind_compare(&tmpdsc,&clisym)) {
364 strcpy(cmd,"Show Symbol/Global *");
365 cmddsc.dsc$w_length = 20;
366 if (env_tables[i]->dsc$w_length == 12 &&
367 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
368 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
369 flags = defflags | CLI$M_NOLOGNAM;
372 strcpy(cmd,"Show Logical *");
373 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
374 strcat(cmd," /Table=");
375 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
376 cmddsc.dsc$w_length = strlen(cmd);
378 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
379 flags = defflags | CLI$M_NOCLISYM;
382 /* Create a new subprocess to execute each command, to exclude the
383 * remote possibility that someone could subvert a mbx or file used
384 * to write multiple commands to a single subprocess.
387 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
388 0,&riseandshine,0,0,&clidsc,&clitabdsc);
389 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
390 defflags &= ~CLI$M_TRUSTED;
391 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
393 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
394 if (seenhv) SvREFCNT_dec(seenhv);
397 char *cp1, *cp2, *key;
398 unsigned long int sts, iosb[2], retlen, keylen;
401 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
402 if (sts & 1) sts = iosb[0] & 0xffff;
403 if (sts == SS$_ENDOFFILE) {
405 while (substs == 0) { sys$hiber(); wakect++;}
406 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
411 retlen = iosb[0] >> 16;
412 if (!retlen) continue; /* blank line */
414 if (iosb[1] != subpid) {
416 croak("Unknown process %x sent message to prime_env_iter: %s",buf);
420 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
421 warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
423 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
424 if (*cp1 == '(' || /* Logical name table name */
425 *cp1 == '=' /* Next eqv of searchlist */) continue;
426 if (*cp1 == '"') cp1++;
427 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
428 key = cp1; keylen = cp2 - cp1;
429 if (keylen && hv_exists(seenhv,key,keylen)) continue;
430 while (*cp2 && *cp2 != '=') cp2++;
431 while (*cp2 && *cp2 != '"') cp2++;
432 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
433 if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) {
434 warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
437 /* Skip "" surrounding translation */
438 PERL_HASH(hash,key,keylen);
439 hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
440 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
442 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
443 /* get the PPFs for this process, not the subprocess */
444 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
445 char eqv[LNM$C_NAMLENGTH+1];
447 for (i = 0; ppfs[i]; i++) {
448 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
449 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
454 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
455 if (buf) Safefree(buf);
456 if (seenhv) SvREFCNT_dec(seenhv);
457 MUTEX_UNLOCK(&primenv_mutex);
460 } /* end of prime_env_iter */
464 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
465 /* Define or delete an element in the same "environment" as
466 * vmstrnenv(). If an element is to be deleted, it's removed from
467 * the first place it's found. If it's to be set, it's set in the
468 * place designated by the first element of the table vector.
469 * Like setenv() returns 0 for success, non-zero on error.
472 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
474 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
475 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
476 unsigned long int retsts, usermode = PSL$C_USER;
477 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
478 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
479 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
480 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
481 $DESCRIPTOR(local,"_LOCAL");
483 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
484 *cp2 = _toupper(*cp1);
485 if (cp1 - lnm > LNM$C_NAMLENGTH) {
486 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
490 lnmdsc.dsc$w_length = cp1 - lnm;
491 if (!tabvec || !*tabvec) tabvec = env_tables;
493 if (!eqv) { /* we're deleting n element */
494 for (curtab = 0; tabvec[curtab]; curtab++) {
495 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
497 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
498 if ((cp1 = strchr(environ[i],'=')) &&
499 !strncmp(environ[i],lnm,cp1 - environ[i])) {
501 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
504 ivenv = 1; retsts = SS$_NOLOGNAM;
506 if (ckWARN(WARN_INTERNAL))
507 warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
508 ivenv = 1; retsts = SS$_NOSUCHPGM;
514 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
515 !str$case_blind_compare(&tmpdsc,&clisym)) {
516 unsigned int symtype;
517 if (tabvec[curtab]->dsc$w_length == 12 &&
518 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
519 !str$case_blind_compare(&tmpdsc,&local))
520 symtype = LIB$K_CLI_LOCAL_SYM;
521 else symtype = LIB$K_CLI_GLOBAL_SYM;
522 retsts = lib$delete_symbol(&lnmdsc,&symtype);
523 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
524 if (retsts == LIB$_NOSUCHSYM) continue;
528 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
529 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
530 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
531 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
532 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
536 else { /* we're defining a value */
537 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
539 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
541 if (ckWARN(WARN_INTERNAL))
542 warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
543 retsts = SS$_NOSUCHPGM;
547 eqvdsc.dsc$a_pointer = eqv;
548 eqvdsc.dsc$w_length = strlen(eqv);
549 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
550 !str$case_blind_compare(&tmpdsc,&clisym)) {
551 unsigned int symtype;
552 if (tabvec[0]->dsc$w_length == 12 &&
553 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
554 !str$case_blind_compare(&tmpdsc,&local))
555 symtype = LIB$K_CLI_LOCAL_SYM;
556 else symtype = LIB$K_CLI_GLOBAL_SYM;
557 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
560 if (!*eqv) eqvdsc.dsc$w_length = 1;
561 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
567 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
568 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
569 set_errno(EVMSERR); break;
570 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
571 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
572 set_errno(EINVAL); break;
579 set_vaxc_errno(retsts);
580 return (int) retsts || 44; /* retsts should never be 0, but just in case */
583 /* We reset error values on success because Perl does an hv_fetch()
584 * before each hv_store(), and if the thing we're setting didn't
585 * previously exist, we've got a leftover error message. (Of course,
586 * this fails in the face of
587 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
588 * in that the error reported in $! isn't spurious,
589 * but it's right more often than not.)
591 set_errno(0); set_vaxc_errno(retsts);
595 } /* end of vmssetenv() */
598 /*{{{ void my_setenv(char *lnm, char *eqv)*/
599 /* This has to be a function since there's a prototype for it in proto.h */
601 my_setenv(char *lnm,char *eqv)
603 if (lnm && *lnm && strlen(lnm) == 7) {
606 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
607 if (!strcmp(uplnm,"DEFAULT")) {
608 if (eqv && *eqv) chdir(eqv);
612 (void) vmssetenv(lnm,eqv,NULL);
618 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
619 /* my_crypt - VMS password hashing
620 * my_crypt() provides an interface compatible with the Unix crypt()
621 * C library function, and uses sys$hash_password() to perform VMS
622 * password hashing. The quadword hashed password value is returned
623 * as a NUL-terminated 8 character string. my_crypt() does not change
624 * the case of its string arguments; in order to match the behavior
625 * of LOGINOUT et al., alphabetic characters in both arguments must
626 * be upcased by the caller.
629 my_crypt(const char *textpasswd, const char *usrname)
631 # ifndef UAI$C_PREFERRED_ALGORITHM
632 # define UAI$C_PREFERRED_ALGORITHM 127
634 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
635 unsigned short int salt = 0;
636 unsigned long int sts;
638 unsigned short int dsc$w_length;
639 unsigned char dsc$b_type;
640 unsigned char dsc$b_class;
641 const char * dsc$a_pointer;
642 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
643 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
644 struct itmlst_3 uailst[3] = {
645 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
646 { sizeof salt, UAI$_SALT, &salt, 0},
647 { 0, 0, NULL, NULL}};
650 usrdsc.dsc$w_length = strlen(usrname);
651 usrdsc.dsc$a_pointer = usrname;
652 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
659 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
665 if (sts != RMS$_RNF) return NULL;
668 txtdsc.dsc$w_length = strlen(textpasswd);
669 txtdsc.dsc$a_pointer = textpasswd;
670 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
671 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
674 return (char *) hash;
676 } /* end of my_crypt() */
680 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
681 static char *do_fileify_dirspec(char *, char *, int);
682 static char *do_tovmsspec(char *, char *, int);
684 /*{{{int do_rmdir(char *name)*/
688 char dirfile[NAM$C_MAXRSS+1];
692 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
693 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
694 else retval = kill_file(dirfile);
697 } /* end of do_rmdir */
701 * Delete any file to which user has control access, regardless of whether
702 * delete access is explicitly allowed.
703 * Limitations: User must have write access to parent directory.
704 * Does not block signals or ASTs; if interrupted in midstream
705 * may leave file with an altered ACL.
708 /*{{{int kill_file(char *name)*/
710 kill_file(char *name)
712 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
713 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
714 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
715 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
717 unsigned char myace$b_length;
718 unsigned char myace$b_type;
719 unsigned short int myace$w_flags;
720 unsigned long int myace$l_access;
721 unsigned long int myace$l_ident;
722 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
723 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
724 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
726 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
727 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
728 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
729 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
730 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
731 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
733 /* Expand the input spec using RMS, since the CRTL remove() and
734 * system services won't do this by themselves, so we may miss
735 * a file "hiding" behind a logical name or search list. */
736 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
737 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
738 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
739 /* If not, can changing protections help? */
740 if (vaxc$errno != RMS$_PRV) return -1;
742 /* No, so we get our own UIC to use as a rights identifier,
743 * and the insert an ACE at the head of the ACL which allows us
744 * to delete the file.
746 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
747 fildsc.dsc$w_length = strlen(rspec);
748 fildsc.dsc$a_pointer = rspec;
750 newace.myace$l_ident = oldace.myace$l_ident;
751 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
756 case SS$_NOSUCHOBJECT:
757 set_errno(ENOENT); break;
759 set_errno(ENODEV); break;
761 case SS$_INVFILFOROP:
762 set_errno(EINVAL); break;
764 set_errno(EACCES); break;
768 set_vaxc_errno(aclsts);
771 /* Grab any existing ACEs with this identifier in case we fail */
772 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
773 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
774 || fndsts == SS$_NOMOREACE ) {
775 /* Add the new ACE . . . */
776 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
778 if ((rmsts = remove(name))) {
779 /* We blew it - dir with files in it, no write priv for
780 * parent directory, etc. Put things back the way they were. */
781 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
784 addlst[0].bufadr = &oldace;
785 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
792 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
793 /* We just deleted it, so of course it's not there. Some versions of
794 * VMS seem to return success on the unlock operation anyhow (after all
795 * the unlock is successful), but others don't.
797 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
798 if (aclsts & 1) aclsts = fndsts;
801 set_vaxc_errno(aclsts);
807 } /* end of kill_file() */
811 /*{{{int my_mkdir(char *,Mode_t)*/
813 my_mkdir(char *dir, Mode_t mode)
815 STRLEN dirlen = strlen(dir);
817 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
818 * null file name/type. However, it's commonplace under Unix,
819 * so we'll allow it for a gain in portability.
821 if (dir[dirlen-1] == '/') {
822 char *newdir = savepvn(dir,dirlen-1);
823 int ret = mkdir(newdir,mode);
827 else return mkdir(dir,mode);
828 } /* end of my_mkdir */
833 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
835 static unsigned long int mbxbufsiz;
836 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
840 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
841 * preprocessor consant BUFSIZ from stdio.h as the size of the
844 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
845 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
847 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
849 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
850 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
852 } /* end of create_mbx() */
854 /*{{{ my_popen and my_pclose*/
857 struct pipe_details *next;
858 PerlIO *fp; /* stdio file pointer to pipe mailbox */
859 int pid; /* PID of subprocess */
860 int mode; /* == 'r' if pipe open for reading */
861 int done; /* subprocess has completed */
862 unsigned long int completion; /* termination status of subprocess */
865 struct exit_control_block
867 struct exit_control_block *flink;
868 unsigned long int (*exit_routine)();
869 unsigned long int arg_count;
870 unsigned long int *status_address;
871 unsigned long int exit_status;
874 static struct pipe_details *open_pipes = NULL;
875 static $DESCRIPTOR(nl_desc, "NL:");
876 static int waitpid_asleep = 0;
878 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
879 * to a mbx; that's the caller's responsibility.
881 static unsigned long int
884 char devnam[NAM$C_MAXRSS+1], *cp;
885 unsigned long int chan, iosb[2], retsts, retsts2;
886 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
888 if (fgetname(fp,devnam,1)) {
889 /* It oughta be a mailbox, so fgetname should give just the device
890 * name, but just in case . . . */
891 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
892 devdsc.dsc$w_length = strlen(devnam);
893 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
894 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
895 if (retsts & 1) retsts = iosb[0];
896 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
897 if (retsts & 1) retsts = retsts2;
901 else _ckvmssts(vaxc$errno); /* Should never happen */
902 return (unsigned long int) vaxc$errno;
905 static unsigned long int
908 struct pipe_details *info;
909 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
913 first we try sending an EOF...ignore if doesn't work, make sure we
920 if (info->mode != 'r' && !info->done) {
921 if (pipe_eof(info->fp) & 1) did_stuff = 1;
925 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
930 if (!info->done) { /* Tap them gently on the shoulder . . .*/
931 sts = sys$forcex(&info->pid,0,&abort);
932 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
937 if (did_stuff) sleep(1); /* wait for them to respond */
941 if (!info->done) { /* We tried to be nice . . . */
942 sts = sys$delprc(&info->pid,0);
943 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
944 info->done = 1; /* so my_pclose doesn't try to write EOF */
950 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
951 else if (!(sts & 1)) retsts = sts;
956 static struct exit_control_block pipe_exitblock =
957 {(struct exit_control_block *) 0,
958 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
962 popen_completion_ast(struct pipe_details *thispipe)
964 thispipe->done = TRUE;
965 if (waitpid_asleep) {
972 safe_popen(char *cmd, char *mode)
974 static int handler_set_up = FALSE;
976 unsigned short int chan;
977 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
978 struct pipe_details *info;
979 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
980 DSC$K_CLASS_S, mbxname},
981 cmddsc = {0, DSC$K_DTYPE_T,
985 cmddsc.dsc$w_length=strlen(cmd);
986 cmddsc.dsc$a_pointer=cmd;
987 if (cmddsc.dsc$w_length > 255) {
988 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
992 New(1301,info,1,struct pipe_details);
995 create_mbx(&chan,&namdsc);
997 /* open a FILE* onto it */
998 info->fp = PerlIO_open(mbxname, mode);
1000 /* give up other channel onto it */
1001 _ckvmssts(sys$dassgn(chan));
1011 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1012 0 /* name */, &info->pid, &info->completion,
1013 0, popen_completion_ast,info,0,0,0));
1016 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1017 0 /* name */, &info->pid, &info->completion,
1018 0, popen_completion_ast,info,0,0,0));
1021 if (!handler_set_up) {
1022 _ckvmssts(sys$dclexh(&pipe_exitblock));
1023 handler_set_up = TRUE;
1025 info->next=open_pipes; /* prepend to list */
1028 PL_forkprocess = info->pid;
1030 } /* end of safe_popen */
1033 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1035 my_popen(char *cmd, char *mode)
1038 TAINT_PROPER("popen");
1039 PERL_FLUSHALL_FOR_CHILD;
1040 return safe_popen(cmd,mode);
1045 /*{{{ I32 my_pclose(FILE *fp)*/
1046 I32 my_pclose(FILE *fp)
1048 struct pipe_details *info, *last = NULL;
1049 unsigned long int retsts;
1051 for (info = open_pipes; info != NULL; last = info, info = info->next)
1052 if (info->fp == fp) break;
1054 if (info == NULL) { /* no such pipe open */
1055 set_errno(ECHILD); /* quoth POSIX */
1056 set_vaxc_errno(SS$_NONEXPR);
1060 /* If we were writing to a subprocess, insure that someone reading from
1061 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1062 * produce an EOF record in the mailbox. */
1063 if (info->mode != 'r' && !info->done) pipe_eof(info->fp);
1064 PerlIO_close(info->fp);
1066 if (info->done) retsts = info->completion;
1067 else waitpid(info->pid,(int *) &retsts,0);
1069 /* remove from list of open pipes */
1070 if (last) last->next = info->next;
1071 else open_pipes = info->next;
1076 } /* end of my_pclose() */
1078 /* sort-of waitpid; use only with popen() */
1079 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1081 my_waitpid(Pid_t pid, int *statusp, int flags)
1083 struct pipe_details *info;
1085 for (info = open_pipes; info != NULL; info = info->next)
1086 if (info->pid == pid) break;
1088 if (info != NULL) { /* we know about this child */
1089 while (!info->done) {
1094 *statusp = info->completion;
1097 else { /* we haven't heard of this child */
1098 $DESCRIPTOR(intdsc,"0 00:00:01");
1099 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1100 unsigned long int interval[2],sts;
1102 if (ckWARN(WARN_EXEC)) {
1103 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1104 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1105 if (ownerpid != mypid)
1106 warner(WARN_EXEC,"pid %x not a child",pid);
1109 _ckvmssts(sys$bintim(&intdsc,interval));
1110 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1111 _ckvmssts(sys$schdwk(0,0,interval,0));
1112 _ckvmssts(sys$hiber());
1116 /* There's no easy way to find the termination status a child we're
1117 * not aware of beforehand. If we're really interested in the future,
1118 * we can go looking for a termination mailbox, or chase after the
1119 * accounting record for the process.
1125 } /* end of waitpid() */
1130 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1132 my_gconvert(double val, int ndig, int trail, char *buf)
1134 static char __gcvtbuf[DBL_DIG+1];
1137 loc = buf ? buf : __gcvtbuf;
1139 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1141 sprintf(loc,"%.*g",ndig,val);
1147 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1148 return gcvt(val,ndig,loc);
1151 loc[0] = '0'; loc[1] = '\0';
1159 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1160 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1161 * to expand file specification. Allows for a single default file
1162 * specification and a simple mask of options. If outbuf is non-NULL,
1163 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1164 * the resultant file specification is placed. If outbuf is NULL, the
1165 * resultant file specification is placed into a static buffer.
1166 * The third argument, if non-NULL, is taken to be a default file
1167 * specification string. The fourth argument is unused at present.
1168 * rmesexpand() returns the address of the resultant string if
1169 * successful, and NULL on error.
1171 static char *do_tounixspec(char *, char *, int);
1174 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1176 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1177 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1178 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1179 struct FAB myfab = cc$rms_fab;
1180 struct NAM mynam = cc$rms_nam;
1182 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1184 if (!filespec || !*filespec) {
1185 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1189 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1190 else outbuf = __rmsexpand_retbuf;
1192 if ((isunix = (strchr(filespec,'/') != NULL))) {
1193 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1194 filespec = vmsfspec;
1197 myfab.fab$l_fna = filespec;
1198 myfab.fab$b_fns = strlen(filespec);
1199 myfab.fab$l_nam = &mynam;
1201 if (defspec && *defspec) {
1202 if (strchr(defspec,'/') != NULL) {
1203 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1206 myfab.fab$l_dna = defspec;
1207 myfab.fab$b_dns = strlen(defspec);
1210 mynam.nam$l_esa = esa;
1211 mynam.nam$b_ess = sizeof esa;
1212 mynam.nam$l_rsa = outbuf;
1213 mynam.nam$b_rss = NAM$C_MAXRSS;
1215 retsts = sys$parse(&myfab,0,0);
1216 if (!(retsts & 1)) {
1217 mynam.nam$b_nop |= NAM$M_SYNCHK;
1218 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1219 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1220 retsts = sys$parse(&myfab,0,0);
1221 if (retsts & 1) goto expanded;
1223 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1224 (void) sys$parse(&myfab,0,0); /* Free search context */
1225 if (out) Safefree(out);
1226 set_vaxc_errno(retsts);
1227 if (retsts == RMS$_PRV) set_errno(EACCES);
1228 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1229 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1230 else set_errno(EVMSERR);
1233 retsts = sys$search(&myfab,0,0);
1234 if (!(retsts & 1) && retsts != RMS$_FNF) {
1235 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1236 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1237 if (out) Safefree(out);
1238 set_vaxc_errno(retsts);
1239 if (retsts == RMS$_PRV) set_errno(EACCES);
1240 else set_errno(EVMSERR);
1244 /* If the input filespec contained any lowercase characters,
1245 * downcase the result for compatibility with Unix-minded code. */
1247 for (out = myfab.fab$l_fna; *out; out++)
1248 if (islower(*out)) { haslower = 1; break; }
1249 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1250 else { out = esa; speclen = mynam.nam$b_esl; }
1251 /* Trim off null fields added by $PARSE
1252 * If type > 1 char, must have been specified in original or default spec
1253 * (not true for version; $SEARCH may have added version of existing file).
1255 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1256 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1257 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1258 if (trimver || trimtype) {
1259 if (defspec && *defspec) {
1260 char defesa[NAM$C_MAXRSS];
1261 struct FAB deffab = cc$rms_fab;
1262 struct NAM defnam = cc$rms_nam;
1264 deffab.fab$l_nam = &defnam;
1265 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1266 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1267 defnam.nam$b_nop = NAM$M_SYNCHK;
1268 if (sys$parse(&deffab,0,0) & 1) {
1269 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1270 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1273 if (trimver) speclen = mynam.nam$l_ver - out;
1275 /* If we didn't already trim version, copy down */
1276 if (speclen > mynam.nam$l_ver - out)
1277 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1278 speclen - (mynam.nam$l_ver - out));
1279 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1282 /* If we just had a directory spec on input, $PARSE "helpfully"
1283 * adds an empty name and type for us */
1284 if (mynam.nam$l_name == mynam.nam$l_type &&
1285 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1286 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1287 speclen = mynam.nam$l_name - out;
1288 out[speclen] = '\0';
1289 if (haslower) __mystrtolower(out);
1291 /* Have we been working with an expanded, but not resultant, spec? */
1292 /* Also, convert back to Unix syntax if necessary. */
1293 if (!mynam.nam$b_rsl) {
1295 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1297 else strcpy(outbuf,esa);
1300 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1301 strcpy(outbuf,tmpfspec);
1303 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1304 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1305 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1309 /* External entry points */
1310 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1311 { return do_rmsexpand(spec,buf,0,def,opt); }
1312 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1313 { return do_rmsexpand(spec,buf,1,def,opt); }
1317 ** The following routines are provided to make life easier when
1318 ** converting among VMS-style and Unix-style directory specifications.
1319 ** All will take input specifications in either VMS or Unix syntax. On
1320 ** failure, all return NULL. If successful, the routines listed below
1321 ** return a pointer to a buffer containing the appropriately
1322 ** reformatted spec (and, therefore, subsequent calls to that routine
1323 ** will clobber the result), while the routines of the same names with
1324 ** a _ts suffix appended will return a pointer to a mallocd string
1325 ** containing the appropriately reformatted spec.
1326 ** In all cases, only explicit syntax is altered; no check is made that
1327 ** the resulting string is valid or that the directory in question
1330 ** fileify_dirspec() - convert a directory spec into the name of the
1331 ** directory file (i.e. what you can stat() to see if it's a dir).
1332 ** The style (VMS or Unix) of the result is the same as the style
1333 ** of the parameter passed in.
1334 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1335 ** what you prepend to a filename to indicate what directory it's in).
1336 ** The style (VMS or Unix) of the result is the same as the style
1337 ** of the parameter passed in.
1338 ** tounixpath() - convert a directory spec into a Unix-style path.
1339 ** tovmspath() - convert a directory spec into a VMS-style path.
1340 ** tounixspec() - convert any file spec into a Unix-style file spec.
1341 ** tovmsspec() - convert any file spec into a VMS-style spec.
1343 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1344 ** Permission is given to distribute this code as part of the Perl
1345 ** standard distribution under the terms of the GNU General Public
1346 ** License or the Perl Artistic License. Copies of each may be
1347 ** found in the Perl standard distribution.
1350 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1351 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1353 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1354 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1355 char *retspec, *cp1, *cp2, *lastdir;
1356 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1358 if (!dir || !*dir) {
1359 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1361 dirlen = strlen(dir);
1362 while (dir[dirlen-1] == '/') --dirlen;
1363 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1364 strcpy(trndir,"/sys$disk/000000");
1368 if (dirlen > NAM$C_MAXRSS) {
1369 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1371 if (!strpbrk(dir+1,"/]>:")) {
1372 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1373 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1375 dirlen = strlen(dir);
1378 strncpy(trndir,dir,dirlen);
1379 trndir[dirlen] = '\0';
1382 /* If we were handed a rooted logical name or spec, treat it like a
1383 * simple directory, so that
1384 * $ Define myroot dev:[dir.]
1385 * ... do_fileify_dirspec("myroot",buf,1) ...
1386 * does something useful.
1388 if (!strcmp(dir+dirlen-2,".]")) {
1389 dir[--dirlen] = '\0';
1390 dir[dirlen-1] = ']';
1393 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1394 /* If we've got an explicit filename, we can just shuffle the string. */
1395 if (*(cp1+1)) hasfilename = 1;
1396 /* Similarly, we can just back up a level if we've got multiple levels
1397 of explicit directories in a VMS spec which ends with directories. */
1399 for (cp2 = cp1; cp2 > dir; cp2--) {
1401 *cp2 = *cp1; *cp1 = '\0';
1405 if (*cp2 == '[' || *cp2 == '<') break;
1410 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1411 if (dir[0] == '.') {
1412 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1413 return do_fileify_dirspec("[]",buf,ts);
1414 else if (dir[1] == '.' &&
1415 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1416 return do_fileify_dirspec("[-]",buf,ts);
1418 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1419 dirlen -= 1; /* to last element */
1420 lastdir = strrchr(dir,'/');
1422 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1423 /* If we have "/." or "/..", VMSify it and let the VMS code
1424 * below expand it, rather than repeating the code to handle
1425 * relative components of a filespec here */
1427 if (*(cp1+2) == '.') cp1++;
1428 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1429 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1430 if (strchr(vmsdir,'/') != NULL) {
1431 /* If do_tovmsspec() returned it, it must have VMS syntax
1432 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1433 * the time to check this here only so we avoid a recursion
1434 * loop; otherwise, gigo.
1436 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1438 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1439 return do_tounixspec(trndir,buf,ts);
1442 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1443 lastdir = strrchr(dir,'/');
1445 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1446 /* Ditto for specs that end in an MFD -- let the VMS code
1447 * figure out whether it's a real device or a rooted logical. */
1448 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1449 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1450 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1451 return do_tounixspec(trndir,buf,ts);
1454 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1455 !(lastdir = cp1 = strrchr(dir,']')) &&
1456 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1457 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1459 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1460 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1461 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1462 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1463 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1464 (ver || *cp3)))))) {
1466 set_vaxc_errno(RMS$_DIR);
1472 /* If we lead off with a device or rooted logical, add the MFD
1473 if we're specifying a top-level directory. */
1474 if (lastdir && *dir == '/') {
1476 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1483 retlen = dirlen + (addmfd ? 13 : 6);
1484 if (buf) retspec = buf;
1485 else if (ts) New(1309,retspec,retlen+1,char);
1486 else retspec = __fileify_retbuf;
1488 dirlen = lastdir - dir;
1489 memcpy(retspec,dir,dirlen);
1490 strcpy(&retspec[dirlen],"/000000");
1491 strcpy(&retspec[dirlen+7],lastdir);
1494 memcpy(retspec,dir,dirlen);
1495 retspec[dirlen] = '\0';
1497 /* We've picked up everything up to the directory file name.
1498 Now just add the type and version, and we're set. */
1499 strcat(retspec,".dir;1");
1502 else { /* VMS-style directory spec */
1503 char esa[NAM$C_MAXRSS+1], term, *cp;
1504 unsigned long int sts, cmplen, haslower = 0;
1505 struct FAB dirfab = cc$rms_fab;
1506 struct NAM savnam, dirnam = cc$rms_nam;
1508 dirfab.fab$b_fns = strlen(dir);
1509 dirfab.fab$l_fna = dir;
1510 dirfab.fab$l_nam = &dirnam;
1511 dirfab.fab$l_dna = ".DIR;1";
1512 dirfab.fab$b_dns = 6;
1513 dirnam.nam$b_ess = NAM$C_MAXRSS;
1514 dirnam.nam$l_esa = esa;
1516 for (cp = dir; *cp; cp++)
1517 if (islower(*cp)) { haslower = 1; break; }
1518 if (!((sts = sys$parse(&dirfab))&1)) {
1519 if (dirfab.fab$l_sts == RMS$_DIR) {
1520 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1521 sts = sys$parse(&dirfab) & 1;
1525 set_vaxc_errno(dirfab.fab$l_sts);
1531 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1532 /* Yes; fake the fnb bits so we'll check type below */
1533 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1536 if (dirfab.fab$l_sts != RMS$_FNF) {
1538 set_vaxc_errno(dirfab.fab$l_sts);
1541 dirnam = savnam; /* No; just work with potential name */
1544 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1545 cp1 = strchr(esa,']');
1546 if (!cp1) cp1 = strchr(esa,'>');
1547 if (cp1) { /* Should always be true */
1548 dirnam.nam$b_esl -= cp1 - esa - 1;
1549 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1552 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1553 /* Yep; check version while we're at it, if it's there. */
1554 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1555 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1556 /* Something other than .DIR[;1]. Bzzt. */
1558 set_vaxc_errno(RMS$_DIR);
1562 esa[dirnam.nam$b_esl] = '\0';
1563 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1564 /* They provided at least the name; we added the type, if necessary, */
1565 if (buf) retspec = buf; /* in sys$parse() */
1566 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1567 else retspec = __fileify_retbuf;
1568 strcpy(retspec,esa);
1571 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1572 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1574 dirnam.nam$b_esl -= 9;
1576 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1577 if (cp1 == NULL) return NULL; /* should never happen */
1580 retlen = strlen(esa);
1581 if ((cp1 = strrchr(esa,'.')) != NULL) {
1582 /* There's more than one directory in the path. Just roll back. */
1584 if (buf) retspec = buf;
1585 else if (ts) New(1311,retspec,retlen+7,char);
1586 else retspec = __fileify_retbuf;
1587 strcpy(retspec,esa);
1590 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1591 /* Go back and expand rooted logical name */
1592 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1593 if (!(sys$parse(&dirfab) & 1)) {
1595 set_vaxc_errno(dirfab.fab$l_sts);
1598 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1599 if (buf) retspec = buf;
1600 else if (ts) New(1312,retspec,retlen+16,char);
1601 else retspec = __fileify_retbuf;
1602 cp1 = strstr(esa,"][");
1604 memcpy(retspec,esa,dirlen);
1605 if (!strncmp(cp1+2,"000000]",7)) {
1606 retspec[dirlen-1] = '\0';
1607 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1608 if (*cp1 == '.') *cp1 = ']';
1610 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1611 memcpy(cp1+1,"000000]",7);
1615 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1616 retspec[retlen] = '\0';
1617 /* Convert last '.' to ']' */
1618 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1619 if (*cp1 == '.') *cp1 = ']';
1621 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1622 memcpy(cp1+1,"000000]",7);
1626 else { /* This is a top-level dir. Add the MFD to the path. */
1627 if (buf) retspec = buf;
1628 else if (ts) New(1312,retspec,retlen+16,char);
1629 else retspec = __fileify_retbuf;
1632 while (*cp1 != ':') *(cp2++) = *(cp1++);
1633 strcpy(cp2,":[000000]");
1638 /* We've set up the string up through the filename. Add the
1639 type and version, and we're done. */
1640 strcat(retspec,".DIR;1");
1642 /* $PARSE may have upcased filespec, so convert output to lower
1643 * case if input contained any lowercase characters. */
1644 if (haslower) __mystrtolower(retspec);
1647 } /* end of do_fileify_dirspec() */
1649 /* External entry points */
1650 char *fileify_dirspec(char *dir, char *buf)
1651 { return do_fileify_dirspec(dir,buf,0); }
1652 char *fileify_dirspec_ts(char *dir, char *buf)
1653 { return do_fileify_dirspec(dir,buf,1); }
1655 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1656 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1658 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1659 unsigned long int retlen;
1660 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1662 if (!dir || !*dir) {
1663 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1666 if (*dir) strcpy(trndir,dir);
1667 else getcwd(trndir,sizeof trndir - 1);
1669 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1670 STRLEN trnlen = strlen(trndir);
1672 /* Trap simple rooted lnms, and return lnm:[000000] */
1673 if (!strcmp(trndir+trnlen-2,".]")) {
1674 if (buf) retpath = buf;
1675 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1676 else retpath = __pathify_retbuf;
1677 strcpy(retpath,dir);
1678 strcat(retpath,":[000000]");
1684 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1685 if (*dir == '.' && (*(dir+1) == '\0' ||
1686 (*(dir+1) == '.' && *(dir+2) == '\0')))
1687 retlen = 2 + (*(dir+1) != '\0');
1689 if ( !(cp1 = strrchr(dir,'/')) &&
1690 !(cp1 = strrchr(dir,']')) &&
1691 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1692 if ((cp2 = strchr(cp1,'.')) != NULL &&
1693 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1694 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1695 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1696 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1698 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1699 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1700 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1701 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1702 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1703 (ver || *cp3)))))) {
1705 set_vaxc_errno(RMS$_DIR);
1708 retlen = cp2 - dir + 1;
1710 else { /* No file type present. Treat the filename as a directory. */
1711 retlen = strlen(dir) + 1;
1714 if (buf) retpath = buf;
1715 else if (ts) New(1313,retpath,retlen+1,char);
1716 else retpath = __pathify_retbuf;
1717 strncpy(retpath,dir,retlen-1);
1718 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1719 retpath[retlen-1] = '/'; /* with '/', add it. */
1720 retpath[retlen] = '\0';
1722 else retpath[retlen-1] = '\0';
1724 else { /* VMS-style directory spec */
1725 char esa[NAM$C_MAXRSS+1], *cp;
1726 unsigned long int sts, cmplen, haslower;
1727 struct FAB dirfab = cc$rms_fab;
1728 struct NAM savnam, dirnam = cc$rms_nam;
1730 /* If we've got an explicit filename, we can just shuffle the string. */
1731 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1732 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1733 if ((cp2 = strchr(cp1,'.')) != NULL) {
1735 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1736 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1737 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1738 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1739 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1740 (ver || *cp3)))))) {
1742 set_vaxc_errno(RMS$_DIR);
1746 else { /* No file type, so just draw name into directory part */
1747 for (cp2 = cp1; *cp2; cp2++) ;
1750 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1752 /* We've now got a VMS 'path'; fall through */
1754 dirfab.fab$b_fns = strlen(dir);
1755 dirfab.fab$l_fna = dir;
1756 if (dir[dirfab.fab$b_fns-1] == ']' ||
1757 dir[dirfab.fab$b_fns-1] == '>' ||
1758 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1759 if (buf) retpath = buf;
1760 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1761 else retpath = __pathify_retbuf;
1762 strcpy(retpath,dir);
1765 dirfab.fab$l_dna = ".DIR;1";
1766 dirfab.fab$b_dns = 6;
1767 dirfab.fab$l_nam = &dirnam;
1768 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1769 dirnam.nam$l_esa = esa;
1771 for (cp = dir; *cp; cp++)
1772 if (islower(*cp)) { haslower = 1; break; }
1774 if (!(sts = (sys$parse(&dirfab)&1))) {
1775 if (dirfab.fab$l_sts == RMS$_DIR) {
1776 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1777 sts = sys$parse(&dirfab) & 1;
1781 set_vaxc_errno(dirfab.fab$l_sts);
1787 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1788 if (dirfab.fab$l_sts != RMS$_FNF) {
1790 set_vaxc_errno(dirfab.fab$l_sts);
1793 dirnam = savnam; /* No; just work with potential name */
1796 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1797 /* Yep; check version while we're at it, if it's there. */
1798 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1799 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1800 /* Something other than .DIR[;1]. Bzzt. */
1802 set_vaxc_errno(RMS$_DIR);
1806 /* OK, the type was fine. Now pull any file name into the
1808 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1810 cp1 = strrchr(esa,'>');
1811 *dirnam.nam$l_type = '>';
1814 *(dirnam.nam$l_type + 1) = '\0';
1815 retlen = dirnam.nam$l_type - esa + 2;
1816 if (buf) retpath = buf;
1817 else if (ts) New(1314,retpath,retlen,char);
1818 else retpath = __pathify_retbuf;
1819 strcpy(retpath,esa);
1820 /* $PARSE may have upcased filespec, so convert output to lower
1821 * case if input contained any lowercase characters. */
1822 if (haslower) __mystrtolower(retpath);
1826 } /* end of do_pathify_dirspec() */
1828 /* External entry points */
1829 char *pathify_dirspec(char *dir, char *buf)
1830 { return do_pathify_dirspec(dir,buf,0); }
1831 char *pathify_dirspec_ts(char *dir, char *buf)
1832 { return do_pathify_dirspec(dir,buf,1); }
1834 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1835 static char *do_tounixspec(char *spec, char *buf, int ts)
1837 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1838 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1839 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1841 if (spec == NULL) return NULL;
1842 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1843 if (buf) rslt = buf;
1845 retlen = strlen(spec);
1846 cp1 = strchr(spec,'[');
1847 if (!cp1) cp1 = strchr(spec,'<');
1849 for (cp1++; *cp1; cp1++) {
1850 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1851 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1852 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1855 New(1315,rslt,retlen+2+2*expand,char);
1857 else rslt = __tounixspec_retbuf;
1858 if (strchr(spec,'/') != NULL) {
1865 dirend = strrchr(spec,']');
1866 if (dirend == NULL) dirend = strrchr(spec,'>');
1867 if (dirend == NULL) dirend = strchr(spec,':');
1868 if (dirend == NULL) {
1872 if (*cp2 != '[' && *cp2 != '<') {
1875 else { /* the VMS spec begins with directories */
1877 if (*cp2 == ']' || *cp2 == '>') {
1878 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1881 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1882 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1883 if (ts) Safefree(rslt);
1888 while (*cp3 != ':' && *cp3) cp3++;
1890 if (strchr(cp3,']') != NULL) break;
1891 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1893 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1894 retlen = devlen + dirlen;
1895 Renew(rslt,retlen+1+2*expand,char);
1901 *(cp1++) = *(cp3++);
1902 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1906 else if ( *cp2 == '.') {
1907 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1908 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1914 for (; cp2 <= dirend; cp2++) {
1917 if (*(cp2+1) == '[') cp2++;
1919 else if (*cp2 == ']' || *cp2 == '>') {
1920 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1922 else if (*cp2 == '.') {
1924 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1925 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1926 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1927 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1928 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1930 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1931 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1935 else if (*cp2 == '-') {
1936 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1937 while (*cp2 == '-') {
1939 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1941 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1942 if (ts) Safefree(rslt); /* filespecs like */
1943 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1947 else *(cp1++) = *cp2;
1949 else *(cp1++) = *cp2;
1951 while (*cp2) *(cp1++) = *(cp2++);
1956 } /* end of do_tounixspec() */
1958 /* External entry points */
1959 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1960 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1962 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1963 static char *do_tovmsspec(char *path, char *buf, int ts) {
1964 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1965 char *rslt, *dirend;
1966 register char *cp1, *cp2;
1967 unsigned long int infront = 0, hasdir = 1;
1969 if (path == NULL) return NULL;
1970 if (buf) rslt = buf;
1971 else if (ts) New(1316,rslt,strlen(path)+9,char);
1972 else rslt = __tovmsspec_retbuf;
1973 if (strpbrk(path,"]:>") ||
1974 (dirend = strrchr(path,'/')) == NULL) {
1975 if (path[0] == '.') {
1976 if (path[1] == '\0') strcpy(rslt,"[]");
1977 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1978 else strcpy(rslt,path); /* probably garbage */
1980 else strcpy(rslt,path);
1983 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1984 if (!*(dirend+2)) dirend +=2;
1985 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1986 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1991 char trndev[NAM$C_MAXRSS+1];
1995 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1997 if (!buf & ts) Renew(rslt,18,char);
1998 strcpy(rslt,"sys$disk:[000000]");
2001 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2003 islnm = my_trnlnm(rslt,trndev,0);
2004 trnend = islnm ? strlen(trndev) - 1 : 0;
2005 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2006 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2007 /* If the first element of the path is a logical name, determine
2008 * whether it has to be translated so we can add more directories. */
2009 if (!islnm || rooted) {
2012 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2016 if (cp2 != dirend) {
2017 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2018 strcpy(rslt,trndev);
2019 cp1 = rslt + trnend;
2032 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2033 cp2 += 2; /* skip over "./" - it's redundant */
2034 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2036 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2037 *(cp1++) = '-'; /* "../" --> "-" */
2040 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2041 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2042 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2043 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2046 if (cp2 > dirend) cp2 = dirend;
2048 else *(cp1++) = '.';
2050 for (; cp2 < dirend; cp2++) {
2052 if (*(cp2-1) == '/') continue;
2053 if (*(cp1-1) != '.') *(cp1++) = '.';
2056 else if (!infront && *cp2 == '.') {
2057 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2058 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2059 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2060 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2061 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2062 else { /* back up over previous directory name */
2064 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2065 if (*(cp1-1) == '[') {
2066 memcpy(cp1,"000000.",7);
2071 if (cp2 == dirend) break;
2073 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2074 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2075 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2076 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2078 *(cp1++) = '.'; /* Simulate trailing '/' */
2079 cp2 += 2; /* for loop will incr this to == dirend */
2081 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2083 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2086 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2087 if (*cp2 == '.') *(cp1++) = '_';
2088 else *(cp1++) = *cp2;
2092 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2093 if (hasdir) *(cp1++) = ']';
2094 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2095 while (*cp2) *(cp1++) = *(cp2++);
2100 } /* end of do_tovmsspec() */
2102 /* External entry points */
2103 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2104 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2106 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2107 static char *do_tovmspath(char *path, char *buf, int ts) {
2108 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2110 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2112 if (path == NULL) return NULL;
2113 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2114 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2115 if (buf) return buf;
2117 vmslen = strlen(vmsified);
2118 New(1317,cp,vmslen+1,char);
2119 memcpy(cp,vmsified,vmslen);
2124 strcpy(__tovmspath_retbuf,vmsified);
2125 return __tovmspath_retbuf;
2128 } /* end of do_tovmspath() */
2130 /* External entry points */
2131 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2132 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2135 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2136 static char *do_tounixpath(char *path, char *buf, int ts) {
2137 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2139 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2141 if (path == NULL) return NULL;
2142 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2143 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2144 if (buf) return buf;
2146 unixlen = strlen(unixified);
2147 New(1317,cp,unixlen+1,char);
2148 memcpy(cp,unixified,unixlen);
2153 strcpy(__tounixpath_retbuf,unixified);
2154 return __tounixpath_retbuf;
2157 } /* end of do_tounixpath() */
2159 /* External entry points */
2160 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2161 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2164 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2166 *****************************************************************************
2168 * Copyright (C) 1989-1994 by *
2169 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2171 * Permission is hereby granted for the reproduction of this software, *
2172 * on condition that this copyright notice is included in the reproduction, *
2173 * and that such reproduction is not for purposes of profit or material *
2176 * 27-Aug-1994 Modified for inclusion in perl5 *
2177 * by Charles Bailey bailey@newman.upenn.edu *
2178 *****************************************************************************
2182 * getredirection() is intended to aid in porting C programs
2183 * to VMS (Vax-11 C). The native VMS environment does not support
2184 * '>' and '<' I/O redirection, or command line wild card expansion,
2185 * or a command line pipe mechanism using the '|' AND background
2186 * command execution '&'. All of these capabilities are provided to any
2187 * C program which calls this procedure as the first thing in the
2189 * The piping mechanism will probably work with almost any 'filter' type
2190 * of program. With suitable modification, it may useful for other
2191 * portability problems as well.
2193 * Author: Mark Pizzolato mark@infocomm.com
2197 struct list_item *next;
2201 static void add_item(struct list_item **head,
2202 struct list_item **tail,
2206 static void expand_wild_cards(char *item,
2207 struct list_item **head,
2208 struct list_item **tail,
2211 static int background_process(int argc, char **argv);
2213 static void pipe_and_fork(char **cmargv);
2215 /*{{{ void getredirection(int *ac, char ***av)*/
2217 getredirection(int *ac, char ***av)
2219 * Process vms redirection arg's. Exit if any error is seen.
2220 * If getredirection() processes an argument, it is erased
2221 * from the vector. getredirection() returns a new argc and argv value.
2222 * In the event that a background command is requested (by a trailing "&"),
2223 * this routine creates a background subprocess, and simply exits the program.
2225 * Warning: do not try to simplify the code for vms. The code
2226 * presupposes that getredirection() is called before any data is
2227 * read from stdin or written to stdout.
2229 * Normal usage is as follows:
2235 * getredirection(&argc, &argv);
2239 int argc = *ac; /* Argument Count */
2240 char **argv = *av; /* Argument Vector */
2241 char *ap; /* Argument pointer */
2242 int j; /* argv[] index */
2243 int item_count = 0; /* Count of Items in List */
2244 struct list_item *list_head = 0; /* First Item in List */
2245 struct list_item *list_tail; /* Last Item in List */
2246 char *in = NULL; /* Input File Name */
2247 char *out = NULL; /* Output File Name */
2248 char *outmode = "w"; /* Mode to Open Output File */
2249 char *err = NULL; /* Error File Name */
2250 char *errmode = "w"; /* Mode to Open Error File */
2251 int cmargc = 0; /* Piped Command Arg Count */
2252 char **cmargv = NULL;/* Piped Command Arg Vector */
2255 * First handle the case where the last thing on the line ends with
2256 * a '&'. This indicates the desire for the command to be run in a
2257 * subprocess, so we satisfy that desire.
2260 if (0 == strcmp("&", ap))
2261 exit(background_process(--argc, argv));
2262 if (*ap && '&' == ap[strlen(ap)-1])
2264 ap[strlen(ap)-1] = '\0';
2265 exit(background_process(argc, argv));
2268 * Now we handle the general redirection cases that involve '>', '>>',
2269 * '<', and pipes '|'.
2271 for (j = 0; j < argc; ++j)
2273 if (0 == strcmp("<", argv[j]))
2277 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2278 exit(LIB$_WRONUMARG);
2283 if ('<' == *(ap = argv[j]))
2288 if (0 == strcmp(">", ap))
2292 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2293 exit(LIB$_WRONUMARG);
2312 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2313 exit(LIB$_WRONUMARG);
2317 if (('2' == *ap) && ('>' == ap[1]))
2334 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2335 exit(LIB$_WRONUMARG);
2339 if (0 == strcmp("|", argv[j]))
2343 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2344 exit(LIB$_WRONUMARG);
2346 cmargc = argc-(j+1);
2347 cmargv = &argv[j+1];
2351 if ('|' == *(ap = argv[j]))
2359 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2362 * Allocate and fill in the new argument vector, Some Unix's terminate
2363 * the list with an extra null pointer.
2365 New(1302, argv, item_count+1, char *);
2367 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2368 argv[j] = list_head->value;
2374 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2375 exit(LIB$_INVARGORD);
2377 pipe_and_fork(cmargv);
2380 /* Check for input from a pipe (mailbox) */
2382 if (in == NULL && 1 == isapipe(0))
2384 char mbxname[L_tmpnam];
2386 long int dvi_item = DVI$_DEVBUFSIZ;
2387 $DESCRIPTOR(mbxnam, "");
2388 $DESCRIPTOR(mbxdevnam, "");
2390 /* Input from a pipe, reopen it in binary mode to disable */
2391 /* carriage control processing. */
2393 PerlIO_getname(stdin, mbxname);
2394 mbxnam.dsc$a_pointer = mbxname;
2395 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2396 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2397 mbxdevnam.dsc$a_pointer = mbxname;
2398 mbxdevnam.dsc$w_length = sizeof(mbxname);
2399 dvi_item = DVI$_DEVNAM;
2400 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2401 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2404 freopen(mbxname, "rb", stdin);
2407 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2411 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2413 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2416 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2418 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2423 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2425 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2429 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2434 #ifdef ARGPROC_DEBUG
2435 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2436 for (j = 0; j < *ac; ++j)
2437 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2439 /* Clear errors we may have hit expanding wildcards, so they don't
2440 show up in Perl's $! later */
2441 set_errno(0); set_vaxc_errno(1);
2442 } /* end of getredirection() */
2445 static void add_item(struct list_item **head,
2446 struct list_item **tail,
2452 New(1303,*head,1,struct list_item);
2456 New(1304,(*tail)->next,1,struct list_item);
2457 *tail = (*tail)->next;
2459 (*tail)->value = value;
2463 static void expand_wild_cards(char *item,
2464 struct list_item **head,
2465 struct list_item **tail,
2469 unsigned long int context = 0;
2475 char vmsspec[NAM$C_MAXRSS+1];
2476 $DESCRIPTOR(filespec, "");
2477 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2478 $DESCRIPTOR(resultspec, "");
2479 unsigned long int zero = 0, sts;
2481 for (cp = item; *cp; cp++) {
2482 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2483 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2485 if (!*cp || isspace(*cp))
2487 add_item(head, tail, item, count);
2490 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2491 resultspec.dsc$b_class = DSC$K_CLASS_D;
2492 resultspec.dsc$a_pointer = NULL;
2493 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2494 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2495 if (!isunix || !filespec.dsc$a_pointer)
2496 filespec.dsc$a_pointer = item;
2497 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2499 * Only return version specs, if the caller specified a version
2501 had_version = strchr(item, ';');
2503 * Only return device and directory specs, if the caller specifed either.
2505 had_device = strchr(item, ':');
2506 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2508 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2509 &defaultspec, 0, 0, &zero))))
2514 New(1305,string,resultspec.dsc$w_length+1,char);
2515 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2516 string[resultspec.dsc$w_length] = '\0';
2517 if (NULL == had_version)
2518 *((char *)strrchr(string, ';')) = '\0';
2519 if ((!had_directory) && (had_device == NULL))
2521 if (NULL == (devdir = strrchr(string, ']')))
2522 devdir = strrchr(string, '>');
2523 strcpy(string, devdir + 1);
2526 * Be consistent with what the C RTL has already done to the rest of
2527 * the argv items and lowercase all of these names.
2529 for (c = string; *c; ++c)
2532 if (isunix) trim_unixpath(string,item,1);
2533 add_item(head, tail, string, count);
2536 if (sts != RMS$_NMF)
2538 set_vaxc_errno(sts);
2544 set_errno(ENOENT); break;
2546 set_errno(ENODEV); break;
2549 set_errno(EINVAL); break;
2551 set_errno(EACCES); break;
2553 _ckvmssts_noperl(sts);
2557 add_item(head, tail, item, count);
2558 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2559 _ckvmssts_noperl(lib$find_file_end(&context));
2562 static int child_st[2];/* Event Flag set when child process completes */
2564 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2566 static unsigned long int exit_handler(int *status)
2570 if (0 == child_st[0])
2572 #ifdef ARGPROC_DEBUG
2573 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2575 fflush(stdout); /* Have to flush pipe for binary data to */
2576 /* terminate properly -- <tp@mccall.com> */
2577 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2578 sys$dassgn(child_chan);
2580 sys$synch(0, child_st);
2585 static void sig_child(int chan)
2587 #ifdef ARGPROC_DEBUG
2588 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2590 if (child_st[0] == 0)
2594 static struct exit_control_block exit_block =
2599 &exit_block.exit_status,
2603 static void pipe_and_fork(char **cmargv)
2606 $DESCRIPTOR(cmddsc, "");
2607 static char mbxname[64];
2608 $DESCRIPTOR(mbxdsc, mbxname);
2610 unsigned long int zero = 0, one = 1;
2612 strcpy(subcmd, cmargv[0]);
2613 for (j = 1; NULL != cmargv[j]; ++j)
2615 strcat(subcmd, " \"");
2616 strcat(subcmd, cmargv[j]);
2617 strcat(subcmd, "\"");
2619 cmddsc.dsc$a_pointer = subcmd;
2620 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2622 create_mbx(&child_chan,&mbxdsc);
2623 #ifdef ARGPROC_DEBUG
2624 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2625 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2627 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2628 0, &pid, child_st, &zero, sig_child,
2630 #ifdef ARGPROC_DEBUG
2631 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2633 sys$dclexh(&exit_block);
2634 if (NULL == freopen(mbxname, "wb", stdout))
2636 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2640 static int background_process(int argc, char **argv)
2642 char command[2048] = "$";
2643 $DESCRIPTOR(value, "");
2644 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2645 static $DESCRIPTOR(null, "NLA0:");
2646 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2648 $DESCRIPTOR(pidstr, "");
2650 unsigned long int flags = 17, one = 1, retsts;
2652 strcat(command, argv[0]);
2655 strcat(command, " \"");
2656 strcat(command, *(++argv));
2657 strcat(command, "\"");
2659 value.dsc$a_pointer = command;
2660 value.dsc$w_length = strlen(value.dsc$a_pointer);
2661 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2662 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2663 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2664 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2667 _ckvmssts_noperl(retsts);
2669 #ifdef ARGPROC_DEBUG
2670 PerlIO_printf(Perl_debug_log, "%s\n", command);
2672 sprintf(pidstring, "%08X", pid);
2673 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2674 pidstr.dsc$a_pointer = pidstring;
2675 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2676 lib$set_symbol(&pidsymbol, &pidstr);
2680 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2683 /* OS-specific initialization at image activation (not thread startup) */
2684 /* Older VAXC header files lack these constants */
2685 #ifndef JPI$_RIGHTS_SIZE
2686 # define JPI$_RIGHTS_SIZE 817
2688 #ifndef KGB$M_SUBSYSTEM
2689 # define KGB$M_SUBSYSTEM 0x8
2692 /*{{{void vms_image_init(int *, char ***)*/
2694 vms_image_init(int *argcp, char ***argvp)
2696 char eqv[LNM$C_NAMLENGTH+1] = "";
2697 unsigned int len, tabct = 8, tabidx = 0;
2698 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2699 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2700 unsigned short int dummy, rlen;
2701 struct dsc$descriptor_s **tabvec;
2702 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2703 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2704 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2707 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2709 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2710 if (iprv[i]) { /* Running image installed with privs? */
2711 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2716 /* Rights identifiers might trigger tainting as well. */
2717 if (!will_taint && (rlen || rsz)) {
2718 while (rlen < rsz) {
2719 /* We didn't get all the identifiers on the first pass. Allocate a
2720 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2721 * were needed to hold all identifiers at time of last call; we'll
2722 * allocate that many unsigned long ints), and go back and get 'em.
2724 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2725 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2726 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2727 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2730 mask = jpilist[1].bufadr;
2731 /* Check attribute flags for each identifier (2nd longword); protected
2732 * subsystem identifiers trigger tainting.
2734 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2735 if (mask[i] & KGB$M_SUBSYSTEM) {
2740 if (mask != rlst) Safefree(mask);
2742 /* We need to use this hack to tell Perl it should run with tainting,
2743 * since its tainting flag may be part of the PL_curinterp struct, which
2744 * hasn't been allocated when vms_image_init() is called.
2748 New(1320,newap,*argcp+2,char **);
2749 newap[0] = argvp[0];
2751 Copy(argvp[1],newap[2],*argcp-1,char **);
2752 /* We orphan the old argv, since we don't know where it's come from,
2753 * so we don't know how to free it.
2755 *argcp++; argvp = newap;
2757 else { /* Did user explicitly request tainting? */
2759 char *cp, **av = *argvp;
2760 for (i = 1; i < *argcp; i++) {
2761 if (*av[i] != '-') break;
2762 for (cp = av[i]+1; *cp; cp++) {
2763 if (*cp == 'T') { will_taint = 1; break; }
2764 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2765 strchr("DFIiMmx",*cp)) break;
2767 if (will_taint) break;
2772 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2774 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2775 else if (tabidx >= tabct) {
2777 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2779 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2780 tabvec[tabidx]->dsc$w_length = 0;
2781 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2782 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2783 tabvec[tabidx]->dsc$a_pointer = NULL;
2784 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2786 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2788 getredirection(argcp,argvp);
2789 #if defined(USE_THREADS) && defined(__DECC)
2791 # include <reentrancy.h>
2792 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2801 * Trim Unix-style prefix off filespec, so it looks like what a shell
2802 * glob expansion would return (i.e. from specified prefix on, not
2803 * full path). Note that returned filespec is Unix-style, regardless
2804 * of whether input filespec was VMS-style or Unix-style.
2806 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2807 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2808 * vector of options; at present, only bit 0 is used, and if set tells
2809 * trim unixpath to try the current default directory as a prefix when
2810 * presented with a possibly ambiguous ... wildcard.
2812 * Returns !=0 on success, with trimmed filespec replacing contents of
2813 * fspec, and 0 on failure, with contents of fpsec unchanged.
2815 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2817 trim_unixpath(char *fspec, char *wildspec, int opts)
2819 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2820 *template, *base, *end, *cp1, *cp2;
2821 register int tmplen, reslen = 0, dirs = 0;
2823 if (!wildspec || !fspec) return 0;
2824 if (strpbrk(wildspec,"]>:") != NULL) {
2825 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2826 else template = unixwild;
2828 else template = wildspec;
2829 if (strpbrk(fspec,"]>:") != NULL) {
2830 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2831 else base = unixified;
2832 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2833 * check to see that final result fits into (isn't longer than) fspec */
2834 reslen = strlen(fspec);
2838 /* No prefix or absolute path on wildcard, so nothing to remove */
2839 if (!*template || *template == '/') {
2840 if (base == fspec) return 1;
2841 tmplen = strlen(unixified);
2842 if (tmplen > reslen) return 0; /* not enough space */
2843 /* Copy unixified resultant, including trailing NUL */
2844 memmove(fspec,unixified,tmplen+1);
2848 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2849 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2850 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2851 for (cp1 = end ;cp1 >= base; cp1--)
2852 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2854 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2858 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2859 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2860 int ells = 1, totells, segdirs, match;
2861 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2862 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2864 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2866 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2867 if (ellipsis == template && opts & 1) {
2868 /* Template begins with an ellipsis. Since we can't tell how many
2869 * directory names at the front of the resultant to keep for an
2870 * arbitrary starting point, we arbitrarily choose the current
2871 * default directory as a starting point. If it's there as a prefix,
2872 * clip it off. If not, fall through and act as if the leading
2873 * ellipsis weren't there (i.e. return shortest possible path that
2874 * could match template).
2876 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2877 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2878 if (_tolower(*cp1) != _tolower(*cp2)) break;
2879 segdirs = dirs - totells; /* Min # of dirs we must have left */
2880 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2881 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2882 memcpy(fspec,cp2+1,end - cp2);
2886 /* First off, back up over constant elements at end of path */
2888 for (front = end ; front >= base; front--)
2889 if (*front == '/' && !dirs--) { front++; break; }
2891 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2892 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2893 if (cp1 != '\0') return 0; /* Path too long. */
2895 *cp2 = '\0'; /* Pick up with memcpy later */
2896 lcfront = lcres + (front - base);
2897 /* Now skip over each ellipsis and try to match the path in front of it. */
2899 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2900 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2901 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2902 if (cp1 < template) break; /* template started with an ellipsis */
2903 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2904 ellipsis = cp1; continue;
2906 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2908 for (segdirs = 0, cp2 = tpl;
2909 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2911 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2912 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2913 if (*cp2 == '/') segdirs++;
2915 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2916 /* Back up at least as many dirs as in template before matching */
2917 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2918 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2919 for (match = 0; cp1 > lcres;) {
2920 resdsc.dsc$a_pointer = cp1;
2921 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2923 if (match == 1) lcfront = cp1;
2925 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2927 if (!match) return 0; /* Can't find prefix ??? */
2928 if (match > 1 && opts & 1) {
2929 /* This ... wildcard could cover more than one set of dirs (i.e.
2930 * a set of similar dir names is repeated). If the template
2931 * contains more than 1 ..., upstream elements could resolve the
2932 * ambiguity, but it's not worth a full backtracking setup here.
2933 * As a quick heuristic, clip off the current default directory
2934 * if it's present to find the trimmed spec, else use the
2935 * shortest string that this ... could cover.
2937 char def[NAM$C_MAXRSS+1], *st;
2939 if (getcwd(def, sizeof def,0) == NULL) return 0;
2940 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2941 if (_tolower(*cp1) != _tolower(*cp2)) break;
2942 segdirs = dirs - totells; /* Min # of dirs we must have left */
2943 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2944 if (*cp1 == '\0' && *cp2 == '/') {
2945 memcpy(fspec,cp2+1,end - cp2);
2948 /* Nope -- stick with lcfront from above and keep going. */
2951 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2956 } /* end of trim_unixpath() */
2961 * VMS readdir() routines.
2962 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2964 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
2965 * Minor modifications to original routines.
2968 /* Number of elements in vms_versions array */
2969 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2972 * Open a directory, return a handle for later use.
2974 /*{{{ DIR *opendir(char*name) */
2979 char dir[NAM$C_MAXRSS+1];
2982 if (do_tovmspath(name,dir,0) == NULL) {
2985 if (flex_stat(dir,&sb) == -1) return NULL;
2986 if (!S_ISDIR(sb.st_mode)) {
2987 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2990 if (!cando_by_name(S_IRUSR,0,dir)) {
2991 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2994 /* Get memory for the handle, and the pattern. */
2996 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2998 /* Fill in the fields; mainly playing with the descriptor. */
2999 (void)sprintf(dd->pattern, "%s*.*",dir);
3002 dd->vms_wantversions = 0;
3003 dd->pat.dsc$a_pointer = dd->pattern;
3004 dd->pat.dsc$w_length = strlen(dd->pattern);
3005 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3006 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3009 } /* end of opendir() */
3013 * Set the flag to indicate we want versions or not.
3015 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3017 vmsreaddirversions(DIR *dd, int flag)
3019 dd->vms_wantversions = flag;
3024 * Free up an opened directory.
3026 /*{{{ void closedir(DIR *dd)*/
3030 (void)lib$find_file_end(&dd->context);
3031 Safefree(dd->pattern);
3032 Safefree((char *)dd);
3037 * Collect all the version numbers for the current file.
3043 struct dsc$descriptor_s pat;
3044 struct dsc$descriptor_s res;
3046 char *p, *text, buff[sizeof dd->entry.d_name];
3048 unsigned long context, tmpsts;
3050 /* Convenient shorthand. */
3053 /* Add the version wildcard, ignoring the "*.*" put on before */
3054 i = strlen(dd->pattern);
3055 New(1308,text,i + e->d_namlen + 3,char);
3056 (void)strcpy(text, dd->pattern);
3057 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3059 /* Set up the pattern descriptor. */
3060 pat.dsc$a_pointer = text;
3061 pat.dsc$w_length = i + e->d_namlen - 1;
3062 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3063 pat.dsc$b_class = DSC$K_CLASS_S;
3065 /* Set up result descriptor. */
3066 res.dsc$a_pointer = buff;
3067 res.dsc$w_length = sizeof buff - 2;
3068 res.dsc$b_dtype = DSC$K_DTYPE_T;
3069 res.dsc$b_class = DSC$K_CLASS_S;
3071 /* Read files, collecting versions. */
3072 for (context = 0, e->vms_verscount = 0;
3073 e->vms_verscount < VERSIZE(e);
3074 e->vms_verscount++) {
3075 tmpsts = lib$find_file(&pat, &res, &context);
3076 if (tmpsts == RMS$_NMF || context == 0) break;
3078 buff[sizeof buff - 1] = '\0';
3079 if ((p = strchr(buff, ';')))
3080 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3082 e->vms_versions[e->vms_verscount] = -1;
3085 _ckvmssts(lib$find_file_end(&context));
3088 } /* end of collectversions() */
3091 * Read the next entry from the directory.
3093 /*{{{ struct dirent *readdir(DIR *dd)*/
3097 struct dsc$descriptor_s res;
3098 char *p, buff[sizeof dd->entry.d_name];
3099 unsigned long int tmpsts;
3101 /* Set up result descriptor, and get next file. */
3102 res.dsc$a_pointer = buff;
3103 res.dsc$w_length = sizeof buff - 2;
3104 res.dsc$b_dtype = DSC$K_DTYPE_T;
3105 res.dsc$b_class = DSC$K_CLASS_S;
3106 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3107 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3108 if (!(tmpsts & 1)) {
3109 set_vaxc_errno(tmpsts);
3112 set_errno(EACCES); break;
3114 set_errno(ENODEV); break;
3117 set_errno(ENOENT); break;
3124 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3125 buff[sizeof buff - 1] = '\0';
3126 for (p = buff; *p; p++) *p = _tolower(*p);
3127 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3130 /* Skip any directory component and just copy the name. */
3131 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3132 else (void)strcpy(dd->entry.d_name, buff);
3134 /* Clobber the version. */
3135 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3137 dd->entry.d_namlen = strlen(dd->entry.d_name);
3138 dd->entry.vms_verscount = 0;
3139 if (dd->vms_wantversions) collectversions(dd);
3142 } /* end of readdir() */
3146 * Return something that can be used in a seekdir later.
3148 /*{{{ long telldir(DIR *dd)*/
3157 * Return to a spot where we used to be. Brute force.
3159 /*{{{ void seekdir(DIR *dd,long count)*/
3161 seekdir(DIR *dd, long count)
3163 int vms_wantversions;
3165 /* If we haven't done anything yet... */
3169 /* Remember some state, and clear it. */
3170 vms_wantversions = dd->vms_wantversions;
3171 dd->vms_wantversions = 0;
3172 _ckvmssts(lib$find_file_end(&dd->context));
3175 /* The increment is in readdir(). */
3176 for (dd->count = 0; dd->count < count; )
3179 dd->vms_wantversions = vms_wantversions;
3181 } /* end of seekdir() */
3184 /* VMS subprocess management
3186 * my_vfork() - just a vfork(), after setting a flag to record that
3187 * the current script is trying a Unix-style fork/exec.
3189 * vms_do_aexec() and vms_do_exec() are called in response to the
3190 * perl 'exec' function. If this follows a vfork call, then they
3191 * call out the the regular perl routines in doio.c which do an
3192 * execvp (for those who really want to try this under VMS).
3193 * Otherwise, they do exactly what the perl docs say exec should
3194 * do - terminate the current script and invoke a new command
3195 * (See below for notes on command syntax.)
3197 * do_aspawn() and do_spawn() implement the VMS side of the perl
3198 * 'system' function.
3200 * Note on command arguments to perl 'exec' and 'system': When handled
3201 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3202 * are concatenated to form a DCL command string. If the first arg
3203 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3204 * the the command string is handed off to DCL directly. Otherwise,
3205 * the first token of the command is taken as the filespec of an image
3206 * to run. The filespec is expanded using a default type of '.EXE' and
3207 * the process defaults for device, directory, etc., and if found, the resultant
3208 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3209 * the command string as parameters. This is perhaps a bit complicated,
3210 * but I hope it will form a happy medium between what VMS folks expect
3211 * from lib$spawn and what Unix folks expect from exec.
3214 static int vfork_called;
3216 /*{{{int my_vfork()*/
3226 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3234 if (VMScmd.dsc$a_pointer) {
3235 Safefree(VMScmd.dsc$a_pointer);
3236 VMScmd.dsc$w_length = 0;
3237 VMScmd.dsc$a_pointer = Nullch;
3242 setup_argstr(SV *really, SV **mark, SV **sp)
3245 char *junk, *tmps = Nullch;
3246 register size_t cmdlen = 0;
3253 tmps = SvPV(really,rlen);
3260 for (idx++; idx <= sp; idx++) {
3262 junk = SvPVx(*idx,rlen);
3263 cmdlen += rlen ? rlen + 1 : 0;
3266 New(401,PL_Cmd,cmdlen+1,char);
3268 if (tmps && *tmps) {
3269 strcpy(PL_Cmd,tmps);
3272 else *PL_Cmd = '\0';
3273 while (++mark <= sp) {
3275 char *s = SvPVx(*mark,n_a);
3277 if (*PL_Cmd) strcat(PL_Cmd," ");
3283 } /* end of setup_argstr() */
3286 static unsigned long int
3287 setup_cmddsc(char *cmd, int check_img)
3289 char resspec[NAM$C_MAXRSS+1];
3290 $DESCRIPTOR(defdsc,".EXE");
3291 $DESCRIPTOR(resdsc,resspec);
3292 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3293 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3294 register char *s, *rest, *cp;
3295 register int isdcl = 0;
3298 while (*s && isspace(*s)) s++;
3300 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3301 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3302 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3303 if (*cp == ':' || *cp == '[' || *cp == '<') {
3313 while (*s && !isspace(*s)) s++;
3315 imgdsc.dsc$a_pointer = cmd;
3316 imgdsc.dsc$w_length = s - cmd;
3317 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3319 _ckvmssts(lib$find_file_end(&cxt));
3321 while (*s && !isspace(*s)) s++;
3323 if (cando_by_name(S_IXUSR,0,resspec)) {
3324 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3325 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3326 strcat(VMScmd.dsc$a_pointer,resspec);
3327 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3328 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3331 else retsts = RMS$_PRV;
3334 /* It's either a DCL command or we couldn't find a suitable image */
3335 VMScmd.dsc$w_length = strlen(cmd);
3336 if (cmd == PL_Cmd) {
3337 VMScmd.dsc$a_pointer = PL_Cmd;
3338 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3340 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3341 if (!(retsts & 1)) {
3342 /* just hand off status values likely to be due to user error */
3343 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3344 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3345 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3346 else { _ckvmssts(retsts); }
3349 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3351 } /* end of setup_cmddsc() */
3354 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3356 vms_do_aexec(SV *really,SV **mark,SV **sp)
3360 if (vfork_called) { /* this follows a vfork - act Unixish */
3362 if (vfork_called < 0) {
3363 warn("Internal inconsistency in tracking vforks");
3366 else return do_aexec(really,mark,sp);
3368 /* no vfork - act VMSish */
3369 return vms_do_exec(setup_argstr(really,mark,sp));
3374 } /* end of vms_do_aexec() */
3377 /* {{{bool vms_do_exec(char *cmd) */
3379 vms_do_exec(char *cmd)
3382 if (vfork_called) { /* this follows a vfork - act Unixish */
3384 if (vfork_called < 0) {
3385 warn("Internal inconsistency in tracking vforks");
3388 else return do_exec(cmd);
3391 { /* no vfork - act VMSish */
3392 unsigned long int retsts;
3395 TAINT_PROPER("exec");
3396 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3397 retsts = lib$do_command(&VMScmd);
3401 set_errno(ENOENT); break;
3402 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3403 set_errno(ENOTDIR); break;
3405 set_errno(EACCES); break;
3407 set_errno(EINVAL); break;
3409 set_errno(E2BIG); break;
3410 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3411 _ckvmssts(retsts); /* fall through */
3412 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3415 set_vaxc_errno(retsts);
3416 if (ckWARN(WARN_EXEC)) {
3417 warner(WARN_EXEC,"Can't exec \"%*s\": %s",
3418 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3425 } /* end of vms_do_exec() */
3428 unsigned long int do_spawn(char *);
3430 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3432 do_aspawn(void *really,void **mark,void **sp)
3435 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3438 } /* end of do_aspawn() */
3441 /* {{{unsigned long int do_spawn(char *cmd) */
3445 unsigned long int sts, substs, hadcmd = 1;
3448 TAINT_PROPER("spawn");
3449 if (!cmd || !*cmd) {
3451 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3453 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3454 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3460 set_errno(ENOENT); break;
3461 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3462 set_errno(ENOTDIR); break;
3464 set_errno(EACCES); break;
3466 set_errno(EINVAL); break;
3468 set_errno(E2BIG); break;
3469 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3470 _ckvmssts(sts); /* fall through */
3471 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3474 set_vaxc_errno(sts);
3475 if (ckWARN(WARN_EXEC)) {
3476 warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
3477 hadcmd ? VMScmd.dsc$w_length : 0,
3478 hadcmd ? VMScmd.dsc$a_pointer : "",
3485 } /* end of do_spawn() */
3489 * A simple fwrite replacement which outputs itmsz*nitm chars without
3490 * introducing record boundaries every itmsz chars.
3492 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3494 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3496 register char *cp, *end;
3498 end = (char *)src + itmsz * nitm;
3500 while ((char *)src <= end) {
3501 for (cp = src; cp <= end; cp++) if (!*cp) break;
3502 if (fputs(src,dest) == EOF) return EOF;
3504 if (fputc('\0',dest) == EOF) return EOF;
3510 } /* end of my_fwrite() */
3513 /*{{{ int my_flush(FILE *fp)*/
3518 if ((res = fflush(fp)) == 0) {
3519 #ifdef VMS_DO_SOCKETS
3521 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3523 res = fsync(fileno(fp));
3530 * Here are replacements for the following Unix routines in the VMS environment:
3531 * getpwuid Get information for a particular UIC or UID
3532 * getpwnam Get information for a named user
3533 * getpwent Get information for each user in the rights database
3534 * setpwent Reset search to the start of the rights database
3535 * endpwent Finish searching for users in the rights database
3537 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3538 * (defined in pwd.h), which contains the following fields:-
3540 * char *pw_name; Username (in lower case)
3541 * char *pw_passwd; Hashed password
3542 * unsigned int pw_uid; UIC
3543 * unsigned int pw_gid; UIC group number
3544 * char *pw_unixdir; Default device/directory (VMS-style)
3545 * char *pw_gecos; Owner name
3546 * char *pw_dir; Default device/directory (Unix-style)
3547 * char *pw_shell; Default CLI name (eg. DCL)
3549 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3551 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3552 * not the UIC member number (eg. what's returned by getuid()),
3553 * getpwuid() can accept either as input (if uid is specified, the caller's
3554 * UIC group is used), though it won't recognise gid=0.
3556 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3557 * information about other users in your group or in other groups, respectively.
3558 * If the required privilege is not available, then these routines fill only
3559 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3562 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3565 /* sizes of various UAF record fields */
3566 #define UAI$S_USERNAME 12
3567 #define UAI$S_IDENT 31
3568 #define UAI$S_OWNER 31
3569 #define UAI$S_DEFDEV 31
3570 #define UAI$S_DEFDIR 63
3571 #define UAI$S_DEFCLI 31
3574 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3575 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3576 (uic).uic$v_group != UIC$K_WILD_GROUP)
3578 static char __empty[]= "";
3579 static struct passwd __passwd_empty=
3580 {(char *) __empty, (char *) __empty, 0, 0,
3581 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3582 static int contxt= 0;
3583 static struct passwd __pwdcache;
3584 static char __pw_namecache[UAI$S_IDENT+1];
3587 * This routine does most of the work extracting the user information.
3589 static int fillpasswd (const char *name, struct passwd *pwd)
3592 unsigned char length;
3593 char pw_gecos[UAI$S_OWNER+1];
3595 static union uicdef uic;
3597 unsigned char length;
3598 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3601 unsigned char length;
3602 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3605 unsigned char length;
3606 char pw_shell[UAI$S_DEFCLI+1];
3608 static char pw_passwd[UAI$S_PWD+1];
3610 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3611 struct dsc$descriptor_s name_desc;
3612 unsigned long int sts;
3614 static struct itmlst_3 itmlst[]= {
3615 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3616 {sizeof(uic), UAI$_UIC, &uic, &luic},
3617 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3618 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3619 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3620 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3621 {0, 0, NULL, NULL}};
3623 name_desc.dsc$w_length= strlen(name);
3624 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3625 name_desc.dsc$b_class= DSC$K_CLASS_S;
3626 name_desc.dsc$a_pointer= (char *) name;
3628 /* Note that sys$getuai returns many fields as counted strings. */
3629 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3630 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3631 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3633 else { _ckvmssts(sts); }
3634 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3636 if ((int) owner.length < lowner) lowner= (int) owner.length;
3637 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3638 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3639 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3640 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3641 owner.pw_gecos[lowner]= '\0';
3642 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3643 defcli.pw_shell[ldefcli]= '\0';
3644 if (valid_uic(uic)) {
3645 pwd->pw_uid= uic.uic$l_uic;
3646 pwd->pw_gid= uic.uic$v_group;
3649 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3650 pwd->pw_passwd= pw_passwd;
3651 pwd->pw_gecos= owner.pw_gecos;
3652 pwd->pw_dir= defdev.pw_dir;
3653 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3654 pwd->pw_shell= defcli.pw_shell;
3655 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3657 ldir= strlen(pwd->pw_unixdir) - 1;
3658 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3661 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3662 __mystrtolower(pwd->pw_unixdir);
3667 * Get information for a named user.
3669 /*{{{struct passwd *getpwnam(char *name)*/
3670 struct passwd *my_getpwnam(char *name)
3672 struct dsc$descriptor_s name_desc;
3674 unsigned long int status, sts;
3676 __pwdcache = __passwd_empty;
3677 if (!fillpasswd(name, &__pwdcache)) {
3678 /* We still may be able to determine pw_uid and pw_gid */
3679 name_desc.dsc$w_length= strlen(name);
3680 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3681 name_desc.dsc$b_class= DSC$K_CLASS_S;
3682 name_desc.dsc$a_pointer= (char *) name;
3683 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3684 __pwdcache.pw_uid= uic.uic$l_uic;
3685 __pwdcache.pw_gid= uic.uic$v_group;
3688 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3689 set_vaxc_errno(sts);
3690 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3693 else { _ckvmssts(sts); }
3696 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3697 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3698 __pwdcache.pw_name= __pw_namecache;
3700 } /* end of my_getpwnam() */
3704 * Get information for a particular UIC or UID.
3705 * Called by my_getpwent with uid=-1 to list all users.
3707 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3708 struct passwd *my_getpwuid(Uid_t uid)
3710 const $DESCRIPTOR(name_desc,__pw_namecache);
3711 unsigned short lname;
3713 unsigned long int status;
3715 if (uid == (unsigned int) -1) {
3717 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3718 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3719 set_vaxc_errno(status);
3720 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3724 else { _ckvmssts(status); }
3725 } while (!valid_uic (uic));
3729 if (!uic.uic$v_group)
3730 uic.uic$v_group= PerlProc_getgid();
3732 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3733 else status = SS$_IVIDENT;
3734 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3735 status == RMS$_PRV) {
3736 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3739 else { _ckvmssts(status); }
3741 __pw_namecache[lname]= '\0';
3742 __mystrtolower(__pw_namecache);
3744 __pwdcache = __passwd_empty;
3745 __pwdcache.pw_name = __pw_namecache;
3747 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3748 The identifier's value is usually the UIC, but it doesn't have to be,
3749 so if we can, we let fillpasswd update this. */
3750 __pwdcache.pw_uid = uic.uic$l_uic;
3751 __pwdcache.pw_gid = uic.uic$v_group;
3753 fillpasswd(__pw_namecache, &__pwdcache);
3756 } /* end of my_getpwuid() */
3760 * Get information for next user.
3762 /*{{{struct passwd *my_getpwent()*/
3763 struct passwd *my_getpwent()
3765 return (my_getpwuid((unsigned int) -1));
3770 * Finish searching rights database for users.
3772 /*{{{void my_endpwent()*/
3776 _ckvmssts(sys$finish_rdb(&contxt));
3782 #ifdef HOMEGROWN_POSIX_SIGNALS
3783 /* Signal handling routines, pulled into the core from POSIX.xs.
3785 * We need these for threads, so they've been rolled into the core,
3786 * rather than left in POSIX.xs.
3788 * (DRS, Oct 23, 1997)
3791 /* sigset_t is atomic under VMS, so these routines are easy */
3792 /*{{{int my_sigemptyset(sigset_t *) */
3793 int my_sigemptyset(sigset_t *set) {
3794 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3800 /*{{{int my_sigfillset(sigset_t *)*/
3801 int my_sigfillset(sigset_t *set) {
3803 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3804 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3810 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3811 int my_sigaddset(sigset_t *set, int sig) {
3812 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3813 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3814 *set |= (1 << (sig - 1));
3820 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3821 int my_sigdelset(sigset_t *set, int sig) {
3822 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3823 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3824 *set &= ~(1 << (sig - 1));
3830 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3831 int my_sigismember(sigset_t *set, int sig) {
3832 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3833 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3834 *set & (1 << (sig - 1));
3839 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3840 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3843 /* If set and oset are both null, then things are badly wrong. Bail out. */
3844 if ((oset == NULL) && (set == NULL)) {
3845 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3849 /* If set's null, then we're just handling a fetch. */
3851 tempmask = sigblock(0);
3856 tempmask = sigsetmask(*set);
3859 tempmask = sigblock(*set);
3862 tempmask = sigblock(0);
3863 sigsetmask(*oset & ~tempmask);
3866 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3871 /* Did they pass us an oset? If so, stick our holding mask into it */
3878 #endif /* HOMEGROWN_POSIX_SIGNALS */
3881 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3882 * my_utime(), and flex_stat(), all of which operate on UTC unless
3883 * VMSISH_TIMES is true.
3885 /* method used to handle UTC conversions:
3886 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3888 static int gmtime_emulation_type;
3889 /* number of secs to add to UTC POSIX-style time to get local time */
3890 static long int utc_offset_secs;
3892 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3893 * in vmsish.h. #undef them here so we can call the CRTL routines
3900 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3901 # define RTL_USES_UTC 1
3904 static time_t toutc_dst(time_t loc) {
3907 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3908 loc -= utc_offset_secs;
3909 if (rsltmp->tm_isdst) loc -= 3600;
3912 #define _toutc(secs) ((secs) == -1 ? -1 : \
3913 ((gmtime_emulation_type || my_time(NULL)), \
3914 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3915 ((secs) - utc_offset_secs))))
3917 static time_t toloc_dst(time_t utc) {
3920 utc += utc_offset_secs;
3921 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3922 if (rsltmp->tm_isdst) utc += 3600;
3925 #define _toloc(secs) ((secs) == -1 ? -1 : \
3926 ((gmtime_emulation_type || my_time(NULL)), \
3927 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3928 ((secs) + utc_offset_secs))))
3931 /* my_time(), my_localtime(), my_gmtime()
3932 * By default traffic in UTC time values, using CRTL gmtime() or
3933 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3934 * Note: We need to use these functions even when the CRTL has working
3935 * UTC support, since they also handle C<use vmsish qw(times);>
3937 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3938 * Modified by Charles Bailey <bailey@newman.upenn.edu>
3941 /*{{{time_t my_time(time_t *timep)*/
3942 time_t my_time(time_t *timep)
3948 if (gmtime_emulation_type == 0) {
3950 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3951 /* results of calls to gmtime() and localtime() */
3952 /* for same &base */
3954 gmtime_emulation_type++;
3955 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3956 char off[LNM$C_NAMLENGTH+1];;
3958 gmtime_emulation_type++;
3959 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
3960 gmtime_emulation_type++;
3961 warn("no UTC offset information; assuming local time is UTC");
3963 else { utc_offset_secs = atol(off); }
3965 else { /* We've got a working gmtime() */
3966 struct tm gmt, local;
3969 tm_p = localtime(&base);
3971 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3972 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3973 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3974 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3980 # ifdef RTL_USES_UTC
3981 if (VMSISH_TIME) when = _toloc(when);
3983 if (!VMSISH_TIME) when = _toutc(when);
3986 if (timep != NULL) *timep = when;
3989 } /* end of my_time() */
3993 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3995 my_gmtime(const time_t *timep)
4002 if (timep == NULL) {
4003 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4006 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4010 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4012 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4013 return gmtime(&when);
4015 /* CRTL localtime() wants local time as input, so does no tz correction */
4016 rsltmp = localtime(&when);
4017 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4020 } /* end of my_gmtime() */
4024 /*{{{struct tm *my_localtime(const time_t *timep)*/
4026 my_localtime(const time_t *timep)
4032 if (timep == NULL) {
4033 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4036 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4037 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4040 # ifdef RTL_USES_UTC
4042 if (VMSISH_TIME) when = _toutc(when);
4044 /* CRTL localtime() wants UTC as input, does tz correction itself */
4045 return localtime(&when);
4048 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4051 /* CRTL localtime() wants local time as input, so does no tz correction */
4052 rsltmp = localtime(&when);
4053 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4056 } /* end of my_localtime() */
4059 /* Reset definitions for later calls */
4060 #define gmtime(t) my_gmtime(t)
4061 #define localtime(t) my_localtime(t)
4062 #define time(t) my_time(t)
4065 /* my_utime - update modification time of a file
4066 * calling sequence is identical to POSIX utime(), but under
4067 * VMS only the modification time is changed; ODS-2 does not
4068 * maintain access times. Restrictions differ from the POSIX
4069 * definition in that the time can be changed as long as the
4070 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4071 * no separate checks are made to insure that the caller is the
4072 * owner of the file or has special privs enabled.
4073 * Code here is based on Joe Meadows' FILE utility.
4076 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4077 * to VMS epoch (01-JAN-1858 00:00:00.00)
4078 * in 100 ns intervals.
4080 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4082 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4083 int my_utime(char *file, struct utimbuf *utimes)
4087 long int bintime[2], len = 2, lowbit, unixtime,
4088 secscale = 10000000; /* seconds --> 100 ns intervals */
4089 unsigned long int chan, iosb[2], retsts;
4090 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4091 struct FAB myfab = cc$rms_fab;
4092 struct NAM mynam = cc$rms_nam;
4093 #if defined (__DECC) && defined (__VAX)
4094 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4095 * at least through VMS V6.1, which causes a type-conversion warning.
4097 # pragma message save
4098 # pragma message disable cvtdiftypes
4100 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4101 struct fibdef myfib;
4102 #if defined (__DECC) && defined (__VAX)
4103 /* This should be right after the declaration of myatr, but due
4104 * to a bug in VAX DEC C, this takes effect a statement early.
4106 # pragma message restore
4108 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4109 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4110 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4112 if (file == NULL || *file == '\0') {
4114 set_vaxc_errno(LIB$_INVARG);
4117 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4119 if (utimes != NULL) {
4120 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4121 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4122 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4123 * as input, we force the sign bit to be clear by shifting unixtime right
4124 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4126 lowbit = (utimes->modtime & 1) ? secscale : 0;
4127 unixtime = (long int) utimes->modtime;
4129 /* If input was UTC; convert to local for sys svc */
4130 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4132 unixtime >> 1; secscale << 1;
4133 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4134 if (!(retsts & 1)) {
4136 set_vaxc_errno(retsts);
4139 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4140 if (!(retsts & 1)) {
4142 set_vaxc_errno(retsts);
4147 /* Just get the current time in VMS format directly */
4148 retsts = sys$gettim(bintime);
4149 if (!(retsts & 1)) {
4151 set_vaxc_errno(retsts);
4156 myfab.fab$l_fna = vmsspec;
4157 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4158 myfab.fab$l_nam = &mynam;
4159 mynam.nam$l_esa = esa;
4160 mynam.nam$b_ess = (unsigned char) sizeof esa;
4161 mynam.nam$l_rsa = rsa;
4162 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4164 /* Look for the file to be affected, letting RMS parse the file
4165 * specification for us as well. I have set errno using only
4166 * values documented in the utime() man page for VMS POSIX.
4168 retsts = sys$parse(&myfab,0,0);
4169 if (!(retsts & 1)) {
4170 set_vaxc_errno(retsts);
4171 if (retsts == RMS$_PRV) set_errno(EACCES);
4172 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4173 else set_errno(EVMSERR);
4176 retsts = sys$search(&myfab,0,0);
4177 if (!(retsts & 1)) {
4178 set_vaxc_errno(retsts);
4179 if (retsts == RMS$_PRV) set_errno(EACCES);
4180 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4181 else set_errno(EVMSERR);
4185 devdsc.dsc$w_length = mynam.nam$b_dev;
4186 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4188 retsts = sys$assign(&devdsc,&chan,0,0);
4189 if (!(retsts & 1)) {
4190 set_vaxc_errno(retsts);
4191 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4192 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4193 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4194 else set_errno(EVMSERR);
4198 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4199 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4201 memset((void *) &myfib, 0, sizeof myfib);
4203 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4204 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4205 /* This prevents the revision time of the file being reset to the current
4206 * time as a result of our IO$_MODIFY $QIO. */
4207 myfib.fib$l_acctl = FIB$M_NORECORD;
4209 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4210 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4211 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4213 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4214 _ckvmssts(sys$dassgn(chan));
4215 if (retsts & 1) retsts = iosb[0];
4216 if (!(retsts & 1)) {
4217 set_vaxc_errno(retsts);
4218 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4219 else set_errno(EVMSERR);
4224 } /* end of my_utime() */
4228 * flex_stat, flex_fstat
4229 * basic stat, but gets it right when asked to stat
4230 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4233 /* encode_dev packs a VMS device name string into an integer to allow
4234 * simple comparisons. This can be used, for example, to check whether two
4235 * files are located on the same device, by comparing their encoded device
4236 * names. Even a string comparison would not do, because stat() reuses the
4237 * device name buffer for each call; so without encode_dev, it would be
4238 * necessary to save the buffer and use strcmp (this would mean a number of
4239 * changes to the standard Perl code, to say nothing of what a Perl script
4242 * The device lock id, if it exists, should be unique (unless perhaps compared
4243 * with lock ids transferred from other nodes). We have a lock id if the disk is
4244 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4245 * device names. Thus we use the lock id in preference, and only if that isn't
4246 * available, do we try to pack the device name into an integer (flagged by
4247 * the sign bit (LOCKID_MASK) being set).
4249 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4250 * name and its encoded form, but it seems very unlikely that we will find
4251 * two files on different disks that share the same encoded device names,
4252 * and even more remote that they will share the same file id (if the test
4253 * is to check for the same file).
4255 * A better method might be to use sys$device_scan on the first call, and to
4256 * search for the device, returning an index into the cached array.
4257 * The number returned would be more intelligable.
4258 * This is probably not worth it, and anyway would take quite a bit longer
4259 * on the first call.
4261 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4262 static mydev_t encode_dev (const char *dev)
4265 unsigned long int f;
4270 if (!dev || !dev[0]) return 0;
4274 struct dsc$descriptor_s dev_desc;
4275 unsigned long int status, lockid, item = DVI$_LOCKID;
4277 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4278 can try that first. */
4279 dev_desc.dsc$w_length = strlen (dev);
4280 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4281 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4282 dev_desc.dsc$a_pointer = (char *) dev;
4283 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4284 if (lockid) return (lockid & ~LOCKID_MASK);
4288 /* Otherwise we try to encode the device name */
4292 for (q = dev + strlen(dev); q--; q >= dev) {
4295 else if (isalpha (toupper (*q)))
4296 c= toupper (*q) - 'A' + (char)10;
4298 continue; /* Skip '$'s */
4300 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4302 enc += f * (unsigned long int) c;
4304 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4306 } /* end of encode_dev() */
4308 static char namecache[NAM$C_MAXRSS+1];
4311 is_null_device(name)
4314 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4315 The underscore prefix, controller letter, and unit number are
4316 independently optional; for our purposes, the colon punctuation
4317 is not. The colon can be trailed by optional directory and/or
4318 filename, but two consecutive colons indicates a nodename rather
4319 than a device. [pr] */
4320 if (*name == '_') ++name;
4321 if (tolower(*name++) != 'n') return 0;
4322 if (tolower(*name++) != 'l') return 0;
4323 if (tolower(*name) == 'a') ++name;
4324 if (*name == '0') ++name;
4325 return (*name++ == ':') && (*name != ':');
4328 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4329 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4330 * subset of the applicable information.
4332 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4334 cando(I32 bit, I32 effective, Stat_t *statbufp)
4337 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4339 char fname[NAM$C_MAXRSS+1];
4340 unsigned long int retsts;
4341 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4342 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4344 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4345 device name on successive calls */
4346 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4347 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4348 namdsc.dsc$a_pointer = fname;
4349 namdsc.dsc$w_length = sizeof fname - 1;
4351 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4352 &namdsc,&namdsc.dsc$w_length,0,0);
4354 fname[namdsc.dsc$w_length] = '\0';
4355 return cando_by_name(bit,effective,fname);
4357 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4358 warn("Can't get filespec - stale stat buffer?\n");
4362 return FALSE; /* Should never get to here */
4364 } /* end of cando() */
4368 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4370 cando_by_name(I32 bit, I32 effective, char *fname)
4372 static char usrname[L_cuserid];
4373 static struct dsc$descriptor_s usrdsc =
4374 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4375 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4376 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4377 unsigned short int retlen;
4378 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4379 union prvdef curprv;
4380 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4381 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4382 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4385 if (!fname || !*fname) return FALSE;
4386 /* Make sure we expand logical names, since sys$check_access doesn't */
4387 if (!strpbrk(fname,"/]>:")) {
4388 strcpy(fileified,fname);
4389 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4392 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4393 retlen = namdsc.dsc$w_length = strlen(vmsname);
4394 namdsc.dsc$a_pointer = vmsname;
4395 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4396 vmsname[retlen-1] == ':') {
4397 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4398 namdsc.dsc$w_length = strlen(fileified);
4399 namdsc.dsc$a_pointer = fileified;
4402 if (!usrdsc.dsc$w_length) {
4404 usrdsc.dsc$w_length = strlen(usrname);
4411 access = ARM$M_EXECUTE;
4416 access = ARM$M_READ;
4421 access = ARM$M_WRITE;
4426 access = ARM$M_DELETE;
4432 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4433 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4434 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4435 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4436 set_vaxc_errno(retsts);
4437 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4438 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4439 else set_errno(ENOENT);
4442 if (retsts == SS$_NORMAL) {
4443 if (!privused) return TRUE;
4444 /* We can get access, but only by using privs. Do we have the
4445 necessary privs currently enabled? */
4446 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4447 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4448 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4449 !curprv.prv$v_bypass) return FALSE;
4450 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4451 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4452 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4455 if (retsts == SS$_ACCONFLICT) {
4460 return FALSE; /* Should never get here */
4462 } /* end of cando_by_name() */
4466 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4468 flex_fstat(int fd, Stat_t *statbufp)
4471 if (!fstat(fd,(stat_t *) statbufp)) {
4472 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4473 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4474 # ifdef RTL_USES_UTC
4477 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4478 statbufp->st_atime = _toloc(statbufp->st_atime);
4479 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4484 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4488 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4489 statbufp->st_atime = _toutc(statbufp->st_atime);
4490 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4497 } /* end of flex_fstat() */
4500 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4502 flex_stat(char *fspec, Stat_t *statbufp)
4505 char fileified[NAM$C_MAXRSS+1];
4508 if (statbufp == (Stat_t *) &PL_statcache)
4509 do_tovmsspec(fspec,namecache,0);
4510 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4511 memset(statbufp,0,sizeof *statbufp);
4512 statbufp->st_dev = encode_dev("_NLA0:");
4513 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4514 statbufp->st_uid = 0x00010001;
4515 statbufp->st_gid = 0x0001;
4516 time((time_t *)&statbufp->st_mtime);
4517 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4521 /* Try for a directory name first. If fspec contains a filename without
4522 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4523 * and sea:[wine.dark]water. exist, we prefer the directory here.
4524 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4525 * not sea:[wine.dark]., if the latter exists. If the intended target is
4526 * the file with null type, specify this by calling flex_stat() with
4527 * a '.' at the end of fspec.
4529 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4530 retval = stat(fileified,(stat_t *) statbufp);
4531 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4532 strcpy(namecache,fileified);
4534 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4536 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4537 # ifdef RTL_USES_UTC
4540 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4541 statbufp->st_atime = _toloc(statbufp->st_atime);
4542 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4547 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4551 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4552 statbufp->st_atime = _toutc(statbufp->st_atime);
4553 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4559 } /* end of flex_stat() */
4563 /*{{{char *my_getlogin()*/
4564 /* VMS cuserid == Unix getlogin, except calling sequence */
4568 static char user[L_cuserid];
4569 return cuserid(user);
4574 /* rmscopy - copy a file using VMS RMS routines
4576 * Copies contents and attributes of spec_in to spec_out, except owner
4577 * and protection information. Name and type of spec_in are used as
4578 * defaults for spec_out. The third parameter specifies whether rmscopy()
4579 * should try to propagate timestamps from the input file to the output file.
4580 * If it is less than 0, no timestamps are preserved. If it is 0, then
4581 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4582 * propagated to the output file at creation iff the output file specification
4583 * did not contain an explicit name or type, and the revision date is always
4584 * updated at the end of the copy operation. If it is greater than 0, then
4585 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4586 * other than the revision date should be propagated, and bit 1 indicates
4587 * that the revision date should be propagated.
4589 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4591 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4592 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4593 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4594 * as part of the Perl standard distribution under the terms of the
4595 * GNU General Public License or the Perl Artistic License. Copies
4596 * of each may be found in the Perl standard distribution.
4598 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4600 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4602 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4603 rsa[NAM$C_MAXRSS], ubf[32256];
4604 unsigned long int i, sts, sts2;
4605 struct FAB fab_in, fab_out;
4606 struct RAB rab_in, rab_out;
4608 struct XABDAT xabdat;
4609 struct XABFHC xabfhc;
4610 struct XABRDT xabrdt;
4611 struct XABSUM xabsum;
4613 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4614 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4615 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4619 fab_in = cc$rms_fab;
4620 fab_in.fab$l_fna = vmsin;
4621 fab_in.fab$b_fns = strlen(vmsin);
4622 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4623 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4624 fab_in.fab$l_fop = FAB$M_SQO;
4625 fab_in.fab$l_nam = &nam;
4626 fab_in.fab$l_xab = (void *) &xabdat;
4629 nam.nam$l_rsa = rsa;
4630 nam.nam$b_rss = sizeof(rsa);
4631 nam.nam$l_esa = esa;
4632 nam.nam$b_ess = sizeof (esa);
4633 nam.nam$b_esl = nam.nam$b_rsl = 0;
4635 xabdat = cc$rms_xabdat; /* To get creation date */
4636 xabdat.xab$l_nxt = (void *) &xabfhc;
4638 xabfhc = cc$rms_xabfhc; /* To get record length */
4639 xabfhc.xab$l_nxt = (void *) &xabsum;
4641 xabsum = cc$rms_xabsum; /* To get key and area information */
4643 if (!((sts = sys$open(&fab_in)) & 1)) {
4644 set_vaxc_errno(sts);
4648 set_errno(ENOENT); break;
4650 set_errno(ENODEV); break;
4652 set_errno(EINVAL); break;
4654 set_errno(EACCES); break;
4662 fab_out.fab$w_ifi = 0;
4663 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4664 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4665 fab_out.fab$l_fop = FAB$M_SQO;
4666 fab_out.fab$l_fna = vmsout;
4667 fab_out.fab$b_fns = strlen(vmsout);
4668 fab_out.fab$l_dna = nam.nam$l_name;
4669 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4671 if (preserve_dates == 0) { /* Act like DCL COPY */
4672 nam.nam$b_nop = NAM$M_SYNCHK;
4673 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4674 if (!((sts = sys$parse(&fab_out)) & 1)) {
4675 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4676 set_vaxc_errno(sts);
4679 fab_out.fab$l_xab = (void *) &xabdat;
4680 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4682 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4683 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4684 preserve_dates =0; /* bitmask from this point forward */
4686 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4687 if (!((sts = sys$create(&fab_out)) & 1)) {
4688 set_vaxc_errno(sts);
4691 set_errno(ENOENT); break;
4693 set_errno(ENODEV); break;
4695 set_errno(EINVAL); break;
4697 set_errno(EACCES); break;
4703 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4704 if (preserve_dates & 2) {
4705 /* sys$close() will process xabrdt, not xabdat */
4706 xabrdt = cc$rms_xabrdt;
4708 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4710 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4711 * is unsigned long[2], while DECC & VAXC use a struct */
4712 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4714 fab_out.fab$l_xab = (void *) &xabrdt;
4717 rab_in = cc$rms_rab;
4718 rab_in.rab$l_fab = &fab_in;
4719 rab_in.rab$l_rop = RAB$M_BIO;
4720 rab_in.rab$l_ubf = ubf;
4721 rab_in.rab$w_usz = sizeof ubf;
4722 if (!((sts = sys$connect(&rab_in)) & 1)) {
4723 sys$close(&fab_in); sys$close(&fab_out);
4724 set_errno(EVMSERR); set_vaxc_errno(sts);
4728 rab_out = cc$rms_rab;
4729 rab_out.rab$l_fab = &fab_out;
4730 rab_out.rab$l_rbf = ubf;
4731 if (!((sts = sys$connect(&rab_out)) & 1)) {
4732 sys$close(&fab_in); sys$close(&fab_out);
4733 set_errno(EVMSERR); set_vaxc_errno(sts);
4737 while ((sts = sys$read(&rab_in))) { /* always true */
4738 if (sts == RMS$_EOF) break;
4739 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4740 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4741 sys$close(&fab_in); sys$close(&fab_out);
4742 set_errno(EVMSERR); set_vaxc_errno(sts);
4747 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4748 sys$close(&fab_in); sys$close(&fab_out);
4749 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4751 set_errno(EVMSERR); set_vaxc_errno(sts);
4757 } /* end of rmscopy() */
4761 /*** The following glue provides 'hooks' to make some of the routines
4762 * from this file available from Perl. These routines are sufficiently
4763 * basic, and are required sufficiently early in the build process,
4764 * that's it's nice to have them available to miniperl as well as the
4765 * full Perl, so they're set up here instead of in an extension. The
4766 * Perl code which handles importation of these names into a given
4767 * package lives in [.VMS]Filespec.pm in @INC.
4771 rmsexpand_fromperl(CV *cv)
4774 char *fspec, *defspec = NULL, *rslt;
4777 if (!items || items > 2)
4778 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4779 fspec = SvPV(ST(0),n_a);
4780 if (!fspec || !*fspec) XSRETURN_UNDEF;
4781 if (items == 2) defspec = SvPV(ST(1),n_a);
4783 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4784 ST(0) = sv_newmortal();
4785 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4790 vmsify_fromperl(CV *cv)
4796 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4797 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4798 ST(0) = sv_newmortal();
4799 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4804 unixify_fromperl(CV *cv)
4810 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4811 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4812 ST(0) = sv_newmortal();
4813 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4818 fileify_fromperl(CV *cv)
4824 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4825 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4826 ST(0) = sv_newmortal();
4827 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4832 pathify_fromperl(CV *cv)
4838 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4839 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4840 ST(0) = sv_newmortal();
4841 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4846 vmspath_fromperl(CV *cv)
4852 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4853 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4854 ST(0) = sv_newmortal();
4855 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4860 unixpath_fromperl(CV *cv)
4866 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4867 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4868 ST(0) = sv_newmortal();
4869 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4874 candelete_fromperl(CV *cv)
4877 char fspec[NAM$C_MAXRSS+1], *fsp;
4882 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4884 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4885 if (SvTYPE(mysv) == SVt_PVGV) {
4886 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4887 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4894 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4895 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4901 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4906 rmscopy_fromperl(CV *cv)
4909 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4911 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4912 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4913 unsigned long int sts;
4918 if (items < 2 || items > 3)
4919 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4921 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4922 if (SvTYPE(mysv) == SVt_PVGV) {
4923 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4924 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4931 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
4932 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4937 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4938 if (SvTYPE(mysv) == SVt_PVGV) {
4939 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
4940 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4947 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
4948 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4953 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4955 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4962 char* file = __FILE__;
4964 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4965 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4966 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4967 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4968 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4969 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4970 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4971 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4972 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);