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 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
952 static unsigned long int mbxbufsiz;
953 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
958 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
959 * preprocessor consant BUFSIZ from stdio.h as the size of the
962 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
963 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
965 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
967 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
968 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
970 } /* end of create_mbx() */
972 /*{{{ my_popen and my_pclose*/
975 struct pipe_details *next;
976 PerlIO *fp; /* stdio file pointer to pipe mailbox */
977 int pid; /* PID of subprocess */
978 int mode; /* == 'r' if pipe open for reading */
979 int done; /* subprocess has completed */
980 unsigned long int completion; /* termination status of subprocess */
983 struct exit_control_block
985 struct exit_control_block *flink;
986 unsigned long int (*exit_routine)();
987 unsigned long int arg_count;
988 unsigned long int *status_address;
989 unsigned long int exit_status;
992 static struct pipe_details *open_pipes = NULL;
993 static $DESCRIPTOR(nl_desc, "NL:");
994 static int waitpid_asleep = 0;
996 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
997 * to a mbx; that's the caller's responsibility.
999 static unsigned long int
1000 pipe_eof(FILE *fp, int immediate)
1002 char devnam[NAM$C_MAXRSS+1], *cp;
1003 unsigned long int chan, iosb[2], retsts, retsts2;
1004 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
1007 if (fgetname(fp,devnam,1)) {
1008 /* It oughta be a mailbox, so fgetname should give just the device
1009 * name, but just in case . . . */
1010 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
1011 devdsc.dsc$w_length = strlen(devnam);
1012 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
1013 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
1014 iosb,0,0,0,0,0,0,0,0);
1015 if (retsts & 1) retsts = iosb[0];
1016 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
1017 if (retsts & 1) retsts = retsts2;
1021 else _ckvmssts(vaxc$errno); /* Should never happen */
1022 return (unsigned long int) vaxc$errno;
1025 static unsigned long int
1028 struct pipe_details *info;
1029 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1034 first we try sending an EOF...ignore if doesn't work, make sure we
1042 _ckvmssts(sys$setast(0));
1043 need_eof = info->mode != 'r' && !info->done;
1044 _ckvmssts(sys$setast(1));
1046 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1050 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1055 _ckvmssts(sys$setast(0));
1056 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1057 sts = sys$forcex(&info->pid,0,&abort);
1058 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1061 _ckvmssts(sys$setast(1));
1064 if (did_stuff) sleep(1); /* wait for them to respond */
1068 _ckvmssts(sys$setast(0));
1069 if (!info->done) { /* We tried to be nice . . . */
1070 sts = sys$delprc(&info->pid,0);
1071 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1072 info->done = 1; /* so my_pclose doesn't try to write EOF */
1074 _ckvmssts(sys$setast(1));
1079 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1080 else if (!(sts & 1)) retsts = sts;
1085 static struct exit_control_block pipe_exitblock =
1086 {(struct exit_control_block *) 0,
1087 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1091 popen_completion_ast(struct pipe_details *thispipe)
1093 thispipe->done = TRUE;
1094 if (waitpid_asleep) {
1100 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1101 static void vms_execfree(pTHX);
1104 safe_popen(char *cmd, char *mode)
1106 static int handler_set_up = FALSE;
1108 unsigned short int chan;
1109 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1111 struct pipe_details *info;
1112 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1113 DSC$K_CLASS_S, mbxname},
1114 cmddsc = {0, DSC$K_DTYPE_T,
1118 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1119 New(1301,info,1,struct pipe_details);
1121 /* create mailbox */
1122 create_mbx(&chan,&namdsc);
1124 /* open a FILE* onto it */
1125 info->fp = PerlIO_open(mbxname, mode);
1127 /* give up other channel onto it */
1128 _ckvmssts(sys$dassgn(chan));
1138 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1139 0 /* name */, &info->pid, &info->completion,
1140 0, popen_completion_ast,info,0,0,0));
1143 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1144 0 /* name */, &info->pid, &info->completion,
1145 0, popen_completion_ast,info,0,0,0));
1149 if (!handler_set_up) {
1150 _ckvmssts(sys$dclexh(&pipe_exitblock));
1151 handler_set_up = TRUE;
1153 info->next=open_pipes; /* prepend to list */
1156 PL_forkprocess = info->pid;
1158 } /* end of safe_popen */
1161 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1163 Perl_my_popen(pTHX_ char *cmd, char *mode)
1166 TAINT_PROPER("popen");
1167 PERL_FLUSHALL_FOR_CHILD;
1168 return safe_popen(cmd,mode);
1173 /*{{{ I32 my_pclose(FILE *fp)*/
1174 I32 Perl_my_pclose(pTHX_ FILE *fp)
1176 struct pipe_details *info, *last = NULL;
1177 unsigned long int retsts;
1180 for (info = open_pipes; info != NULL; last = info, info = info->next)
1181 if (info->fp == fp) break;
1183 if (info == NULL) { /* no such pipe open */
1184 set_errno(ECHILD); /* quoth POSIX */
1185 set_vaxc_errno(SS$_NONEXPR);
1189 /* If we were writing to a subprocess, insure that someone reading from
1190 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1191 * produce an EOF record in the mailbox. */
1192 _ckvmssts(sys$setast(0));
1193 need_eof = info->mode != 'r' && !info->done;
1194 _ckvmssts(sys$setast(1));
1195 if (need_eof) pipe_eof(info->fp,0);
1196 PerlIO_close(info->fp);
1198 if (info->done) retsts = info->completion;
1199 else waitpid(info->pid,(int *) &retsts,0);
1201 /* remove from list of open pipes */
1202 _ckvmssts(sys$setast(0));
1203 if (last) last->next = info->next;
1204 else open_pipes = info->next;
1205 _ckvmssts(sys$setast(1));
1210 } /* end of my_pclose() */
1212 /* sort-of waitpid; use only with popen() */
1213 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1215 my_waitpid(Pid_t pid, int *statusp, int flags)
1217 struct pipe_details *info;
1220 for (info = open_pipes; info != NULL; info = info->next)
1221 if (info->pid == pid) break;
1223 if (info != NULL) { /* we know about this child */
1224 while (!info->done) {
1229 *statusp = info->completion;
1232 else { /* we haven't heard of this child */
1233 $DESCRIPTOR(intdsc,"0 00:00:01");
1234 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1235 unsigned long int interval[2],sts;
1237 if (ckWARN(WARN_EXEC)) {
1238 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1239 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1240 if (ownerpid != mypid)
1241 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1244 _ckvmssts(sys$bintim(&intdsc,interval));
1245 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1246 _ckvmssts(sys$schdwk(0,0,interval,0));
1247 _ckvmssts(sys$hiber());
1251 /* There's no easy way to find the termination status a child we're
1252 * not aware of beforehand. If we're really interested in the future,
1253 * we can go looking for a termination mailbox, or chase after the
1254 * accounting record for the process.
1260 } /* end of waitpid() */
1265 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1267 my_gconvert(double val, int ndig, int trail, char *buf)
1269 static char __gcvtbuf[DBL_DIG+1];
1272 loc = buf ? buf : __gcvtbuf;
1274 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1276 sprintf(loc,"%.*g",ndig,val);
1282 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1283 return gcvt(val,ndig,loc);
1286 loc[0] = '0'; loc[1] = '\0';
1294 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1295 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1296 * to expand file specification. Allows for a single default file
1297 * specification and a simple mask of options. If outbuf is non-NULL,
1298 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1299 * the resultant file specification is placed. If outbuf is NULL, the
1300 * resultant file specification is placed into a static buffer.
1301 * The third argument, if non-NULL, is taken to be a default file
1302 * specification string. The fourth argument is unused at present.
1303 * rmesexpand() returns the address of the resultant string if
1304 * successful, and NULL on error.
1306 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
1309 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1311 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1312 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1313 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1314 struct FAB myfab = cc$rms_fab;
1315 struct NAM mynam = cc$rms_nam;
1317 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1319 if (!filespec || !*filespec) {
1320 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1324 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1325 else outbuf = __rmsexpand_retbuf;
1327 if ((isunix = (strchr(filespec,'/') != NULL))) {
1328 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1329 filespec = vmsfspec;
1332 myfab.fab$l_fna = filespec;
1333 myfab.fab$b_fns = strlen(filespec);
1334 myfab.fab$l_nam = &mynam;
1336 if (defspec && *defspec) {
1337 if (strchr(defspec,'/') != NULL) {
1338 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1341 myfab.fab$l_dna = defspec;
1342 myfab.fab$b_dns = strlen(defspec);
1345 mynam.nam$l_esa = esa;
1346 mynam.nam$b_ess = sizeof esa;
1347 mynam.nam$l_rsa = outbuf;
1348 mynam.nam$b_rss = NAM$C_MAXRSS;
1350 retsts = sys$parse(&myfab,0,0);
1351 if (!(retsts & 1)) {
1352 mynam.nam$b_nop |= NAM$M_SYNCHK;
1353 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
1354 retsts = sys$parse(&myfab,0,0);
1355 if (retsts & 1) goto expanded;
1357 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1358 (void) sys$parse(&myfab,0,0); /* Free search context */
1359 if (out) Safefree(out);
1360 set_vaxc_errno(retsts);
1361 if (retsts == RMS$_PRV) set_errno(EACCES);
1362 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1363 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1364 else set_errno(EVMSERR);
1367 retsts = sys$search(&myfab,0,0);
1368 if (!(retsts & 1) && retsts != RMS$_FNF) {
1369 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1370 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1371 if (out) Safefree(out);
1372 set_vaxc_errno(retsts);
1373 if (retsts == RMS$_PRV) set_errno(EACCES);
1374 else set_errno(EVMSERR);
1378 /* If the input filespec contained any lowercase characters,
1379 * downcase the result for compatibility with Unix-minded code. */
1381 for (out = myfab.fab$l_fna; *out; out++)
1382 if (islower(*out)) { haslower = 1; break; }
1383 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1384 else { out = esa; speclen = mynam.nam$b_esl; }
1385 /* Trim off null fields added by $PARSE
1386 * If type > 1 char, must have been specified in original or default spec
1387 * (not true for version; $SEARCH may have added version of existing file).
1389 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1390 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1391 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1392 if (trimver || trimtype) {
1393 if (defspec && *defspec) {
1394 char defesa[NAM$C_MAXRSS];
1395 struct FAB deffab = cc$rms_fab;
1396 struct NAM defnam = cc$rms_nam;
1398 deffab.fab$l_nam = &defnam;
1399 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1400 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1401 defnam.nam$b_nop = NAM$M_SYNCHK;
1402 if (sys$parse(&deffab,0,0) & 1) {
1403 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1404 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1407 if (trimver) speclen = mynam.nam$l_ver - out;
1409 /* If we didn't already trim version, copy down */
1410 if (speclen > mynam.nam$l_ver - out)
1411 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1412 speclen - (mynam.nam$l_ver - out));
1413 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1416 /* If we just had a directory spec on input, $PARSE "helpfully"
1417 * adds an empty name and type for us */
1418 if (mynam.nam$l_name == mynam.nam$l_type &&
1419 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1420 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1421 speclen = mynam.nam$l_name - out;
1422 out[speclen] = '\0';
1423 if (haslower) __mystrtolower(out);
1425 /* Have we been working with an expanded, but not resultant, spec? */
1426 /* Also, convert back to Unix syntax if necessary. */
1427 if (!mynam.nam$b_rsl) {
1429 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1431 else strcpy(outbuf,esa);
1434 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1435 strcpy(outbuf,tmpfspec);
1437 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1438 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1439 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1443 /* External entry points */
1444 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1445 { return do_rmsexpand(spec,buf,0,def,opt); }
1446 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
1447 { return do_rmsexpand(spec,buf,1,def,opt); }
1451 ** The following routines are provided to make life easier when
1452 ** converting among VMS-style and Unix-style directory specifications.
1453 ** All will take input specifications in either VMS or Unix syntax. On
1454 ** failure, all return NULL. If successful, the routines listed below
1455 ** return a pointer to a buffer containing the appropriately
1456 ** reformatted spec (and, therefore, subsequent calls to that routine
1457 ** will clobber the result), while the routines of the same names with
1458 ** a _ts suffix appended will return a pointer to a mallocd string
1459 ** containing the appropriately reformatted spec.
1460 ** In all cases, only explicit syntax is altered; no check is made that
1461 ** the resulting string is valid or that the directory in question
1464 ** fileify_dirspec() - convert a directory spec into the name of the
1465 ** directory file (i.e. what you can stat() to see if it's a dir).
1466 ** The style (VMS or Unix) of the result is the same as the style
1467 ** of the parameter passed in.
1468 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1469 ** what you prepend to a filename to indicate what directory it's in).
1470 ** The style (VMS or Unix) of the result is the same as the style
1471 ** of the parameter passed in.
1472 ** tounixpath() - convert a directory spec into a Unix-style path.
1473 ** tovmspath() - convert a directory spec into a VMS-style path.
1474 ** tounixspec() - convert any file spec into a Unix-style file spec.
1475 ** tovmsspec() - convert any file spec into a VMS-style spec.
1477 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1478 ** Permission is given to distribute this code as part of the Perl
1479 ** standard distribution under the terms of the GNU General Public
1480 ** License or the Perl Artistic License. Copies of each may be
1481 ** found in the Perl standard distribution.
1484 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1485 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
1487 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1488 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1489 char *retspec, *cp1, *cp2, *lastdir;
1490 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1492 if (!dir || !*dir) {
1493 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1495 dirlen = strlen(dir);
1496 while (dirlen && dir[dirlen-1] == '/') --dirlen;
1497 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1498 strcpy(trndir,"/sys$disk/000000");
1502 if (dirlen > NAM$C_MAXRSS) {
1503 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1505 if (!strpbrk(dir+1,"/]>:")) {
1506 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1507 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1509 dirlen = strlen(dir);
1512 strncpy(trndir,dir,dirlen);
1513 trndir[dirlen] = '\0';
1516 /* If we were handed a rooted logical name or spec, treat it like a
1517 * simple directory, so that
1518 * $ Define myroot dev:[dir.]
1519 * ... do_fileify_dirspec("myroot",buf,1) ...
1520 * does something useful.
1522 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
1523 dir[--dirlen] = '\0';
1524 dir[dirlen-1] = ']';
1527 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1528 /* If we've got an explicit filename, we can just shuffle the string. */
1529 if (*(cp1+1)) hasfilename = 1;
1530 /* Similarly, we can just back up a level if we've got multiple levels
1531 of explicit directories in a VMS spec which ends with directories. */
1533 for (cp2 = cp1; cp2 > dir; cp2--) {
1535 *cp2 = *cp1; *cp1 = '\0';
1539 if (*cp2 == '[' || *cp2 == '<') break;
1544 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1545 if (dir[0] == '.') {
1546 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1547 return do_fileify_dirspec("[]",buf,ts);
1548 else if (dir[1] == '.' &&
1549 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1550 return do_fileify_dirspec("[-]",buf,ts);
1552 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1553 dirlen -= 1; /* to last element */
1554 lastdir = strrchr(dir,'/');
1556 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1557 /* If we have "/." or "/..", VMSify it and let the VMS code
1558 * below expand it, rather than repeating the code to handle
1559 * relative components of a filespec here */
1561 if (*(cp1+2) == '.') cp1++;
1562 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1563 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1564 if (strchr(vmsdir,'/') != NULL) {
1565 /* If do_tovmsspec() returned it, it must have VMS syntax
1566 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1567 * the time to check this here only so we avoid a recursion
1568 * loop; otherwise, gigo.
1570 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1572 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1573 return do_tounixspec(trndir,buf,ts);
1576 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1577 lastdir = strrchr(dir,'/');
1579 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
1580 /* Ditto for specs that end in an MFD -- let the VMS code
1581 * figure out whether it's a real device or a rooted logical. */
1582 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1583 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1584 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1585 return do_tounixspec(trndir,buf,ts);
1588 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1589 !(lastdir = cp1 = strrchr(dir,']')) &&
1590 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1591 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1593 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1594 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1595 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1596 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1597 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1598 (ver || *cp3)))))) {
1600 set_vaxc_errno(RMS$_DIR);
1606 /* If we lead off with a device or rooted logical, add the MFD
1607 if we're specifying a top-level directory. */
1608 if (lastdir && *dir == '/') {
1610 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1617 retlen = dirlen + (addmfd ? 13 : 6);
1618 if (buf) retspec = buf;
1619 else if (ts) New(1309,retspec,retlen+1,char);
1620 else retspec = __fileify_retbuf;
1622 dirlen = lastdir - dir;
1623 memcpy(retspec,dir,dirlen);
1624 strcpy(&retspec[dirlen],"/000000");
1625 strcpy(&retspec[dirlen+7],lastdir);
1628 memcpy(retspec,dir,dirlen);
1629 retspec[dirlen] = '\0';
1631 /* We've picked up everything up to the directory file name.
1632 Now just add the type and version, and we're set. */
1633 strcat(retspec,".dir;1");
1636 else { /* VMS-style directory spec */
1637 char esa[NAM$C_MAXRSS+1], term, *cp;
1638 unsigned long int sts, cmplen, haslower = 0;
1639 struct FAB dirfab = cc$rms_fab;
1640 struct NAM savnam, dirnam = cc$rms_nam;
1642 dirfab.fab$b_fns = strlen(dir);
1643 dirfab.fab$l_fna = dir;
1644 dirfab.fab$l_nam = &dirnam;
1645 dirfab.fab$l_dna = ".DIR;1";
1646 dirfab.fab$b_dns = 6;
1647 dirnam.nam$b_ess = NAM$C_MAXRSS;
1648 dirnam.nam$l_esa = esa;
1650 for (cp = dir; *cp; cp++)
1651 if (islower(*cp)) { haslower = 1; break; }
1652 if (!((sts = sys$parse(&dirfab))&1)) {
1653 if (dirfab.fab$l_sts == RMS$_DIR) {
1654 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1655 sts = sys$parse(&dirfab) & 1;
1659 set_vaxc_errno(dirfab.fab$l_sts);
1665 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1666 /* Yes; fake the fnb bits so we'll check type below */
1667 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1669 else { /* No; just work with potential name */
1670 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1672 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1673 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1674 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1679 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1680 cp1 = strchr(esa,']');
1681 if (!cp1) cp1 = strchr(esa,'>');
1682 if (cp1) { /* Should always be true */
1683 dirnam.nam$b_esl -= cp1 - esa - 1;
1684 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1687 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1688 /* Yep; check version while we're at it, if it's there. */
1689 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1690 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1691 /* Something other than .DIR[;1]. Bzzt. */
1692 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1693 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1695 set_vaxc_errno(RMS$_DIR);
1699 esa[dirnam.nam$b_esl] = '\0';
1700 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1701 /* They provided at least the name; we added the type, if necessary, */
1702 if (buf) retspec = buf; /* in sys$parse() */
1703 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1704 else retspec = __fileify_retbuf;
1705 strcpy(retspec,esa);
1706 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1707 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1710 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1711 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1713 dirnam.nam$b_esl -= 9;
1715 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1716 if (cp1 == NULL) { /* should never happen */
1717 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1718 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1723 retlen = strlen(esa);
1724 if ((cp1 = strrchr(esa,'.')) != NULL) {
1725 /* There's more than one directory in the path. Just roll back. */
1727 if (buf) retspec = buf;
1728 else if (ts) New(1311,retspec,retlen+7,char);
1729 else retspec = __fileify_retbuf;
1730 strcpy(retspec,esa);
1733 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1734 /* Go back and expand rooted logical name */
1735 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1736 if (!(sys$parse(&dirfab) & 1)) {
1737 dirnam.nam$l_rlf = NULL;
1738 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1740 set_vaxc_errno(dirfab.fab$l_sts);
1743 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1744 if (buf) retspec = buf;
1745 else if (ts) New(1312,retspec,retlen+16,char);
1746 else retspec = __fileify_retbuf;
1747 cp1 = strstr(esa,"][");
1749 memcpy(retspec,esa,dirlen);
1750 if (!strncmp(cp1+2,"000000]",7)) {
1751 retspec[dirlen-1] = '\0';
1752 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1753 if (*cp1 == '.') *cp1 = ']';
1755 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1756 memcpy(cp1+1,"000000]",7);
1760 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1761 retspec[retlen] = '\0';
1762 /* Convert last '.' to ']' */
1763 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1764 if (*cp1 == '.') *cp1 = ']';
1766 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1767 memcpy(cp1+1,"000000]",7);
1771 else { /* This is a top-level dir. Add the MFD to the path. */
1772 if (buf) retspec = buf;
1773 else if (ts) New(1312,retspec,retlen+16,char);
1774 else retspec = __fileify_retbuf;
1777 while (*cp1 != ':') *(cp2++) = *(cp1++);
1778 strcpy(cp2,":[000000]");
1783 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1784 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1785 /* We've set up the string up through the filename. Add the
1786 type and version, and we're done. */
1787 strcat(retspec,".DIR;1");
1789 /* $PARSE may have upcased filespec, so convert output to lower
1790 * case if input contained any lowercase characters. */
1791 if (haslower) __mystrtolower(retspec);
1794 } /* end of do_fileify_dirspec() */
1796 /* External entry points */
1797 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
1798 { return do_fileify_dirspec(dir,buf,0); }
1799 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
1800 { return do_fileify_dirspec(dir,buf,1); }
1802 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1803 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
1805 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1806 unsigned long int retlen;
1807 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1809 if (!dir || !*dir) {
1810 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1813 if (*dir) strcpy(trndir,dir);
1814 else getcwd(trndir,sizeof trndir - 1);
1816 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1817 && my_trnlnm(trndir,trndir,0)) {
1818 STRLEN trnlen = strlen(trndir);
1820 /* Trap simple rooted lnms, and return lnm:[000000] */
1821 if (!strcmp(trndir+trnlen-2,".]")) {
1822 if (buf) retpath = buf;
1823 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1824 else retpath = __pathify_retbuf;
1825 strcpy(retpath,dir);
1826 strcat(retpath,":[000000]");
1832 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1833 if (*dir == '.' && (*(dir+1) == '\0' ||
1834 (*(dir+1) == '.' && *(dir+2) == '\0')))
1835 retlen = 2 + (*(dir+1) != '\0');
1837 if ( !(cp1 = strrchr(dir,'/')) &&
1838 !(cp1 = strrchr(dir,']')) &&
1839 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1840 if ((cp2 = strchr(cp1,'.')) != NULL &&
1841 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1842 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1843 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1844 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1846 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1847 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1848 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1849 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1850 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1851 (ver || *cp3)))))) {
1853 set_vaxc_errno(RMS$_DIR);
1856 retlen = cp2 - dir + 1;
1858 else { /* No file type present. Treat the filename as a directory. */
1859 retlen = strlen(dir) + 1;
1862 if (buf) retpath = buf;
1863 else if (ts) New(1313,retpath,retlen+1,char);
1864 else retpath = __pathify_retbuf;
1865 strncpy(retpath,dir,retlen-1);
1866 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1867 retpath[retlen-1] = '/'; /* with '/', add it. */
1868 retpath[retlen] = '\0';
1870 else retpath[retlen-1] = '\0';
1872 else { /* VMS-style directory spec */
1873 char esa[NAM$C_MAXRSS+1], *cp;
1874 unsigned long int sts, cmplen, haslower;
1875 struct FAB dirfab = cc$rms_fab;
1876 struct NAM savnam, dirnam = cc$rms_nam;
1878 /* If we've got an explicit filename, we can just shuffle the string. */
1879 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1880 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1881 if ((cp2 = strchr(cp1,'.')) != NULL) {
1883 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1884 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1885 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1886 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1887 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1888 (ver || *cp3)))))) {
1890 set_vaxc_errno(RMS$_DIR);
1894 else { /* No file type, so just draw name into directory part */
1895 for (cp2 = cp1; *cp2; cp2++) ;
1898 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1900 /* We've now got a VMS 'path'; fall through */
1902 dirfab.fab$b_fns = strlen(dir);
1903 dirfab.fab$l_fna = dir;
1904 if (dir[dirfab.fab$b_fns-1] == ']' ||
1905 dir[dirfab.fab$b_fns-1] == '>' ||
1906 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1907 if (buf) retpath = buf;
1908 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1909 else retpath = __pathify_retbuf;
1910 strcpy(retpath,dir);
1913 dirfab.fab$l_dna = ".DIR;1";
1914 dirfab.fab$b_dns = 6;
1915 dirfab.fab$l_nam = &dirnam;
1916 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1917 dirnam.nam$l_esa = esa;
1919 for (cp = dir; *cp; cp++)
1920 if (islower(*cp)) { haslower = 1; break; }
1922 if (!(sts = (sys$parse(&dirfab)&1))) {
1923 if (dirfab.fab$l_sts == RMS$_DIR) {
1924 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1925 sts = sys$parse(&dirfab) & 1;
1929 set_vaxc_errno(dirfab.fab$l_sts);
1935 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1936 if (dirfab.fab$l_sts != RMS$_FNF) {
1937 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1938 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1940 set_vaxc_errno(dirfab.fab$l_sts);
1943 dirnam = savnam; /* No; just work with potential name */
1946 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1947 /* Yep; check version while we're at it, if it's there. */
1948 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1949 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1950 /* Something other than .DIR[;1]. Bzzt. */
1951 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1952 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1954 set_vaxc_errno(RMS$_DIR);
1958 /* OK, the type was fine. Now pull any file name into the
1960 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1962 cp1 = strrchr(esa,'>');
1963 *dirnam.nam$l_type = '>';
1966 *(dirnam.nam$l_type + 1) = '\0';
1967 retlen = dirnam.nam$l_type - esa + 2;
1968 if (buf) retpath = buf;
1969 else if (ts) New(1314,retpath,retlen,char);
1970 else retpath = __pathify_retbuf;
1971 strcpy(retpath,esa);
1972 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1973 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1974 /* $PARSE may have upcased filespec, so convert output to lower
1975 * case if input contained any lowercase characters. */
1976 if (haslower) __mystrtolower(retpath);
1980 } /* end of do_pathify_dirspec() */
1982 /* External entry points */
1983 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
1984 { return do_pathify_dirspec(dir,buf,0); }
1985 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
1986 { return do_pathify_dirspec(dir,buf,1); }
1988 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1989 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
1991 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1992 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1993 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1995 if (spec == NULL) return NULL;
1996 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1997 if (buf) rslt = buf;
1999 retlen = strlen(spec);
2000 cp1 = strchr(spec,'[');
2001 if (!cp1) cp1 = strchr(spec,'<');
2003 for (cp1++; *cp1; cp1++) {
2004 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
2005 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2006 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2009 New(1315,rslt,retlen+2+2*expand,char);
2011 else rslt = __tounixspec_retbuf;
2012 if (strchr(spec,'/') != NULL) {
2019 dirend = strrchr(spec,']');
2020 if (dirend == NULL) dirend = strrchr(spec,'>');
2021 if (dirend == NULL) dirend = strchr(spec,':');
2022 if (dirend == NULL) {
2026 if (*cp2 != '[' && *cp2 != '<') {
2029 else { /* the VMS spec begins with directories */
2031 if (*cp2 == ']' || *cp2 == '>') {
2032 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2035 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2036 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2037 if (ts) Safefree(rslt);
2042 while (*cp3 != ':' && *cp3) cp3++;
2044 if (strchr(cp3,']') != NULL) break;
2045 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2047 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2048 retlen = devlen + dirlen;
2049 Renew(rslt,retlen+1+2*expand,char);
2055 *(cp1++) = *(cp3++);
2056 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2060 else if ( *cp2 == '.') {
2061 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2062 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2068 for (; cp2 <= dirend; cp2++) {
2071 if (*(cp2+1) == '[') cp2++;
2073 else if (*cp2 == ']' || *cp2 == '>') {
2074 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2076 else if (*cp2 == '.') {
2078 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2079 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2080 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2081 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2082 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2084 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2085 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2089 else if (*cp2 == '-') {
2090 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2091 while (*cp2 == '-') {
2093 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2095 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2096 if (ts) Safefree(rslt); /* filespecs like */
2097 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2101 else *(cp1++) = *cp2;
2103 else *(cp1++) = *cp2;
2105 while (*cp2) *(cp1++) = *(cp2++);
2110 } /* end of do_tounixspec() */
2112 /* External entry points */
2113 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2114 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2116 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2117 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
2118 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2119 char *rslt, *dirend;
2120 register char *cp1, *cp2;
2121 unsigned long int infront = 0, hasdir = 1;
2123 if (path == NULL) return NULL;
2124 if (buf) rslt = buf;
2125 else if (ts) New(1316,rslt,strlen(path)+9,char);
2126 else rslt = __tovmsspec_retbuf;
2127 if (strpbrk(path,"]:>") ||
2128 (dirend = strrchr(path,'/')) == NULL) {
2129 if (path[0] == '.') {
2130 if (path[1] == '\0') strcpy(rslt,"[]");
2131 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2132 else strcpy(rslt,path); /* probably garbage */
2134 else strcpy(rslt,path);
2137 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2138 if (!*(dirend+2)) dirend +=2;
2139 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2140 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2145 char trndev[NAM$C_MAXRSS+1];
2149 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2151 if (!buf & ts) Renew(rslt,18,char);
2152 strcpy(rslt,"sys$disk:[000000]");
2155 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2157 islnm = my_trnlnm(rslt,trndev,0);
2158 trnend = islnm ? strlen(trndev) - 1 : 0;
2159 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2160 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2161 /* If the first element of the path is a logical name, determine
2162 * whether it has to be translated so we can add more directories. */
2163 if (!islnm || rooted) {
2166 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2170 if (cp2 != dirend) {
2171 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2172 strcpy(rslt,trndev);
2173 cp1 = rslt + trnend;
2186 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2187 cp2 += 2; /* skip over "./" - it's redundant */
2188 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2190 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2191 *(cp1++) = '-'; /* "../" --> "-" */
2194 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2195 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2196 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2197 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2200 if (cp2 > dirend) cp2 = dirend;
2202 else *(cp1++) = '.';
2204 for (; cp2 < dirend; cp2++) {
2206 if (*(cp2-1) == '/') continue;
2207 if (*(cp1-1) != '.') *(cp1++) = '.';
2210 else if (!infront && *cp2 == '.') {
2211 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2212 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2213 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2214 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2215 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2216 else { /* back up over previous directory name */
2218 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2219 if (*(cp1-1) == '[') {
2220 memcpy(cp1,"000000.",7);
2225 if (cp2 == dirend) break;
2227 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2228 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2229 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2230 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2232 *(cp1++) = '.'; /* Simulate trailing '/' */
2233 cp2 += 2; /* for loop will incr this to == dirend */
2235 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2237 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2240 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2241 if (*cp2 == '.') *(cp1++) = '_';
2242 else *(cp1++) = *cp2;
2246 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2247 if (hasdir) *(cp1++) = ']';
2248 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2249 while (*cp2) *(cp1++) = *(cp2++);
2254 } /* end of do_tovmsspec() */
2256 /* External entry points */
2257 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2258 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2260 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2261 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
2262 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2264 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2266 if (path == NULL) return NULL;
2267 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2268 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2269 if (buf) return buf;
2271 vmslen = strlen(vmsified);
2272 New(1317,cp,vmslen+1,char);
2273 memcpy(cp,vmsified,vmslen);
2278 strcpy(__tovmspath_retbuf,vmsified);
2279 return __tovmspath_retbuf;
2282 } /* end of do_tovmspath() */
2284 /* External entry points */
2285 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
2286 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
2289 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2290 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
2291 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2293 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2295 if (path == NULL) return NULL;
2296 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2297 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2298 if (buf) return buf;
2300 unixlen = strlen(unixified);
2301 New(1317,cp,unixlen+1,char);
2302 memcpy(cp,unixified,unixlen);
2307 strcpy(__tounixpath_retbuf,unixified);
2308 return __tounixpath_retbuf;
2311 } /* end of do_tounixpath() */
2313 /* External entry points */
2314 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
2315 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
2318 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2320 *****************************************************************************
2322 * Copyright (C) 1989-1994 by *
2323 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2325 * Permission is hereby granted for the reproduction of this software, *
2326 * on condition that this copyright notice is included in the reproduction, *
2327 * and that such reproduction is not for purposes of profit or material *
2330 * 27-Aug-1994 Modified for inclusion in perl5 *
2331 * by Charles Bailey bailey@newman.upenn.edu *
2332 *****************************************************************************
2336 * getredirection() is intended to aid in porting C programs
2337 * to VMS (Vax-11 C). The native VMS environment does not support
2338 * '>' and '<' I/O redirection, or command line wild card expansion,
2339 * or a command line pipe mechanism using the '|' AND background
2340 * command execution '&'. All of these capabilities are provided to any
2341 * C program which calls this procedure as the first thing in the
2343 * The piping mechanism will probably work with almost any 'filter' type
2344 * of program. With suitable modification, it may useful for other
2345 * portability problems as well.
2347 * Author: Mark Pizzolato mark@infocomm.com
2351 struct list_item *next;
2355 static void add_item(struct list_item **head,
2356 struct list_item **tail,
2360 static void mp_expand_wild_cards(pTHX_ char *item,
2361 struct list_item **head,
2362 struct list_item **tail,
2365 static int background_process(int argc, char **argv);
2367 static void pipe_and_fork(char **cmargv);
2369 /*{{{ void getredirection(int *ac, char ***av)*/
2371 mp_getredirection(pTHX_ int *ac, char ***av)
2373 * Process vms redirection arg's. Exit if any error is seen.
2374 * If getredirection() processes an argument, it is erased
2375 * from the vector. getredirection() returns a new argc and argv value.
2376 * In the event that a background command is requested (by a trailing "&"),
2377 * this routine creates a background subprocess, and simply exits the program.
2379 * Warning: do not try to simplify the code for vms. The code
2380 * presupposes that getredirection() is called before any data is
2381 * read from stdin or written to stdout.
2383 * Normal usage is as follows:
2389 * getredirection(&argc, &argv);
2393 int argc = *ac; /* Argument Count */
2394 char **argv = *av; /* Argument Vector */
2395 char *ap; /* Argument pointer */
2396 int j; /* argv[] index */
2397 int item_count = 0; /* Count of Items in List */
2398 struct list_item *list_head = 0; /* First Item in List */
2399 struct list_item *list_tail; /* Last Item in List */
2400 char *in = NULL; /* Input File Name */
2401 char *out = NULL; /* Output File Name */
2402 char *outmode = "w"; /* Mode to Open Output File */
2403 char *err = NULL; /* Error File Name */
2404 char *errmode = "w"; /* Mode to Open Error File */
2405 int cmargc = 0; /* Piped Command Arg Count */
2406 char **cmargv = NULL;/* Piped Command Arg Vector */
2409 * First handle the case where the last thing on the line ends with
2410 * a '&'. This indicates the desire for the command to be run in a
2411 * subprocess, so we satisfy that desire.
2414 if (0 == strcmp("&", ap))
2415 exit(background_process(--argc, argv));
2416 if (*ap && '&' == ap[strlen(ap)-1])
2418 ap[strlen(ap)-1] = '\0';
2419 exit(background_process(argc, argv));
2422 * Now we handle the general redirection cases that involve '>', '>>',
2423 * '<', and pipes '|'.
2425 for (j = 0; j < argc; ++j)
2427 if (0 == strcmp("<", argv[j]))
2431 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2432 exit(LIB$_WRONUMARG);
2437 if ('<' == *(ap = argv[j]))
2442 if (0 == strcmp(">", ap))
2446 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2447 exit(LIB$_WRONUMARG);
2466 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2467 exit(LIB$_WRONUMARG);
2471 if (('2' == *ap) && ('>' == ap[1]))
2488 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2489 exit(LIB$_WRONUMARG);
2493 if (0 == strcmp("|", argv[j]))
2497 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2498 exit(LIB$_WRONUMARG);
2500 cmargc = argc-(j+1);
2501 cmargv = &argv[j+1];
2505 if ('|' == *(ap = argv[j]))
2513 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2516 * Allocate and fill in the new argument vector, Some Unix's terminate
2517 * the list with an extra null pointer.
2519 New(1302, argv, item_count+1, char *);
2521 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2522 argv[j] = list_head->value;
2528 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2529 exit(LIB$_INVARGORD);
2531 pipe_and_fork(cmargv);
2534 /* Check for input from a pipe (mailbox) */
2536 if (in == NULL && 1 == isapipe(0))
2538 char mbxname[L_tmpnam];
2540 long int dvi_item = DVI$_DEVBUFSIZ;
2541 $DESCRIPTOR(mbxnam, "");
2542 $DESCRIPTOR(mbxdevnam, "");
2544 /* Input from a pipe, reopen it in binary mode to disable */
2545 /* carriage control processing. */
2547 PerlIO_getname(stdin, mbxname);
2548 mbxnam.dsc$a_pointer = mbxname;
2549 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2550 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2551 mbxdevnam.dsc$a_pointer = mbxname;
2552 mbxdevnam.dsc$w_length = sizeof(mbxname);
2553 dvi_item = DVI$_DEVNAM;
2554 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2555 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2558 freopen(mbxname, "rb", stdin);
2561 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2565 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2567 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2570 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2572 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2576 if (strcmp(err,"&1") == 0) {
2577 dup2(fileno(stdout), fileno(Perl_debug_log));
2580 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2582 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2586 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2592 #ifdef ARGPROC_DEBUG
2593 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2594 for (j = 0; j < *ac; ++j)
2595 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2597 /* Clear errors we may have hit expanding wildcards, so they don't
2598 show up in Perl's $! later */
2599 set_errno(0); set_vaxc_errno(1);
2600 } /* end of getredirection() */
2603 static void add_item(struct list_item **head,
2604 struct list_item **tail,
2610 New(1303,*head,1,struct list_item);
2614 New(1304,(*tail)->next,1,struct list_item);
2615 *tail = (*tail)->next;
2617 (*tail)->value = value;
2621 static void mp_expand_wild_cards(pTHX_ char *item,
2622 struct list_item **head,
2623 struct list_item **tail,
2627 unsigned long int context = 0;
2633 char vmsspec[NAM$C_MAXRSS+1];
2634 $DESCRIPTOR(filespec, "");
2635 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2636 $DESCRIPTOR(resultspec, "");
2637 unsigned long int zero = 0, sts;
2639 for (cp = item; *cp; cp++) {
2640 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2641 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2643 if (!*cp || isspace(*cp))
2645 add_item(head, tail, item, count);
2648 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2649 resultspec.dsc$b_class = DSC$K_CLASS_D;
2650 resultspec.dsc$a_pointer = NULL;
2651 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2652 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2653 if (!isunix || !filespec.dsc$a_pointer)
2654 filespec.dsc$a_pointer = item;
2655 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2657 * Only return version specs, if the caller specified a version
2659 had_version = strchr(item, ';');
2661 * Only return device and directory specs, if the caller specifed either.
2663 had_device = strchr(item, ':');
2664 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2666 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2667 &defaultspec, 0, 0, &zero))))
2672 New(1305,string,resultspec.dsc$w_length+1,char);
2673 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2674 string[resultspec.dsc$w_length] = '\0';
2675 if (NULL == had_version)
2676 *((char *)strrchr(string, ';')) = '\0';
2677 if ((!had_directory) && (had_device == NULL))
2679 if (NULL == (devdir = strrchr(string, ']')))
2680 devdir = strrchr(string, '>');
2681 strcpy(string, devdir + 1);
2684 * Be consistent with what the C RTL has already done to the rest of
2685 * the argv items and lowercase all of these names.
2687 for (c = string; *c; ++c)
2690 if (isunix) trim_unixpath(string,item,1);
2691 add_item(head, tail, string, count);
2694 if (sts != RMS$_NMF)
2696 set_vaxc_errno(sts);
2699 case RMS$_FNF: case RMS$_DNF:
2700 set_errno(ENOENT); break;
2702 set_errno(ENOTDIR); break;
2704 set_errno(ENODEV); break;
2705 case RMS$_FNM: case RMS$_SYN:
2706 set_errno(EINVAL); break;
2708 set_errno(EACCES); break;
2710 _ckvmssts_noperl(sts);
2714 add_item(head, tail, item, count);
2715 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2716 _ckvmssts_noperl(lib$find_file_end(&context));
2719 static int child_st[2];/* Event Flag set when child process completes */
2721 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2723 static unsigned long int exit_handler(int *status)
2727 if (0 == child_st[0])
2729 #ifdef ARGPROC_DEBUG
2730 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2732 fflush(stdout); /* Have to flush pipe for binary data to */
2733 /* terminate properly -- <tp@mccall.com> */
2734 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2735 sys$dassgn(child_chan);
2737 sys$synch(0, child_st);
2742 static void sig_child(int chan)
2744 #ifdef ARGPROC_DEBUG
2745 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2747 if (child_st[0] == 0)
2751 static struct exit_control_block exit_block =
2756 &exit_block.exit_status,
2760 static void pipe_and_fork(char **cmargv)
2763 $DESCRIPTOR(cmddsc, "");
2764 static char mbxname[64];
2765 $DESCRIPTOR(mbxdsc, mbxname);
2767 unsigned long int zero = 0, one = 1;
2769 strcpy(subcmd, cmargv[0]);
2770 for (j = 1; NULL != cmargv[j]; ++j)
2772 strcat(subcmd, " \"");
2773 strcat(subcmd, cmargv[j]);
2774 strcat(subcmd, "\"");
2776 cmddsc.dsc$a_pointer = subcmd;
2777 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2779 create_mbx(&child_chan,&mbxdsc);
2780 #ifdef ARGPROC_DEBUG
2781 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2782 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2784 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2785 0, &pid, child_st, &zero, sig_child,
2787 #ifdef ARGPROC_DEBUG
2788 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2790 sys$dclexh(&exit_block);
2791 if (NULL == freopen(mbxname, "wb", stdout))
2793 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2797 static int background_process(int argc, char **argv)
2799 char command[2048] = "$";
2800 $DESCRIPTOR(value, "");
2801 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2802 static $DESCRIPTOR(null, "NLA0:");
2803 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2805 $DESCRIPTOR(pidstr, "");
2807 unsigned long int flags = 17, one = 1, retsts;
2809 strcat(command, argv[0]);
2812 strcat(command, " \"");
2813 strcat(command, *(++argv));
2814 strcat(command, "\"");
2816 value.dsc$a_pointer = command;
2817 value.dsc$w_length = strlen(value.dsc$a_pointer);
2818 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2819 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2820 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2821 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2824 _ckvmssts_noperl(retsts);
2826 #ifdef ARGPROC_DEBUG
2827 PerlIO_printf(Perl_debug_log, "%s\n", command);
2829 sprintf(pidstring, "%08X", pid);
2830 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2831 pidstr.dsc$a_pointer = pidstring;
2832 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2833 lib$set_symbol(&pidsymbol, &pidstr);
2837 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2840 /* OS-specific initialization at image activation (not thread startup) */
2841 /* Older VAXC header files lack these constants */
2842 #ifndef JPI$_RIGHTS_SIZE
2843 # define JPI$_RIGHTS_SIZE 817
2845 #ifndef KGB$M_SUBSYSTEM
2846 # define KGB$M_SUBSYSTEM 0x8
2849 /*{{{void vms_image_init(int *, char ***)*/
2851 vms_image_init(int *argcp, char ***argvp)
2853 char eqv[LNM$C_NAMLENGTH+1] = "";
2854 unsigned int len, tabct = 8, tabidx = 0;
2855 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2856 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2857 unsigned short int dummy, rlen;
2858 struct dsc$descriptor_s **tabvec;
2860 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2861 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2862 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2865 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2867 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2868 if (iprv[i]) { /* Running image installed with privs? */
2869 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2874 /* Rights identifiers might trigger tainting as well. */
2875 if (!will_taint && (rlen || rsz)) {
2876 while (rlen < rsz) {
2877 /* We didn't get all the identifiers on the first pass. Allocate a
2878 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2879 * were needed to hold all identifiers at time of last call; we'll
2880 * allocate that many unsigned long ints), and go back and get 'em.
2882 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2883 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2884 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2885 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2888 mask = jpilist[1].bufadr;
2889 /* Check attribute flags for each identifier (2nd longword); protected
2890 * subsystem identifiers trigger tainting.
2892 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2893 if (mask[i] & KGB$M_SUBSYSTEM) {
2898 if (mask != rlst) Safefree(mask);
2900 /* We need to use this hack to tell Perl it should run with tainting,
2901 * since its tainting flag may be part of the PL_curinterp struct, which
2902 * hasn't been allocated when vms_image_init() is called.
2906 New(1320,newap,*argcp+2,char **);
2907 newap[0] = argvp[0];
2909 Copy(argvp[1],newap[2],*argcp-1,char **);
2910 /* We orphan the old argv, since we don't know where it's come from,
2911 * so we don't know how to free it.
2913 *argcp++; argvp = newap;
2915 else { /* Did user explicitly request tainting? */
2917 char *cp, **av = *argvp;
2918 for (i = 1; i < *argcp; i++) {
2919 if (*av[i] != '-') break;
2920 for (cp = av[i]+1; *cp; cp++) {
2921 if (*cp == 'T') { will_taint = 1; break; }
2922 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2923 strchr("DFIiMmx",*cp)) break;
2925 if (will_taint) break;
2930 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2932 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2933 else if (tabidx >= tabct) {
2935 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2937 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2938 tabvec[tabidx]->dsc$w_length = 0;
2939 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2940 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2941 tabvec[tabidx]->dsc$a_pointer = NULL;
2942 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2944 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2946 getredirection(argcp,argvp);
2947 #if defined(USE_THREADS) && defined(__DECC)
2949 # include <reentrancy.h>
2950 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2959 * Trim Unix-style prefix off filespec, so it looks like what a shell
2960 * glob expansion would return (i.e. from specified prefix on, not
2961 * full path). Note that returned filespec is Unix-style, regardless
2962 * of whether input filespec was VMS-style or Unix-style.
2964 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2965 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2966 * vector of options; at present, only bit 0 is used, and if set tells
2967 * trim unixpath to try the current default directory as a prefix when
2968 * presented with a possibly ambiguous ... wildcard.
2970 * Returns !=0 on success, with trimmed filespec replacing contents of
2971 * fspec, and 0 on failure, with contents of fpsec unchanged.
2973 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2975 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
2977 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2978 *template, *base, *end, *cp1, *cp2;
2979 register int tmplen, reslen = 0, dirs = 0;
2981 if (!wildspec || !fspec) return 0;
2982 if (strpbrk(wildspec,"]>:") != NULL) {
2983 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2984 else template = unixwild;
2986 else template = wildspec;
2987 if (strpbrk(fspec,"]>:") != NULL) {
2988 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2989 else base = unixified;
2990 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2991 * check to see that final result fits into (isn't longer than) fspec */
2992 reslen = strlen(fspec);
2996 /* No prefix or absolute path on wildcard, so nothing to remove */
2997 if (!*template || *template == '/') {
2998 if (base == fspec) return 1;
2999 tmplen = strlen(unixified);
3000 if (tmplen > reslen) return 0; /* not enough space */
3001 /* Copy unixified resultant, including trailing NUL */
3002 memmove(fspec,unixified,tmplen+1);
3006 for (end = base; *end; end++) ; /* Find end of resultant filespec */
3007 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3008 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3009 for (cp1 = end ;cp1 >= base; cp1--)
3010 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3012 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3016 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3017 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3018 int ells = 1, totells, segdirs, match;
3019 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3020 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3022 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3024 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3025 if (ellipsis == template && opts & 1) {
3026 /* Template begins with an ellipsis. Since we can't tell how many
3027 * directory names at the front of the resultant to keep for an
3028 * arbitrary starting point, we arbitrarily choose the current
3029 * default directory as a starting point. If it's there as a prefix,
3030 * clip it off. If not, fall through and act as if the leading
3031 * ellipsis weren't there (i.e. return shortest possible path that
3032 * could match template).
3034 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3035 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3036 if (_tolower(*cp1) != _tolower(*cp2)) break;
3037 segdirs = dirs - totells; /* Min # of dirs we must have left */
3038 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3039 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3040 memcpy(fspec,cp2+1,end - cp2);
3044 /* First off, back up over constant elements at end of path */
3046 for (front = end ; front >= base; front--)
3047 if (*front == '/' && !dirs--) { front++; break; }
3049 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3050 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3051 if (cp1 != '\0') return 0; /* Path too long. */
3053 *cp2 = '\0'; /* Pick up with memcpy later */
3054 lcfront = lcres + (front - base);
3055 /* Now skip over each ellipsis and try to match the path in front of it. */
3057 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3058 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3059 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3060 if (cp1 < template) break; /* template started with an ellipsis */
3061 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3062 ellipsis = cp1; continue;
3064 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3066 for (segdirs = 0, cp2 = tpl;
3067 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3069 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3070 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3071 if (*cp2 == '/') segdirs++;
3073 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3074 /* Back up at least as many dirs as in template before matching */
3075 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3076 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3077 for (match = 0; cp1 > lcres;) {
3078 resdsc.dsc$a_pointer = cp1;
3079 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3081 if (match == 1) lcfront = cp1;
3083 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3085 if (!match) return 0; /* Can't find prefix ??? */
3086 if (match > 1 && opts & 1) {
3087 /* This ... wildcard could cover more than one set of dirs (i.e.
3088 * a set of similar dir names is repeated). If the template
3089 * contains more than 1 ..., upstream elements could resolve the
3090 * ambiguity, but it's not worth a full backtracking setup here.
3091 * As a quick heuristic, clip off the current default directory
3092 * if it's present to find the trimmed spec, else use the
3093 * shortest string that this ... could cover.
3095 char def[NAM$C_MAXRSS+1], *st;
3097 if (getcwd(def, sizeof def,0) == NULL) return 0;
3098 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3099 if (_tolower(*cp1) != _tolower(*cp2)) break;
3100 segdirs = dirs - totells; /* Min # of dirs we must have left */
3101 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3102 if (*cp1 == '\0' && *cp2 == '/') {
3103 memcpy(fspec,cp2+1,end - cp2);
3106 /* Nope -- stick with lcfront from above and keep going. */
3109 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3114 } /* end of trim_unixpath() */
3119 * VMS readdir() routines.
3120 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3122 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3123 * Minor modifications to original routines.
3126 /* Number of elements in vms_versions array */
3127 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3130 * Open a directory, return a handle for later use.
3132 /*{{{ DIR *opendir(char*name) */
3134 Perl_opendir(pTHX_ char *name)
3137 char dir[NAM$C_MAXRSS+1];
3140 if (do_tovmspath(name,dir,0) == NULL) {
3143 if (flex_stat(dir,&sb) == -1) return NULL;
3144 if (!S_ISDIR(sb.st_mode)) {
3145 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3148 if (!cando_by_name(S_IRUSR,0,dir)) {
3149 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3152 /* Get memory for the handle, and the pattern. */
3154 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3156 /* Fill in the fields; mainly playing with the descriptor. */
3157 (void)sprintf(dd->pattern, "%s*.*",dir);
3160 dd->vms_wantversions = 0;
3161 dd->pat.dsc$a_pointer = dd->pattern;
3162 dd->pat.dsc$w_length = strlen(dd->pattern);
3163 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3164 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3167 } /* end of opendir() */
3171 * Set the flag to indicate we want versions or not.
3173 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3175 vmsreaddirversions(DIR *dd, int flag)
3177 dd->vms_wantversions = flag;
3182 * Free up an opened directory.
3184 /*{{{ void closedir(DIR *dd)*/
3188 (void)lib$find_file_end(&dd->context);
3189 Safefree(dd->pattern);
3190 Safefree((char *)dd);
3195 * Collect all the version numbers for the current file.
3201 struct dsc$descriptor_s pat;
3202 struct dsc$descriptor_s res;
3204 char *p, *text, buff[sizeof dd->entry.d_name];
3206 unsigned long context, tmpsts;
3209 /* Convenient shorthand. */
3212 /* Add the version wildcard, ignoring the "*.*" put on before */
3213 i = strlen(dd->pattern);
3214 New(1308,text,i + e->d_namlen + 3,char);
3215 (void)strcpy(text, dd->pattern);
3216 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3218 /* Set up the pattern descriptor. */
3219 pat.dsc$a_pointer = text;
3220 pat.dsc$w_length = i + e->d_namlen - 1;
3221 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3222 pat.dsc$b_class = DSC$K_CLASS_S;
3224 /* Set up result descriptor. */
3225 res.dsc$a_pointer = buff;
3226 res.dsc$w_length = sizeof buff - 2;
3227 res.dsc$b_dtype = DSC$K_DTYPE_T;
3228 res.dsc$b_class = DSC$K_CLASS_S;
3230 /* Read files, collecting versions. */
3231 for (context = 0, e->vms_verscount = 0;
3232 e->vms_verscount < VERSIZE(e);
3233 e->vms_verscount++) {
3234 tmpsts = lib$find_file(&pat, &res, &context);
3235 if (tmpsts == RMS$_NMF || context == 0) break;
3237 buff[sizeof buff - 1] = '\0';
3238 if ((p = strchr(buff, ';')))
3239 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3241 e->vms_versions[e->vms_verscount] = -1;
3244 _ckvmssts(lib$find_file_end(&context));
3247 } /* end of collectversions() */
3250 * Read the next entry from the directory.
3252 /*{{{ struct dirent *readdir(DIR *dd)*/
3256 struct dsc$descriptor_s res;
3257 char *p, buff[sizeof dd->entry.d_name];
3258 unsigned long int tmpsts;
3260 /* Set up result descriptor, and get next file. */
3261 res.dsc$a_pointer = buff;
3262 res.dsc$w_length = sizeof buff - 2;
3263 res.dsc$b_dtype = DSC$K_DTYPE_T;
3264 res.dsc$b_class = DSC$K_CLASS_S;
3265 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3266 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3267 if (!(tmpsts & 1)) {
3268 set_vaxc_errno(tmpsts);
3271 set_errno(EACCES); break;
3273 set_errno(ENODEV); break;
3275 set_errno(ENOTDIR); break;
3276 case RMS$_FNF: case RMS$_DNF:
3277 set_errno(ENOENT); break;
3284 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3285 buff[sizeof buff - 1] = '\0';
3286 for (p = buff; *p; p++) *p = _tolower(*p);
3287 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3290 /* Skip any directory component and just copy the name. */
3291 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3292 else (void)strcpy(dd->entry.d_name, buff);
3294 /* Clobber the version. */
3295 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3297 dd->entry.d_namlen = strlen(dd->entry.d_name);
3298 dd->entry.vms_verscount = 0;
3299 if (dd->vms_wantversions) collectversions(dd);
3302 } /* end of readdir() */
3306 * Return something that can be used in a seekdir later.
3308 /*{{{ long telldir(DIR *dd)*/
3317 * Return to a spot where we used to be. Brute force.
3319 /*{{{ void seekdir(DIR *dd,long count)*/
3321 seekdir(DIR *dd, long count)
3323 int vms_wantversions;
3326 /* If we haven't done anything yet... */
3330 /* Remember some state, and clear it. */
3331 vms_wantversions = dd->vms_wantversions;
3332 dd->vms_wantversions = 0;
3333 _ckvmssts(lib$find_file_end(&dd->context));
3336 /* The increment is in readdir(). */
3337 for (dd->count = 0; dd->count < count; )
3340 dd->vms_wantversions = vms_wantversions;
3342 } /* end of seekdir() */
3345 /* VMS subprocess management
3347 * my_vfork() - just a vfork(), after setting a flag to record that
3348 * the current script is trying a Unix-style fork/exec.
3350 * vms_do_aexec() and vms_do_exec() are called in response to the
3351 * perl 'exec' function. If this follows a vfork call, then they
3352 * call out the the regular perl routines in doio.c which do an
3353 * execvp (for those who really want to try this under VMS).
3354 * Otherwise, they do exactly what the perl docs say exec should
3355 * do - terminate the current script and invoke a new command
3356 * (See below for notes on command syntax.)
3358 * do_aspawn() and do_spawn() implement the VMS side of the perl
3359 * 'system' function.
3361 * Note on command arguments to perl 'exec' and 'system': When handled
3362 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3363 * are concatenated to form a DCL command string. If the first arg
3364 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3365 * the the command string is handed off to DCL directly. Otherwise,
3366 * the first token of the command is taken as the filespec of an image
3367 * to run. The filespec is expanded using a default type of '.EXE' and
3368 * the process defaults for device, directory, etc., and if found, the resultant
3369 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3370 * the command string as parameters. This is perhaps a bit complicated,
3371 * but I hope it will form a happy medium between what VMS folks expect
3372 * from lib$spawn and what Unix folks expect from exec.
3375 static int vfork_called;
3377 /*{{{int my_vfork()*/
3388 vms_execfree(pTHX) {
3390 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3393 if (VMScmd.dsc$a_pointer) {
3394 Safefree(VMScmd.dsc$a_pointer);
3395 VMScmd.dsc$w_length = 0;
3396 VMScmd.dsc$a_pointer = Nullch;
3401 setup_argstr(SV *really, SV **mark, SV **sp)
3404 char *junk, *tmps = Nullch;
3405 register size_t cmdlen = 0;
3412 tmps = SvPV(really,rlen);
3419 for (idx++; idx <= sp; idx++) {
3421 junk = SvPVx(*idx,rlen);
3422 cmdlen += rlen ? rlen + 1 : 0;
3425 New(401,PL_Cmd,cmdlen+1,char);
3427 if (tmps && *tmps) {
3428 strcpy(PL_Cmd,tmps);
3431 else *PL_Cmd = '\0';
3432 while (++mark <= sp) {
3434 char *s = SvPVx(*mark,n_a);
3436 if (*PL_Cmd) strcat(PL_Cmd," ");
3442 } /* end of setup_argstr() */
3445 static unsigned long int
3446 setup_cmddsc(char *cmd, int check_img)
3448 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3449 $DESCRIPTOR(defdsc,".EXE");
3450 $DESCRIPTOR(defdsc2,".");
3451 $DESCRIPTOR(resdsc,resspec);
3452 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3453 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3454 register char *s, *rest, *cp, *wordbreak;
3459 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3462 while (*s && isspace(*s)) s++;
3464 if (*s == '@' || *s == '$') {
3465 vmsspec[0] = *s; rest = s + 1;
3466 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3468 else { cp = vmsspec; rest = s; }
3469 if (*rest == '.' || *rest == '/') {
3472 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3473 rest++, cp2++) *cp2 = *rest;
3475 if (do_tovmsspec(resspec,cp,0)) {
3478 for (cp2 = vmsspec + strlen(vmsspec);
3479 *rest && cp2 - vmsspec < sizeof vmsspec;
3480 rest++, cp2++) *cp2 = *rest;
3485 /* Intuit whether verb (first word of cmd) is a DCL command:
3486 * - if first nonspace char is '@', it's a DCL indirection
3488 * - if verb contains a filespec separator, it's not a DCL command
3489 * - if it doesn't, caller tells us whether to default to a DCL
3490 * command, or to a local image unless told it's DCL (by leading '$')
3492 if (*s == '@') isdcl = 1;
3494 register char *filespec = strpbrk(s,":<[.;");
3495 rest = wordbreak = strpbrk(s," \"\t/");
3496 if (!wordbreak) wordbreak = s + strlen(s);
3497 if (*s == '$') check_img = 0;
3498 if (filespec && (filespec < wordbreak)) isdcl = 0;
3499 else isdcl = !check_img;
3503 imgdsc.dsc$a_pointer = s;
3504 imgdsc.dsc$w_length = wordbreak - s;
3505 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3507 _ckvmssts(lib$find_file_end(&cxt));
3508 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3509 if (!(retsts & 1) && *s == '$') {
3510 _ckvmssts(lib$find_file_end(&cxt));
3511 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3512 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3514 _ckvmssts(lib$find_file_end(&cxt));
3515 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3519 _ckvmssts(lib$find_file_end(&cxt));
3524 while (*s && !isspace(*s)) s++;
3527 /* check that it's really not DCL with no file extension */
3528 fp = fopen(resspec,"r","ctx=bin,shr=get");
3530 char b[4] = {0,0,0,0};
3531 read(fileno(fp),b,4);
3532 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3535 if (check_img && isdcl) return RMS$_FNF;
3537 if (cando_by_name(S_IXUSR,0,resspec)) {
3538 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3540 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3542 strcpy(VMScmd.dsc$a_pointer,"@");
3544 strcat(VMScmd.dsc$a_pointer,resspec);
3545 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3546 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3549 else retsts = RMS$_PRV;
3552 /* It's either a DCL command or we couldn't find a suitable image */
3553 VMScmd.dsc$w_length = strlen(cmd);
3554 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3555 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3556 if (!(retsts & 1)) {
3557 /* just hand off status values likely to be due to user error */
3558 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3559 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3560 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3561 else { _ckvmssts(retsts); }
3564 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3566 } /* end of setup_cmddsc() */
3569 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3571 vms_do_aexec(SV *really,SV **mark,SV **sp)
3575 if (vfork_called) { /* this follows a vfork - act Unixish */
3577 if (vfork_called < 0) {
3578 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3581 else return do_aexec(really,mark,sp);
3583 /* no vfork - act VMSish */
3584 return vms_do_exec(setup_argstr(really,mark,sp));
3589 } /* end of vms_do_aexec() */
3592 /* {{{bool vms_do_exec(char *cmd) */
3594 vms_do_exec(char *cmd)
3598 if (vfork_called) { /* this follows a vfork - act Unixish */
3600 if (vfork_called < 0) {
3601 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3604 else return do_exec(cmd);
3607 { /* no vfork - act VMSish */
3608 unsigned long int retsts;
3611 TAINT_PROPER("exec");
3612 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3613 retsts = lib$do_command(&VMScmd);
3616 case RMS$_FNF: case RMS$_DNF:
3617 set_errno(ENOENT); break;
3619 set_errno(ENOTDIR); break;
3621 set_errno(ENODEV); break;
3623 set_errno(EACCES); break;
3625 set_errno(EINVAL); break;
3627 set_errno(E2BIG); break;
3628 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3629 _ckvmssts(retsts); /* fall through */
3630 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3633 set_vaxc_errno(retsts);
3634 if (ckWARN(WARN_EXEC)) {
3635 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3636 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3643 } /* end of vms_do_exec() */
3646 unsigned long int do_spawn(char *);
3648 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3650 do_aspawn(void *really,void **mark,void **sp)
3653 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3656 } /* end of do_aspawn() */
3659 /* {{{unsigned long int do_spawn(char *cmd) */
3663 unsigned long int sts, substs, hadcmd = 1;
3667 TAINT_PROPER("spawn");
3668 if (!cmd || !*cmd) {
3670 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3672 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3673 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3678 case RMS$_FNF: case RMS$_DNF:
3679 set_errno(ENOENT); break;
3681 set_errno(ENOTDIR); break;
3683 set_errno(ENODEV); break;
3685 set_errno(EACCES); break;
3687 set_errno(EINVAL); break;
3689 set_errno(E2BIG); break;
3690 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3691 _ckvmssts(sts); /* fall through */
3692 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3695 set_vaxc_errno(sts);
3696 if (ckWARN(WARN_EXEC)) {
3697 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3698 hadcmd ? VMScmd.dsc$w_length : 0,
3699 hadcmd ? VMScmd.dsc$a_pointer : "",
3706 } /* end of do_spawn() */
3710 * A simple fwrite replacement which outputs itmsz*nitm chars without
3711 * introducing record boundaries every itmsz chars.
3713 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3715 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3717 register char *cp, *end;
3719 end = (char *)src + itmsz * nitm;
3721 while ((char *)src <= end) {
3722 for (cp = src; cp <= end; cp++) if (!*cp) break;
3723 if (fputs(src,dest) == EOF) return EOF;
3725 if (fputc('\0',dest) == EOF) return EOF;
3731 } /* end of my_fwrite() */
3734 /*{{{ int my_flush(FILE *fp)*/
3739 if ((res = fflush(fp)) == 0 && fp) {
3740 #ifdef VMS_DO_SOCKETS
3742 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3744 res = fsync(fileno(fp));
3751 * Here are replacements for the following Unix routines in the VMS environment:
3752 * getpwuid Get information for a particular UIC or UID
3753 * getpwnam Get information for a named user
3754 * getpwent Get information for each user in the rights database
3755 * setpwent Reset search to the start of the rights database
3756 * endpwent Finish searching for users in the rights database
3758 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3759 * (defined in pwd.h), which contains the following fields:-
3761 * char *pw_name; Username (in lower case)
3762 * char *pw_passwd; Hashed password
3763 * unsigned int pw_uid; UIC
3764 * unsigned int pw_gid; UIC group number
3765 * char *pw_unixdir; Default device/directory (VMS-style)
3766 * char *pw_gecos; Owner name
3767 * char *pw_dir; Default device/directory (Unix-style)
3768 * char *pw_shell; Default CLI name (eg. DCL)
3770 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3772 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3773 * not the UIC member number (eg. what's returned by getuid()),
3774 * getpwuid() can accept either as input (if uid is specified, the caller's
3775 * UIC group is used), though it won't recognise gid=0.
3777 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3778 * information about other users in your group or in other groups, respectively.
3779 * If the required privilege is not available, then these routines fill only
3780 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3783 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3786 /* sizes of various UAF record fields */
3787 #define UAI$S_USERNAME 12
3788 #define UAI$S_IDENT 31
3789 #define UAI$S_OWNER 31
3790 #define UAI$S_DEFDEV 31
3791 #define UAI$S_DEFDIR 63
3792 #define UAI$S_DEFCLI 31
3795 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3796 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3797 (uic).uic$v_group != UIC$K_WILD_GROUP)
3799 static char __empty[]= "";
3800 static struct passwd __passwd_empty=
3801 {(char *) __empty, (char *) __empty, 0, 0,
3802 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3803 static int contxt= 0;
3804 static struct passwd __pwdcache;
3805 static char __pw_namecache[UAI$S_IDENT+1];
3808 * This routine does most of the work extracting the user information.
3810 static int fillpasswd (const char *name, struct passwd *pwd)
3814 unsigned char length;
3815 char pw_gecos[UAI$S_OWNER+1];
3817 static union uicdef uic;
3819 unsigned char length;
3820 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3823 unsigned char length;
3824 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3827 unsigned char length;
3828 char pw_shell[UAI$S_DEFCLI+1];
3830 static char pw_passwd[UAI$S_PWD+1];
3832 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3833 struct dsc$descriptor_s name_desc;
3834 unsigned long int sts;
3836 static struct itmlst_3 itmlst[]= {
3837 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3838 {sizeof(uic), UAI$_UIC, &uic, &luic},
3839 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3840 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3841 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3842 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3843 {0, 0, NULL, NULL}};
3845 name_desc.dsc$w_length= strlen(name);
3846 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3847 name_desc.dsc$b_class= DSC$K_CLASS_S;
3848 name_desc.dsc$a_pointer= (char *) name;
3850 /* Note that sys$getuai returns many fields as counted strings. */
3851 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3852 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3853 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3855 else { _ckvmssts(sts); }
3856 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3858 if ((int) owner.length < lowner) lowner= (int) owner.length;
3859 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3860 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3861 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3862 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3863 owner.pw_gecos[lowner]= '\0';
3864 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3865 defcli.pw_shell[ldefcli]= '\0';
3866 if (valid_uic(uic)) {
3867 pwd->pw_uid= uic.uic$l_uic;
3868 pwd->pw_gid= uic.uic$v_group;
3871 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3872 pwd->pw_passwd= pw_passwd;
3873 pwd->pw_gecos= owner.pw_gecos;
3874 pwd->pw_dir= defdev.pw_dir;
3875 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3876 pwd->pw_shell= defcli.pw_shell;
3877 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3879 ldir= strlen(pwd->pw_unixdir) - 1;
3880 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3883 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3884 __mystrtolower(pwd->pw_unixdir);
3889 * Get information for a named user.
3891 /*{{{struct passwd *getpwnam(char *name)*/
3892 struct passwd *my_getpwnam(char *name)
3894 struct dsc$descriptor_s name_desc;
3896 unsigned long int status, sts;
3899 __pwdcache = __passwd_empty;
3900 if (!fillpasswd(name, &__pwdcache)) {
3901 /* We still may be able to determine pw_uid and pw_gid */
3902 name_desc.dsc$w_length= strlen(name);
3903 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3904 name_desc.dsc$b_class= DSC$K_CLASS_S;
3905 name_desc.dsc$a_pointer= (char *) name;
3906 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3907 __pwdcache.pw_uid= uic.uic$l_uic;
3908 __pwdcache.pw_gid= uic.uic$v_group;
3911 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3912 set_vaxc_errno(sts);
3913 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3916 else { _ckvmssts(sts); }
3919 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3920 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3921 __pwdcache.pw_name= __pw_namecache;
3923 } /* end of my_getpwnam() */
3927 * Get information for a particular UIC or UID.
3928 * Called by my_getpwent with uid=-1 to list all users.
3930 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3931 struct passwd *my_getpwuid(Uid_t uid)
3933 const $DESCRIPTOR(name_desc,__pw_namecache);
3934 unsigned short lname;
3936 unsigned long int status;
3939 if (uid == (unsigned int) -1) {
3941 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3942 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3943 set_vaxc_errno(status);
3944 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3948 else { _ckvmssts(status); }
3949 } while (!valid_uic (uic));
3953 if (!uic.uic$v_group)
3954 uic.uic$v_group= PerlProc_getgid();
3956 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3957 else status = SS$_IVIDENT;
3958 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3959 status == RMS$_PRV) {
3960 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3963 else { _ckvmssts(status); }
3965 __pw_namecache[lname]= '\0';
3966 __mystrtolower(__pw_namecache);
3968 __pwdcache = __passwd_empty;
3969 __pwdcache.pw_name = __pw_namecache;
3971 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3972 The identifier's value is usually the UIC, but it doesn't have to be,
3973 so if we can, we let fillpasswd update this. */
3974 __pwdcache.pw_uid = uic.uic$l_uic;
3975 __pwdcache.pw_gid = uic.uic$v_group;
3977 fillpasswd(__pw_namecache, &__pwdcache);
3980 } /* end of my_getpwuid() */
3984 * Get information for next user.
3986 /*{{{struct passwd *my_getpwent()*/
3987 struct passwd *my_getpwent()
3989 return (my_getpwuid((unsigned int) -1));
3994 * Finish searching rights database for users.
3996 /*{{{void my_endpwent()*/
4001 _ckvmssts(sys$finish_rdb(&contxt));
4007 #ifdef HOMEGROWN_POSIX_SIGNALS
4008 /* Signal handling routines, pulled into the core from POSIX.xs.
4010 * We need these for threads, so they've been rolled into the core,
4011 * rather than left in POSIX.xs.
4013 * (DRS, Oct 23, 1997)
4016 /* sigset_t is atomic under VMS, so these routines are easy */
4017 /*{{{int my_sigemptyset(sigset_t *) */
4018 int my_sigemptyset(sigset_t *set) {
4019 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4025 /*{{{int my_sigfillset(sigset_t *)*/
4026 int my_sigfillset(sigset_t *set) {
4028 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4029 for (i = 0; i < NSIG; i++) *set |= (1 << i);
4035 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4036 int my_sigaddset(sigset_t *set, int sig) {
4037 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4038 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4039 *set |= (1 << (sig - 1));
4045 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4046 int my_sigdelset(sigset_t *set, int sig) {
4047 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4048 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4049 *set &= ~(1 << (sig - 1));
4055 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4056 int my_sigismember(sigset_t *set, int sig) {
4057 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4058 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4059 *set & (1 << (sig - 1));
4064 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4065 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4068 /* If set and oset are both null, then things are badly wrong. Bail out. */
4069 if ((oset == NULL) && (set == NULL)) {
4070 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4074 /* If set's null, then we're just handling a fetch. */
4076 tempmask = sigblock(0);
4081 tempmask = sigsetmask(*set);
4084 tempmask = sigblock(*set);
4087 tempmask = sigblock(0);
4088 sigsetmask(*oset & ~tempmask);
4091 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4096 /* Did they pass us an oset? If so, stick our holding mask into it */
4103 #endif /* HOMEGROWN_POSIX_SIGNALS */
4106 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4107 * my_utime(), and flex_stat(), all of which operate on UTC unless
4108 * VMSISH_TIMES is true.
4110 /* method used to handle UTC conversions:
4111 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4113 static int gmtime_emulation_type;
4114 /* number of secs to add to UTC POSIX-style time to get local time */
4115 static long int utc_offset_secs;
4117 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4118 * in vmsish.h. #undef them here so we can call the CRTL routines
4125 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4126 # define RTL_USES_UTC 1
4130 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4131 * qualifier with the extern prefix pragma. This provisional
4132 * hack circumvents this prefix pragma problem in previous
4135 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4136 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4137 # pragma __extern_prefix save
4138 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4139 # define gmtime decc$__utctz_gmtime
4140 # define localtime decc$__utctz_localtime
4141 # define time decc$__utc_time
4142 # pragma __extern_prefix restore
4144 struct tm *gmtime(), *localtime();
4150 static time_t toutc_dst(time_t loc) {
4153 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4154 loc -= utc_offset_secs;
4155 if (rsltmp->tm_isdst) loc -= 3600;
4158 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4159 ((gmtime_emulation_type || my_time(NULL)), \
4160 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4161 ((secs) - utc_offset_secs))))
4163 static time_t toloc_dst(time_t utc) {
4166 utc += utc_offset_secs;
4167 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4168 if (rsltmp->tm_isdst) utc += 3600;
4171 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4172 ((gmtime_emulation_type || my_time(NULL)), \
4173 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4174 ((secs) + utc_offset_secs))))
4177 /* my_time(), my_localtime(), my_gmtime()
4178 * By default traffic in UTC time values, using CRTL gmtime() or
4179 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4180 * Note: We need to use these functions even when the CRTL has working
4181 * UTC support, since they also handle C<use vmsish qw(times);>
4183 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4184 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4187 /*{{{time_t my_time(time_t *timep)*/
4188 time_t my_time(time_t *timep)
4194 if (gmtime_emulation_type == 0) {
4196 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4197 /* results of calls to gmtime() and localtime() */
4198 /* for same &base */
4200 gmtime_emulation_type++;
4201 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4202 char off[LNM$C_NAMLENGTH+1];;
4204 gmtime_emulation_type++;
4205 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4206 gmtime_emulation_type++;
4207 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4209 else { utc_offset_secs = atol(off); }
4211 else { /* We've got a working gmtime() */
4212 struct tm gmt, local;
4215 tm_p = localtime(&base);
4217 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4218 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4219 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4220 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4226 # ifdef RTL_USES_UTC
4227 if (VMSISH_TIME) when = _toloc(when);
4229 if (!VMSISH_TIME) when = _toutc(when);
4232 if (timep != NULL) *timep = when;
4235 } /* end of my_time() */
4239 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4241 my_gmtime(const time_t *timep)
4248 if (timep == NULL) {
4249 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4252 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4256 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4258 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4259 return gmtime(&when);
4261 /* CRTL localtime() wants local time as input, so does no tz correction */
4262 rsltmp = localtime(&when);
4263 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4266 } /* end of my_gmtime() */
4270 /*{{{struct tm *my_localtime(const time_t *timep)*/
4272 my_localtime(const time_t *timep)
4278 if (timep == NULL) {
4279 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4282 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4283 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4286 # ifdef RTL_USES_UTC
4288 if (VMSISH_TIME) when = _toutc(when);
4290 /* CRTL localtime() wants UTC as input, does tz correction itself */
4291 return localtime(&when);
4294 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4297 /* CRTL localtime() wants local time as input, so does no tz correction */
4298 rsltmp = localtime(&when);
4299 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4302 } /* end of my_localtime() */
4305 /* Reset definitions for later calls */
4306 #define gmtime(t) my_gmtime(t)
4307 #define localtime(t) my_localtime(t)
4308 #define time(t) my_time(t)
4311 /* my_utime - update modification time of a file
4312 * calling sequence is identical to POSIX utime(), but under
4313 * VMS only the modification time is changed; ODS-2 does not
4314 * maintain access times. Restrictions differ from the POSIX
4315 * definition in that the time can be changed as long as the
4316 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4317 * no separate checks are made to insure that the caller is the
4318 * owner of the file or has special privs enabled.
4319 * Code here is based on Joe Meadows' FILE utility.
4322 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4323 * to VMS epoch (01-JAN-1858 00:00:00.00)
4324 * in 100 ns intervals.
4326 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4328 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4329 int my_utime(char *file, struct utimbuf *utimes)
4333 long int bintime[2], len = 2, lowbit, unixtime,
4334 secscale = 10000000; /* seconds --> 100 ns intervals */
4335 unsigned long int chan, iosb[2], retsts;
4336 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4337 struct FAB myfab = cc$rms_fab;
4338 struct NAM mynam = cc$rms_nam;
4339 #if defined (__DECC) && defined (__VAX)
4340 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4341 * at least through VMS V6.1, which causes a type-conversion warning.
4343 # pragma message save
4344 # pragma message disable cvtdiftypes
4346 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4347 struct fibdef myfib;
4348 #if defined (__DECC) && defined (__VAX)
4349 /* This should be right after the declaration of myatr, but due
4350 * to a bug in VAX DEC C, this takes effect a statement early.
4352 # pragma message restore
4354 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4355 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4356 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4358 if (file == NULL || *file == '\0') {
4360 set_vaxc_errno(LIB$_INVARG);
4363 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4365 if (utimes != NULL) {
4366 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4367 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4368 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4369 * as input, we force the sign bit to be clear by shifting unixtime right
4370 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4372 lowbit = (utimes->modtime & 1) ? secscale : 0;
4373 unixtime = (long int) utimes->modtime;
4375 /* If input was UTC; convert to local for sys svc */
4376 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4378 unixtime >>= 1; secscale <<= 1;
4379 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4380 if (!(retsts & 1)) {
4382 set_vaxc_errno(retsts);
4385 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4386 if (!(retsts & 1)) {
4388 set_vaxc_errno(retsts);
4393 /* Just get the current time in VMS format directly */
4394 retsts = sys$gettim(bintime);
4395 if (!(retsts & 1)) {
4397 set_vaxc_errno(retsts);
4402 myfab.fab$l_fna = vmsspec;
4403 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4404 myfab.fab$l_nam = &mynam;
4405 mynam.nam$l_esa = esa;
4406 mynam.nam$b_ess = (unsigned char) sizeof esa;
4407 mynam.nam$l_rsa = rsa;
4408 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4410 /* Look for the file to be affected, letting RMS parse the file
4411 * specification for us as well. I have set errno using only
4412 * values documented in the utime() man page for VMS POSIX.
4414 retsts = sys$parse(&myfab,0,0);
4415 if (!(retsts & 1)) {
4416 set_vaxc_errno(retsts);
4417 if (retsts == RMS$_PRV) set_errno(EACCES);
4418 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4419 else set_errno(EVMSERR);
4422 retsts = sys$search(&myfab,0,0);
4423 if (!(retsts & 1)) {
4424 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4425 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4426 set_vaxc_errno(retsts);
4427 if (retsts == RMS$_PRV) set_errno(EACCES);
4428 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4429 else set_errno(EVMSERR);
4433 devdsc.dsc$w_length = mynam.nam$b_dev;
4434 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4436 retsts = sys$assign(&devdsc,&chan,0,0);
4437 if (!(retsts & 1)) {
4438 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4439 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4440 set_vaxc_errno(retsts);
4441 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4442 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4443 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4444 else set_errno(EVMSERR);
4448 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4449 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4451 memset((void *) &myfib, 0, sizeof myfib);
4453 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4454 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4455 /* This prevents the revision time of the file being reset to the current
4456 * time as a result of our IO$_MODIFY $QIO. */
4457 myfib.fib$l_acctl = FIB$M_NORECORD;
4459 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4460 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4461 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4463 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4464 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4465 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4466 _ckvmssts(sys$dassgn(chan));
4467 if (retsts & 1) retsts = iosb[0];
4468 if (!(retsts & 1)) {
4469 set_vaxc_errno(retsts);
4470 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4471 else set_errno(EVMSERR);
4476 } /* end of my_utime() */
4480 * flex_stat, flex_fstat
4481 * basic stat, but gets it right when asked to stat
4482 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4485 /* encode_dev packs a VMS device name string into an integer to allow
4486 * simple comparisons. This can be used, for example, to check whether two
4487 * files are located on the same device, by comparing their encoded device
4488 * names. Even a string comparison would not do, because stat() reuses the
4489 * device name buffer for each call; so without encode_dev, it would be
4490 * necessary to save the buffer and use strcmp (this would mean a number of
4491 * changes to the standard Perl code, to say nothing of what a Perl script
4494 * The device lock id, if it exists, should be unique (unless perhaps compared
4495 * with lock ids transferred from other nodes). We have a lock id if the disk is
4496 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4497 * device names. Thus we use the lock id in preference, and only if that isn't
4498 * available, do we try to pack the device name into an integer (flagged by
4499 * the sign bit (LOCKID_MASK) being set).
4501 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4502 * name and its encoded form, but it seems very unlikely that we will find
4503 * two files on different disks that share the same encoded device names,
4504 * and even more remote that they will share the same file id (if the test
4505 * is to check for the same file).
4507 * A better method might be to use sys$device_scan on the first call, and to
4508 * search for the device, returning an index into the cached array.
4509 * The number returned would be more intelligable.
4510 * This is probably not worth it, and anyway would take quite a bit longer
4511 * on the first call.
4513 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4514 static mydev_t encode_dev (const char *dev)
4517 unsigned long int f;
4523 if (!dev || !dev[0]) return 0;
4527 struct dsc$descriptor_s dev_desc;
4528 unsigned long int status, lockid, item = DVI$_LOCKID;
4530 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4531 can try that first. */
4532 dev_desc.dsc$w_length = strlen (dev);
4533 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4534 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4535 dev_desc.dsc$a_pointer = (char *) dev;
4536 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4537 if (lockid) return (lockid & ~LOCKID_MASK);
4541 /* Otherwise we try to encode the device name */
4545 for (q = dev + strlen(dev); q--; q >= dev) {
4548 else if (isalpha (toupper (*q)))
4549 c= toupper (*q) - 'A' + (char)10;
4551 continue; /* Skip '$'s */
4553 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4555 enc += f * (unsigned long int) c;
4557 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4559 } /* end of encode_dev() */
4561 static char namecache[NAM$C_MAXRSS+1];
4564 is_null_device(name)
4568 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4569 The underscore prefix, controller letter, and unit number are
4570 independently optional; for our purposes, the colon punctuation
4571 is not. The colon can be trailed by optional directory and/or
4572 filename, but two consecutive colons indicates a nodename rather
4573 than a device. [pr] */
4574 if (*name == '_') ++name;
4575 if (tolower(*name++) != 'n') return 0;
4576 if (tolower(*name++) != 'l') return 0;
4577 if (tolower(*name) == 'a') ++name;
4578 if (*name == '0') ++name;
4579 return (*name++ == ':') && (*name != ':');
4582 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4583 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4584 * subset of the applicable information.
4587 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4589 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4591 char fname[NAM$C_MAXRSS+1];
4592 unsigned long int retsts;
4593 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4594 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4596 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4597 device name on successive calls */
4598 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4599 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4600 namdsc.dsc$a_pointer = fname;
4601 namdsc.dsc$w_length = sizeof fname - 1;
4603 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4604 &namdsc,&namdsc.dsc$w_length,0,0);
4606 fname[namdsc.dsc$w_length] = '\0';
4607 return cando_by_name(bit,effective,fname);
4609 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4610 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4614 return FALSE; /* Should never get to here */
4616 } /* end of cando() */
4620 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4622 cando_by_name(I32 bit, Uid_t effective, char *fname)
4624 static char usrname[L_cuserid];
4625 static struct dsc$descriptor_s usrdsc =
4626 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4627 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4628 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4629 unsigned short int retlen;
4631 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4632 union prvdef curprv;
4633 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4634 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4635 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4638 if (!fname || !*fname) return FALSE;
4639 /* Make sure we expand logical names, since sys$check_access doesn't */
4640 if (!strpbrk(fname,"/]>:")) {
4641 strcpy(fileified,fname);
4642 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4645 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4646 retlen = namdsc.dsc$w_length = strlen(vmsname);
4647 namdsc.dsc$a_pointer = vmsname;
4648 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4649 vmsname[retlen-1] == ':') {
4650 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4651 namdsc.dsc$w_length = strlen(fileified);
4652 namdsc.dsc$a_pointer = fileified;
4655 if (!usrdsc.dsc$w_length) {
4657 usrdsc.dsc$w_length = strlen(usrname);
4661 case S_IXUSR: case S_IXGRP: case S_IXOTH:
4662 access = ARM$M_EXECUTE; break;
4663 case S_IRUSR: case S_IRGRP: case S_IROTH:
4664 access = ARM$M_READ; break;
4665 case S_IWUSR: case S_IWGRP: case S_IWOTH:
4666 access = ARM$M_WRITE; break;
4667 case S_IDUSR: case S_IDGRP: case S_IDOTH:
4668 access = ARM$M_DELETE; break;
4673 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4674 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4675 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4676 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4677 set_vaxc_errno(retsts);
4678 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4679 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4680 else set_errno(ENOENT);
4683 if (retsts == SS$_NORMAL) {
4684 if (!privused) return TRUE;
4685 /* We can get access, but only by using privs. Do we have the
4686 necessary privs currently enabled? */
4687 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4688 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4689 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4690 !curprv.prv$v_bypass) return FALSE;
4691 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4692 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4693 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4696 if (retsts == SS$_ACCONFLICT) {
4700 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001
4701 /* XXX Hideous kluge to accomodate error in specific version of RTL;
4702 we hope it'll be buried soon */
4703 if (retsts == 114762) return TRUE;
4707 return FALSE; /* Should never get here */
4709 } /* end of cando_by_name() */
4713 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4715 flex_fstat(int fd, Stat_t *statbufp)
4718 if (!fstat(fd,(stat_t *) statbufp)) {
4719 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4720 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4721 # ifdef RTL_USES_UTC
4724 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4725 statbufp->st_atime = _toloc(statbufp->st_atime);
4726 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4731 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4735 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4736 statbufp->st_atime = _toutc(statbufp->st_atime);
4737 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4744 } /* end of flex_fstat() */
4747 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4749 flex_stat(const char *fspec, Stat_t *statbufp)
4752 char fileified[NAM$C_MAXRSS+1];
4753 char temp_fspec[NAM$C_MAXRSS+300];
4756 strcpy(temp_fspec, fspec);
4757 if (statbufp == (Stat_t *) &PL_statcache)
4758 do_tovmsspec(temp_fspec,namecache,0);
4759 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4760 memset(statbufp,0,sizeof *statbufp);
4761 statbufp->st_dev = encode_dev("_NLA0:");
4762 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4763 statbufp->st_uid = 0x00010001;
4764 statbufp->st_gid = 0x0001;
4765 time((time_t *)&statbufp->st_mtime);
4766 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4770 /* Try for a directory name first. If fspec contains a filename without
4771 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4772 * and sea:[wine.dark]water. exist, we prefer the directory here.
4773 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4774 * not sea:[wine.dark]., if the latter exists. If the intended target is
4775 * the file with null type, specify this by calling flex_stat() with
4776 * a '.' at the end of fspec.
4778 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4779 retval = stat(fileified,(stat_t *) statbufp);
4780 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4781 strcpy(namecache,fileified);
4783 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4785 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4786 # ifdef RTL_USES_UTC
4789 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4790 statbufp->st_atime = _toloc(statbufp->st_atime);
4791 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4796 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4800 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4801 statbufp->st_atime = _toutc(statbufp->st_atime);
4802 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4808 } /* end of flex_stat() */
4812 /*{{{char *my_getlogin()*/
4813 /* VMS cuserid == Unix getlogin, except calling sequence */
4817 static char user[L_cuserid];
4818 return cuserid(user);
4823 /* rmscopy - copy a file using VMS RMS routines
4825 * Copies contents and attributes of spec_in to spec_out, except owner
4826 * and protection information. Name and type of spec_in are used as
4827 * defaults for spec_out. The third parameter specifies whether rmscopy()
4828 * should try to propagate timestamps from the input file to the output file.
4829 * If it is less than 0, no timestamps are preserved. If it is 0, then
4830 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4831 * propagated to the output file at creation iff the output file specification
4832 * did not contain an explicit name or type, and the revision date is always
4833 * updated at the end of the copy operation. If it is greater than 0, then
4834 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4835 * other than the revision date should be propagated, and bit 1 indicates
4836 * that the revision date should be propagated.
4838 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4840 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4841 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4842 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4843 * as part of the Perl standard distribution under the terms of the
4844 * GNU General Public License or the Perl Artistic License. Copies
4845 * of each may be found in the Perl standard distribution.
4847 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4849 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
4851 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4852 rsa[NAM$C_MAXRSS], ubf[32256];
4853 unsigned long int i, sts, sts2;
4854 struct FAB fab_in, fab_out;
4855 struct RAB rab_in, rab_out;
4857 struct XABDAT xabdat;
4858 struct XABFHC xabfhc;
4859 struct XABRDT xabrdt;
4860 struct XABSUM xabsum;
4862 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4863 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4864 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4868 fab_in = cc$rms_fab;
4869 fab_in.fab$l_fna = vmsin;
4870 fab_in.fab$b_fns = strlen(vmsin);
4871 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4872 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4873 fab_in.fab$l_fop = FAB$M_SQO;
4874 fab_in.fab$l_nam = &nam;
4875 fab_in.fab$l_xab = (void *) &xabdat;
4878 nam.nam$l_rsa = rsa;
4879 nam.nam$b_rss = sizeof(rsa);
4880 nam.nam$l_esa = esa;
4881 nam.nam$b_ess = sizeof (esa);
4882 nam.nam$b_esl = nam.nam$b_rsl = 0;
4884 xabdat = cc$rms_xabdat; /* To get creation date */
4885 xabdat.xab$l_nxt = (void *) &xabfhc;
4887 xabfhc = cc$rms_xabfhc; /* To get record length */
4888 xabfhc.xab$l_nxt = (void *) &xabsum;
4890 xabsum = cc$rms_xabsum; /* To get key and area information */
4892 if (!((sts = sys$open(&fab_in)) & 1)) {
4893 set_vaxc_errno(sts);
4895 case RMS$_FNF: case RMS$_DNF:
4896 set_errno(ENOENT); break;
4898 set_errno(ENOTDIR); break;
4900 set_errno(ENODEV); break;
4902 set_errno(EINVAL); break;
4904 set_errno(EACCES); break;
4912 fab_out.fab$w_ifi = 0;
4913 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4914 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4915 fab_out.fab$l_fop = FAB$M_SQO;
4916 fab_out.fab$l_fna = vmsout;
4917 fab_out.fab$b_fns = strlen(vmsout);
4918 fab_out.fab$l_dna = nam.nam$l_name;
4919 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4921 if (preserve_dates == 0) { /* Act like DCL COPY */
4922 nam.nam$b_nop = NAM$M_SYNCHK;
4923 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4924 if (!((sts = sys$parse(&fab_out)) & 1)) {
4925 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4926 set_vaxc_errno(sts);
4929 fab_out.fab$l_xab = (void *) &xabdat;
4930 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4932 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4933 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4934 preserve_dates =0; /* bitmask from this point forward */
4936 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4937 if (!((sts = sys$create(&fab_out)) & 1)) {
4938 set_vaxc_errno(sts);
4941 set_errno(ENOENT); break;
4943 set_errno(ENOTDIR); break;
4945 set_errno(ENODEV); break;
4947 set_errno(EINVAL); break;
4949 set_errno(EACCES); break;
4955 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4956 if (preserve_dates & 2) {
4957 /* sys$close() will process xabrdt, not xabdat */
4958 xabrdt = cc$rms_xabrdt;
4960 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4962 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4963 * is unsigned long[2], while DECC & VAXC use a struct */
4964 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4966 fab_out.fab$l_xab = (void *) &xabrdt;
4969 rab_in = cc$rms_rab;
4970 rab_in.rab$l_fab = &fab_in;
4971 rab_in.rab$l_rop = RAB$M_BIO;
4972 rab_in.rab$l_ubf = ubf;
4973 rab_in.rab$w_usz = sizeof ubf;
4974 if (!((sts = sys$connect(&rab_in)) & 1)) {
4975 sys$close(&fab_in); sys$close(&fab_out);
4976 set_errno(EVMSERR); set_vaxc_errno(sts);
4980 rab_out = cc$rms_rab;
4981 rab_out.rab$l_fab = &fab_out;
4982 rab_out.rab$l_rbf = ubf;
4983 if (!((sts = sys$connect(&rab_out)) & 1)) {
4984 sys$close(&fab_in); sys$close(&fab_out);
4985 set_errno(EVMSERR); set_vaxc_errno(sts);
4989 while ((sts = sys$read(&rab_in))) { /* always true */
4990 if (sts == RMS$_EOF) break;
4991 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4992 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4993 sys$close(&fab_in); sys$close(&fab_out);
4994 set_errno(EVMSERR); set_vaxc_errno(sts);
4999 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
5000 sys$close(&fab_in); sys$close(&fab_out);
5001 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5003 set_errno(EVMSERR); set_vaxc_errno(sts);
5009 } /* end of rmscopy() */
5013 /*** The following glue provides 'hooks' to make some of the routines
5014 * from this file available from Perl. These routines are sufficiently
5015 * basic, and are required sufficiently early in the build process,
5016 * that's it's nice to have them available to miniperl as well as the
5017 * full Perl, so they're set up here instead of in an extension. The
5018 * Perl code which handles importation of these names into a given
5019 * package lives in [.VMS]Filespec.pm in @INC.
5023 rmsexpand_fromperl(pTHX_ CV *cv)
5026 char *fspec, *defspec = NULL, *rslt;
5029 if (!items || items > 2)
5030 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5031 fspec = SvPV(ST(0),n_a);
5032 if (!fspec || !*fspec) XSRETURN_UNDEF;
5033 if (items == 2) defspec = SvPV(ST(1),n_a);
5035 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5036 ST(0) = sv_newmortal();
5037 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5042 vmsify_fromperl(pTHX_ CV *cv)
5048 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5049 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5050 ST(0) = sv_newmortal();
5051 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5056 unixify_fromperl(pTHX_ CV *cv)
5062 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5063 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5064 ST(0) = sv_newmortal();
5065 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5070 fileify_fromperl(pTHX_ CV *cv)
5076 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5077 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5078 ST(0) = sv_newmortal();
5079 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5084 pathify_fromperl(pTHX_ CV *cv)
5090 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5091 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5092 ST(0) = sv_newmortal();
5093 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5098 vmspath_fromperl(pTHX_ CV *cv)
5104 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5105 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5106 ST(0) = sv_newmortal();
5107 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5112 unixpath_fromperl(pTHX_ CV *cv)
5118 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5119 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5120 ST(0) = sv_newmortal();
5121 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5126 candelete_fromperl(pTHX_ CV *cv)
5129 char fspec[NAM$C_MAXRSS+1], *fsp;
5134 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5136 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5137 if (SvTYPE(mysv) == SVt_PVGV) {
5138 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5139 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5146 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5147 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5153 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5158 rmscopy_fromperl(pTHX_ CV *cv)
5161 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5163 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5164 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5165 unsigned long int sts;
5170 if (items < 2 || items > 3)
5171 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5173 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5174 if (SvTYPE(mysv) == SVt_PVGV) {
5175 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5176 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5183 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5184 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5189 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5190 if (SvTYPE(mysv) == SVt_PVGV) {
5191 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5192 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5199 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5200 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5205 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5207 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5214 char* file = __FILE__;
5216 char temp_buff[512];
5217 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5218 no_translate_barewords = TRUE;
5220 no_translate_barewords = FALSE;
5223 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5224 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5225 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5226 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5227 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5228 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5229 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5230 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5231 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);