3 * VMS-specific routines for perl5
5 * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
71 #if defined(NEED_AN_H_ERRNO)
76 unsigned short int buflen;
77 unsigned short int itmcode;
79 unsigned short int *retlen;
82 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
83 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
84 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
85 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
86 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
87 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
88 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
89 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
90 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
92 static char *__mystrtolower(char *str)
94 if (str) for (; *str; ++str) *str= tolower(*str);
98 static struct dsc$descriptor_s fildevdsc =
99 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
100 static struct dsc$descriptor_s crtlenvdsc =
101 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
102 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
103 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
104 static struct dsc$descriptor_s **env_tables = defenv;
105 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
107 /* True if we shouldn't treat barewords as logicals during directory */
109 static int no_translate_barewords;
111 /* Temp for subprocess commands */
112 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
114 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
116 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
117 struct dsc$descriptor_s **tabvec, unsigned long int flags)
119 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
120 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
121 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
122 unsigned char acmode;
123 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
124 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
125 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
126 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
128 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
129 #if defined(USE_THREADS)
130 /* We jump through these hoops because we can be called at */
131 /* platform-specific initialization time, which is before anything is */
132 /* set up--we can't even do a plain dTHX since that relies on the */
133 /* interpreter structure to be initialized */
134 struct perl_thread *thr;
136 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
142 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
143 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
145 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
146 *cp2 = _toupper(*cp1);
147 if (cp1 - lnm > LNM$C_NAMLENGTH) {
148 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
152 lnmdsc.dsc$w_length = cp1 - lnm;
153 lnmdsc.dsc$a_pointer = uplnm;
154 uplnm[lnmdsc.dsc$w_length] = '\0';
155 secure = flags & PERL__TRNENV_SECURE;
156 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
157 if (!tabvec || !*tabvec) tabvec = env_tables;
159 for (curtab = 0; tabvec[curtab]; curtab++) {
160 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
161 if (!ivenv && !secure) {
166 Perl_warn(aTHX_ "Can't read CRTL environ\n");
169 retsts = SS$_NOLOGNAM;
170 for (i = 0; environ[i]; i++) {
171 if ((eq = strchr(environ[i],'=')) &&
172 !strncmp(environ[i],uplnm,eq - environ[i])) {
174 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
175 if (!eqvlen) continue;
180 if (retsts != SS$_NOLOGNAM) break;
183 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
184 !str$case_blind_compare(&tmpdsc,&clisym)) {
185 if (!ivsym && !secure) {
186 unsigned short int deflen = LNM$C_NAMLENGTH;
187 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
188 /* dynamic dsc to accomodate possible long value */
189 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
190 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
193 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
195 /* Special hack--we might be called before the interpreter's */
196 /* fully initialized, in which case either thr or PL_curcop */
197 /* might be bogus. We have to check, since ckWARN needs them */
198 /* both to be valid if running threaded */
199 #if defined(USE_THREADS)
200 if (thr && PL_curcop) {
202 if (ckWARN(WARN_MISC)) {
203 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
205 #if defined(USE_THREADS)
207 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
212 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
214 _ckvmssts(lib$sfree1_dd(&eqvdsc));
215 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
216 if (retsts == LIB$_NOSUCHSYM) continue;
221 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
222 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
223 if (retsts == SS$_NOLOGNAM) continue;
224 /* PPFs have a prefix */
227 *((int *)uplnm) == *((int *)"SYS$") &&
229 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
230 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
231 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
232 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
233 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
234 memcpy(eqv,eqv+4,eqvlen-4);
240 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
241 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
242 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
243 retsts == SS$_NOLOGNAM) {
244 set_errno(EINVAL); set_vaxc_errno(retsts);
246 else _ckvmssts(retsts);
248 } /* end of vmstrnenv */
251 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
252 /* Define as a function so we can access statics. */
253 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
255 return vmstrnenv(lnm,eqv,idx,fildev,
256 #ifdef SECURE_INTERNAL_GETENV
257 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
266 * Note: Uses Perl temp to store result so char * can be returned to
267 * caller; this pointer will be invalidated at next Perl statement
269 * We define this as a function rather than a macro in terms of my_getenv_len()
270 * so that it'll work when PL_curinterp is undefined (and we therefore can't
273 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
275 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
277 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
278 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
279 unsigned long int idx = 0;
283 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
284 /* Set up a temporary buffer for the return value; Perl will
285 * clean it up at the next statement transition */
286 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
287 if (!tmpsv) return NULL;
290 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
291 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
292 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
293 getcwd(eqv,LNM$C_NAMLENGTH);
297 if ((cp2 = strchr(lnm,';')) != NULL) {
299 uplnm[cp2-lnm] = '\0';
300 idx = strtoul(cp2+1,NULL,0);
303 /* Impose security constraints only if tainting */
304 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
305 if (vmstrnenv(lnm,eqv,idx,
307 #ifdef SECURE_INTERNAL_GETENV
308 sys ? PERL__TRNENV_SECURE : 0
316 } /* end of my_getenv() */
320 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
322 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
325 char *buf, *cp1, *cp2;
326 unsigned long idx = 0;
327 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
330 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
331 /* Set up a temporary buffer for the return value; Perl will
332 * clean it up at the next statement transition */
333 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
334 if (!tmpsv) return NULL;
337 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
338 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
339 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
340 getcwd(buf,LNM$C_NAMLENGTH);
345 if ((cp2 = strchr(lnm,';')) != NULL) {
348 idx = strtoul(cp2+1,NULL,0);
351 /* Impose security constraints only if tainting */
352 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
353 if ((*len = vmstrnenv(lnm,buf,idx,
355 #ifdef SECURE_INTERNAL_GETENV
356 sys ? PERL__TRNENV_SECURE : 0
366 } /* end of my_getenv_len() */
369 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
371 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
373 /*{{{ void prime_env_iter() */
376 /* Fill the %ENV associative array with all logical names we can
377 * find, in preparation for iterating over it.
381 static int primed = 0;
382 HV *seenhv = NULL, *envhv;
383 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
384 unsigned short int chan;
385 #ifndef CLI$M_TRUSTED
386 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
388 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
389 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
391 bool have_sym = FALSE, have_lnm = FALSE;
392 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
393 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
394 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
395 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
396 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
398 static perl_mutex primenv_mutex;
399 MUTEX_INIT(&primenv_mutex);
402 if (primed || !PL_envgv) return;
403 MUTEX_LOCK(&primenv_mutex);
404 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
405 envhv = GvHVn(PL_envgv);
406 /* Perform a dummy fetch as an lval to insure that the hash table is
407 * set up. Otherwise, the hv_store() will turn into a nullop. */
408 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
410 for (i = 0; env_tables[i]; i++) {
411 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
412 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
413 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
415 if (have_sym || have_lnm) {
416 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
417 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
418 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
419 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
422 for (i--; i >= 0; i--) {
423 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
426 for (j = 0; environ[j]; j++) {
427 if (!(start = strchr(environ[j],'='))) {
428 if (ckWARN(WARN_INTERNAL))
429 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
433 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
439 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
440 !str$case_blind_compare(&tmpdsc,&clisym)) {
441 strcpy(cmd,"Show Symbol/Global *");
442 cmddsc.dsc$w_length = 20;
443 if (env_tables[i]->dsc$w_length == 12 &&
444 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
445 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
446 flags = defflags | CLI$M_NOLOGNAM;
449 strcpy(cmd,"Show Logical *");
450 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
451 strcat(cmd," /Table=");
452 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
453 cmddsc.dsc$w_length = strlen(cmd);
455 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
456 flags = defflags | CLI$M_NOCLISYM;
459 /* Create a new subprocess to execute each command, to exclude the
460 * remote possibility that someone could subvert a mbx or file used
461 * to write multiple commands to a single subprocess.
464 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
465 0,&riseandshine,0,0,&clidsc,&clitabdsc);
466 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
467 defflags &= ~CLI$M_TRUSTED;
468 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
470 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
471 if (seenhv) SvREFCNT_dec(seenhv);
474 char *cp1, *cp2, *key;
475 unsigned long int sts, iosb[2], retlen, keylen;
478 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
479 if (sts & 1) sts = iosb[0] & 0xffff;
480 if (sts == SS$_ENDOFFILE) {
482 while (substs == 0) { sys$hiber(); wakect++;}
483 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
488 retlen = iosb[0] >> 16;
489 if (!retlen) continue; /* blank line */
491 if (iosb[1] != subpid) {
493 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
497 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
498 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
500 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
501 if (*cp1 == '(' || /* Logical name table name */
502 *cp1 == '=' /* Next eqv of searchlist */) continue;
503 if (*cp1 == '"') cp1++;
504 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
505 key = cp1; keylen = cp2 - cp1;
506 if (keylen && hv_exists(seenhv,key,keylen)) continue;
507 while (*cp2 && *cp2 != '=') cp2++;
508 while (*cp2 && *cp2 == '=') cp2++;
509 while (*cp2 && *cp2 == ' ') cp2++;
510 if (*cp2 == '"') { /* String translation; may embed "" */
511 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
512 cp2++; cp1--; /* Skip "" surrounding translation */
514 else { /* Numeric translation */
515 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
516 cp1--; /* stop on last non-space char */
518 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
519 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
522 PERL_HASH(hash,key,keylen);
523 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
524 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
526 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
527 /* get the PPFs for this process, not the subprocess */
528 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
529 char eqv[LNM$C_NAMLENGTH+1];
531 for (i = 0; ppfs[i]; i++) {
532 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
533 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
538 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
539 if (buf) Safefree(buf);
540 if (seenhv) SvREFCNT_dec(seenhv);
541 MUTEX_UNLOCK(&primenv_mutex);
544 } /* end of prime_env_iter */
548 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
549 /* Define or delete an element in the same "environment" as
550 * vmstrnenv(). If an element is to be deleted, it's removed from
551 * the first place it's found. If it's to be set, it's set in the
552 * place designated by the first element of the table vector.
553 * Like setenv() returns 0 for success, non-zero on error.
556 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
558 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
559 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
560 unsigned long int retsts, usermode = PSL$C_USER;
561 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
562 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
563 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
564 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
565 $DESCRIPTOR(local,"_LOCAL");
568 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
569 *cp2 = _toupper(*cp1);
570 if (cp1 - lnm > LNM$C_NAMLENGTH) {
571 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
575 lnmdsc.dsc$w_length = cp1 - lnm;
576 if (!tabvec || !*tabvec) tabvec = env_tables;
578 if (!eqv) { /* we're deleting n element */
579 for (curtab = 0; tabvec[curtab]; curtab++) {
580 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
582 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
583 if ((cp1 = strchr(environ[i],'=')) &&
584 !strncmp(environ[i],lnm,cp1 - environ[i])) {
586 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
589 ivenv = 1; retsts = SS$_NOLOGNAM;
591 if (ckWARN(WARN_INTERNAL))
592 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
593 ivenv = 1; retsts = SS$_NOSUCHPGM;
599 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
600 !str$case_blind_compare(&tmpdsc,&clisym)) {
601 unsigned int symtype;
602 if (tabvec[curtab]->dsc$w_length == 12 &&
603 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
604 !str$case_blind_compare(&tmpdsc,&local))
605 symtype = LIB$K_CLI_LOCAL_SYM;
606 else symtype = LIB$K_CLI_GLOBAL_SYM;
607 retsts = lib$delete_symbol(&lnmdsc,&symtype);
608 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
609 if (retsts == LIB$_NOSUCHSYM) continue;
613 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
614 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
615 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
616 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
617 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
621 else { /* we're defining a value */
622 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
624 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
626 if (ckWARN(WARN_INTERNAL))
627 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
628 retsts = SS$_NOSUCHPGM;
632 eqvdsc.dsc$a_pointer = eqv;
633 eqvdsc.dsc$w_length = strlen(eqv);
634 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
635 !str$case_blind_compare(&tmpdsc,&clisym)) {
636 unsigned int symtype;
637 if (tabvec[0]->dsc$w_length == 12 &&
638 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
639 !str$case_blind_compare(&tmpdsc,&local))
640 symtype = LIB$K_CLI_LOCAL_SYM;
641 else symtype = LIB$K_CLI_GLOBAL_SYM;
642 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
645 if (!*eqv) eqvdsc.dsc$w_length = 1;
646 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
647 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
648 if (ckWARN(WARN_MISC)) {
649 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
652 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
658 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
659 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
660 set_errno(EVMSERR); break;
661 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
662 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
663 set_errno(EINVAL); break;
670 set_vaxc_errno(retsts);
671 return (int) retsts || 44; /* retsts should never be 0, but just in case */
674 /* We reset error values on success because Perl does an hv_fetch()
675 * before each hv_store(), and if the thing we're setting didn't
676 * previously exist, we've got a leftover error message. (Of course,
677 * this fails in the face of
678 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
679 * in that the error reported in $! isn't spurious,
680 * but it's right more often than not.)
682 set_errno(0); set_vaxc_errno(retsts);
686 } /* end of vmssetenv() */
689 /*{{{ void my_setenv(char *lnm, char *eqv)*/
690 /* This has to be a function since there's a prototype for it in proto.h */
692 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
694 if (lnm && *lnm && strlen(lnm) == 7) {
697 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
698 if (!strcmp(uplnm,"DEFAULT")) {
699 if (eqv && *eqv) chdir(eqv);
703 (void) vmssetenv(lnm,eqv,NULL);
709 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
710 /* my_crypt - VMS password hashing
711 * my_crypt() provides an interface compatible with the Unix crypt()
712 * C library function, and uses sys$hash_password() to perform VMS
713 * password hashing. The quadword hashed password value is returned
714 * as a NUL-terminated 8 character string. my_crypt() does not change
715 * the case of its string arguments; in order to match the behavior
716 * of LOGINOUT et al., alphabetic characters in both arguments must
717 * be upcased by the caller.
720 my_crypt(const char *textpasswd, const char *usrname)
722 # ifndef UAI$C_PREFERRED_ALGORITHM
723 # define UAI$C_PREFERRED_ALGORITHM 127
725 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
726 unsigned short int salt = 0;
727 unsigned long int sts;
729 unsigned short int dsc$w_length;
730 unsigned char dsc$b_type;
731 unsigned char dsc$b_class;
732 const char * dsc$a_pointer;
733 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
734 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
735 struct itmlst_3 uailst[3] = {
736 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
737 { sizeof salt, UAI$_SALT, &salt, 0},
738 { 0, 0, NULL, NULL}};
741 usrdsc.dsc$w_length = strlen(usrname);
742 usrdsc.dsc$a_pointer = usrname;
743 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
745 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
749 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
755 if (sts != RMS$_RNF) return NULL;
758 txtdsc.dsc$w_length = strlen(textpasswd);
759 txtdsc.dsc$a_pointer = textpasswd;
760 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
761 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
764 return (char *) hash;
766 } /* end of my_crypt() */
770 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
771 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
772 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
774 /*{{{int do_rmdir(char *name)*/
776 Perl_do_rmdir(pTHX_ char *name)
778 char dirfile[NAM$C_MAXRSS+1];
782 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
783 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
784 else retval = kill_file(dirfile);
787 } /* end of do_rmdir */
791 * Delete any file to which user has control access, regardless of whether
792 * delete access is explicitly allowed.
793 * Limitations: User must have write access to parent directory.
794 * Does not block signals or ASTs; if interrupted in midstream
795 * may leave file with an altered ACL.
798 /*{{{int kill_file(char *name)*/
800 kill_file(char *name)
802 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
803 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
804 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
806 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
808 unsigned char myace$b_length;
809 unsigned char myace$b_type;
810 unsigned short int myace$w_flags;
811 unsigned long int myace$l_access;
812 unsigned long int myace$l_ident;
813 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
814 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
815 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
817 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
818 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
819 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
820 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
821 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
822 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
824 /* Expand the input spec using RMS, since the CRTL remove() and
825 * system services won't do this by themselves, so we may miss
826 * a file "hiding" behind a logical name or search list. */
827 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
828 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
829 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
830 /* If not, can changing protections help? */
831 if (vaxc$errno != RMS$_PRV) return -1;
833 /* No, so we get our own UIC to use as a rights identifier,
834 * and the insert an ACE at the head of the ACL which allows us
835 * to delete the file.
837 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
838 fildsc.dsc$w_length = strlen(rspec);
839 fildsc.dsc$a_pointer = rspec;
841 newace.myace$l_ident = oldace.myace$l_ident;
842 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
844 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
845 set_errno(ENOENT); break;
847 set_errno(ENOTDIR); break;
849 set_errno(ENODEV); break;
850 case RMS$_SYN: case SS$_INVFILFOROP:
851 set_errno(EINVAL); break;
853 set_errno(EACCES); break;
857 set_vaxc_errno(aclsts);
860 /* Grab any existing ACEs with this identifier in case we fail */
861 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
862 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
863 || fndsts == SS$_NOMOREACE ) {
864 /* Add the new ACE . . . */
865 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
867 if ((rmsts = remove(name))) {
868 /* We blew it - dir with files in it, no write priv for
869 * parent directory, etc. Put things back the way they were. */
870 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
873 addlst[0].bufadr = &oldace;
874 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
881 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
882 /* We just deleted it, so of course it's not there. Some versions of
883 * VMS seem to return success on the unlock operation anyhow (after all
884 * the unlock is successful), but others don't.
886 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
887 if (aclsts & 1) aclsts = fndsts;
890 set_vaxc_errno(aclsts);
896 } /* end of kill_file() */
900 /*{{{int my_mkdir(char *,Mode_t)*/
902 my_mkdir(char *dir, Mode_t mode)
904 STRLEN dirlen = strlen(dir);
907 /* zero length string sometimes gives ACCVIO */
908 if (dirlen == 0) return -1;
910 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
911 * null file name/type. However, it's commonplace under Unix,
912 * so we'll allow it for a gain in portability.
914 if (dir[dirlen-1] == '/') {
915 char *newdir = savepvn(dir,dirlen-1);
916 int ret = mkdir(newdir,mode);
920 else return mkdir(dir,mode);
921 } /* end of my_mkdir */
924 /*{{{int my_chdir(char *)*/
928 STRLEN dirlen = strlen(dir);
931 /* zero length string sometimes gives ACCVIO */
932 if (dirlen == 0) return -1;
934 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
936 * null file name/type. However, it's commonplace under Unix,
937 * so we'll allow it for a gain in portability.
939 if (dir[dirlen-1] == '/') {
940 char *newdir = savepvn(dir,dirlen-1);
941 int ret = chdir(newdir);
945 else return chdir(dir);
946 } /* end of my_chdir */
950 /*{{{FILE *my_tmpfile()*/
958 if ((fp = tmpfile())) return fp;
960 New(1323,cp,L_tmpnam+24,char);
961 strcpy(cp,"Sys$Scratch:");
962 tmpnam(cp+strlen(cp));
963 strcat(cp,".Perltmp");
964 fp = fopen(cp,"w+","fop=dlt");
972 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
974 static unsigned long int mbxbufsiz;
975 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
980 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
981 * preprocessor consant BUFSIZ from stdio.h as the size of the
984 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
985 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
987 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
989 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
990 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
992 } /* end of create_mbx() */
994 /*{{{ my_popen and my_pclose*/
997 struct pipe_details *next;
998 PerlIO *fp; /* stdio file pointer to pipe mailbox */
999 int pid; /* PID of subprocess */
1000 int mode; /* == 'r' if pipe open for reading */
1001 int done; /* subprocess has completed */
1002 unsigned long int completion; /* termination status of subprocess */
1005 struct exit_control_block
1007 struct exit_control_block *flink;
1008 unsigned long int (*exit_routine)();
1009 unsigned long int arg_count;
1010 unsigned long int *status_address;
1011 unsigned long int exit_status;
1014 static struct pipe_details *open_pipes = NULL;
1015 static $DESCRIPTOR(nl_desc, "NL:");
1016 static int waitpid_asleep = 0;
1018 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
1019 * to a mbx; that's the caller's responsibility.
1021 static unsigned long int
1022 pipe_eof(FILE *fp, int immediate)
1024 char devnam[NAM$C_MAXRSS+1], *cp;
1025 unsigned long int chan, iosb[2], retsts, retsts2;
1026 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
1029 if (fgetname(fp,devnam,1)) {
1030 /* It oughta be a mailbox, so fgetname should give just the device
1031 * name, but just in case . . . */
1032 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
1033 devdsc.dsc$w_length = strlen(devnam);
1034 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
1035 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
1036 iosb,0,0,0,0,0,0,0,0);
1037 if (retsts & 1) retsts = iosb[0];
1038 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
1039 if (retsts & 1) retsts = retsts2;
1043 else _ckvmssts(vaxc$errno); /* Should never happen */
1044 return (unsigned long int) vaxc$errno;
1047 static unsigned long int
1050 struct pipe_details *info;
1051 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1056 first we try sending an EOF...ignore if doesn't work, make sure we
1064 _ckvmssts(sys$setast(0));
1065 need_eof = info->mode != 'r' && !info->done;
1066 _ckvmssts(sys$setast(1));
1068 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1072 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1077 _ckvmssts(sys$setast(0));
1078 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1079 sts = sys$forcex(&info->pid,0,&abort);
1080 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1083 _ckvmssts(sys$setast(1));
1086 if (did_stuff) sleep(1); /* wait for them to respond */
1090 _ckvmssts(sys$setast(0));
1091 if (!info->done) { /* We tried to be nice . . . */
1092 sts = sys$delprc(&info->pid,0);
1093 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1094 info->done = 1; /* so my_pclose doesn't try to write EOF */
1096 _ckvmssts(sys$setast(1));
1101 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1102 else if (!(sts & 1)) retsts = sts;
1107 static struct exit_control_block pipe_exitblock =
1108 {(struct exit_control_block *) 0,
1109 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1113 popen_completion_ast(struct pipe_details *thispipe)
1115 thispipe->done = TRUE;
1116 if (waitpid_asleep) {
1122 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1123 static void vms_execfree(pTHX);
1126 safe_popen(char *cmd, char *mode)
1128 static int handler_set_up = FALSE;
1130 unsigned short int chan;
1131 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1133 struct pipe_details *info;
1134 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1135 DSC$K_CLASS_S, mbxname},
1136 cmddsc = {0, DSC$K_DTYPE_T,
1140 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1141 New(1301,info,1,struct pipe_details);
1143 /* create mailbox */
1144 create_mbx(&chan,&namdsc);
1146 /* open a FILE* onto it */
1147 info->fp = PerlIO_open(mbxname, mode);
1149 /* give up other channel onto it */
1150 _ckvmssts(sys$dassgn(chan));
1160 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1161 0 /* name */, &info->pid, &info->completion,
1162 0, popen_completion_ast,info,0,0,0));
1165 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1166 0 /* name */, &info->pid, &info->completion,
1167 0, popen_completion_ast,info,0,0,0));
1171 if (!handler_set_up) {
1172 _ckvmssts(sys$dclexh(&pipe_exitblock));
1173 handler_set_up = TRUE;
1175 info->next=open_pipes; /* prepend to list */
1178 PL_forkprocess = info->pid;
1180 } /* end of safe_popen */
1183 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1185 Perl_my_popen(pTHX_ char *cmd, char *mode)
1188 TAINT_PROPER("popen");
1189 PERL_FLUSHALL_FOR_CHILD;
1190 return safe_popen(cmd,mode);
1195 /*{{{ I32 my_pclose(FILE *fp)*/
1196 I32 Perl_my_pclose(pTHX_ FILE *fp)
1198 struct pipe_details *info, *last = NULL;
1199 unsigned long int retsts;
1202 for (info = open_pipes; info != NULL; last = info, info = info->next)
1203 if (info->fp == fp) break;
1205 if (info == NULL) { /* no such pipe open */
1206 set_errno(ECHILD); /* quoth POSIX */
1207 set_vaxc_errno(SS$_NONEXPR);
1211 /* If we were writing to a subprocess, insure that someone reading from
1212 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1213 * produce an EOF record in the mailbox. */
1214 _ckvmssts(sys$setast(0));
1215 need_eof = info->mode != 'r' && !info->done;
1216 _ckvmssts(sys$setast(1));
1217 if (need_eof) pipe_eof(info->fp,0);
1218 PerlIO_close(info->fp);
1220 if (info->done) retsts = info->completion;
1221 else waitpid(info->pid,(int *) &retsts,0);
1223 /* remove from list of open pipes */
1224 _ckvmssts(sys$setast(0));
1225 if (last) last->next = info->next;
1226 else open_pipes = info->next;
1227 _ckvmssts(sys$setast(1));
1232 } /* end of my_pclose() */
1234 /* sort-of waitpid; use only with popen() */
1235 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1237 my_waitpid(Pid_t pid, int *statusp, int flags)
1239 struct pipe_details *info;
1242 for (info = open_pipes; info != NULL; info = info->next)
1243 if (info->pid == pid) break;
1245 if (info != NULL) { /* we know about this child */
1246 while (!info->done) {
1251 *statusp = info->completion;
1254 else { /* we haven't heard of this child */
1255 $DESCRIPTOR(intdsc,"0 00:00:01");
1256 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1257 unsigned long int interval[2],sts;
1259 if (ckWARN(WARN_EXEC)) {
1260 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1261 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1262 if (ownerpid != mypid)
1263 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1266 _ckvmssts(sys$bintim(&intdsc,interval));
1267 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1268 _ckvmssts(sys$schdwk(0,0,interval,0));
1269 _ckvmssts(sys$hiber());
1273 /* There's no easy way to find the termination status a child we're
1274 * not aware of beforehand. If we're really interested in the future,
1275 * we can go looking for a termination mailbox, or chase after the
1276 * accounting record for the process.
1282 } /* end of waitpid() */
1287 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1289 my_gconvert(double val, int ndig, int trail, char *buf)
1291 static char __gcvtbuf[DBL_DIG+1];
1294 loc = buf ? buf : __gcvtbuf;
1296 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1298 sprintf(loc,"%.*g",ndig,val);
1304 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1305 return gcvt(val,ndig,loc);
1308 loc[0] = '0'; loc[1] = '\0';
1316 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1317 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1318 * to expand file specification. Allows for a single default file
1319 * specification and a simple mask of options. If outbuf is non-NULL,
1320 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1321 * the resultant file specification is placed. If outbuf is NULL, the
1322 * resultant file specification is placed into a static buffer.
1323 * The third argument, if non-NULL, is taken to be a default file
1324 * specification string. The fourth argument is unused at present.
1325 * rmesexpand() returns the address of the resultant string if
1326 * successful, and NULL on error.
1328 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
1331 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1333 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1334 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1335 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1336 struct FAB myfab = cc$rms_fab;
1337 struct NAM mynam = cc$rms_nam;
1339 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1341 if (!filespec || !*filespec) {
1342 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1346 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1347 else outbuf = __rmsexpand_retbuf;
1349 if ((isunix = (strchr(filespec,'/') != NULL))) {
1350 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1351 filespec = vmsfspec;
1354 myfab.fab$l_fna = filespec;
1355 myfab.fab$b_fns = strlen(filespec);
1356 myfab.fab$l_nam = &mynam;
1358 if (defspec && *defspec) {
1359 if (strchr(defspec,'/') != NULL) {
1360 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1363 myfab.fab$l_dna = defspec;
1364 myfab.fab$b_dns = strlen(defspec);
1367 mynam.nam$l_esa = esa;
1368 mynam.nam$b_ess = sizeof esa;
1369 mynam.nam$l_rsa = outbuf;
1370 mynam.nam$b_rss = NAM$C_MAXRSS;
1372 retsts = sys$parse(&myfab,0,0);
1373 if (!(retsts & 1)) {
1374 mynam.nam$b_nop |= NAM$M_SYNCHK;
1375 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
1376 retsts = sys$parse(&myfab,0,0);
1377 if (retsts & 1) goto expanded;
1379 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1380 (void) sys$parse(&myfab,0,0); /* Free search context */
1381 if (out) Safefree(out);
1382 set_vaxc_errno(retsts);
1383 if (retsts == RMS$_PRV) set_errno(EACCES);
1384 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1385 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1386 else set_errno(EVMSERR);
1389 retsts = sys$search(&myfab,0,0);
1390 if (!(retsts & 1) && retsts != RMS$_FNF) {
1391 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1392 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1393 if (out) Safefree(out);
1394 set_vaxc_errno(retsts);
1395 if (retsts == RMS$_PRV) set_errno(EACCES);
1396 else set_errno(EVMSERR);
1400 /* If the input filespec contained any lowercase characters,
1401 * downcase the result for compatibility with Unix-minded code. */
1403 for (out = myfab.fab$l_fna; *out; out++)
1404 if (islower(*out)) { haslower = 1; break; }
1405 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1406 else { out = esa; speclen = mynam.nam$b_esl; }
1407 /* Trim off null fields added by $PARSE
1408 * If type > 1 char, must have been specified in original or default spec
1409 * (not true for version; $SEARCH may have added version of existing file).
1411 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1412 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1413 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1414 if (trimver || trimtype) {
1415 if (defspec && *defspec) {
1416 char defesa[NAM$C_MAXRSS];
1417 struct FAB deffab = cc$rms_fab;
1418 struct NAM defnam = cc$rms_nam;
1420 deffab.fab$l_nam = &defnam;
1421 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1422 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1423 defnam.nam$b_nop = NAM$M_SYNCHK;
1424 if (sys$parse(&deffab,0,0) & 1) {
1425 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1426 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1429 if (trimver) speclen = mynam.nam$l_ver - out;
1431 /* If we didn't already trim version, copy down */
1432 if (speclen > mynam.nam$l_ver - out)
1433 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1434 speclen - (mynam.nam$l_ver - out));
1435 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1438 /* If we just had a directory spec on input, $PARSE "helpfully"
1439 * adds an empty name and type for us */
1440 if (mynam.nam$l_name == mynam.nam$l_type &&
1441 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1442 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1443 speclen = mynam.nam$l_name - out;
1444 out[speclen] = '\0';
1445 if (haslower) __mystrtolower(out);
1447 /* Have we been working with an expanded, but not resultant, spec? */
1448 /* Also, convert back to Unix syntax if necessary. */
1449 if (!mynam.nam$b_rsl) {
1451 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1453 else strcpy(outbuf,esa);
1456 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1457 strcpy(outbuf,tmpfspec);
1459 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1460 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1461 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1465 /* External entry points */
1466 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1467 { return do_rmsexpand(spec,buf,0,def,opt); }
1468 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1469 { return do_rmsexpand(spec,buf,1,def,opt); }
1473 ** The following routines are provided to make life easier when
1474 ** converting among VMS-style and Unix-style directory specifications.
1475 ** All will take input specifications in either VMS or Unix syntax. On
1476 ** failure, all return NULL. If successful, the routines listed below
1477 ** return a pointer to a buffer containing the appropriately
1478 ** reformatted spec (and, therefore, subsequent calls to that routine
1479 ** will clobber the result), while the routines of the same names with
1480 ** a _ts suffix appended will return a pointer to a mallocd string
1481 ** containing the appropriately reformatted spec.
1482 ** In all cases, only explicit syntax is altered; no check is made that
1483 ** the resulting string is valid or that the directory in question
1486 ** fileify_dirspec() - convert a directory spec into the name of the
1487 ** directory file (i.e. what you can stat() to see if it's a dir).
1488 ** The style (VMS or Unix) of the result is the same as the style
1489 ** of the parameter passed in.
1490 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1491 ** what you prepend to a filename to indicate what directory it's in).
1492 ** The style (VMS or Unix) of the result is the same as the style
1493 ** of the parameter passed in.
1494 ** tounixpath() - convert a directory spec into a Unix-style path.
1495 ** tovmspath() - convert a directory spec into a VMS-style path.
1496 ** tounixspec() - convert any file spec into a Unix-style file spec.
1497 ** tovmsspec() - convert any file spec into a VMS-style spec.
1499 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1500 ** Permission is given to distribute this code as part of the Perl
1501 ** standard distribution under the terms of the GNU General Public
1502 ** License or the Perl Artistic License. Copies of each may be
1503 ** found in the Perl standard distribution.
1506 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1507 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
1509 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1510 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1511 char *retspec, *cp1, *cp2, *lastdir;
1512 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1514 if (!dir || !*dir) {
1515 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1517 dirlen = strlen(dir);
1518 while (dirlen && dir[dirlen-1] == '/') --dirlen;
1519 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1520 strcpy(trndir,"/sys$disk/000000");
1524 if (dirlen > NAM$C_MAXRSS) {
1525 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1527 if (!strpbrk(dir+1,"/]>:")) {
1528 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1529 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1531 dirlen = strlen(dir);
1534 strncpy(trndir,dir,dirlen);
1535 trndir[dirlen] = '\0';
1538 /* If we were handed a rooted logical name or spec, treat it like a
1539 * simple directory, so that
1540 * $ Define myroot dev:[dir.]
1541 * ... do_fileify_dirspec("myroot",buf,1) ...
1542 * does something useful.
1544 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
1545 dir[--dirlen] = '\0';
1546 dir[dirlen-1] = ']';
1549 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1550 /* If we've got an explicit filename, we can just shuffle the string. */
1551 if (*(cp1+1)) hasfilename = 1;
1552 /* Similarly, we can just back up a level if we've got multiple levels
1553 of explicit directories in a VMS spec which ends with directories. */
1555 for (cp2 = cp1; cp2 > dir; cp2--) {
1557 *cp2 = *cp1; *cp1 = '\0';
1561 if (*cp2 == '[' || *cp2 == '<') break;
1566 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1567 if (dir[0] == '.') {
1568 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1569 return do_fileify_dirspec("[]",buf,ts);
1570 else if (dir[1] == '.' &&
1571 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1572 return do_fileify_dirspec("[-]",buf,ts);
1574 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1575 dirlen -= 1; /* to last element */
1576 lastdir = strrchr(dir,'/');
1578 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1579 /* If we have "/." or "/..", VMSify it and let the VMS code
1580 * below expand it, rather than repeating the code to handle
1581 * relative components of a filespec here */
1583 if (*(cp1+2) == '.') cp1++;
1584 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1585 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1586 if (strchr(vmsdir,'/') != NULL) {
1587 /* If do_tovmsspec() returned it, it must have VMS syntax
1588 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1589 * the time to check this here only so we avoid a recursion
1590 * loop; otherwise, gigo.
1592 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1594 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1595 return do_tounixspec(trndir,buf,ts);
1598 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1599 lastdir = strrchr(dir,'/');
1601 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
1602 /* Ditto for specs that end in an MFD -- let the VMS code
1603 * figure out whether it's a real device or a rooted logical. */
1604 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1605 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1606 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1607 return do_tounixspec(trndir,buf,ts);
1610 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1611 !(lastdir = cp1 = strrchr(dir,']')) &&
1612 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1613 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1615 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1616 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1617 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1618 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1619 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1620 (ver || *cp3)))))) {
1622 set_vaxc_errno(RMS$_DIR);
1628 /* If we lead off with a device or rooted logical, add the MFD
1629 if we're specifying a top-level directory. */
1630 if (lastdir && *dir == '/') {
1632 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1639 retlen = dirlen + (addmfd ? 13 : 6);
1640 if (buf) retspec = buf;
1641 else if (ts) New(1309,retspec,retlen+1,char);
1642 else retspec = __fileify_retbuf;
1644 dirlen = lastdir - dir;
1645 memcpy(retspec,dir,dirlen);
1646 strcpy(&retspec[dirlen],"/000000");
1647 strcpy(&retspec[dirlen+7],lastdir);
1650 memcpy(retspec,dir,dirlen);
1651 retspec[dirlen] = '\0';
1653 /* We've picked up everything up to the directory file name.
1654 Now just add the type and version, and we're set. */
1655 strcat(retspec,".dir;1");
1658 else { /* VMS-style directory spec */
1659 char esa[NAM$C_MAXRSS+1], term, *cp;
1660 unsigned long int sts, cmplen, haslower = 0;
1661 struct FAB dirfab = cc$rms_fab;
1662 struct NAM savnam, dirnam = cc$rms_nam;
1664 dirfab.fab$b_fns = strlen(dir);
1665 dirfab.fab$l_fna = dir;
1666 dirfab.fab$l_nam = &dirnam;
1667 dirfab.fab$l_dna = ".DIR;1";
1668 dirfab.fab$b_dns = 6;
1669 dirnam.nam$b_ess = NAM$C_MAXRSS;
1670 dirnam.nam$l_esa = esa;
1672 for (cp = dir; *cp; cp++)
1673 if (islower(*cp)) { haslower = 1; break; }
1674 if (!((sts = sys$parse(&dirfab))&1)) {
1675 if (dirfab.fab$l_sts == RMS$_DIR) {
1676 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1677 sts = sys$parse(&dirfab) & 1;
1681 set_vaxc_errno(dirfab.fab$l_sts);
1687 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1688 /* Yes; fake the fnb bits so we'll check type below */
1689 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1691 else { /* No; just work with potential name */
1692 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1694 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1695 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1696 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1701 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1702 cp1 = strchr(esa,']');
1703 if (!cp1) cp1 = strchr(esa,'>');
1704 if (cp1) { /* Should always be true */
1705 dirnam.nam$b_esl -= cp1 - esa - 1;
1706 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1709 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1710 /* Yep; check version while we're at it, if it's there. */
1711 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1712 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1713 /* Something other than .DIR[;1]. Bzzt. */
1714 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1715 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1717 set_vaxc_errno(RMS$_DIR);
1721 esa[dirnam.nam$b_esl] = '\0';
1722 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1723 /* They provided at least the name; we added the type, if necessary, */
1724 if (buf) retspec = buf; /* in sys$parse() */
1725 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1726 else retspec = __fileify_retbuf;
1727 strcpy(retspec,esa);
1728 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1729 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1732 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1733 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1735 dirnam.nam$b_esl -= 9;
1737 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1738 if (cp1 == NULL) { /* should never happen */
1739 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1740 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1745 retlen = strlen(esa);
1746 if ((cp1 = strrchr(esa,'.')) != NULL) {
1747 /* There's more than one directory in the path. Just roll back. */
1749 if (buf) retspec = buf;
1750 else if (ts) New(1311,retspec,retlen+7,char);
1751 else retspec = __fileify_retbuf;
1752 strcpy(retspec,esa);
1755 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1756 /* Go back and expand rooted logical name */
1757 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1758 if (!(sys$parse(&dirfab) & 1)) {
1759 dirnam.nam$l_rlf = NULL;
1760 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1762 set_vaxc_errno(dirfab.fab$l_sts);
1765 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1766 if (buf) retspec = buf;
1767 else if (ts) New(1312,retspec,retlen+16,char);
1768 else retspec = __fileify_retbuf;
1769 cp1 = strstr(esa,"][");
1771 memcpy(retspec,esa,dirlen);
1772 if (!strncmp(cp1+2,"000000]",7)) {
1773 retspec[dirlen-1] = '\0';
1774 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1775 if (*cp1 == '.') *cp1 = ']';
1777 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1778 memcpy(cp1+1,"000000]",7);
1782 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1783 retspec[retlen] = '\0';
1784 /* Convert last '.' to ']' */
1785 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1786 if (*cp1 == '.') *cp1 = ']';
1788 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1789 memcpy(cp1+1,"000000]",7);
1793 else { /* This is a top-level dir. Add the MFD to the path. */
1794 if (buf) retspec = buf;
1795 else if (ts) New(1312,retspec,retlen+16,char);
1796 else retspec = __fileify_retbuf;
1799 while (*cp1 != ':') *(cp2++) = *(cp1++);
1800 strcpy(cp2,":[000000]");
1805 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1806 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1807 /* We've set up the string up through the filename. Add the
1808 type and version, and we're done. */
1809 strcat(retspec,".DIR;1");
1811 /* $PARSE may have upcased filespec, so convert output to lower
1812 * case if input contained any lowercase characters. */
1813 if (haslower) __mystrtolower(retspec);
1816 } /* end of do_fileify_dirspec() */
1818 /* External entry points */
1819 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
1820 { return do_fileify_dirspec(dir,buf,0); }
1821 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
1822 { return do_fileify_dirspec(dir,buf,1); }
1824 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1825 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
1827 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1828 unsigned long int retlen;
1829 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1831 if (!dir || !*dir) {
1832 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1835 if (*dir) strcpy(trndir,dir);
1836 else getcwd(trndir,sizeof trndir - 1);
1838 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1839 && my_trnlnm(trndir,trndir,0)) {
1840 STRLEN trnlen = strlen(trndir);
1842 /* Trap simple rooted lnms, and return lnm:[000000] */
1843 if (!strcmp(trndir+trnlen-2,".]")) {
1844 if (buf) retpath = buf;
1845 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1846 else retpath = __pathify_retbuf;
1847 strcpy(retpath,dir);
1848 strcat(retpath,":[000000]");
1854 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1855 if (*dir == '.' && (*(dir+1) == '\0' ||
1856 (*(dir+1) == '.' && *(dir+2) == '\0')))
1857 retlen = 2 + (*(dir+1) != '\0');
1859 if ( !(cp1 = strrchr(dir,'/')) &&
1860 !(cp1 = strrchr(dir,']')) &&
1861 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1862 if ((cp2 = strchr(cp1,'.')) != NULL &&
1863 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1864 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1865 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1866 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1868 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1869 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1870 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1871 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1872 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1873 (ver || *cp3)))))) {
1875 set_vaxc_errno(RMS$_DIR);
1878 retlen = cp2 - dir + 1;
1880 else { /* No file type present. Treat the filename as a directory. */
1881 retlen = strlen(dir) + 1;
1884 if (buf) retpath = buf;
1885 else if (ts) New(1313,retpath,retlen+1,char);
1886 else retpath = __pathify_retbuf;
1887 strncpy(retpath,dir,retlen-1);
1888 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1889 retpath[retlen-1] = '/'; /* with '/', add it. */
1890 retpath[retlen] = '\0';
1892 else retpath[retlen-1] = '\0';
1894 else { /* VMS-style directory spec */
1895 char esa[NAM$C_MAXRSS+1], *cp;
1896 unsigned long int sts, cmplen, haslower;
1897 struct FAB dirfab = cc$rms_fab;
1898 struct NAM savnam, dirnam = cc$rms_nam;
1900 /* If we've got an explicit filename, we can just shuffle the string. */
1901 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1902 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1903 if ((cp2 = strchr(cp1,'.')) != NULL) {
1905 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1906 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1907 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1908 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1909 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1910 (ver || *cp3)))))) {
1912 set_vaxc_errno(RMS$_DIR);
1916 else { /* No file type, so just draw name into directory part */
1917 for (cp2 = cp1; *cp2; cp2++) ;
1920 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1922 /* We've now got a VMS 'path'; fall through */
1924 dirfab.fab$b_fns = strlen(dir);
1925 dirfab.fab$l_fna = dir;
1926 if (dir[dirfab.fab$b_fns-1] == ']' ||
1927 dir[dirfab.fab$b_fns-1] == '>' ||
1928 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1929 if (buf) retpath = buf;
1930 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1931 else retpath = __pathify_retbuf;
1932 strcpy(retpath,dir);
1935 dirfab.fab$l_dna = ".DIR;1";
1936 dirfab.fab$b_dns = 6;
1937 dirfab.fab$l_nam = &dirnam;
1938 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1939 dirnam.nam$l_esa = esa;
1941 for (cp = dir; *cp; cp++)
1942 if (islower(*cp)) { haslower = 1; break; }
1944 if (!(sts = (sys$parse(&dirfab)&1))) {
1945 if (dirfab.fab$l_sts == RMS$_DIR) {
1946 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1947 sts = sys$parse(&dirfab) & 1;
1951 set_vaxc_errno(dirfab.fab$l_sts);
1957 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1958 if (dirfab.fab$l_sts != RMS$_FNF) {
1959 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1960 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1962 set_vaxc_errno(dirfab.fab$l_sts);
1965 dirnam = savnam; /* No; just work with potential name */
1968 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1969 /* Yep; check version while we're at it, if it's there. */
1970 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1971 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1972 /* Something other than .DIR[;1]. Bzzt. */
1973 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1974 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1976 set_vaxc_errno(RMS$_DIR);
1980 /* OK, the type was fine. Now pull any file name into the
1982 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1984 cp1 = strrchr(esa,'>');
1985 *dirnam.nam$l_type = '>';
1988 *(dirnam.nam$l_type + 1) = '\0';
1989 retlen = dirnam.nam$l_type - esa + 2;
1990 if (buf) retpath = buf;
1991 else if (ts) New(1314,retpath,retlen,char);
1992 else retpath = __pathify_retbuf;
1993 strcpy(retpath,esa);
1994 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1995 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1996 /* $PARSE may have upcased filespec, so convert output to lower
1997 * case if input contained any lowercase characters. */
1998 if (haslower) __mystrtolower(retpath);
2002 } /* end of do_pathify_dirspec() */
2004 /* External entry points */
2005 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2006 { return do_pathify_dirspec(dir,buf,0); }
2007 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
2008 { return do_pathify_dirspec(dir,buf,1); }
2010 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
2011 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
2013 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
2014 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
2015 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
2017 if (spec == NULL) return NULL;
2018 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
2019 if (buf) rslt = buf;
2021 retlen = strlen(spec);
2022 cp1 = strchr(spec,'[');
2023 if (!cp1) cp1 = strchr(spec,'<');
2025 for (cp1++; *cp1; cp1++) {
2026 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
2027 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2028 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2031 New(1315,rslt,retlen+2+2*expand,char);
2033 else rslt = __tounixspec_retbuf;
2034 if (strchr(spec,'/') != NULL) {
2041 dirend = strrchr(spec,']');
2042 if (dirend == NULL) dirend = strrchr(spec,'>');
2043 if (dirend == NULL) dirend = strchr(spec,':');
2044 if (dirend == NULL) {
2048 if (*cp2 != '[' && *cp2 != '<') {
2051 else { /* the VMS spec begins with directories */
2053 if (*cp2 == ']' || *cp2 == '>') {
2054 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2057 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2058 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2059 if (ts) Safefree(rslt);
2064 while (*cp3 != ':' && *cp3) cp3++;
2066 if (strchr(cp3,']') != NULL) break;
2067 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2069 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2070 retlen = devlen + dirlen;
2071 Renew(rslt,retlen+1+2*expand,char);
2077 *(cp1++) = *(cp3++);
2078 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2082 else if ( *cp2 == '.') {
2083 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2084 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2090 for (; cp2 <= dirend; cp2++) {
2093 if (*(cp2+1) == '[') cp2++;
2095 else if (*cp2 == ']' || *cp2 == '>') {
2096 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2098 else if (*cp2 == '.') {
2100 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2101 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2102 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2103 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2104 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2106 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2107 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2111 else if (*cp2 == '-') {
2112 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2113 while (*cp2 == '-') {
2115 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2117 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2118 if (ts) Safefree(rslt); /* filespecs like */
2119 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2123 else *(cp1++) = *cp2;
2125 else *(cp1++) = *cp2;
2127 while (*cp2) *(cp1++) = *(cp2++);
2132 } /* end of do_tounixspec() */
2134 /* External entry points */
2135 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2136 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2138 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2139 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
2140 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2141 char *rslt, *dirend;
2142 register char *cp1, *cp2;
2143 unsigned long int infront = 0, hasdir = 1;
2145 if (path == NULL) return NULL;
2146 if (buf) rslt = buf;
2147 else if (ts) New(1316,rslt,strlen(path)+9,char);
2148 else rslt = __tovmsspec_retbuf;
2149 if (strpbrk(path,"]:>") ||
2150 (dirend = strrchr(path,'/')) == NULL) {
2151 if (path[0] == '.') {
2152 if (path[1] == '\0') strcpy(rslt,"[]");
2153 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2154 else strcpy(rslt,path); /* probably garbage */
2156 else strcpy(rslt,path);
2159 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2160 if (!*(dirend+2)) dirend +=2;
2161 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2162 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2167 char trndev[NAM$C_MAXRSS+1];
2171 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2173 if (!buf & ts) Renew(rslt,18,char);
2174 strcpy(rslt,"sys$disk:[000000]");
2177 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2179 islnm = my_trnlnm(rslt,trndev,0);
2180 trnend = islnm ? strlen(trndev) - 1 : 0;
2181 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2182 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2183 /* If the first element of the path is a logical name, determine
2184 * whether it has to be translated so we can add more directories. */
2185 if (!islnm || rooted) {
2188 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2192 if (cp2 != dirend) {
2193 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2194 strcpy(rslt,trndev);
2195 cp1 = rslt + trnend;
2208 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2209 cp2 += 2; /* skip over "./" - it's redundant */
2210 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2212 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2213 *(cp1++) = '-'; /* "../" --> "-" */
2216 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2217 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2218 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2219 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2222 if (cp2 > dirend) cp2 = dirend;
2224 else *(cp1++) = '.';
2226 for (; cp2 < dirend; cp2++) {
2228 if (*(cp2-1) == '/') continue;
2229 if (*(cp1-1) != '.') *(cp1++) = '.';
2232 else if (!infront && *cp2 == '.') {
2233 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2234 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2235 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2236 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2237 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2238 else { /* back up over previous directory name */
2240 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2241 if (*(cp1-1) == '[') {
2242 memcpy(cp1,"000000.",7);
2247 if (cp2 == dirend) break;
2249 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2250 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2251 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2252 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2254 *(cp1++) = '.'; /* Simulate trailing '/' */
2255 cp2 += 2; /* for loop will incr this to == dirend */
2257 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2259 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2262 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2263 if (*cp2 == '.') *(cp1++) = '_';
2264 else *(cp1++) = *cp2;
2268 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2269 if (hasdir) *(cp1++) = ']';
2270 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2271 while (*cp2) *(cp1++) = *(cp2++);
2276 } /* end of do_tovmsspec() */
2278 /* External entry points */
2279 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2280 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2282 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2283 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
2284 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2286 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2288 if (path == NULL) return NULL;
2289 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2290 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2291 if (buf) return buf;
2293 vmslen = strlen(vmsified);
2294 New(1317,cp,vmslen+1,char);
2295 memcpy(cp,vmsified,vmslen);
2300 strcpy(__tovmspath_retbuf,vmsified);
2301 return __tovmspath_retbuf;
2304 } /* end of do_tovmspath() */
2306 /* External entry points */
2307 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
2308 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
2311 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2312 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
2313 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2315 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2317 if (path == NULL) return NULL;
2318 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2319 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2320 if (buf) return buf;
2322 unixlen = strlen(unixified);
2323 New(1317,cp,unixlen+1,char);
2324 memcpy(cp,unixified,unixlen);
2329 strcpy(__tounixpath_retbuf,unixified);
2330 return __tounixpath_retbuf;
2333 } /* end of do_tounixpath() */
2335 /* External entry points */
2336 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
2337 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
2340 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2342 *****************************************************************************
2344 * Copyright (C) 1989-1994 by *
2345 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2347 * Permission is hereby granted for the reproduction of this software, *
2348 * on condition that this copyright notice is included in the reproduction, *
2349 * and that such reproduction is not for purposes of profit or material *
2352 * 27-Aug-1994 Modified for inclusion in perl5 *
2353 * by Charles Bailey bailey@newman.upenn.edu *
2354 *****************************************************************************
2358 * getredirection() is intended to aid in porting C programs
2359 * to VMS (Vax-11 C). The native VMS environment does not support
2360 * '>' and '<' I/O redirection, or command line wild card expansion,
2361 * or a command line pipe mechanism using the '|' AND background
2362 * command execution '&'. All of these capabilities are provided to any
2363 * C program which calls this procedure as the first thing in the
2365 * The piping mechanism will probably work with almost any 'filter' type
2366 * of program. With suitable modification, it may useful for other
2367 * portability problems as well.
2369 * Author: Mark Pizzolato mark@infocomm.com
2373 struct list_item *next;
2377 static void add_item(struct list_item **head,
2378 struct list_item **tail,
2382 static void mp_expand_wild_cards(pTHX_ char *item,
2383 struct list_item **head,
2384 struct list_item **tail,
2387 static int background_process(int argc, char **argv);
2389 static void pipe_and_fork(char **cmargv);
2391 /*{{{ void getredirection(int *ac, char ***av)*/
2393 mp_getredirection(pTHX_ int *ac, char ***av)
2395 * Process vms redirection arg's. Exit if any error is seen.
2396 * If getredirection() processes an argument, it is erased
2397 * from the vector. getredirection() returns a new argc and argv value.
2398 * In the event that a background command is requested (by a trailing "&"),
2399 * this routine creates a background subprocess, and simply exits the program.
2401 * Warning: do not try to simplify the code for vms. The code
2402 * presupposes that getredirection() is called before any data is
2403 * read from stdin or written to stdout.
2405 * Normal usage is as follows:
2411 * getredirection(&argc, &argv);
2415 int argc = *ac; /* Argument Count */
2416 char **argv = *av; /* Argument Vector */
2417 char *ap; /* Argument pointer */
2418 int j; /* argv[] index */
2419 int item_count = 0; /* Count of Items in List */
2420 struct list_item *list_head = 0; /* First Item in List */
2421 struct list_item *list_tail; /* Last Item in List */
2422 char *in = NULL; /* Input File Name */
2423 char *out = NULL; /* Output File Name */
2424 char *outmode = "w"; /* Mode to Open Output File */
2425 char *err = NULL; /* Error File Name */
2426 char *errmode = "w"; /* Mode to Open Error File */
2427 int cmargc = 0; /* Piped Command Arg Count */
2428 char **cmargv = NULL;/* Piped Command Arg Vector */
2431 * First handle the case where the last thing on the line ends with
2432 * a '&'. This indicates the desire for the command to be run in a
2433 * subprocess, so we satisfy that desire.
2436 if (0 == strcmp("&", ap))
2437 exit(background_process(--argc, argv));
2438 if (*ap && '&' == ap[strlen(ap)-1])
2440 ap[strlen(ap)-1] = '\0';
2441 exit(background_process(argc, argv));
2444 * Now we handle the general redirection cases that involve '>', '>>',
2445 * '<', and pipes '|'.
2447 for (j = 0; j < argc; ++j)
2449 if (0 == strcmp("<", argv[j]))
2453 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2454 exit(LIB$_WRONUMARG);
2459 if ('<' == *(ap = argv[j]))
2464 if (0 == strcmp(">", ap))
2468 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2469 exit(LIB$_WRONUMARG);
2488 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2489 exit(LIB$_WRONUMARG);
2493 if (('2' == *ap) && ('>' == ap[1]))
2510 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2511 exit(LIB$_WRONUMARG);
2515 if (0 == strcmp("|", argv[j]))
2519 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2520 exit(LIB$_WRONUMARG);
2522 cmargc = argc-(j+1);
2523 cmargv = &argv[j+1];
2527 if ('|' == *(ap = argv[j]))
2535 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2538 * Allocate and fill in the new argument vector, Some Unix's terminate
2539 * the list with an extra null pointer.
2541 New(1302, argv, item_count+1, char *);
2543 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2544 argv[j] = list_head->value;
2550 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2551 exit(LIB$_INVARGORD);
2553 pipe_and_fork(cmargv);
2556 /* Check for input from a pipe (mailbox) */
2558 if (in == NULL && 1 == isapipe(0))
2560 char mbxname[L_tmpnam];
2562 long int dvi_item = DVI$_DEVBUFSIZ;
2563 $DESCRIPTOR(mbxnam, "");
2564 $DESCRIPTOR(mbxdevnam, "");
2566 /* Input from a pipe, reopen it in binary mode to disable */
2567 /* carriage control processing. */
2569 PerlIO_getname(stdin, mbxname);
2570 mbxnam.dsc$a_pointer = mbxname;
2571 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2572 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2573 mbxdevnam.dsc$a_pointer = mbxname;
2574 mbxdevnam.dsc$w_length = sizeof(mbxname);
2575 dvi_item = DVI$_DEVNAM;
2576 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2577 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2580 freopen(mbxname, "rb", stdin);
2583 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2587 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2589 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2592 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2594 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2598 if (strcmp(err,"&1") == 0) {
2599 dup2(fileno(stdout), fileno(Perl_debug_log));
2602 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2604 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2608 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2614 #ifdef ARGPROC_DEBUG
2615 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2616 for (j = 0; j < *ac; ++j)
2617 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2619 /* Clear errors we may have hit expanding wildcards, so they don't
2620 show up in Perl's $! later */
2621 set_errno(0); set_vaxc_errno(1);
2622 } /* end of getredirection() */
2625 static void add_item(struct list_item **head,
2626 struct list_item **tail,
2632 New(1303,*head,1,struct list_item);
2636 New(1304,(*tail)->next,1,struct list_item);
2637 *tail = (*tail)->next;
2639 (*tail)->value = value;
2643 static void mp_expand_wild_cards(pTHX_ char *item,
2644 struct list_item **head,
2645 struct list_item **tail,
2649 unsigned long int context = 0;
2655 char vmsspec[NAM$C_MAXRSS+1];
2656 $DESCRIPTOR(filespec, "");
2657 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2658 $DESCRIPTOR(resultspec, "");
2659 unsigned long int zero = 0, sts;
2661 for (cp = item; *cp; cp++) {
2662 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2663 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2665 if (!*cp || isspace(*cp))
2667 add_item(head, tail, item, count);
2670 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2671 resultspec.dsc$b_class = DSC$K_CLASS_D;
2672 resultspec.dsc$a_pointer = NULL;
2673 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2674 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2675 if (!isunix || !filespec.dsc$a_pointer)
2676 filespec.dsc$a_pointer = item;
2677 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2679 * Only return version specs, if the caller specified a version
2681 had_version = strchr(item, ';');
2683 * Only return device and directory specs, if the caller specifed either.
2685 had_device = strchr(item, ':');
2686 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2688 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2689 &defaultspec, 0, 0, &zero))))
2694 New(1305,string,resultspec.dsc$w_length+1,char);
2695 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2696 string[resultspec.dsc$w_length] = '\0';
2697 if (NULL == had_version)
2698 *((char *)strrchr(string, ';')) = '\0';
2699 if ((!had_directory) && (had_device == NULL))
2701 if (NULL == (devdir = strrchr(string, ']')))
2702 devdir = strrchr(string, '>');
2703 strcpy(string, devdir + 1);
2706 * Be consistent with what the C RTL has already done to the rest of
2707 * the argv items and lowercase all of these names.
2709 for (c = string; *c; ++c)
2712 if (isunix) trim_unixpath(string,item,1);
2713 add_item(head, tail, string, count);
2716 if (sts != RMS$_NMF)
2718 set_vaxc_errno(sts);
2721 case RMS$_FNF: case RMS$_DNF:
2722 set_errno(ENOENT); break;
2724 set_errno(ENOTDIR); break;
2726 set_errno(ENODEV); break;
2727 case RMS$_FNM: case RMS$_SYN:
2728 set_errno(EINVAL); break;
2730 set_errno(EACCES); break;
2732 _ckvmssts_noperl(sts);
2736 add_item(head, tail, item, count);
2737 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2738 _ckvmssts_noperl(lib$find_file_end(&context));
2741 static int child_st[2];/* Event Flag set when child process completes */
2743 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2745 static unsigned long int exit_handler(int *status)
2749 if (0 == child_st[0])
2751 #ifdef ARGPROC_DEBUG
2752 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2754 fflush(stdout); /* Have to flush pipe for binary data to */
2755 /* terminate properly -- <tp@mccall.com> */
2756 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2757 sys$dassgn(child_chan);
2759 sys$synch(0, child_st);
2764 static void sig_child(int chan)
2766 #ifdef ARGPROC_DEBUG
2767 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2769 if (child_st[0] == 0)
2773 static struct exit_control_block exit_block =
2778 &exit_block.exit_status,
2782 static void pipe_and_fork(char **cmargv)
2785 $DESCRIPTOR(cmddsc, "");
2786 static char mbxname[64];
2787 $DESCRIPTOR(mbxdsc, mbxname);
2789 unsigned long int zero = 0, one = 1;
2791 strcpy(subcmd, cmargv[0]);
2792 for (j = 1; NULL != cmargv[j]; ++j)
2794 strcat(subcmd, " \"");
2795 strcat(subcmd, cmargv[j]);
2796 strcat(subcmd, "\"");
2798 cmddsc.dsc$a_pointer = subcmd;
2799 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2801 create_mbx(&child_chan,&mbxdsc);
2802 #ifdef ARGPROC_DEBUG
2803 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2804 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2806 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2807 0, &pid, child_st, &zero, sig_child,
2809 #ifdef ARGPROC_DEBUG
2810 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2812 sys$dclexh(&exit_block);
2813 if (NULL == freopen(mbxname, "wb", stdout))
2815 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2819 static int background_process(int argc, char **argv)
2821 char command[2048] = "$";
2822 $DESCRIPTOR(value, "");
2823 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2824 static $DESCRIPTOR(null, "NLA0:");
2825 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2827 $DESCRIPTOR(pidstr, "");
2829 unsigned long int flags = 17, one = 1, retsts;
2831 strcat(command, argv[0]);
2834 strcat(command, " \"");
2835 strcat(command, *(++argv));
2836 strcat(command, "\"");
2838 value.dsc$a_pointer = command;
2839 value.dsc$w_length = strlen(value.dsc$a_pointer);
2840 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2841 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2842 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2843 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2846 _ckvmssts_noperl(retsts);
2848 #ifdef ARGPROC_DEBUG
2849 PerlIO_printf(Perl_debug_log, "%s\n", command);
2851 sprintf(pidstring, "%08X", pid);
2852 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2853 pidstr.dsc$a_pointer = pidstring;
2854 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2855 lib$set_symbol(&pidsymbol, &pidstr);
2859 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2862 /* OS-specific initialization at image activation (not thread startup) */
2863 /* Older VAXC header files lack these constants */
2864 #ifndef JPI$_RIGHTS_SIZE
2865 # define JPI$_RIGHTS_SIZE 817
2867 #ifndef KGB$M_SUBSYSTEM
2868 # define KGB$M_SUBSYSTEM 0x8
2871 /*{{{void vms_image_init(int *, char ***)*/
2873 vms_image_init(int *argcp, char ***argvp)
2875 char eqv[LNM$C_NAMLENGTH+1] = "";
2876 unsigned int len, tabct = 8, tabidx = 0;
2877 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2878 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2879 unsigned short int dummy, rlen;
2880 struct dsc$descriptor_s **tabvec;
2882 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2883 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2884 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2887 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2889 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2890 if (iprv[i]) { /* Running image installed with privs? */
2891 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2896 /* Rights identifiers might trigger tainting as well. */
2897 if (!will_taint && (rlen || rsz)) {
2898 while (rlen < rsz) {
2899 /* We didn't get all the identifiers on the first pass. Allocate a
2900 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2901 * were needed to hold all identifiers at time of last call; we'll
2902 * allocate that many unsigned long ints), and go back and get 'em.
2904 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2905 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2906 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2907 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2910 mask = jpilist[1].bufadr;
2911 /* Check attribute flags for each identifier (2nd longword); protected
2912 * subsystem identifiers trigger tainting.
2914 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2915 if (mask[i] & KGB$M_SUBSYSTEM) {
2920 if (mask != rlst) Safefree(mask);
2922 /* We need to use this hack to tell Perl it should run with tainting,
2923 * since its tainting flag may be part of the PL_curinterp struct, which
2924 * hasn't been allocated when vms_image_init() is called.
2928 New(1320,newap,*argcp+2,char **);
2929 newap[0] = argvp[0];
2931 Copy(argvp[1],newap[2],*argcp-1,char **);
2932 /* We orphan the old argv, since we don't know where it's come from,
2933 * so we don't know how to free it.
2935 *argcp++; argvp = newap;
2937 else { /* Did user explicitly request tainting? */
2939 char *cp, **av = *argvp;
2940 for (i = 1; i < *argcp; i++) {
2941 if (*av[i] != '-') break;
2942 for (cp = av[i]+1; *cp; cp++) {
2943 if (*cp == 'T') { will_taint = 1; break; }
2944 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2945 strchr("DFIiMmx",*cp)) break;
2947 if (will_taint) break;
2952 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2954 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2955 else if (tabidx >= tabct) {
2957 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2959 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2960 tabvec[tabidx]->dsc$w_length = 0;
2961 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2962 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2963 tabvec[tabidx]->dsc$a_pointer = NULL;
2964 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2966 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2968 getredirection(argcp,argvp);
2969 #if defined(USE_THREADS) && defined(__DECC)
2971 # include <reentrancy.h>
2972 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2981 * Trim Unix-style prefix off filespec, so it looks like what a shell
2982 * glob expansion would return (i.e. from specified prefix on, not
2983 * full path). Note that returned filespec is Unix-style, regardless
2984 * of whether input filespec was VMS-style or Unix-style.
2986 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2987 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2988 * vector of options; at present, only bit 0 is used, and if set tells
2989 * trim unixpath to try the current default directory as a prefix when
2990 * presented with a possibly ambiguous ... wildcard.
2992 * Returns !=0 on success, with trimmed filespec replacing contents of
2993 * fspec, and 0 on failure, with contents of fpsec unchanged.
2995 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2997 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
2999 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3000 *template, *base, *end, *cp1, *cp2;
3001 register int tmplen, reslen = 0, dirs = 0;
3003 if (!wildspec || !fspec) return 0;
3004 if (strpbrk(wildspec,"]>:") != NULL) {
3005 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3006 else template = unixwild;
3008 else template = wildspec;
3009 if (strpbrk(fspec,"]>:") != NULL) {
3010 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3011 else base = unixified;
3012 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
3013 * check to see that final result fits into (isn't longer than) fspec */
3014 reslen = strlen(fspec);
3018 /* No prefix or absolute path on wildcard, so nothing to remove */
3019 if (!*template || *template == '/') {
3020 if (base == fspec) return 1;
3021 tmplen = strlen(unixified);
3022 if (tmplen > reslen) return 0; /* not enough space */
3023 /* Copy unixified resultant, including trailing NUL */
3024 memmove(fspec,unixified,tmplen+1);
3028 for (end = base; *end; end++) ; /* Find end of resultant filespec */
3029 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3030 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3031 for (cp1 = end ;cp1 >= base; cp1--)
3032 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3034 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3038 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3039 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3040 int ells = 1, totells, segdirs, match;
3041 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3042 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3044 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3046 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3047 if (ellipsis == template && opts & 1) {
3048 /* Template begins with an ellipsis. Since we can't tell how many
3049 * directory names at the front of the resultant to keep for an
3050 * arbitrary starting point, we arbitrarily choose the current
3051 * default directory as a starting point. If it's there as a prefix,
3052 * clip it off. If not, fall through and act as if the leading
3053 * ellipsis weren't there (i.e. return shortest possible path that
3054 * could match template).
3056 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3057 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3058 if (_tolower(*cp1) != _tolower(*cp2)) break;
3059 segdirs = dirs - totells; /* Min # of dirs we must have left */
3060 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3061 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3062 memcpy(fspec,cp2+1,end - cp2);
3066 /* First off, back up over constant elements at end of path */
3068 for (front = end ; front >= base; front--)
3069 if (*front == '/' && !dirs--) { front++; break; }
3071 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3072 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3073 if (cp1 != '\0') return 0; /* Path too long. */
3075 *cp2 = '\0'; /* Pick up with memcpy later */
3076 lcfront = lcres + (front - base);
3077 /* Now skip over each ellipsis and try to match the path in front of it. */
3079 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3080 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3081 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3082 if (cp1 < template) break; /* template started with an ellipsis */
3083 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3084 ellipsis = cp1; continue;
3086 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3088 for (segdirs = 0, cp2 = tpl;
3089 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3091 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3092 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3093 if (*cp2 == '/') segdirs++;
3095 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3096 /* Back up at least as many dirs as in template before matching */
3097 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3098 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3099 for (match = 0; cp1 > lcres;) {
3100 resdsc.dsc$a_pointer = cp1;
3101 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3103 if (match == 1) lcfront = cp1;
3105 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3107 if (!match) return 0; /* Can't find prefix ??? */
3108 if (match > 1 && opts & 1) {
3109 /* This ... wildcard could cover more than one set of dirs (i.e.
3110 * a set of similar dir names is repeated). If the template
3111 * contains more than 1 ..., upstream elements could resolve the
3112 * ambiguity, but it's not worth a full backtracking setup here.
3113 * As a quick heuristic, clip off the current default directory
3114 * if it's present to find the trimmed spec, else use the
3115 * shortest string that this ... could cover.
3117 char def[NAM$C_MAXRSS+1], *st;
3119 if (getcwd(def, sizeof def,0) == NULL) return 0;
3120 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3121 if (_tolower(*cp1) != _tolower(*cp2)) break;
3122 segdirs = dirs - totells; /* Min # of dirs we must have left */
3123 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3124 if (*cp1 == '\0' && *cp2 == '/') {
3125 memcpy(fspec,cp2+1,end - cp2);
3128 /* Nope -- stick with lcfront from above and keep going. */
3131 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3136 } /* end of trim_unixpath() */
3141 * VMS readdir() routines.
3142 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3144 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3145 * Minor modifications to original routines.
3148 /* Number of elements in vms_versions array */
3149 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3152 * Open a directory, return a handle for later use.
3154 /*{{{ DIR *opendir(char*name) */
3156 Perl_opendir(pTHX_ char *name)
3159 char dir[NAM$C_MAXRSS+1];
3162 if (do_tovmspath(name,dir,0) == NULL) {
3165 if (flex_stat(dir,&sb) == -1) return NULL;
3166 if (!S_ISDIR(sb.st_mode)) {
3167 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3170 if (!cando_by_name(S_IRUSR,0,dir)) {
3171 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3174 /* Get memory for the handle, and the pattern. */
3176 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3178 /* Fill in the fields; mainly playing with the descriptor. */
3179 (void)sprintf(dd->pattern, "%s*.*",dir);
3182 dd->vms_wantversions = 0;
3183 dd->pat.dsc$a_pointer = dd->pattern;
3184 dd->pat.dsc$w_length = strlen(dd->pattern);
3185 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3186 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3189 } /* end of opendir() */
3193 * Set the flag to indicate we want versions or not.
3195 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3197 vmsreaddirversions(DIR *dd, int flag)
3199 dd->vms_wantversions = flag;
3204 * Free up an opened directory.
3206 /*{{{ void closedir(DIR *dd)*/
3210 (void)lib$find_file_end(&dd->context);
3211 Safefree(dd->pattern);
3212 Safefree((char *)dd);
3217 * Collect all the version numbers for the current file.
3223 struct dsc$descriptor_s pat;
3224 struct dsc$descriptor_s res;
3226 char *p, *text, buff[sizeof dd->entry.d_name];
3228 unsigned long context, tmpsts;
3231 /* Convenient shorthand. */
3234 /* Add the version wildcard, ignoring the "*.*" put on before */
3235 i = strlen(dd->pattern);
3236 New(1308,text,i + e->d_namlen + 3,char);
3237 (void)strcpy(text, dd->pattern);
3238 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3240 /* Set up the pattern descriptor. */
3241 pat.dsc$a_pointer = text;
3242 pat.dsc$w_length = i + e->d_namlen - 1;
3243 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3244 pat.dsc$b_class = DSC$K_CLASS_S;
3246 /* Set up result descriptor. */
3247 res.dsc$a_pointer = buff;
3248 res.dsc$w_length = sizeof buff - 2;
3249 res.dsc$b_dtype = DSC$K_DTYPE_T;
3250 res.dsc$b_class = DSC$K_CLASS_S;
3252 /* Read files, collecting versions. */
3253 for (context = 0, e->vms_verscount = 0;
3254 e->vms_verscount < VERSIZE(e);
3255 e->vms_verscount++) {
3256 tmpsts = lib$find_file(&pat, &res, &context);
3257 if (tmpsts == RMS$_NMF || context == 0) break;
3259 buff[sizeof buff - 1] = '\0';
3260 if ((p = strchr(buff, ';')))
3261 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3263 e->vms_versions[e->vms_verscount] = -1;
3266 _ckvmssts(lib$find_file_end(&context));
3269 } /* end of collectversions() */
3272 * Read the next entry from the directory.
3274 /*{{{ struct dirent *readdir(DIR *dd)*/
3278 struct dsc$descriptor_s res;
3279 char *p, buff[sizeof dd->entry.d_name];
3280 unsigned long int tmpsts;
3282 /* Set up result descriptor, and get next file. */
3283 res.dsc$a_pointer = buff;
3284 res.dsc$w_length = sizeof buff - 2;
3285 res.dsc$b_dtype = DSC$K_DTYPE_T;
3286 res.dsc$b_class = DSC$K_CLASS_S;
3287 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3288 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3289 if (!(tmpsts & 1)) {
3290 set_vaxc_errno(tmpsts);
3293 set_errno(EACCES); break;
3295 set_errno(ENODEV); break;
3297 set_errno(ENOTDIR); break;
3298 case RMS$_FNF: case RMS$_DNF:
3299 set_errno(ENOENT); break;
3306 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3307 buff[sizeof buff - 1] = '\0';
3308 for (p = buff; *p; p++) *p = _tolower(*p);
3309 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3312 /* Skip any directory component and just copy the name. */
3313 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3314 else (void)strcpy(dd->entry.d_name, buff);
3316 /* Clobber the version. */
3317 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3319 dd->entry.d_namlen = strlen(dd->entry.d_name);
3320 dd->entry.vms_verscount = 0;
3321 if (dd->vms_wantversions) collectversions(dd);
3324 } /* end of readdir() */
3328 * Return something that can be used in a seekdir later.
3330 /*{{{ long telldir(DIR *dd)*/
3339 * Return to a spot where we used to be. Brute force.
3341 /*{{{ void seekdir(DIR *dd,long count)*/
3343 seekdir(DIR *dd, long count)
3345 int vms_wantversions;
3348 /* If we haven't done anything yet... */
3352 /* Remember some state, and clear it. */
3353 vms_wantversions = dd->vms_wantversions;
3354 dd->vms_wantversions = 0;
3355 _ckvmssts(lib$find_file_end(&dd->context));
3358 /* The increment is in readdir(). */
3359 for (dd->count = 0; dd->count < count; )
3362 dd->vms_wantversions = vms_wantversions;
3364 } /* end of seekdir() */
3367 /* VMS subprocess management
3369 * my_vfork() - just a vfork(), after setting a flag to record that
3370 * the current script is trying a Unix-style fork/exec.
3372 * vms_do_aexec() and vms_do_exec() are called in response to the
3373 * perl 'exec' function. If this follows a vfork call, then they
3374 * call out the the regular perl routines in doio.c which do an
3375 * execvp (for those who really want to try this under VMS).
3376 * Otherwise, they do exactly what the perl docs say exec should
3377 * do - terminate the current script and invoke a new command
3378 * (See below for notes on command syntax.)
3380 * do_aspawn() and do_spawn() implement the VMS side of the perl
3381 * 'system' function.
3383 * Note on command arguments to perl 'exec' and 'system': When handled
3384 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3385 * are concatenated to form a DCL command string. If the first arg
3386 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3387 * the the command string is handed off to DCL directly. Otherwise,
3388 * the first token of the command is taken as the filespec of an image
3389 * to run. The filespec is expanded using a default type of '.EXE' and
3390 * the process defaults for device, directory, etc., and if found, the resultant
3391 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3392 * the command string as parameters. This is perhaps a bit complicated,
3393 * but I hope it will form a happy medium between what VMS folks expect
3394 * from lib$spawn and what Unix folks expect from exec.
3397 static int vfork_called;
3399 /*{{{int my_vfork()*/
3410 vms_execfree(pTHX) {
3412 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3415 if (VMScmd.dsc$a_pointer) {
3416 Safefree(VMScmd.dsc$a_pointer);
3417 VMScmd.dsc$w_length = 0;
3418 VMScmd.dsc$a_pointer = Nullch;
3423 setup_argstr(SV *really, SV **mark, SV **sp)
3426 char *junk, *tmps = Nullch;
3427 register size_t cmdlen = 0;
3434 tmps = SvPV(really,rlen);
3441 for (idx++; idx <= sp; idx++) {
3443 junk = SvPVx(*idx,rlen);
3444 cmdlen += rlen ? rlen + 1 : 0;
3447 New(401,PL_Cmd,cmdlen+1,char);
3449 if (tmps && *tmps) {
3450 strcpy(PL_Cmd,tmps);
3453 else *PL_Cmd = '\0';
3454 while (++mark <= sp) {
3456 char *s = SvPVx(*mark,n_a);
3458 if (*PL_Cmd) strcat(PL_Cmd," ");
3464 } /* end of setup_argstr() */
3467 static unsigned long int
3468 setup_cmddsc(char *cmd, int check_img)
3470 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3471 $DESCRIPTOR(defdsc,".EXE");
3472 $DESCRIPTOR(defdsc2,".");
3473 $DESCRIPTOR(resdsc,resspec);
3474 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3475 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3476 register char *s, *rest, *cp, *wordbreak;
3481 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3484 while (*s && isspace(*s)) s++;
3486 if (*s == '@' || *s == '$') {
3487 vmsspec[0] = *s; rest = s + 1;
3488 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3490 else { cp = vmsspec; rest = s; }
3491 if (*rest == '.' || *rest == '/') {
3494 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3495 rest++, cp2++) *cp2 = *rest;
3497 if (do_tovmsspec(resspec,cp,0)) {
3500 for (cp2 = vmsspec + strlen(vmsspec);
3501 *rest && cp2 - vmsspec < sizeof vmsspec;
3502 rest++, cp2++) *cp2 = *rest;
3507 /* Intuit whether verb (first word of cmd) is a DCL command:
3508 * - if first nonspace char is '@', it's a DCL indirection
3510 * - if verb contains a filespec separator, it's not a DCL command
3511 * - if it doesn't, caller tells us whether to default to a DCL
3512 * command, or to a local image unless told it's DCL (by leading '$')
3514 if (*s == '@') isdcl = 1;
3516 register char *filespec = strpbrk(s,":<[.;");
3517 rest = wordbreak = strpbrk(s," \"\t/");
3518 if (!wordbreak) wordbreak = s + strlen(s);
3519 if (*s == '$') check_img = 0;
3520 if (filespec && (filespec < wordbreak)) isdcl = 0;
3521 else isdcl = !check_img;
3525 imgdsc.dsc$a_pointer = s;
3526 imgdsc.dsc$w_length = wordbreak - s;
3527 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3529 _ckvmssts(lib$find_file_end(&cxt));
3530 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3531 if (!(retsts & 1) && *s == '$') {
3532 _ckvmssts(lib$find_file_end(&cxt));
3533 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3534 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3536 _ckvmssts(lib$find_file_end(&cxt));
3537 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3541 _ckvmssts(lib$find_file_end(&cxt));
3546 while (*s && !isspace(*s)) s++;
3549 /* check that it's really not DCL with no file extension */
3550 fp = fopen(resspec,"r","ctx=bin,shr=get");
3552 char b[4] = {0,0,0,0};
3553 read(fileno(fp),b,4);
3554 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3557 if (check_img && isdcl) return RMS$_FNF;
3559 if (cando_by_name(S_IXUSR,0,resspec)) {
3560 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3562 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3564 strcpy(VMScmd.dsc$a_pointer,"@");
3566 strcat(VMScmd.dsc$a_pointer,resspec);
3567 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3568 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3571 else retsts = RMS$_PRV;
3574 /* It's either a DCL command or we couldn't find a suitable image */
3575 VMScmd.dsc$w_length = strlen(cmd);
3576 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3577 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3578 if (!(retsts & 1)) {
3579 /* just hand off status values likely to be due to user error */
3580 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3581 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3582 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3583 else { _ckvmssts(retsts); }
3586 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3588 } /* end of setup_cmddsc() */
3591 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3593 vms_do_aexec(SV *really,SV **mark,SV **sp)
3597 if (vfork_called) { /* this follows a vfork - act Unixish */
3599 if (vfork_called < 0) {
3600 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3603 else return do_aexec(really,mark,sp);
3605 /* no vfork - act VMSish */
3606 return vms_do_exec(setup_argstr(really,mark,sp));
3611 } /* end of vms_do_aexec() */
3614 /* {{{bool vms_do_exec(char *cmd) */
3616 vms_do_exec(char *cmd)
3620 if (vfork_called) { /* this follows a vfork - act Unixish */
3622 if (vfork_called < 0) {
3623 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3626 else return do_exec(cmd);
3629 { /* no vfork - act VMSish */
3630 unsigned long int retsts;
3633 TAINT_PROPER("exec");
3634 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3635 retsts = lib$do_command(&VMScmd);
3638 case RMS$_FNF: case RMS$_DNF:
3639 set_errno(ENOENT); break;
3641 set_errno(ENOTDIR); break;
3643 set_errno(ENODEV); break;
3645 set_errno(EACCES); break;
3647 set_errno(EINVAL); break;
3649 set_errno(E2BIG); break;
3650 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3651 _ckvmssts(retsts); /* fall through */
3652 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3655 set_vaxc_errno(retsts);
3656 if (ckWARN(WARN_EXEC)) {
3657 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3658 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3665 } /* end of vms_do_exec() */
3668 unsigned long int do_spawn(char *);
3670 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3672 do_aspawn(void *really,void **mark,void **sp)
3675 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3678 } /* end of do_aspawn() */
3681 /* {{{unsigned long int do_spawn(char *cmd) */
3685 unsigned long int sts, substs, hadcmd = 1;
3689 TAINT_PROPER("spawn");
3690 if (!cmd || !*cmd) {
3692 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3694 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3695 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3700 case RMS$_FNF: case RMS$_DNF:
3701 set_errno(ENOENT); break;
3703 set_errno(ENOTDIR); break;
3705 set_errno(ENODEV); break;
3707 set_errno(EACCES); break;
3709 set_errno(EINVAL); break;
3711 set_errno(E2BIG); break;
3712 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3713 _ckvmssts(sts); /* fall through */
3714 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3717 set_vaxc_errno(sts);
3718 if (ckWARN(WARN_EXEC)) {
3719 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3720 hadcmd ? VMScmd.dsc$w_length : 0,
3721 hadcmd ? VMScmd.dsc$a_pointer : "",
3728 } /* end of do_spawn() */
3732 * A simple fwrite replacement which outputs itmsz*nitm chars without
3733 * introducing record boundaries every itmsz chars.
3735 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3737 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3739 register char *cp, *end;
3741 end = (char *)src + itmsz * nitm;
3743 while ((char *)src <= end) {
3744 for (cp = src; cp <= end; cp++) if (!*cp) break;
3745 if (fputs(src,dest) == EOF) return EOF;
3747 if (fputc('\0',dest) == EOF) return EOF;
3753 } /* end of my_fwrite() */
3756 /*{{{ int my_flush(FILE *fp)*/
3761 if ((res = fflush(fp)) == 0 && fp) {
3762 #ifdef VMS_DO_SOCKETS
3764 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3766 res = fsync(fileno(fp));
3773 * Here are replacements for the following Unix routines in the VMS environment:
3774 * getpwuid Get information for a particular UIC or UID
3775 * getpwnam Get information for a named user
3776 * getpwent Get information for each user in the rights database
3777 * setpwent Reset search to the start of the rights database
3778 * endpwent Finish searching for users in the rights database
3780 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3781 * (defined in pwd.h), which contains the following fields:-
3783 * char *pw_name; Username (in lower case)
3784 * char *pw_passwd; Hashed password
3785 * unsigned int pw_uid; UIC
3786 * unsigned int pw_gid; UIC group number
3787 * char *pw_unixdir; Default device/directory (VMS-style)
3788 * char *pw_gecos; Owner name
3789 * char *pw_dir; Default device/directory (Unix-style)
3790 * char *pw_shell; Default CLI name (eg. DCL)
3792 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3794 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3795 * not the UIC member number (eg. what's returned by getuid()),
3796 * getpwuid() can accept either as input (if uid is specified, the caller's
3797 * UIC group is used), though it won't recognise gid=0.
3799 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3800 * information about other users in your group or in other groups, respectively.
3801 * If the required privilege is not available, then these routines fill only
3802 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3805 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3808 /* sizes of various UAF record fields */
3809 #define UAI$S_USERNAME 12
3810 #define UAI$S_IDENT 31
3811 #define UAI$S_OWNER 31
3812 #define UAI$S_DEFDEV 31
3813 #define UAI$S_DEFDIR 63
3814 #define UAI$S_DEFCLI 31
3817 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3818 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3819 (uic).uic$v_group != UIC$K_WILD_GROUP)
3821 static char __empty[]= "";
3822 static struct passwd __passwd_empty=
3823 {(char *) __empty, (char *) __empty, 0, 0,
3824 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3825 static int contxt= 0;
3826 static struct passwd __pwdcache;
3827 static char __pw_namecache[UAI$S_IDENT+1];
3830 * This routine does most of the work extracting the user information.
3832 static int fillpasswd (const char *name, struct passwd *pwd)
3836 unsigned char length;
3837 char pw_gecos[UAI$S_OWNER+1];
3839 static union uicdef uic;
3841 unsigned char length;
3842 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3845 unsigned char length;
3846 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3849 unsigned char length;
3850 char pw_shell[UAI$S_DEFCLI+1];
3852 static char pw_passwd[UAI$S_PWD+1];
3854 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3855 struct dsc$descriptor_s name_desc;
3856 unsigned long int sts;
3858 static struct itmlst_3 itmlst[]= {
3859 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3860 {sizeof(uic), UAI$_UIC, &uic, &luic},
3861 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3862 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3863 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3864 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3865 {0, 0, NULL, NULL}};
3867 name_desc.dsc$w_length= strlen(name);
3868 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3869 name_desc.dsc$b_class= DSC$K_CLASS_S;
3870 name_desc.dsc$a_pointer= (char *) name;
3872 /* Note that sys$getuai returns many fields as counted strings. */
3873 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3874 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3875 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3877 else { _ckvmssts(sts); }
3878 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3880 if ((int) owner.length < lowner) lowner= (int) owner.length;
3881 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3882 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3883 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3884 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3885 owner.pw_gecos[lowner]= '\0';
3886 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3887 defcli.pw_shell[ldefcli]= '\0';
3888 if (valid_uic(uic)) {
3889 pwd->pw_uid= uic.uic$l_uic;
3890 pwd->pw_gid= uic.uic$v_group;
3893 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3894 pwd->pw_passwd= pw_passwd;
3895 pwd->pw_gecos= owner.pw_gecos;
3896 pwd->pw_dir= defdev.pw_dir;
3897 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3898 pwd->pw_shell= defcli.pw_shell;
3899 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3901 ldir= strlen(pwd->pw_unixdir) - 1;
3902 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3905 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3906 __mystrtolower(pwd->pw_unixdir);
3911 * Get information for a named user.
3913 /*{{{struct passwd *getpwnam(char *name)*/
3914 struct passwd *my_getpwnam(char *name)
3916 struct dsc$descriptor_s name_desc;
3918 unsigned long int status, sts;
3921 __pwdcache = __passwd_empty;
3922 if (!fillpasswd(name, &__pwdcache)) {
3923 /* We still may be able to determine pw_uid and pw_gid */
3924 name_desc.dsc$w_length= strlen(name);
3925 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3926 name_desc.dsc$b_class= DSC$K_CLASS_S;
3927 name_desc.dsc$a_pointer= (char *) name;
3928 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3929 __pwdcache.pw_uid= uic.uic$l_uic;
3930 __pwdcache.pw_gid= uic.uic$v_group;
3933 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3934 set_vaxc_errno(sts);
3935 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3938 else { _ckvmssts(sts); }
3941 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3942 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3943 __pwdcache.pw_name= __pw_namecache;
3945 } /* end of my_getpwnam() */
3949 * Get information for a particular UIC or UID.
3950 * Called by my_getpwent with uid=-1 to list all users.
3952 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3953 struct passwd *my_getpwuid(Uid_t uid)
3955 const $DESCRIPTOR(name_desc,__pw_namecache);
3956 unsigned short lname;
3958 unsigned long int status;
3961 if (uid == (unsigned int) -1) {
3963 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3964 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3965 set_vaxc_errno(status);
3966 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3970 else { _ckvmssts(status); }
3971 } while (!valid_uic (uic));
3975 if (!uic.uic$v_group)
3976 uic.uic$v_group= PerlProc_getgid();
3978 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3979 else status = SS$_IVIDENT;
3980 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3981 status == RMS$_PRV) {
3982 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3985 else { _ckvmssts(status); }
3987 __pw_namecache[lname]= '\0';
3988 __mystrtolower(__pw_namecache);
3990 __pwdcache = __passwd_empty;
3991 __pwdcache.pw_name = __pw_namecache;
3993 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3994 The identifier's value is usually the UIC, but it doesn't have to be,
3995 so if we can, we let fillpasswd update this. */
3996 __pwdcache.pw_uid = uic.uic$l_uic;
3997 __pwdcache.pw_gid = uic.uic$v_group;
3999 fillpasswd(__pw_namecache, &__pwdcache);
4002 } /* end of my_getpwuid() */
4006 * Get information for next user.
4008 /*{{{struct passwd *my_getpwent()*/
4009 struct passwd *my_getpwent()
4011 return (my_getpwuid((unsigned int) -1));
4016 * Finish searching rights database for users.
4018 /*{{{void my_endpwent()*/
4023 _ckvmssts(sys$finish_rdb(&contxt));
4029 #ifdef HOMEGROWN_POSIX_SIGNALS
4030 /* Signal handling routines, pulled into the core from POSIX.xs.
4032 * We need these for threads, so they've been rolled into the core,
4033 * rather than left in POSIX.xs.
4035 * (DRS, Oct 23, 1997)
4038 /* sigset_t is atomic under VMS, so these routines are easy */
4039 /*{{{int my_sigemptyset(sigset_t *) */
4040 int my_sigemptyset(sigset_t *set) {
4041 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4047 /*{{{int my_sigfillset(sigset_t *)*/
4048 int my_sigfillset(sigset_t *set) {
4050 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4051 for (i = 0; i < NSIG; i++) *set |= (1 << i);
4057 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4058 int my_sigaddset(sigset_t *set, int sig) {
4059 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4060 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4061 *set |= (1 << (sig - 1));
4067 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4068 int my_sigdelset(sigset_t *set, int sig) {
4069 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4070 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4071 *set &= ~(1 << (sig - 1));
4077 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4078 int my_sigismember(sigset_t *set, int sig) {
4079 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4080 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4081 *set & (1 << (sig - 1));
4086 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4087 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4090 /* If set and oset are both null, then things are badly wrong. Bail out. */
4091 if ((oset == NULL) && (set == NULL)) {
4092 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4096 /* If set's null, then we're just handling a fetch. */
4098 tempmask = sigblock(0);
4103 tempmask = sigsetmask(*set);
4106 tempmask = sigblock(*set);
4109 tempmask = sigblock(0);
4110 sigsetmask(*oset & ~tempmask);
4113 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4118 /* Did they pass us an oset? If so, stick our holding mask into it */
4125 #endif /* HOMEGROWN_POSIX_SIGNALS */
4128 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4129 * my_utime(), and flex_stat(), all of which operate on UTC unless
4130 * VMSISH_TIMES is true.
4132 /* method used to handle UTC conversions:
4133 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4135 static int gmtime_emulation_type;
4136 /* number of secs to add to UTC POSIX-style time to get local time */
4137 static long int utc_offset_secs;
4139 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4140 * in vmsish.h. #undef them here so we can call the CRTL routines
4147 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4148 # define RTL_USES_UTC 1
4152 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4153 * qualifier with the extern prefix pragma. This provisional
4154 * hack circumvents this prefix pragma problem in previous
4157 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4158 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4159 # pragma __extern_prefix save
4160 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4161 # define gmtime decc$__utctz_gmtime
4162 # define localtime decc$__utctz_localtime
4163 # define time decc$__utc_time
4164 # pragma __extern_prefix restore
4166 struct tm *gmtime(), *localtime();
4172 static time_t toutc_dst(time_t loc) {
4175 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4176 loc -= utc_offset_secs;
4177 if (rsltmp->tm_isdst) loc -= 3600;
4180 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4181 ((gmtime_emulation_type || my_time(NULL)), \
4182 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4183 ((secs) - utc_offset_secs))))
4185 static time_t toloc_dst(time_t utc) {
4188 utc += utc_offset_secs;
4189 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4190 if (rsltmp->tm_isdst) utc += 3600;
4193 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4194 ((gmtime_emulation_type || my_time(NULL)), \
4195 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4196 ((secs) + utc_offset_secs))))
4199 /* my_time(), my_localtime(), my_gmtime()
4200 * By default traffic in UTC time values, using CRTL gmtime() or
4201 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4202 * Note: We need to use these functions even when the CRTL has working
4203 * UTC support, since they also handle C<use vmsish qw(times);>
4205 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4206 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4209 /*{{{time_t my_time(time_t *timep)*/
4210 time_t my_time(time_t *timep)
4216 if (gmtime_emulation_type == 0) {
4218 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4219 /* results of calls to gmtime() and localtime() */
4220 /* for same &base */
4222 gmtime_emulation_type++;
4223 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4224 char off[LNM$C_NAMLENGTH+1];;
4226 gmtime_emulation_type++;
4227 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4228 gmtime_emulation_type++;
4229 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4231 else { utc_offset_secs = atol(off); }
4233 else { /* We've got a working gmtime() */
4234 struct tm gmt, local;
4237 tm_p = localtime(&base);
4239 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4240 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4241 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4242 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4248 # ifdef RTL_USES_UTC
4249 if (VMSISH_TIME) when = _toloc(when);
4251 if (!VMSISH_TIME) when = _toutc(when);
4254 if (timep != NULL) *timep = when;
4257 } /* end of my_time() */
4261 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4263 my_gmtime(const time_t *timep)
4270 if (timep == NULL) {
4271 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4274 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4278 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4280 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4281 return gmtime(&when);
4283 /* CRTL localtime() wants local time as input, so does no tz correction */
4284 rsltmp = localtime(&when);
4285 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4288 } /* end of my_gmtime() */
4292 /*{{{struct tm *my_localtime(const time_t *timep)*/
4294 my_localtime(const time_t *timep)
4300 if (timep == NULL) {
4301 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4304 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4305 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4308 # ifdef RTL_USES_UTC
4310 if (VMSISH_TIME) when = _toutc(when);
4312 /* CRTL localtime() wants UTC as input, does tz correction itself */
4313 return localtime(&when);
4316 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4319 /* CRTL localtime() wants local time as input, so does no tz correction */
4320 rsltmp = localtime(&when);
4321 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4324 } /* end of my_localtime() */
4327 /* Reset definitions for later calls */
4328 #define gmtime(t) my_gmtime(t)
4329 #define localtime(t) my_localtime(t)
4330 #define time(t) my_time(t)
4333 /* my_utime - update modification time of a file
4334 * calling sequence is identical to POSIX utime(), but under
4335 * VMS only the modification time is changed; ODS-2 does not
4336 * maintain access times. Restrictions differ from the POSIX
4337 * definition in that the time can be changed as long as the
4338 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4339 * no separate checks are made to insure that the caller is the
4340 * owner of the file or has special privs enabled.
4341 * Code here is based on Joe Meadows' FILE utility.
4344 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4345 * to VMS epoch (01-JAN-1858 00:00:00.00)
4346 * in 100 ns intervals.
4348 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4350 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4351 int my_utime(char *file, struct utimbuf *utimes)
4355 long int bintime[2], len = 2, lowbit, unixtime,
4356 secscale = 10000000; /* seconds --> 100 ns intervals */
4357 unsigned long int chan, iosb[2], retsts;
4358 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4359 struct FAB myfab = cc$rms_fab;
4360 struct NAM mynam = cc$rms_nam;
4361 #if defined (__DECC) && defined (__VAX)
4362 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4363 * at least through VMS V6.1, which causes a type-conversion warning.
4365 # pragma message save
4366 # pragma message disable cvtdiftypes
4368 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4369 struct fibdef myfib;
4370 #if defined (__DECC) && defined (__VAX)
4371 /* This should be right after the declaration of myatr, but due
4372 * to a bug in VAX DEC C, this takes effect a statement early.
4374 # pragma message restore
4376 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4377 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4378 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4380 if (file == NULL || *file == '\0') {
4382 set_vaxc_errno(LIB$_INVARG);
4385 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4387 if (utimes != NULL) {
4388 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4389 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4390 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4391 * as input, we force the sign bit to be clear by shifting unixtime right
4392 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4394 lowbit = (utimes->modtime & 1) ? secscale : 0;
4395 unixtime = (long int) utimes->modtime;
4397 /* If input was UTC; convert to local for sys svc */
4398 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4400 unixtime >>= 1; secscale <<= 1;
4401 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4402 if (!(retsts & 1)) {
4404 set_vaxc_errno(retsts);
4407 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4408 if (!(retsts & 1)) {
4410 set_vaxc_errno(retsts);
4415 /* Just get the current time in VMS format directly */
4416 retsts = sys$gettim(bintime);
4417 if (!(retsts & 1)) {
4419 set_vaxc_errno(retsts);
4424 myfab.fab$l_fna = vmsspec;
4425 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4426 myfab.fab$l_nam = &mynam;
4427 mynam.nam$l_esa = esa;
4428 mynam.nam$b_ess = (unsigned char) sizeof esa;
4429 mynam.nam$l_rsa = rsa;
4430 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4432 /* Look for the file to be affected, letting RMS parse the file
4433 * specification for us as well. I have set errno using only
4434 * values documented in the utime() man page for VMS POSIX.
4436 retsts = sys$parse(&myfab,0,0);
4437 if (!(retsts & 1)) {
4438 set_vaxc_errno(retsts);
4439 if (retsts == RMS$_PRV) set_errno(EACCES);
4440 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4441 else set_errno(EVMSERR);
4444 retsts = sys$search(&myfab,0,0);
4445 if (!(retsts & 1)) {
4446 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4447 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4448 set_vaxc_errno(retsts);
4449 if (retsts == RMS$_PRV) set_errno(EACCES);
4450 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4451 else set_errno(EVMSERR);
4455 devdsc.dsc$w_length = mynam.nam$b_dev;
4456 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4458 retsts = sys$assign(&devdsc,&chan,0,0);
4459 if (!(retsts & 1)) {
4460 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4461 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4462 set_vaxc_errno(retsts);
4463 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4464 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4465 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4466 else set_errno(EVMSERR);
4470 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4471 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4473 memset((void *) &myfib, 0, sizeof myfib);
4475 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4476 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4477 /* This prevents the revision time of the file being reset to the current
4478 * time as a result of our IO$_MODIFY $QIO. */
4479 myfib.fib$l_acctl = FIB$M_NORECORD;
4481 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4482 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4483 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4485 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4486 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4487 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4488 _ckvmssts(sys$dassgn(chan));
4489 if (retsts & 1) retsts = iosb[0];
4490 if (!(retsts & 1)) {
4491 set_vaxc_errno(retsts);
4492 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4493 else set_errno(EVMSERR);
4498 } /* end of my_utime() */
4502 * flex_stat, flex_fstat
4503 * basic stat, but gets it right when asked to stat
4504 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4507 /* encode_dev packs a VMS device name string into an integer to allow
4508 * simple comparisons. This can be used, for example, to check whether two
4509 * files are located on the same device, by comparing their encoded device
4510 * names. Even a string comparison would not do, because stat() reuses the
4511 * device name buffer for each call; so without encode_dev, it would be
4512 * necessary to save the buffer and use strcmp (this would mean a number of
4513 * changes to the standard Perl code, to say nothing of what a Perl script
4516 * The device lock id, if it exists, should be unique (unless perhaps compared
4517 * with lock ids transferred from other nodes). We have a lock id if the disk is
4518 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4519 * device names. Thus we use the lock id in preference, and only if that isn't
4520 * available, do we try to pack the device name into an integer (flagged by
4521 * the sign bit (LOCKID_MASK) being set).
4523 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4524 * name and its encoded form, but it seems very unlikely that we will find
4525 * two files on different disks that share the same encoded device names,
4526 * and even more remote that they will share the same file id (if the test
4527 * is to check for the same file).
4529 * A better method might be to use sys$device_scan on the first call, and to
4530 * search for the device, returning an index into the cached array.
4531 * The number returned would be more intelligable.
4532 * This is probably not worth it, and anyway would take quite a bit longer
4533 * on the first call.
4535 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4536 static mydev_t encode_dev (const char *dev)
4539 unsigned long int f;
4545 if (!dev || !dev[0]) return 0;
4549 struct dsc$descriptor_s dev_desc;
4550 unsigned long int status, lockid, item = DVI$_LOCKID;
4552 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4553 can try that first. */
4554 dev_desc.dsc$w_length = strlen (dev);
4555 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4556 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4557 dev_desc.dsc$a_pointer = (char *) dev;
4558 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4559 if (lockid) return (lockid & ~LOCKID_MASK);
4563 /* Otherwise we try to encode the device name */
4567 for (q = dev + strlen(dev); q--; q >= dev) {
4570 else if (isalpha (toupper (*q)))
4571 c= toupper (*q) - 'A' + (char)10;
4573 continue; /* Skip '$'s */
4575 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4577 enc += f * (unsigned long int) c;
4579 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4581 } /* end of encode_dev() */
4583 static char namecache[NAM$C_MAXRSS+1];
4586 is_null_device(name)
4590 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4591 The underscore prefix, controller letter, and unit number are
4592 independently optional; for our purposes, the colon punctuation
4593 is not. The colon can be trailed by optional directory and/or
4594 filename, but two consecutive colons indicates a nodename rather
4595 than a device. [pr] */
4596 if (*name == '_') ++name;
4597 if (tolower(*name++) != 'n') return 0;
4598 if (tolower(*name++) != 'l') return 0;
4599 if (tolower(*name) == 'a') ++name;
4600 if (*name == '0') ++name;
4601 return (*name++ == ':') && (*name != ':');
4604 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4605 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4606 * subset of the applicable information.
4609 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4611 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4613 char fname[NAM$C_MAXRSS+1];
4614 unsigned long int retsts;
4615 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4616 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4618 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4619 device name on successive calls */
4620 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4621 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4622 namdsc.dsc$a_pointer = fname;
4623 namdsc.dsc$w_length = sizeof fname - 1;
4625 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4626 &namdsc,&namdsc.dsc$w_length,0,0);
4628 fname[namdsc.dsc$w_length] = '\0';
4629 return cando_by_name(bit,effective,fname);
4631 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4632 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4636 return FALSE; /* Should never get to here */
4638 } /* end of cando() */
4642 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4644 cando_by_name(I32 bit, Uid_t effective, char *fname)
4646 static char usrname[L_cuserid];
4647 static struct dsc$descriptor_s usrdsc =
4648 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4649 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4650 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4651 unsigned short int retlen;
4653 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4654 union prvdef curprv;
4655 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4656 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4657 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4660 if (!fname || !*fname) return FALSE;
4661 /* Make sure we expand logical names, since sys$check_access doesn't */
4662 if (!strpbrk(fname,"/]>:")) {
4663 strcpy(fileified,fname);
4664 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4667 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4668 retlen = namdsc.dsc$w_length = strlen(vmsname);
4669 namdsc.dsc$a_pointer = vmsname;
4670 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4671 vmsname[retlen-1] == ':') {
4672 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4673 namdsc.dsc$w_length = strlen(fileified);
4674 namdsc.dsc$a_pointer = fileified;
4677 if (!usrdsc.dsc$w_length) {
4679 usrdsc.dsc$w_length = strlen(usrname);
4683 case S_IXUSR: case S_IXGRP: case S_IXOTH:
4684 access = ARM$M_EXECUTE; break;
4685 case S_IRUSR: case S_IRGRP: case S_IROTH:
4686 access = ARM$M_READ; break;
4687 case S_IWUSR: case S_IWGRP: case S_IWOTH:
4688 access = ARM$M_WRITE; break;
4689 case S_IDUSR: case S_IDGRP: case S_IDOTH:
4690 access = ARM$M_DELETE; break;
4695 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4696 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4697 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4698 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4699 set_vaxc_errno(retsts);
4700 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4701 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4702 else set_errno(ENOENT);
4705 if (retsts == SS$_NORMAL) {
4706 if (!privused) return TRUE;
4707 /* We can get access, but only by using privs. Do we have the
4708 necessary privs currently enabled? */
4709 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4710 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4711 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4712 !curprv.prv$v_bypass) return FALSE;
4713 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4714 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4715 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4718 if (retsts == SS$_ACCONFLICT) {
4722 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001
4723 /* XXX Hideous kluge to accomodate error in specific version of RTL;
4724 we hope it'll be buried soon */
4725 if (retsts == 114762) return TRUE;
4729 return FALSE; /* Should never get here */
4731 } /* end of cando_by_name() */
4735 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4737 flex_fstat(int fd, Stat_t *statbufp)
4740 if (!fstat(fd,(stat_t *) statbufp)) {
4741 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4742 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4743 # ifdef RTL_USES_UTC
4746 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4747 statbufp->st_atime = _toloc(statbufp->st_atime);
4748 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4753 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4757 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4758 statbufp->st_atime = _toutc(statbufp->st_atime);
4759 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4766 } /* end of flex_fstat() */
4769 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4771 flex_stat(const char *fspec, Stat_t *statbufp)
4774 char fileified[NAM$C_MAXRSS+1];
4775 char temp_fspec[NAM$C_MAXRSS+300];
4778 strcpy(temp_fspec, fspec);
4779 if (statbufp == (Stat_t *) &PL_statcache)
4780 do_tovmsspec(temp_fspec,namecache,0);
4781 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4782 memset(statbufp,0,sizeof *statbufp);
4783 statbufp->st_dev = encode_dev("_NLA0:");
4784 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4785 statbufp->st_uid = 0x00010001;
4786 statbufp->st_gid = 0x0001;
4787 time((time_t *)&statbufp->st_mtime);
4788 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4792 /* Try for a directory name first. If fspec contains a filename without
4793 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4794 * and sea:[wine.dark]water. exist, we prefer the directory here.
4795 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4796 * not sea:[wine.dark]., if the latter exists. If the intended target is
4797 * the file with null type, specify this by calling flex_stat() with
4798 * a '.' at the end of fspec.
4800 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4801 retval = stat(fileified,(stat_t *) statbufp);
4802 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4803 strcpy(namecache,fileified);
4805 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4807 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4808 # ifdef RTL_USES_UTC
4811 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4812 statbufp->st_atime = _toloc(statbufp->st_atime);
4813 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4818 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4822 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4823 statbufp->st_atime = _toutc(statbufp->st_atime);
4824 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4830 } /* end of flex_stat() */
4834 /*{{{char *my_getlogin()*/
4835 /* VMS cuserid == Unix getlogin, except calling sequence */
4839 static char user[L_cuserid];
4840 return cuserid(user);
4845 /* rmscopy - copy a file using VMS RMS routines
4847 * Copies contents and attributes of spec_in to spec_out, except owner
4848 * and protection information. Name and type of spec_in are used as
4849 * defaults for spec_out. The third parameter specifies whether rmscopy()
4850 * should try to propagate timestamps from the input file to the output file.
4851 * If it is less than 0, no timestamps are preserved. If it is 0, then
4852 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4853 * propagated to the output file at creation iff the output file specification
4854 * did not contain an explicit name or type, and the revision date is always
4855 * updated at the end of the copy operation. If it is greater than 0, then
4856 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4857 * other than the revision date should be propagated, and bit 1 indicates
4858 * that the revision date should be propagated.
4860 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4862 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4863 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4864 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4865 * as part of the Perl standard distribution under the terms of the
4866 * GNU General Public License or the Perl Artistic License. Copies
4867 * of each may be found in the Perl standard distribution.
4869 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4871 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
4873 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4874 rsa[NAM$C_MAXRSS], ubf[32256];
4875 unsigned long int i, sts, sts2;
4876 struct FAB fab_in, fab_out;
4877 struct RAB rab_in, rab_out;
4879 struct XABDAT xabdat;
4880 struct XABFHC xabfhc;
4881 struct XABRDT xabrdt;
4882 struct XABSUM xabsum;
4884 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4885 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4886 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4890 fab_in = cc$rms_fab;
4891 fab_in.fab$l_fna = vmsin;
4892 fab_in.fab$b_fns = strlen(vmsin);
4893 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4894 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4895 fab_in.fab$l_fop = FAB$M_SQO;
4896 fab_in.fab$l_nam = &nam;
4897 fab_in.fab$l_xab = (void *) &xabdat;
4900 nam.nam$l_rsa = rsa;
4901 nam.nam$b_rss = sizeof(rsa);
4902 nam.nam$l_esa = esa;
4903 nam.nam$b_ess = sizeof (esa);
4904 nam.nam$b_esl = nam.nam$b_rsl = 0;
4906 xabdat = cc$rms_xabdat; /* To get creation date */
4907 xabdat.xab$l_nxt = (void *) &xabfhc;
4909 xabfhc = cc$rms_xabfhc; /* To get record length */
4910 xabfhc.xab$l_nxt = (void *) &xabsum;
4912 xabsum = cc$rms_xabsum; /* To get key and area information */
4914 if (!((sts = sys$open(&fab_in)) & 1)) {
4915 set_vaxc_errno(sts);
4917 case RMS$_FNF: case RMS$_DNF:
4918 set_errno(ENOENT); break;
4920 set_errno(ENOTDIR); break;
4922 set_errno(ENODEV); break;
4924 set_errno(EINVAL); break;
4926 set_errno(EACCES); break;
4934 fab_out.fab$w_ifi = 0;
4935 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4936 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4937 fab_out.fab$l_fop = FAB$M_SQO;
4938 fab_out.fab$l_fna = vmsout;
4939 fab_out.fab$b_fns = strlen(vmsout);
4940 fab_out.fab$l_dna = nam.nam$l_name;
4941 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4943 if (preserve_dates == 0) { /* Act like DCL COPY */
4944 nam.nam$b_nop = NAM$M_SYNCHK;
4945 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4946 if (!((sts = sys$parse(&fab_out)) & 1)) {
4947 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4948 set_vaxc_errno(sts);
4951 fab_out.fab$l_xab = (void *) &xabdat;
4952 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4954 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4955 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4956 preserve_dates =0; /* bitmask from this point forward */
4958 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4959 if (!((sts = sys$create(&fab_out)) & 1)) {
4960 set_vaxc_errno(sts);
4963 set_errno(ENOENT); break;
4965 set_errno(ENOTDIR); break;
4967 set_errno(ENODEV); break;
4969 set_errno(EINVAL); break;
4971 set_errno(EACCES); break;
4977 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4978 if (preserve_dates & 2) {
4979 /* sys$close() will process xabrdt, not xabdat */
4980 xabrdt = cc$rms_xabrdt;
4982 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4984 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4985 * is unsigned long[2], while DECC & VAXC use a struct */
4986 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4988 fab_out.fab$l_xab = (void *) &xabrdt;
4991 rab_in = cc$rms_rab;
4992 rab_in.rab$l_fab = &fab_in;
4993 rab_in.rab$l_rop = RAB$M_BIO;
4994 rab_in.rab$l_ubf = ubf;
4995 rab_in.rab$w_usz = sizeof ubf;
4996 if (!((sts = sys$connect(&rab_in)) & 1)) {
4997 sys$close(&fab_in); sys$close(&fab_out);
4998 set_errno(EVMSERR); set_vaxc_errno(sts);
5002 rab_out = cc$rms_rab;
5003 rab_out.rab$l_fab = &fab_out;
5004 rab_out.rab$l_rbf = ubf;
5005 if (!((sts = sys$connect(&rab_out)) & 1)) {
5006 sys$close(&fab_in); sys$close(&fab_out);
5007 set_errno(EVMSERR); set_vaxc_errno(sts);
5011 while ((sts = sys$read(&rab_in))) { /* always true */
5012 if (sts == RMS$_EOF) break;
5013 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
5014 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
5015 sys$close(&fab_in); sys$close(&fab_out);
5016 set_errno(EVMSERR); set_vaxc_errno(sts);
5021 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
5022 sys$close(&fab_in); sys$close(&fab_out);
5023 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5025 set_errno(EVMSERR); set_vaxc_errno(sts);
5031 } /* end of rmscopy() */
5035 /*** The following glue provides 'hooks' to make some of the routines
5036 * from this file available from Perl. These routines are sufficiently
5037 * basic, and are required sufficiently early in the build process,
5038 * that's it's nice to have them available to miniperl as well as the
5039 * full Perl, so they're set up here instead of in an extension. The
5040 * Perl code which handles importation of these names into a given
5041 * package lives in [.VMS]Filespec.pm in @INC.
5045 rmsexpand_fromperl(pTHX_ CV *cv)
5048 char *fspec, *defspec = NULL, *rslt;
5051 if (!items || items > 2)
5052 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5053 fspec = SvPV(ST(0),n_a);
5054 if (!fspec || !*fspec) XSRETURN_UNDEF;
5055 if (items == 2) defspec = SvPV(ST(1),n_a);
5057 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5058 ST(0) = sv_newmortal();
5059 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5064 vmsify_fromperl(pTHX_ CV *cv)
5070 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5071 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5072 ST(0) = sv_newmortal();
5073 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5078 unixify_fromperl(pTHX_ CV *cv)
5084 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5085 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5086 ST(0) = sv_newmortal();
5087 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5092 fileify_fromperl(pTHX_ CV *cv)
5098 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5099 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5100 ST(0) = sv_newmortal();
5101 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5106 pathify_fromperl(pTHX_ CV *cv)
5112 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5113 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5114 ST(0) = sv_newmortal();
5115 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5120 vmspath_fromperl(pTHX_ CV *cv)
5126 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5127 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5128 ST(0) = sv_newmortal();
5129 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5134 unixpath_fromperl(pTHX_ CV *cv)
5140 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5141 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5142 ST(0) = sv_newmortal();
5143 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5148 candelete_fromperl(pTHX_ CV *cv)
5151 char fspec[NAM$C_MAXRSS+1], *fsp;
5156 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5158 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5159 if (SvTYPE(mysv) == SVt_PVGV) {
5160 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5161 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5168 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5169 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5175 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5180 rmscopy_fromperl(pTHX_ CV *cv)
5183 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5185 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5186 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5187 unsigned long int sts;
5192 if (items < 2 || items > 3)
5193 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5195 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5196 if (SvTYPE(mysv) == SVt_PVGV) {
5197 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5198 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5205 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5206 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5211 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5212 if (SvTYPE(mysv) == SVt_PVGV) {
5213 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5214 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5221 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5222 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5227 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5229 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5236 char* file = __FILE__;
5238 char temp_buff[512];
5239 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5240 no_translate_barewords = TRUE;
5242 no_translate_barewords = FALSE;
5245 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5246 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5247 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5248 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5249 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5250 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5251 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5252 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5253 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);