3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
18 #include <climsgdef.h>
28 #include <libclidef.h>
30 #include <lib$routines.h>
39 #include <str$routines.h>
44 /* Older versions of ssdef.h don't have these */
45 #ifndef SS$_INVFILFOROP
46 # define SS$_INVFILFOROP 3930
48 #ifndef SS$_NOSUCHOBJECT
49 # define SS$_NOSUCHOBJECT 2696
52 /* Don't replace system definitions of vfork, getenv, and stat,
53 * code below needs to get to the underlying CRTL routines. */
54 #define DONT_MASK_RTL_CALLS
58 /* Anticipating future expansion in lexical warnings . . . */
60 # define WARN_INTERNAL WARN_MISC
63 /* gcc's header files don't #define direct access macros
64 * corresponding to VAXC's variant structs */
66 # define uic$v_format uic$r_uic_form.uic$v_format
67 # define uic$v_group uic$r_uic_form.uic$v_group
68 # define uic$v_member uic$r_uic_form.uic$v_member
69 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
70 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
71 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
72 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
75 #if defined(NEED_AN_H_ERRNO)
80 unsigned short int buflen;
81 unsigned short int itmcode;
83 unsigned short int *retlen;
86 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
87 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
88 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
89 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
90 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
91 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
92 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
93 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
94 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
96 static char *__mystrtolower(char *str)
98 if (str) for (; *str; ++str) *str= tolower(*str);
102 static struct dsc$descriptor_s fildevdsc =
103 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
104 static struct dsc$descriptor_s crtlenvdsc =
105 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
106 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
107 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
108 static struct dsc$descriptor_s **env_tables = defenv;
109 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
111 /* True if we shouldn't treat barewords as logicals during directory */
113 static int no_translate_barewords;
115 /* Temp for subprocess commands */
116 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
118 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
120 Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
121 struct dsc$descriptor_s **tabvec, unsigned long int flags)
123 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
124 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
125 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
126 unsigned char acmode;
127 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
128 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
129 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
130 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
132 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
133 #if defined(USE_THREADS)
134 /* We jump through these hoops because we can be called at */
135 /* platform-specific initialization time, which is before anything is */
136 /* set up--we can't even do a plain dTHX since that relies on the */
137 /* interpreter structure to be initialized */
138 struct perl_thread *thr;
140 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
146 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
147 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
149 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
150 *cp2 = _toupper(*cp1);
151 if (cp1 - lnm > LNM$C_NAMLENGTH) {
152 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
156 lnmdsc.dsc$w_length = cp1 - lnm;
157 lnmdsc.dsc$a_pointer = uplnm;
158 uplnm[lnmdsc.dsc$w_length] = '\0';
159 secure = flags & PERL__TRNENV_SECURE;
160 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
161 if (!tabvec || !*tabvec) tabvec = env_tables;
163 for (curtab = 0; tabvec[curtab]; curtab++) {
164 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
165 if (!ivenv && !secure) {
170 Perl_warn(aTHX_ "Can't read CRTL environ\n");
173 retsts = SS$_NOLOGNAM;
174 for (i = 0; environ[i]; i++) {
175 if ((eq = strchr(environ[i],'=')) &&
176 !strncmp(environ[i],uplnm,eq - environ[i])) {
178 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
179 if (!eqvlen) continue;
184 if (retsts != SS$_NOLOGNAM) break;
187 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
188 !str$case_blind_compare(&tmpdsc,&clisym)) {
189 if (!ivsym && !secure) {
190 unsigned short int deflen = LNM$C_NAMLENGTH;
191 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
192 /* dynamic dsc to accomodate possible long value */
193 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
194 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
197 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
199 /* Special hack--we might be called before the interpreter's */
200 /* fully initialized, in which case either thr or PL_curcop */
201 /* might be bogus. We have to check, since ckWARN needs them */
202 /* both to be valid if running threaded */
203 #if defined(USE_THREADS)
204 if (thr && PL_curcop) {
206 if (ckWARN(WARN_MISC)) {
207 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
209 #if defined(USE_THREADS)
211 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
216 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
218 _ckvmssts(lib$sfree1_dd(&eqvdsc));
219 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
220 if (retsts == LIB$_NOSUCHSYM) continue;
225 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
226 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
227 if (retsts == SS$_NOLOGNAM) continue;
228 /* PPFs have a prefix */
231 *((int *)uplnm) == *((int *)"SYS$") &&
233 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
234 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
235 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
236 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
237 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
238 memcpy(eqv,eqv+4,eqvlen-4);
244 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
245 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
246 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
247 retsts == SS$_NOLOGNAM) {
248 set_errno(EINVAL); set_vaxc_errno(retsts);
250 else _ckvmssts(retsts);
252 } /* end of vmstrnenv */
255 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
256 /* Define as a function so we can access statics. */
257 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
259 return vmstrnenv(lnm,eqv,idx,fildev,
260 #ifdef SECURE_INTERNAL_GETENV
261 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
270 * Note: Uses Perl temp to store result so char * can be returned to
271 * caller; this pointer will be invalidated at next Perl statement
273 * We define this as a function rather than a macro in terms of my_getenv_len()
274 * so that it'll work when PL_curinterp is undefined (and we therefore can't
277 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
279 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
281 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
282 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
283 unsigned long int idx = 0;
287 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
288 /* Set up a temporary buffer for the return value; Perl will
289 * clean it up at the next statement transition */
290 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
291 if (!tmpsv) return NULL;
294 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
295 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
296 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
297 getcwd(eqv,LNM$C_NAMLENGTH);
301 if ((cp2 = strchr(lnm,';')) != NULL) {
303 uplnm[cp2-lnm] = '\0';
304 idx = strtoul(cp2+1,NULL,0);
307 /* Impose security constraints only if tainting */
308 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
309 if (vmstrnenv(lnm,eqv,idx,
311 #ifdef SECURE_INTERNAL_GETENV
312 sys ? PERL__TRNENV_SECURE : 0
320 } /* end of my_getenv() */
324 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
326 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
329 char *buf, *cp1, *cp2;
330 unsigned long idx = 0;
331 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
334 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
335 /* Set up a temporary buffer for the return value; Perl will
336 * clean it up at the next statement transition */
337 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
338 if (!tmpsv) return NULL;
341 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
342 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
343 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
344 getcwd(buf,LNM$C_NAMLENGTH);
349 if ((cp2 = strchr(lnm,';')) != NULL) {
352 idx = strtoul(cp2+1,NULL,0);
355 /* Impose security constraints only if tainting */
356 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
357 if ((*len = vmstrnenv(lnm,buf,idx,
359 #ifdef SECURE_INTERNAL_GETENV
360 sys ? PERL__TRNENV_SECURE : 0
370 } /* end of my_getenv_len() */
373 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
375 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
377 /*{{{ void prime_env_iter() */
380 /* Fill the %ENV associative array with all logical names we can
381 * find, in preparation for iterating over it.
385 static int primed = 0;
386 HV *seenhv = NULL, *envhv;
387 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
388 unsigned short int chan;
389 #ifndef CLI$M_TRUSTED
390 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
392 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
393 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
395 bool have_sym = FALSE, have_lnm = FALSE;
396 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
397 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
398 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
399 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
400 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
401 #if defined(USE_THREADS) || defined(USE_ITHREADS)
402 static perl_mutex primenv_mutex;
403 MUTEX_INIT(&primenv_mutex);
406 if (primed || !PL_envgv) return;
407 MUTEX_LOCK(&primenv_mutex);
408 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
409 envhv = GvHVn(PL_envgv);
410 /* Perform a dummy fetch as an lval to insure that the hash table is
411 * set up. Otherwise, the hv_store() will turn into a nullop. */
412 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
414 for (i = 0; env_tables[i]; i++) {
415 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
416 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
417 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
419 if (have_sym || have_lnm) {
420 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
421 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
422 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
423 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
426 for (i--; i >= 0; i--) {
427 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
430 for (j = 0; environ[j]; j++) {
431 if (!(start = strchr(environ[j],'='))) {
432 if (ckWARN(WARN_INTERNAL))
433 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
437 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
443 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
444 !str$case_blind_compare(&tmpdsc,&clisym)) {
445 strcpy(cmd,"Show Symbol/Global *");
446 cmddsc.dsc$w_length = 20;
447 if (env_tables[i]->dsc$w_length == 12 &&
448 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
449 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
450 flags = defflags | CLI$M_NOLOGNAM;
453 strcpy(cmd,"Show Logical *");
454 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
455 strcat(cmd," /Table=");
456 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
457 cmddsc.dsc$w_length = strlen(cmd);
459 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
460 flags = defflags | CLI$M_NOCLISYM;
463 /* Create a new subprocess to execute each command, to exclude the
464 * remote possibility that someone could subvert a mbx or file used
465 * to write multiple commands to a single subprocess.
468 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
469 0,&riseandshine,0,0,&clidsc,&clitabdsc);
470 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
471 defflags &= ~CLI$M_TRUSTED;
472 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
474 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
475 if (seenhv) SvREFCNT_dec(seenhv);
478 char *cp1, *cp2, *key;
479 unsigned long int sts, iosb[2], retlen, keylen;
482 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
483 if (sts & 1) sts = iosb[0] & 0xffff;
484 if (sts == SS$_ENDOFFILE) {
486 while (substs == 0) { sys$hiber(); wakect++;}
487 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
492 retlen = iosb[0] >> 16;
493 if (!retlen) continue; /* blank line */
495 if (iosb[1] != subpid) {
497 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
501 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
502 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
504 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
505 if (*cp1 == '(' || /* Logical name table name */
506 *cp1 == '=' /* Next eqv of searchlist */) continue;
507 if (*cp1 == '"') cp1++;
508 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
509 key = cp1; keylen = cp2 - cp1;
510 if (keylen && hv_exists(seenhv,key,keylen)) continue;
511 while (*cp2 && *cp2 != '=') cp2++;
512 while (*cp2 && *cp2 == '=') cp2++;
513 while (*cp2 && *cp2 == ' ') cp2++;
514 if (*cp2 == '"') { /* String translation; may embed "" */
515 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
516 cp2++; cp1--; /* Skip "" surrounding translation */
518 else { /* Numeric translation */
519 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
520 cp1--; /* stop on last non-space char */
522 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
523 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
526 PERL_HASH(hash,key,keylen);
527 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
528 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
530 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
531 /* get the PPFs for this process, not the subprocess */
532 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
533 char eqv[LNM$C_NAMLENGTH+1];
535 for (i = 0; ppfs[i]; i++) {
536 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
537 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
542 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
543 if (buf) Safefree(buf);
544 if (seenhv) SvREFCNT_dec(seenhv);
545 MUTEX_UNLOCK(&primenv_mutex);
548 } /* end of prime_env_iter */
552 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
553 /* Define or delete an element in the same "environment" as
554 * vmstrnenv(). If an element is to be deleted, it's removed from
555 * the first place it's found. If it's to be set, it's set in the
556 * place designated by the first element of the table vector.
557 * Like setenv() returns 0 for success, non-zero on error.
560 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
562 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
563 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
564 unsigned long int retsts, usermode = PSL$C_USER;
565 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
566 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
567 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
568 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
569 $DESCRIPTOR(local,"_LOCAL");
572 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
573 *cp2 = _toupper(*cp1);
574 if (cp1 - lnm > LNM$C_NAMLENGTH) {
575 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
579 lnmdsc.dsc$w_length = cp1 - lnm;
580 if (!tabvec || !*tabvec) tabvec = env_tables;
582 if (!eqv) { /* we're deleting n element */
583 for (curtab = 0; tabvec[curtab]; curtab++) {
584 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
586 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
587 if ((cp1 = strchr(environ[i],'=')) &&
588 !strncmp(environ[i],lnm,cp1 - environ[i])) {
590 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
593 ivenv = 1; retsts = SS$_NOLOGNAM;
595 if (ckWARN(WARN_INTERNAL))
596 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
597 ivenv = 1; retsts = SS$_NOSUCHPGM;
603 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
604 !str$case_blind_compare(&tmpdsc,&clisym)) {
605 unsigned int symtype;
606 if (tabvec[curtab]->dsc$w_length == 12 &&
607 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
608 !str$case_blind_compare(&tmpdsc,&local))
609 symtype = LIB$K_CLI_LOCAL_SYM;
610 else symtype = LIB$K_CLI_GLOBAL_SYM;
611 retsts = lib$delete_symbol(&lnmdsc,&symtype);
612 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
613 if (retsts == LIB$_NOSUCHSYM) continue;
617 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
618 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
619 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
620 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
621 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
625 else { /* we're defining a value */
626 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
628 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
630 if (ckWARN(WARN_INTERNAL))
631 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
632 retsts = SS$_NOSUCHPGM;
636 eqvdsc.dsc$a_pointer = eqv;
637 eqvdsc.dsc$w_length = strlen(eqv);
638 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
639 !str$case_blind_compare(&tmpdsc,&clisym)) {
640 unsigned int symtype;
641 if (tabvec[0]->dsc$w_length == 12 &&
642 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
643 !str$case_blind_compare(&tmpdsc,&local))
644 symtype = LIB$K_CLI_LOCAL_SYM;
645 else symtype = LIB$K_CLI_GLOBAL_SYM;
646 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
649 if (!*eqv) eqvdsc.dsc$w_length = 1;
650 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
651 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
652 if (ckWARN(WARN_MISC)) {
653 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
656 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
662 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
663 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
664 set_errno(EVMSERR); break;
665 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
666 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
667 set_errno(EINVAL); break;
674 set_vaxc_errno(retsts);
675 return (int) retsts || 44; /* retsts should never be 0, but just in case */
678 /* We reset error values on success because Perl does an hv_fetch()
679 * before each hv_store(), and if the thing we're setting didn't
680 * previously exist, we've got a leftover error message. (Of course,
681 * this fails in the face of
682 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
683 * in that the error reported in $! isn't spurious,
684 * but it's right more often than not.)
686 set_errno(0); set_vaxc_errno(retsts);
690 } /* end of vmssetenv() */
693 /*{{{ void my_setenv(char *lnm, char *eqv)*/
694 /* This has to be a function since there's a prototype for it in proto.h */
696 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
698 if (lnm && *lnm && strlen(lnm) == 7) {
701 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
702 if (!strcmp(uplnm,"DEFAULT")) {
703 if (eqv && *eqv) chdir(eqv);
707 (void) vmssetenv(lnm,eqv,NULL);
713 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
714 /* my_crypt - VMS password hashing
715 * my_crypt() provides an interface compatible with the Unix crypt()
716 * C library function, and uses sys$hash_password() to perform VMS
717 * password hashing. The quadword hashed password value is returned
718 * as a NUL-terminated 8 character string. my_crypt() does not change
719 * the case of its string arguments; in order to match the behavior
720 * of LOGINOUT et al., alphabetic characters in both arguments must
721 * be upcased by the caller.
724 my_crypt(const char *textpasswd, const char *usrname)
726 # ifndef UAI$C_PREFERRED_ALGORITHM
727 # define UAI$C_PREFERRED_ALGORITHM 127
729 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
730 unsigned short int salt = 0;
731 unsigned long int sts;
733 unsigned short int dsc$w_length;
734 unsigned char dsc$b_type;
735 unsigned char dsc$b_class;
736 const char * dsc$a_pointer;
737 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
738 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
739 struct itmlst_3 uailst[3] = {
740 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
741 { sizeof salt, UAI$_SALT, &salt, 0},
742 { 0, 0, NULL, NULL}};
745 usrdsc.dsc$w_length = strlen(usrname);
746 usrdsc.dsc$a_pointer = usrname;
747 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
749 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
753 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
759 if (sts != RMS$_RNF) return NULL;
762 txtdsc.dsc$w_length = strlen(textpasswd);
763 txtdsc.dsc$a_pointer = textpasswd;
764 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
765 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
768 return (char *) hash;
770 } /* end of my_crypt() */
774 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
775 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
776 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
778 /*{{{int do_rmdir(char *name)*/
780 Perl_do_rmdir(pTHX_ char *name)
782 char dirfile[NAM$C_MAXRSS+1];
786 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
787 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
788 else retval = kill_file(dirfile);
791 } /* end of do_rmdir */
795 * Delete any file to which user has control access, regardless of whether
796 * delete access is explicitly allowed.
797 * Limitations: User must have write access to parent directory.
798 * Does not block signals or ASTs; if interrupted in midstream
799 * may leave file with an altered ACL.
802 /*{{{int kill_file(char *name)*/
804 kill_file(char *name)
806 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
807 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
808 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
810 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
812 unsigned char myace$b_length;
813 unsigned char myace$b_type;
814 unsigned short int myace$w_flags;
815 unsigned long int myace$l_access;
816 unsigned long int myace$l_ident;
817 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
818 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
819 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
821 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
822 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
823 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
824 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
825 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
826 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
828 /* Expand the input spec using RMS, since the CRTL remove() and
829 * system services won't do this by themselves, so we may miss
830 * a file "hiding" behind a logical name or search list. */
831 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
832 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
833 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
834 /* If not, can changing protections help? */
835 if (vaxc$errno != RMS$_PRV) return -1;
837 /* No, so we get our own UIC to use as a rights identifier,
838 * and the insert an ACE at the head of the ACL which allows us
839 * to delete the file.
841 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
842 fildsc.dsc$w_length = strlen(rspec);
843 fildsc.dsc$a_pointer = rspec;
845 newace.myace$l_ident = oldace.myace$l_ident;
846 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
848 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
849 set_errno(ENOENT); break;
851 set_errno(ENOTDIR); break;
853 set_errno(ENODEV); break;
854 case RMS$_SYN: case SS$_INVFILFOROP:
855 set_errno(EINVAL); break;
857 set_errno(EACCES); break;
861 set_vaxc_errno(aclsts);
864 /* Grab any existing ACEs with this identifier in case we fail */
865 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
866 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
867 || fndsts == SS$_NOMOREACE ) {
868 /* Add the new ACE . . . */
869 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
871 if ((rmsts = remove(name))) {
872 /* We blew it - dir with files in it, no write priv for
873 * parent directory, etc. Put things back the way they were. */
874 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
877 addlst[0].bufadr = &oldace;
878 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
885 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
886 /* We just deleted it, so of course it's not there. Some versions of
887 * VMS seem to return success on the unlock operation anyhow (after all
888 * the unlock is successful), but others don't.
890 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
891 if (aclsts & 1) aclsts = fndsts;
894 set_vaxc_errno(aclsts);
900 } /* end of kill_file() */
904 /*{{{int my_mkdir(char *,Mode_t)*/
906 my_mkdir(char *dir, Mode_t mode)
908 STRLEN dirlen = strlen(dir);
911 /* zero length string sometimes gives ACCVIO */
912 if (dirlen == 0) return -1;
914 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
915 * null file name/type. However, it's commonplace under Unix,
916 * so we'll allow it for a gain in portability.
918 if (dir[dirlen-1] == '/') {
919 char *newdir = savepvn(dir,dirlen-1);
920 int ret = mkdir(newdir,mode);
924 else return mkdir(dir,mode);
925 } /* end of my_mkdir */
928 /*{{{int my_chdir(char *)*/
932 STRLEN dirlen = strlen(dir);
935 /* zero length string sometimes gives ACCVIO */
936 if (dirlen == 0) return -1;
938 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
940 * null file name/type. However, it's commonplace under Unix,
941 * so we'll allow it for a gain in portability.
943 if (dir[dirlen-1] == '/') {
944 char *newdir = savepvn(dir,dirlen-1);
945 int ret = chdir(newdir);
949 else return chdir(dir);
950 } /* end of my_chdir */
954 /*{{{FILE *my_tmpfile()*/
962 if ((fp = tmpfile())) return fp;
964 New(1323,cp,L_tmpnam+24,char);
965 strcpy(cp,"Sys$Scratch:");
966 tmpnam(cp+strlen(cp));
967 strcat(cp,".Perltmp");
968 fp = fopen(cp,"w+","fop=dlt");
976 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
978 unsigned long int mbxbufsiz;
979 static unsigned long int syssize = 0;
980 unsigned long int dviitm = DVI$_DEVNAM;
982 char csize[LNM$C_NAMLENGTH+1];
985 unsigned long syiitm = SYI$_MAXBUF;
987 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
988 * preprocessor consant BUFSIZ from stdio.h defaults as the size of the
991 * If the logical 'PERL_MBX_SIZE' is defined
992 * use the value of the logical instead of BUFSIZ, but again
993 * keep the size between 128 and MAXBUF.
996 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
999 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1000 mbxbufsiz = atoi(csize);
1004 if (mbxbufsiz < 128) mbxbufsiz = 128;
1005 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1007 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1009 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1010 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1012 } /* end of create_mbx() */
1015 /*{{{ my_popen and my_pclose*/
1017 typedef struct _iosb IOSB;
1018 typedef struct _iosb* pIOSB;
1019 typedef struct _pipe Pipe;
1020 typedef struct _pipe* pPipe;
1021 typedef struct pipe_details Info;
1022 typedef struct pipe_details* pInfo;
1023 typedef struct _srqp RQE;
1024 typedef struct _srqp* pRQE;
1025 typedef struct _tochildbuf CBuf;
1026 typedef struct _tochildbuf* pCBuf;
1029 unsigned short status;
1030 unsigned short count;
1031 unsigned long dvispec;
1034 #pragma member_alignment save
1035 #pragma nomember_alignment quadword
1036 struct _srqp { /* VMS self-relative queue entry */
1037 unsigned long qptr[2];
1039 #pragma member_alignment restore
1040 static RQE RQE_ZERO = {0,0};
1042 struct _tochildbuf {
1045 unsigned short size;
1053 unsigned short chan_in;
1054 unsigned short chan_out;
1056 unsigned int bufsize;
1074 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1075 int pid; /* PID of subprocess */
1076 int mode; /* == 'r' if pipe open for reading */
1077 int done; /* subprocess has completed */
1078 int closing; /* my_pclose is closing this pipe */
1079 unsigned long completion; /* termination status of subprocess */
1080 pPipe in; /* pipe in to sub */
1081 pPipe out; /* pipe out of sub */
1082 pPipe err; /* pipe of sub's sys$error */
1083 int in_done; /* true when in pipe finished */
1088 struct exit_control_block
1090 struct exit_control_block *flink;
1091 unsigned long int (*exit_routine)();
1092 unsigned long int arg_count;
1093 unsigned long int *status_address;
1094 unsigned long int exit_status;
1097 #define RETRY_DELAY "0 ::0.20"
1098 #define MAX_RETRY 50
1100 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1101 static unsigned long mypid;
1102 static unsigned long delaytime[2];
1104 static pInfo open_pipes = NULL;
1105 static $DESCRIPTOR(nl_desc, "NL:");
1108 static unsigned long int
1112 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1113 int sts, did_stuff, need_eof;
1117 first we try sending an EOF...ignore if doesn't work, make sure we
1125 _ckvmssts(sys$setast(0));
1126 if (info->in && !info->in->shut_on_empty) {
1127 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1131 _ckvmssts(sys$setast(1));
1134 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1139 _ckvmssts(sys$setast(0));
1140 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1141 sts = sys$forcex(&info->pid,0,&abort);
1142 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1145 _ckvmssts(sys$setast(1));
1148 if (did_stuff) sleep(1); /* wait for them to respond */
1152 _ckvmssts(sys$setast(0));
1153 if (!info->done) { /* We tried to be nice . . . */
1154 sts = sys$delprc(&info->pid,0);
1155 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1157 _ckvmssts(sys$setast(1));
1162 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1163 else if (!(sts & 1)) retsts = sts;
1168 static struct exit_control_block pipe_exitblock =
1169 {(struct exit_control_block *) 0,
1170 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1172 static void pipe_mbxtofd_ast(pPipe p);
1173 static void pipe_tochild1_ast(pPipe p);
1174 static void pipe_tochild2_ast(pPipe p);
1177 popen_completion_ast(pInfo info)
1180 pInfo i = open_pipes;
1184 if (i == info) break;
1187 if (!i) return; /* unlinked, probably freed too */
1189 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1193 Writing to subprocess ...
1194 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1196 chan_out may be waiting for "done" flag, or hung waiting
1197 for i/o completion to child...cancel the i/o. This will
1198 put it into "snarf mode" (done but no EOF yet) that discards
1201 Output from subprocess (stdout, stderr) needs to be flushed and
1202 shut down. We try sending an EOF, but if the mbx is full the pipe
1203 routine should still catch the "shut_on_empty" flag, telling it to
1204 use immediate-style reads so that "mbx empty" -> EOF.
1208 if (info->in && !info->in_done) { /* only for mode=w */
1209 if (info->in->shut_on_empty && info->in->need_wake) {
1210 info->in->need_wake = FALSE;
1211 _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0));
1213 _ckvmssts(sys$cancel(info->in->chan_out));
1217 if (info->out && !info->out_done) { /* were we also piping output? */
1218 info->out->shut_on_empty = TRUE;
1219 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1220 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1224 if (info->err && !info->err_done) { /* we were piping stderr */
1225 info->err->shut_on_empty = TRUE;
1226 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1227 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1230 _ckvmssts(sys$setef(pipe_ef));
1234 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1235 static void vms_execfree(pTHX);
1238 we actually differ from vmstrnenv since we use this to
1239 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1240 are pointing to the same thing
1243 static unsigned short
1244 popen_translate(char *logical, char *result)
1247 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1248 $DESCRIPTOR(d_log,"");
1250 unsigned short length;
1251 unsigned short code;
1253 unsigned short *retlenaddr;
1255 unsigned short l, ifi;
1257 d_log.dsc$a_pointer = logical;
1258 d_log.dsc$w_length = strlen(logical);
1260 itmlst[0].code = LNM$_STRING;
1261 itmlst[0].length = 255;
1262 itmlst[0].buffer_addr = result;
1263 itmlst[0].retlenaddr = &l;
1266 itmlst[1].length = 0;
1267 itmlst[1].buffer_addr = 0;
1268 itmlst[1].retlenaddr = 0;
1270 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1271 if (iss == SS$_NOLOGNAM) {
1275 if (!(iss&1)) lib$signal(iss);
1278 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1279 strip it off and return the ifi, if any
1282 if (result[0] == 0x1b && result[1] == 0x00) {
1283 memcpy(&ifi,result+2,2);
1284 strcpy(result,result+4);
1286 return ifi; /* this is the RMS internal file id */
1289 #define MAX_DCL_SYMBOL 255
1290 static void pipe_infromchild_ast(pPipe p);
1293 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1294 inside an AST routine without worrying about reentrancy and which Perl
1295 memory allocator is being used.
1297 We read data and queue up the buffers, then spit them out one at a
1298 time to the output mailbox when the output mailbox is ready for one.
1301 #define INITIAL_TOCHILDQUEUE 2
1304 pipe_tochild_setup(char *rmbx, char *wmbx)
1309 char mbx1[64], mbx2[64];
1310 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1311 DSC$K_CLASS_S, mbx1},
1312 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1313 DSC$K_CLASS_S, mbx2};
1314 unsigned int dviitm = DVI$_DEVBUFSIZ;
1317 New(1368, p, 1, Pipe);
1319 create_mbx(&p->chan_in , &d_mbx1);
1320 create_mbx(&p->chan_out, &d_mbx2);
1321 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1324 p->shut_on_empty = FALSE;
1325 p->need_wake = FALSE;
1328 p->iosb.status = SS$_NORMAL;
1329 p->iosb2.status = SS$_NORMAL;
1336 n = sizeof(CBuf) + p->bufsize;
1338 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1339 _ckvmssts(lib$get_vm(&n, &b));
1340 b->buf = (char *) b + sizeof(CBuf);
1341 _ckvmssts(lib$insqhi(b, &p->free));
1344 pipe_tochild2_ast(p);
1345 pipe_tochild1_ast(p);
1351 /* reads the MBX Perl is writing, and queues */
1354 pipe_tochild1_ast(pPipe p)
1358 int iss = p->iosb.status;
1359 int eof = (iss == SS$_ENDOFFILE);
1363 p->shut_on_empty = TRUE;
1365 _ckvmssts(sys$dassgn(p->chan_in));
1371 b->size = p->iosb.count;
1372 _ckvmssts(lib$insqhi(b, &p->wait));
1374 p->need_wake = FALSE;
1375 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1378 p->retry = 1; /* initial call */
1381 if (eof) { /* flush the free queue, return when done */
1382 int n = sizeof(CBuf) + p->bufsize;
1384 iss = lib$remqti(&p->free, &b);
1385 if (iss == LIB$_QUEWASEMP) return;
1387 _ckvmssts(lib$free_vm(&n, &b));
1391 iss = lib$remqti(&p->free, &b);
1392 if (iss == LIB$_QUEWASEMP) {
1393 int n = sizeof(CBuf) + p->bufsize;
1394 _ckvmssts(lib$get_vm(&n, &b));
1395 b->buf = (char *) b + sizeof(CBuf);
1401 iss = sys$qio(0,p->chan_in,
1402 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1404 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1405 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1410 /* writes queued buffers to output, waits for each to complete before
1414 pipe_tochild2_ast(pPipe p)
1418 int iss = p->iosb2.status;
1419 int n = sizeof(CBuf) + p->bufsize;
1420 int done = (p->info && p->info->done) ||
1421 iss == SS$_CANCEL || iss == SS$_ABORT;
1424 if (p->type) { /* type=1 has old buffer, dispose */
1425 if (p->shut_on_empty) {
1426 _ckvmssts(lib$free_vm(&n, &b));
1428 _ckvmssts(lib$insqhi(b, &p->free));
1433 iss = lib$remqti(&p->wait, &b);
1434 if (iss == LIB$_QUEWASEMP) {
1435 if (p->shut_on_empty) {
1437 _ckvmssts(sys$dassgn(p->chan_out));
1438 *p->pipe_done = TRUE;
1439 _ckvmssts(sys$setef(pipe_ef));
1441 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1442 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1446 p->need_wake = TRUE;
1456 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1457 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1459 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1460 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1469 pipe_infromchild_setup(char *rmbx, char *wmbx)
1473 char mbx1[64], mbx2[64];
1474 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1475 DSC$K_CLASS_S, mbx1},
1476 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1477 DSC$K_CLASS_S, mbx2};
1478 unsigned int dviitm = DVI$_DEVBUFSIZ;
1480 New(1367, p, 1, Pipe);
1481 create_mbx(&p->chan_in , &d_mbx1);
1482 create_mbx(&p->chan_out, &d_mbx2);
1484 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1485 New(1367, p->buf, p->bufsize, char);
1486 p->shut_on_empty = FALSE;
1489 p->iosb.status = SS$_NORMAL;
1490 pipe_infromchild_ast(p);
1498 pipe_infromchild_ast(pPipe p)
1501 int iss = p->iosb.status;
1502 int eof = (iss == SS$_ENDOFFILE);
1503 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1504 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1506 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1507 _ckvmssts(sys$dassgn(p->chan_out));
1512 input shutdown if EOF from self (done or shut_on_empty)
1513 output shutdown if closing flag set (my_pclose)
1514 send data/eof from child or eof from self
1515 otherwise, re-read (snarf of data from child)
1520 if (myeof && p->chan_in) { /* input shutdown */
1521 _ckvmssts(sys$dassgn(p->chan_in));
1526 if (myeof || kideof) { /* pass EOF to parent */
1527 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1528 pipe_infromchild_ast, p,
1531 } else if (eof) { /* eat EOF --- fall through to read*/
1533 } else { /* transmit data */
1534 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1535 pipe_infromchild_ast,p,
1536 p->buf, p->iosb.count, 0, 0, 0, 0));
1542 /* everything shut? flag as done */
1544 if (!p->chan_in && !p->chan_out) {
1545 *p->pipe_done = TRUE;
1546 _ckvmssts(sys$setef(pipe_ef));
1550 /* write completed (or read, if snarfing from child)
1551 if still have input active,
1552 queue read...immediate mode if shut_on_empty so we get EOF if empty
1554 check if Perl reading, generate EOFs as needed
1560 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1561 pipe_infromchild_ast,p,
1562 p->buf, p->bufsize, 0, 0, 0, 0);
1563 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1565 } else { /* send EOFs for extra reads */
1566 p->iosb.status = SS$_ENDOFFILE;
1567 p->iosb.dvispec = 0;
1568 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1570 pipe_infromchild_ast, p, 0, 0, 0, 0));
1576 pipe_mbxtofd_setup(int fd, char *out)
1581 unsigned long dviitm = DVI$_DEVBUFSIZ;
1583 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1584 DSC$K_CLASS_S, mbx};
1586 /* things like terminals and mbx's don't need this filter */
1587 if (fd && fstat(fd,&s) == 0) {
1588 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1589 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1590 DSC$K_CLASS_S, s.st_dev};
1592 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1593 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1594 strcpy(out, s.st_dev);
1599 New(1366, p, 1, Pipe);
1600 p->fd_out = dup(fd);
1601 create_mbx(&p->chan_in, &d_mbx);
1602 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1603 New(1366, p->buf, p->bufsize+1, char);
1604 p->shut_on_empty = FALSE;
1609 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1610 pipe_mbxtofd_ast, p,
1611 p->buf, p->bufsize, 0, 0, 0, 0));
1617 pipe_mbxtofd_ast(pPipe p)
1620 int iss = p->iosb.status;
1621 int done = p->info->done;
1623 int eof = (iss == SS$_ENDOFFILE);
1624 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1625 int err = !(iss&1) && !eof;
1628 if (done && myeof) { /* end piping */
1630 sys$dassgn(p->chan_in);
1631 *p->pipe_done = TRUE;
1632 _ckvmssts(sys$setef(pipe_ef));
1636 if (!err && !eof) { /* good data to send to file */
1637 p->buf[p->iosb.count] = '\n';
1638 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1641 if (p->retry < MAX_RETRY) {
1642 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1652 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1653 pipe_mbxtofd_ast, p,
1654 p->buf, p->bufsize, 0, 0, 0, 0);
1655 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1660 typedef struct _pipeloc PLOC;
1661 typedef struct _pipeloc* pPLOC;
1665 char dir[NAM$C_MAXRSS+1];
1667 static pPLOC head_PLOC = 0;
1675 AV *av = GvAVn(PL_incgv);
1680 char temp[NAM$C_MAXRSS+1];
1683 /* the . directory from @INC comes last */
1686 p->next = head_PLOC;
1688 strcpy(p->dir,"./");
1690 /* get the directory from $^X */
1692 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1693 strcpy(temp, PL_origargv[0]);
1694 x = strrchr(temp,']');
1697 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1699 p->next = head_PLOC;
1701 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1702 p->dir[NAM$C_MAXRSS] = '\0';
1706 /* reverse order of @INC entries, skip "." since entered above */
1708 for (i = 0; i <= AvFILL(av); i++) {
1709 dirsv = *av_fetch(av,i,TRUE);
1711 if (SvROK(dirsv)) continue;
1712 dir = SvPVx(dirsv,n_a);
1713 if (strcmp(dir,".") == 0) continue;
1714 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1718 p->next = head_PLOC;
1720 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1721 p->dir[NAM$C_MAXRSS] = '\0';
1724 /* most likely spot (ARCHLIB) put first in the list */
1727 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1729 p->next = head_PLOC;
1731 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1732 p->dir[NAM$C_MAXRSS] = '\0';
1742 static int vmspipe_file_status = 0;
1743 static char vmspipe_file[NAM$C_MAXRSS+1];
1745 /* already found? Check and use ... need read+execute permission */
1747 if (vmspipe_file_status == 1) {
1748 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1749 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1750 return vmspipe_file;
1752 vmspipe_file_status = 0;
1755 /* scan through stored @INC, $^X */
1757 if (vmspipe_file_status == 0) {
1758 char file[NAM$C_MAXRSS+1];
1759 pPLOC p = head_PLOC;
1762 strcpy(file, p->dir);
1763 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1764 file[NAM$C_MAXRSS] = '\0';
1767 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1769 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1770 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1771 vmspipe_file_status = 1;
1772 return vmspipe_file;
1775 vmspipe_file_status = -1; /* failed, use tempfiles */
1782 vmspipe_tempfile(void)
1784 char file[NAM$C_MAXRSS+1];
1786 static int index = 0;
1789 /* create a tempfile */
1791 /* we can't go from W, shr=get to R, shr=get without
1792 an intermediate vulnerable state, so don't bother trying...
1794 and lib$spawn doesn't shr=put, so have to close the write
1796 So... match up the creation date/time and the FID to
1797 make sure we're dealing with the same file
1802 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1803 fp = fopen(file,"w");
1805 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1806 fp = fopen(file,"w");
1808 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1809 fp = fopen(file,"w");
1812 if (!fp) return 0; /* we're hosed */
1814 fprintf(fp,"$! 'f$verify(0)\n");
1815 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1816 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1817 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1818 fprintf(fp,"$ perl_on = \"set noon\"\n");
1819 fprintf(fp,"$ perl_exit = \"exit\"\n");
1820 fprintf(fp,"$ perl_del = \"delete\"\n");
1821 fprintf(fp,"$ pif = \"if\"\n");
1822 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1823 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n");
1824 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\n");
1825 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1826 fprintf(fp,"$! --- get rid of global symbols\n");
1827 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1828 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1829 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1830 fprintf(fp,"$ perl_on\n");
1831 fprintf(fp,"$ 'cmd\n");
1832 fprintf(fp,"$ perl_status = $STATUS\n");
1833 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1834 fprintf(fp,"$ perl_exit 'perl_status'\n");
1837 fgetname(fp, file, 1);
1838 fstat(fileno(fp), &s0);
1841 fp = fopen(file,"r","shr=get");
1843 fstat(fileno(fp), &s1);
1845 if (s0.st_ino[0] != s1.st_ino[0] ||
1846 s0.st_ino[1] != s1.st_ino[1] ||
1847 s0.st_ino[2] != s1.st_ino[2] ||
1848 s0.st_ctime != s1.st_ctime ) {
1859 safe_popen(char *cmd, char *mode)
1862 static int handler_set_up = FALSE;
1863 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1864 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1865 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1866 char in[512], out[512], err[512], mbx[512];
1868 char tfilebuf[NAM$C_MAXRSS+1];
1870 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1871 DSC$K_CLASS_S, symbol};
1872 struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
1873 DSC$K_CLASS_S, out};
1874 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1876 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1877 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1878 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1880 /* once-per-program initialization...
1881 note that the SETAST calls and the dual test of pipe_ef
1882 makes sure that only the FIRST thread through here does
1883 the initialization...all other threads wait until it's
1886 Yeah, uglier than a pthread call, it's got all the stuff inline
1887 rather than in a separate routine.
1891 _ckvmssts(sys$setast(0));
1893 unsigned long int pidcode = JPI$_PID;
1894 $DESCRIPTOR(d_delay, RETRY_DELAY);
1895 _ckvmssts(lib$get_ef(&pipe_ef));
1896 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
1897 _ckvmssts(sys$bintim(&d_delay, delaytime));
1899 if (!handler_set_up) {
1900 _ckvmssts(sys$dclexh(&pipe_exitblock));
1901 handler_set_up = TRUE;
1903 _ckvmssts(sys$setast(1));
1906 /* see if we can find a VMSPIPE.COM */
1909 vmspipe = find_vmspipe();
1911 strcpy(tfilebuf+1,vmspipe);
1912 } else { /* uh, oh...we're in tempfile hell */
1913 tpipe = vmspipe_tempfile();
1914 if (!tpipe) { /* a fish popular in Boston */
1915 if (ckWARN(WARN_PIPE)) {
1916 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
1920 fgetname(tpipe,tfilebuf+1,1);
1922 vmspipedsc.dsc$a_pointer = tfilebuf;
1923 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1925 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1926 New(1301,info,1,Info);
1930 info->completion = 0;
1931 info->closing = FALSE;
1935 info->in_done = TRUE;
1936 info->out_done = TRUE;
1937 info->err_done = TRUE;
1939 if (*mode == 'r') { /* piping from subroutine */
1942 info->out = pipe_infromchild_setup(mbx,out);
1944 info->out->pipe_done = &info->out_done;
1945 info->out_done = FALSE;
1946 info->out->info = info;
1948 info->fp = PerlIO_open(mbx, mode);
1949 if (!info->fp && info->out) {
1950 sys$cancel(info->out->chan_out);
1952 while (!info->out_done) {
1954 _ckvmssts(sys$setast(0));
1955 done = info->out_done;
1956 if (!done) _ckvmssts(sys$clref(pipe_ef));
1957 _ckvmssts(sys$setast(1));
1958 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1961 if (info->out->buf) Safefree(info->out->buf);
1962 Safefree(info->out);
1967 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1969 info->err->pipe_done = &info->err_done;
1970 info->err_done = FALSE;
1971 info->err->info = info;
1974 } else { /* piping to subroutine , mode=w*/
1977 info->in = pipe_tochild_setup(in,mbx);
1978 info->fp = PerlIO_open(mbx, mode);
1980 info->in->pipe_done = &info->in_done;
1981 info->in_done = FALSE;
1982 info->in->info = info;
1986 if (!info->fp && info->in) {
1988 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
1989 0, 0, 0, 0, 0, 0, 0, 0));
1991 while (!info->in_done) {
1993 _ckvmssts(sys$setast(0));
1994 done = info->in_done;
1995 if (!done) _ckvmssts(sys$clref(pipe_ef));
1996 _ckvmssts(sys$setast(1));
1997 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2000 if (info->in->buf) Safefree(info->in->buf);
2006 /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
2009 fgetname(stderr, err);
2010 if (strncmp(err,"SYS$ERROR:",10) == 0) {
2011 fgetname(stdout, out);
2012 if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
2013 if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
2019 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
2021 info->out->pipe_done = &info->out_done;
2022 info->out_done = FALSE;
2023 info->out->info = info;
2026 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
2028 info->err->pipe_done = &info->err_done;
2029 info->err_done = FALSE;
2030 info->err->info = info;
2036 d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/
2038 symbol[MAX_DCL_SYMBOL] = '\0';
2040 strncpy(symbol, in, MAX_DCL_SYMBOL);
2041 d_symbol.dsc$w_length = strlen(symbol);
2042 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2044 strncpy(symbol, err, MAX_DCL_SYMBOL);
2045 d_symbol.dsc$w_length = strlen(symbol);
2046 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2049 p = VMScmd.dsc$a_pointer;
2050 while (*p && *p != '\n') p++;
2051 *p = '\0'; /* truncate on \n */
2052 p = VMScmd.dsc$a_pointer;
2053 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2054 if (*p == '$') p++; /* remove leading $ */
2055 while (*p == ' ' || *p == '\t') p++;
2056 strncpy(symbol, p, MAX_DCL_SYMBOL);
2057 d_symbol.dsc$w_length = strlen(symbol);
2058 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2060 _ckvmssts(sys$setast(0));
2061 info->next=open_pipes; /* prepend to list */
2063 _ckvmssts(sys$setast(1));
2064 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
2065 0, &info->pid, &info->completion,
2066 0, popen_completion_ast,info,0,0,0));
2068 /* if we were using a tempfile, close it now */
2070 if (tpipe) fclose(tpipe);
2072 /* once the subprocess is spawned, its copied the symbols and
2073 we can get rid of ours */
2075 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2076 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2077 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2081 PL_forkprocess = info->pid;
2083 } /* end of safe_popen */
2086 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2088 Perl_my_popen(pTHX_ char *cmd, char *mode)
2091 TAINT_PROPER("popen");
2092 PERL_FLUSHALL_FOR_CHILD;
2093 return safe_popen(cmd,mode);
2098 /*{{{ I32 my_pclose(FILE *fp)*/
2099 I32 Perl_my_pclose(pTHX_ FILE *fp)
2102 pInfo info, last = NULL;
2103 unsigned long int retsts;
2106 for (info = open_pipes; info != NULL; last = info, info = info->next)
2107 if (info->fp == fp) break;
2109 if (info == NULL) { /* no such pipe open */
2110 set_errno(ECHILD); /* quoth POSIX */
2111 set_vaxc_errno(SS$_NONEXPR);
2115 /* If we were writing to a subprocess, insure that someone reading from
2116 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2117 * produce an EOF record in the mailbox.
2119 * well, at least sometimes it *does*, so we have to watch out for
2120 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2123 fsync(fileno(info->fp)); /* first, flush data */
2125 _ckvmssts(sys$setast(0));
2126 info->closing = TRUE;
2127 done = info->done && info->in_done && info->out_done && info->err_done;
2128 /* hanging on write to Perl's input? cancel it */
2129 if (info->mode == 'r' && info->out && !info->out_done) {
2130 if (info->out->chan_out) {
2131 _ckvmssts(sys$cancel(info->out->chan_out));
2132 if (!info->out->chan_in) { /* EOF generation, need AST */
2133 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2137 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2138 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2140 _ckvmssts(sys$setast(1));
2141 PerlIO_close(info->fp);
2144 we have to wait until subprocess completes, but ALSO wait until all
2145 the i/o completes...otherwise we'll be freeing the "info" structure
2146 that the i/o ASTs could still be using...
2150 _ckvmssts(sys$setast(0));
2151 done = info->done && info->in_done && info->out_done && info->err_done;
2152 if (!done) _ckvmssts(sys$clref(pipe_ef));
2153 _ckvmssts(sys$setast(1));
2154 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2156 retsts = info->completion;
2158 /* remove from list of open pipes */
2159 _ckvmssts(sys$setast(0));
2160 if (last) last->next = info->next;
2161 else open_pipes = info->next;
2162 _ckvmssts(sys$setast(1));
2164 /* free buffers and structures */
2167 if (info->in->buf) Safefree(info->in->buf);
2171 if (info->out->buf) Safefree(info->out->buf);
2172 Safefree(info->out);
2175 if (info->err->buf) Safefree(info->err->buf);
2176 Safefree(info->err);
2182 } /* end of my_pclose() */
2184 /* sort-of waitpid; use only with popen() */
2185 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2187 my_waitpid(Pid_t pid, int *statusp, int flags)
2193 for (info = open_pipes; info != NULL; info = info->next)
2194 if (info->pid == pid) break;
2196 if (info != NULL) { /* we know about this child */
2197 while (!info->done) {
2198 _ckvmssts(sys$setast(0));
2200 if (!done) _ckvmssts(sys$clref(pipe_ef));
2201 _ckvmssts(sys$setast(1));
2202 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2205 *statusp = info->completion;
2208 else { /* we haven't heard of this child */
2209 $DESCRIPTOR(intdsc,"0 00:00:01");
2210 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2211 unsigned long int interval[2],sts;
2213 if (ckWARN(WARN_EXEC)) {
2214 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2215 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2216 if (ownerpid != mypid)
2217 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2220 _ckvmssts(sys$bintim(&intdsc,interval));
2221 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2222 _ckvmssts(sys$schdwk(0,0,interval,0));
2223 _ckvmssts(sys$hiber());
2225 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2228 /* There's no easy way to find the termination status a child we're
2229 * not aware of beforehand. If we're really interested in the future,
2230 * we can go looking for a termination mailbox, or chase after the
2231 * accounting record for the process.
2237 } /* end of waitpid() */
2242 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2244 my_gconvert(double val, int ndig, int trail, char *buf)
2246 static char __gcvtbuf[DBL_DIG+1];
2249 loc = buf ? buf : __gcvtbuf;
2251 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2253 sprintf(loc,"%.*g",ndig,val);
2259 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2260 return gcvt(val,ndig,loc);
2263 loc[0] = '0'; loc[1] = '\0';
2271 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2272 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2273 * to expand file specification. Allows for a single default file
2274 * specification and a simple mask of options. If outbuf is non-NULL,
2275 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2276 * the resultant file specification is placed. If outbuf is NULL, the
2277 * resultant file specification is placed into a static buffer.
2278 * The third argument, if non-NULL, is taken to be a default file
2279 * specification string. The fourth argument is unused at present.
2280 * rmesexpand() returns the address of the resultant string if
2281 * successful, and NULL on error.
2283 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2286 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2288 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2289 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2290 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2291 struct FAB myfab = cc$rms_fab;
2292 struct NAM mynam = cc$rms_nam;
2294 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2296 if (!filespec || !*filespec) {
2297 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2301 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2302 else outbuf = __rmsexpand_retbuf;
2304 if ((isunix = (strchr(filespec,'/') != NULL))) {
2305 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2306 filespec = vmsfspec;
2309 myfab.fab$l_fna = filespec;
2310 myfab.fab$b_fns = strlen(filespec);
2311 myfab.fab$l_nam = &mynam;
2313 if (defspec && *defspec) {
2314 if (strchr(defspec,'/') != NULL) {
2315 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2318 myfab.fab$l_dna = defspec;
2319 myfab.fab$b_dns = strlen(defspec);
2322 mynam.nam$l_esa = esa;
2323 mynam.nam$b_ess = sizeof esa;
2324 mynam.nam$l_rsa = outbuf;
2325 mynam.nam$b_rss = NAM$C_MAXRSS;
2327 retsts = sys$parse(&myfab,0,0);
2328 if (!(retsts & 1)) {
2329 mynam.nam$b_nop |= NAM$M_SYNCHK;
2330 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2331 retsts = sys$parse(&myfab,0,0);
2332 if (retsts & 1) goto expanded;
2334 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2335 (void) sys$parse(&myfab,0,0); /* Free search context */
2336 if (out) Safefree(out);
2337 set_vaxc_errno(retsts);
2338 if (retsts == RMS$_PRV) set_errno(EACCES);
2339 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2340 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2341 else set_errno(EVMSERR);
2344 retsts = sys$search(&myfab,0,0);
2345 if (!(retsts & 1) && retsts != RMS$_FNF) {
2346 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2347 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2348 if (out) Safefree(out);
2349 set_vaxc_errno(retsts);
2350 if (retsts == RMS$_PRV) set_errno(EACCES);
2351 else set_errno(EVMSERR);
2355 /* If the input filespec contained any lowercase characters,
2356 * downcase the result for compatibility with Unix-minded code. */
2358 for (out = myfab.fab$l_fna; *out; out++)
2359 if (islower(*out)) { haslower = 1; break; }
2360 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2361 else { out = esa; speclen = mynam.nam$b_esl; }
2362 /* Trim off null fields added by $PARSE
2363 * If type > 1 char, must have been specified in original or default spec
2364 * (not true for version; $SEARCH may have added version of existing file).
2366 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2367 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2368 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2369 if (trimver || trimtype) {
2370 if (defspec && *defspec) {
2371 char defesa[NAM$C_MAXRSS];
2372 struct FAB deffab = cc$rms_fab;
2373 struct NAM defnam = cc$rms_nam;
2375 deffab.fab$l_nam = &defnam;
2376 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2377 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2378 defnam.nam$b_nop = NAM$M_SYNCHK;
2379 if (sys$parse(&deffab,0,0) & 1) {
2380 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2381 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2384 if (trimver) speclen = mynam.nam$l_ver - out;
2386 /* If we didn't already trim version, copy down */
2387 if (speclen > mynam.nam$l_ver - out)
2388 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2389 speclen - (mynam.nam$l_ver - out));
2390 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2393 /* If we just had a directory spec on input, $PARSE "helpfully"
2394 * adds an empty name and type for us */
2395 if (mynam.nam$l_name == mynam.nam$l_type &&
2396 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2397 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2398 speclen = mynam.nam$l_name - out;
2399 out[speclen] = '\0';
2400 if (haslower) __mystrtolower(out);
2402 /* Have we been working with an expanded, but not resultant, spec? */
2403 /* Also, convert back to Unix syntax if necessary. */
2404 if (!mynam.nam$b_rsl) {
2406 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2408 else strcpy(outbuf,esa);
2411 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2412 strcpy(outbuf,tmpfspec);
2414 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2415 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2416 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2420 /* External entry points */
2421 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2422 { return do_rmsexpand(spec,buf,0,def,opt); }
2423 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2424 { return do_rmsexpand(spec,buf,1,def,opt); }
2428 ** The following routines are provided to make life easier when
2429 ** converting among VMS-style and Unix-style directory specifications.
2430 ** All will take input specifications in either VMS or Unix syntax. On
2431 ** failure, all return NULL. If successful, the routines listed below
2432 ** return a pointer to a buffer containing the appropriately
2433 ** reformatted spec (and, therefore, subsequent calls to that routine
2434 ** will clobber the result), while the routines of the same names with
2435 ** a _ts suffix appended will return a pointer to a mallocd string
2436 ** containing the appropriately reformatted spec.
2437 ** In all cases, only explicit syntax is altered; no check is made that
2438 ** the resulting string is valid or that the directory in question
2441 ** fileify_dirspec() - convert a directory spec into the name of the
2442 ** directory file (i.e. what you can stat() to see if it's a dir).
2443 ** The style (VMS or Unix) of the result is the same as the style
2444 ** of the parameter passed in.
2445 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2446 ** what you prepend to a filename to indicate what directory it's in).
2447 ** The style (VMS or Unix) of the result is the same as the style
2448 ** of the parameter passed in.
2449 ** tounixpath() - convert a directory spec into a Unix-style path.
2450 ** tovmspath() - convert a directory spec into a VMS-style path.
2451 ** tounixspec() - convert any file spec into a Unix-style file spec.
2452 ** tovmsspec() - convert any file spec into a VMS-style spec.
2454 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2455 ** Permission is given to distribute this code as part of the Perl
2456 ** standard distribution under the terms of the GNU General Public
2457 ** License or the Perl Artistic License. Copies of each may be
2458 ** found in the Perl standard distribution.
2461 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2462 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2464 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2465 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2466 char *retspec, *cp1, *cp2, *lastdir;
2467 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2469 if (!dir || !*dir) {
2470 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2472 dirlen = strlen(dir);
2473 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2474 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2475 strcpy(trndir,"/sys$disk/000000");
2479 if (dirlen > NAM$C_MAXRSS) {
2480 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2482 if (!strpbrk(dir+1,"/]>:")) {
2483 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2484 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2486 dirlen = strlen(dir);
2489 strncpy(trndir,dir,dirlen);
2490 trndir[dirlen] = '\0';
2493 /* If we were handed a rooted logical name or spec, treat it like a
2494 * simple directory, so that
2495 * $ Define myroot dev:[dir.]
2496 * ... do_fileify_dirspec("myroot",buf,1) ...
2497 * does something useful.
2499 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2500 dir[--dirlen] = '\0';
2501 dir[dirlen-1] = ']';
2504 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2505 /* If we've got an explicit filename, we can just shuffle the string. */
2506 if (*(cp1+1)) hasfilename = 1;
2507 /* Similarly, we can just back up a level if we've got multiple levels
2508 of explicit directories in a VMS spec which ends with directories. */
2510 for (cp2 = cp1; cp2 > dir; cp2--) {
2512 *cp2 = *cp1; *cp1 = '\0';
2516 if (*cp2 == '[' || *cp2 == '<') break;
2521 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2522 if (dir[0] == '.') {
2523 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2524 return do_fileify_dirspec("[]",buf,ts);
2525 else if (dir[1] == '.' &&
2526 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2527 return do_fileify_dirspec("[-]",buf,ts);
2529 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2530 dirlen -= 1; /* to last element */
2531 lastdir = strrchr(dir,'/');
2533 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2534 /* If we have "/." or "/..", VMSify it and let the VMS code
2535 * below expand it, rather than repeating the code to handle
2536 * relative components of a filespec here */
2538 if (*(cp1+2) == '.') cp1++;
2539 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2540 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2541 if (strchr(vmsdir,'/') != NULL) {
2542 /* If do_tovmsspec() returned it, it must have VMS syntax
2543 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2544 * the time to check this here only so we avoid a recursion
2545 * loop; otherwise, gigo.
2547 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2549 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2550 return do_tounixspec(trndir,buf,ts);
2553 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2554 lastdir = strrchr(dir,'/');
2556 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2557 /* Ditto for specs that end in an MFD -- let the VMS code
2558 * figure out whether it's a real device or a rooted logical. */
2559 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2560 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2561 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2562 return do_tounixspec(trndir,buf,ts);
2565 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2566 !(lastdir = cp1 = strrchr(dir,']')) &&
2567 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2568 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2570 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2571 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2572 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2573 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2574 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2575 (ver || *cp3)))))) {
2577 set_vaxc_errno(RMS$_DIR);
2583 /* If we lead off with a device or rooted logical, add the MFD
2584 if we're specifying a top-level directory. */
2585 if (lastdir && *dir == '/') {
2587 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2594 retlen = dirlen + (addmfd ? 13 : 6);
2595 if (buf) retspec = buf;
2596 else if (ts) New(1309,retspec,retlen+1,char);
2597 else retspec = __fileify_retbuf;
2599 dirlen = lastdir - dir;
2600 memcpy(retspec,dir,dirlen);
2601 strcpy(&retspec[dirlen],"/000000");
2602 strcpy(&retspec[dirlen+7],lastdir);
2605 memcpy(retspec,dir,dirlen);
2606 retspec[dirlen] = '\0';
2608 /* We've picked up everything up to the directory file name.
2609 Now just add the type and version, and we're set. */
2610 strcat(retspec,".dir;1");
2613 else { /* VMS-style directory spec */
2614 char esa[NAM$C_MAXRSS+1], term, *cp;
2615 unsigned long int sts, cmplen, haslower = 0;
2616 struct FAB dirfab = cc$rms_fab;
2617 struct NAM savnam, dirnam = cc$rms_nam;
2619 dirfab.fab$b_fns = strlen(dir);
2620 dirfab.fab$l_fna = dir;
2621 dirfab.fab$l_nam = &dirnam;
2622 dirfab.fab$l_dna = ".DIR;1";
2623 dirfab.fab$b_dns = 6;
2624 dirnam.nam$b_ess = NAM$C_MAXRSS;
2625 dirnam.nam$l_esa = esa;
2627 for (cp = dir; *cp; cp++)
2628 if (islower(*cp)) { haslower = 1; break; }
2629 if (!((sts = sys$parse(&dirfab))&1)) {
2630 if (dirfab.fab$l_sts == RMS$_DIR) {
2631 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2632 sts = sys$parse(&dirfab) & 1;
2636 set_vaxc_errno(dirfab.fab$l_sts);
2642 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2643 /* Yes; fake the fnb bits so we'll check type below */
2644 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2646 else { /* No; just work with potential name */
2647 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2649 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2650 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2651 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2656 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2657 cp1 = strchr(esa,']');
2658 if (!cp1) cp1 = strchr(esa,'>');
2659 if (cp1) { /* Should always be true */
2660 dirnam.nam$b_esl -= cp1 - esa - 1;
2661 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2664 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2665 /* Yep; check version while we're at it, if it's there. */
2666 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2667 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2668 /* Something other than .DIR[;1]. Bzzt. */
2669 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2670 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2672 set_vaxc_errno(RMS$_DIR);
2676 esa[dirnam.nam$b_esl] = '\0';
2677 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2678 /* They provided at least the name; we added the type, if necessary, */
2679 if (buf) retspec = buf; /* in sys$parse() */
2680 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2681 else retspec = __fileify_retbuf;
2682 strcpy(retspec,esa);
2683 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2684 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2687 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2688 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2690 dirnam.nam$b_esl -= 9;
2692 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2693 if (cp1 == NULL) { /* should never happen */
2694 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2695 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2700 retlen = strlen(esa);
2701 if ((cp1 = strrchr(esa,'.')) != NULL) {
2702 /* There's more than one directory in the path. Just roll back. */
2704 if (buf) retspec = buf;
2705 else if (ts) New(1311,retspec,retlen+7,char);
2706 else retspec = __fileify_retbuf;
2707 strcpy(retspec,esa);
2710 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2711 /* Go back and expand rooted logical name */
2712 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2713 if (!(sys$parse(&dirfab) & 1)) {
2714 dirnam.nam$l_rlf = NULL;
2715 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2717 set_vaxc_errno(dirfab.fab$l_sts);
2720 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2721 if (buf) retspec = buf;
2722 else if (ts) New(1312,retspec,retlen+16,char);
2723 else retspec = __fileify_retbuf;
2724 cp1 = strstr(esa,"][");
2726 memcpy(retspec,esa,dirlen);
2727 if (!strncmp(cp1+2,"000000]",7)) {
2728 retspec[dirlen-1] = '\0';
2729 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2730 if (*cp1 == '.') *cp1 = ']';
2732 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2733 memcpy(cp1+1,"000000]",7);
2737 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2738 retspec[retlen] = '\0';
2739 /* Convert last '.' to ']' */
2740 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2741 if (*cp1 == '.') *cp1 = ']';
2743 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2744 memcpy(cp1+1,"000000]",7);
2748 else { /* This is a top-level dir. Add the MFD to the path. */
2749 if (buf) retspec = buf;
2750 else if (ts) New(1312,retspec,retlen+16,char);
2751 else retspec = __fileify_retbuf;
2754 while (*cp1 != ':') *(cp2++) = *(cp1++);
2755 strcpy(cp2,":[000000]");
2760 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2761 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2762 /* We've set up the string up through the filename. Add the
2763 type and version, and we're done. */
2764 strcat(retspec,".DIR;1");
2766 /* $PARSE may have upcased filespec, so convert output to lower
2767 * case if input contained any lowercase characters. */
2768 if (haslower) __mystrtolower(retspec);
2771 } /* end of do_fileify_dirspec() */
2773 /* External entry points */
2774 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2775 { return do_fileify_dirspec(dir,buf,0); }
2776 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2777 { return do_fileify_dirspec(dir,buf,1); }
2779 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2780 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2782 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2783 unsigned long int retlen;
2784 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2786 if (!dir || !*dir) {
2787 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2790 if (*dir) strcpy(trndir,dir);
2791 else getcwd(trndir,sizeof trndir - 1);
2793 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2794 && my_trnlnm(trndir,trndir,0)) {
2795 STRLEN trnlen = strlen(trndir);
2797 /* Trap simple rooted lnms, and return lnm:[000000] */
2798 if (!strcmp(trndir+trnlen-2,".]")) {
2799 if (buf) retpath = buf;
2800 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2801 else retpath = __pathify_retbuf;
2802 strcpy(retpath,dir);
2803 strcat(retpath,":[000000]");
2809 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2810 if (*dir == '.' && (*(dir+1) == '\0' ||
2811 (*(dir+1) == '.' && *(dir+2) == '\0')))
2812 retlen = 2 + (*(dir+1) != '\0');
2814 if ( !(cp1 = strrchr(dir,'/')) &&
2815 !(cp1 = strrchr(dir,']')) &&
2816 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2817 if ((cp2 = strchr(cp1,'.')) != NULL &&
2818 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2819 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2820 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2821 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2823 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2824 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2825 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2826 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2827 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2828 (ver || *cp3)))))) {
2830 set_vaxc_errno(RMS$_DIR);
2833 retlen = cp2 - dir + 1;
2835 else { /* No file type present. Treat the filename as a directory. */
2836 retlen = strlen(dir) + 1;
2839 if (buf) retpath = buf;
2840 else if (ts) New(1313,retpath,retlen+1,char);
2841 else retpath = __pathify_retbuf;
2842 strncpy(retpath,dir,retlen-1);
2843 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2844 retpath[retlen-1] = '/'; /* with '/', add it. */
2845 retpath[retlen] = '\0';
2847 else retpath[retlen-1] = '\0';
2849 else { /* VMS-style directory spec */
2850 char esa[NAM$C_MAXRSS+1], *cp;
2851 unsigned long int sts, cmplen, haslower;
2852 struct FAB dirfab = cc$rms_fab;
2853 struct NAM savnam, dirnam = cc$rms_nam;
2855 /* If we've got an explicit filename, we can just shuffle the string. */
2856 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2857 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2858 if ((cp2 = strchr(cp1,'.')) != NULL) {
2860 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2861 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2862 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2863 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2864 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2865 (ver || *cp3)))))) {
2867 set_vaxc_errno(RMS$_DIR);
2871 else { /* No file type, so just draw name into directory part */
2872 for (cp2 = cp1; *cp2; cp2++) ;
2875 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2877 /* We've now got a VMS 'path'; fall through */
2879 dirfab.fab$b_fns = strlen(dir);
2880 dirfab.fab$l_fna = dir;
2881 if (dir[dirfab.fab$b_fns-1] == ']' ||
2882 dir[dirfab.fab$b_fns-1] == '>' ||
2883 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2884 if (buf) retpath = buf;
2885 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2886 else retpath = __pathify_retbuf;
2887 strcpy(retpath,dir);
2890 dirfab.fab$l_dna = ".DIR;1";
2891 dirfab.fab$b_dns = 6;
2892 dirfab.fab$l_nam = &dirnam;
2893 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2894 dirnam.nam$l_esa = esa;
2896 for (cp = dir; *cp; cp++)
2897 if (islower(*cp)) { haslower = 1; break; }
2899 if (!(sts = (sys$parse(&dirfab)&1))) {
2900 if (dirfab.fab$l_sts == RMS$_DIR) {
2901 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2902 sts = sys$parse(&dirfab) & 1;
2906 set_vaxc_errno(dirfab.fab$l_sts);
2912 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
2913 if (dirfab.fab$l_sts != RMS$_FNF) {
2914 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2915 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2917 set_vaxc_errno(dirfab.fab$l_sts);
2920 dirnam = savnam; /* No; just work with potential name */
2923 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2924 /* Yep; check version while we're at it, if it's there. */
2925 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2926 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2927 /* Something other than .DIR[;1]. Bzzt. */
2928 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2929 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2931 set_vaxc_errno(RMS$_DIR);
2935 /* OK, the type was fine. Now pull any file name into the
2937 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
2939 cp1 = strrchr(esa,'>');
2940 *dirnam.nam$l_type = '>';
2943 *(dirnam.nam$l_type + 1) = '\0';
2944 retlen = dirnam.nam$l_type - esa + 2;
2945 if (buf) retpath = buf;
2946 else if (ts) New(1314,retpath,retlen,char);
2947 else retpath = __pathify_retbuf;
2948 strcpy(retpath,esa);
2949 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2950 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2951 /* $PARSE may have upcased filespec, so convert output to lower
2952 * case if input contained any lowercase characters. */
2953 if (haslower) __mystrtolower(retpath);
2957 } /* end of do_pathify_dirspec() */
2959 /* External entry points */
2960 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
2961 { return do_pathify_dirspec(dir,buf,0); }
2962 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
2963 { return do_pathify_dirspec(dir,buf,1); }
2965 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
2966 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
2968 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
2969 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
2970 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
2972 if (spec == NULL) return NULL;
2973 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
2974 if (buf) rslt = buf;
2976 retlen = strlen(spec);
2977 cp1 = strchr(spec,'[');
2978 if (!cp1) cp1 = strchr(spec,'<');
2980 for (cp1++; *cp1; cp1++) {
2981 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
2982 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
2983 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2986 New(1315,rslt,retlen+2+2*expand,char);
2988 else rslt = __tounixspec_retbuf;
2989 if (strchr(spec,'/') != NULL) {
2996 dirend = strrchr(spec,']');
2997 if (dirend == NULL) dirend = strrchr(spec,'>');
2998 if (dirend == NULL) dirend = strchr(spec,':');
2999 if (dirend == NULL) {
3003 if (*cp2 != '[' && *cp2 != '<') {
3006 else { /* the VMS spec begins with directories */
3008 if (*cp2 == ']' || *cp2 == '>') {
3009 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3012 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3013 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3014 if (ts) Safefree(rslt);
3019 while (*cp3 != ':' && *cp3) cp3++;
3021 if (strchr(cp3,']') != NULL) break;
3022 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3024 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3025 retlen = devlen + dirlen;
3026 Renew(rslt,retlen+1+2*expand,char);
3032 *(cp1++) = *(cp3++);
3033 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3037 else if ( *cp2 == '.') {
3038 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3039 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3045 for (; cp2 <= dirend; cp2++) {
3048 if (*(cp2+1) == '[') cp2++;
3050 else if (*cp2 == ']' || *cp2 == '>') {
3051 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3053 else if (*cp2 == '.') {
3055 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3056 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3057 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3058 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3059 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3061 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3062 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3066 else if (*cp2 == '-') {
3067 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3068 while (*cp2 == '-') {
3070 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3072 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3073 if (ts) Safefree(rslt); /* filespecs like */
3074 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3078 else *(cp1++) = *cp2;
3080 else *(cp1++) = *cp2;
3082 while (*cp2) *(cp1++) = *(cp2++);
3087 } /* end of do_tounixspec() */
3089 /* External entry points */
3090 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3091 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3093 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3094 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3095 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3096 char *rslt, *dirend;
3097 register char *cp1, *cp2;
3098 unsigned long int infront = 0, hasdir = 1;
3100 if (path == NULL) return NULL;
3101 if (buf) rslt = buf;
3102 else if (ts) New(1316,rslt,strlen(path)+9,char);
3103 else rslt = __tovmsspec_retbuf;
3104 if (strpbrk(path,"]:>") ||
3105 (dirend = strrchr(path,'/')) == NULL) {
3106 if (path[0] == '.') {
3107 if (path[1] == '\0') strcpy(rslt,"[]");
3108 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3109 else strcpy(rslt,path); /* probably garbage */
3111 else strcpy(rslt,path);
3114 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3115 if (!*(dirend+2)) dirend +=2;
3116 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3117 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3122 char trndev[NAM$C_MAXRSS+1];
3126 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3128 if (!buf & ts) Renew(rslt,18,char);
3129 strcpy(rslt,"sys$disk:[000000]");
3132 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3134 islnm = my_trnlnm(rslt,trndev,0);
3135 trnend = islnm ? strlen(trndev) - 1 : 0;
3136 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3137 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3138 /* If the first element of the path is a logical name, determine
3139 * whether it has to be translated so we can add more directories. */
3140 if (!islnm || rooted) {
3143 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3147 if (cp2 != dirend) {
3148 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3149 strcpy(rslt,trndev);
3150 cp1 = rslt + trnend;
3163 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3164 cp2 += 2; /* skip over "./" - it's redundant */
3165 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3167 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3168 *(cp1++) = '-'; /* "../" --> "-" */
3171 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3172 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3173 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3174 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3177 if (cp2 > dirend) cp2 = dirend;
3179 else *(cp1++) = '.';
3181 for (; cp2 < dirend; cp2++) {
3183 if (*(cp2-1) == '/') continue;
3184 if (*(cp1-1) != '.') *(cp1++) = '.';
3187 else if (!infront && *cp2 == '.') {
3188 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3189 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3190 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3191 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3192 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3193 else { /* back up over previous directory name */
3195 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3196 if (*(cp1-1) == '[') {
3197 memcpy(cp1,"000000.",7);
3202 if (cp2 == dirend) break;
3204 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3205 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3206 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3207 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3209 *(cp1++) = '.'; /* Simulate trailing '/' */
3210 cp2 += 2; /* for loop will incr this to == dirend */
3212 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3214 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3217 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3218 if (*cp2 == '.') *(cp1++) = '_';
3219 else *(cp1++) = *cp2;
3223 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3224 if (hasdir) *(cp1++) = ']';
3225 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3226 while (*cp2) *(cp1++) = *(cp2++);
3231 } /* end of do_tovmsspec() */
3233 /* External entry points */
3234 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3235 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3237 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3238 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3239 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3241 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3243 if (path == NULL) return NULL;
3244 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3245 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3246 if (buf) return buf;
3248 vmslen = strlen(vmsified);
3249 New(1317,cp,vmslen+1,char);
3250 memcpy(cp,vmsified,vmslen);
3255 strcpy(__tovmspath_retbuf,vmsified);
3256 return __tovmspath_retbuf;
3259 } /* end of do_tovmspath() */
3261 /* External entry points */
3262 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3263 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3266 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3267 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3268 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3270 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3272 if (path == NULL) return NULL;
3273 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3274 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3275 if (buf) return buf;
3277 unixlen = strlen(unixified);
3278 New(1317,cp,unixlen+1,char);
3279 memcpy(cp,unixified,unixlen);
3284 strcpy(__tounixpath_retbuf,unixified);
3285 return __tounixpath_retbuf;
3288 } /* end of do_tounixpath() */
3290 /* External entry points */
3291 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3292 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3295 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3297 *****************************************************************************
3299 * Copyright (C) 1989-1994 by *
3300 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3302 * Permission is hereby granted for the reproduction of this software, *
3303 * on condition that this copyright notice is included in the reproduction, *
3304 * and that such reproduction is not for purposes of profit or material *
3307 * 27-Aug-1994 Modified for inclusion in perl5 *
3308 * by Charles Bailey bailey@newman.upenn.edu *
3309 *****************************************************************************
3313 * getredirection() is intended to aid in porting C programs
3314 * to VMS (Vax-11 C). The native VMS environment does not support
3315 * '>' and '<' I/O redirection, or command line wild card expansion,
3316 * or a command line pipe mechanism using the '|' AND background
3317 * command execution '&'. All of these capabilities are provided to any
3318 * C program which calls this procedure as the first thing in the
3320 * The piping mechanism will probably work with almost any 'filter' type
3321 * of program. With suitable modification, it may useful for other
3322 * portability problems as well.
3324 * Author: Mark Pizzolato mark@infocomm.com
3328 struct list_item *next;
3332 static void add_item(struct list_item **head,
3333 struct list_item **tail,
3337 static void mp_expand_wild_cards(pTHX_ char *item,
3338 struct list_item **head,
3339 struct list_item **tail,
3342 static int background_process(int argc, char **argv);
3344 static void pipe_and_fork(char **cmargv);
3346 /*{{{ void getredirection(int *ac, char ***av)*/
3348 mp_getredirection(pTHX_ int *ac, char ***av)
3350 * Process vms redirection arg's. Exit if any error is seen.
3351 * If getredirection() processes an argument, it is erased
3352 * from the vector. getredirection() returns a new argc and argv value.
3353 * In the event that a background command is requested (by a trailing "&"),
3354 * this routine creates a background subprocess, and simply exits the program.
3356 * Warning: do not try to simplify the code for vms. The code
3357 * presupposes that getredirection() is called before any data is
3358 * read from stdin or written to stdout.
3360 * Normal usage is as follows:
3366 * getredirection(&argc, &argv);
3370 int argc = *ac; /* Argument Count */
3371 char **argv = *av; /* Argument Vector */
3372 char *ap; /* Argument pointer */
3373 int j; /* argv[] index */
3374 int item_count = 0; /* Count of Items in List */
3375 struct list_item *list_head = 0; /* First Item in List */
3376 struct list_item *list_tail; /* Last Item in List */
3377 char *in = NULL; /* Input File Name */
3378 char *out = NULL; /* Output File Name */
3379 char *outmode = "w"; /* Mode to Open Output File */
3380 char *err = NULL; /* Error File Name */
3381 char *errmode = "w"; /* Mode to Open Error File */
3382 int cmargc = 0; /* Piped Command Arg Count */
3383 char **cmargv = NULL;/* Piped Command Arg Vector */
3386 * First handle the case where the last thing on the line ends with
3387 * a '&'. This indicates the desire for the command to be run in a
3388 * subprocess, so we satisfy that desire.
3391 if (0 == strcmp("&", ap))
3392 exit(background_process(--argc, argv));
3393 if (*ap && '&' == ap[strlen(ap)-1])
3395 ap[strlen(ap)-1] = '\0';
3396 exit(background_process(argc, argv));
3399 * Now we handle the general redirection cases that involve '>', '>>',
3400 * '<', and pipes '|'.
3402 for (j = 0; j < argc; ++j)
3404 if (0 == strcmp("<", argv[j]))
3408 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3409 exit(LIB$_WRONUMARG);
3414 if ('<' == *(ap = argv[j]))
3419 if (0 == strcmp(">", ap))
3423 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3424 exit(LIB$_WRONUMARG);
3443 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3444 exit(LIB$_WRONUMARG);
3448 if (('2' == *ap) && ('>' == ap[1]))
3465 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3466 exit(LIB$_WRONUMARG);
3470 if (0 == strcmp("|", argv[j]))
3474 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3475 exit(LIB$_WRONUMARG);
3477 cmargc = argc-(j+1);
3478 cmargv = &argv[j+1];
3482 if ('|' == *(ap = argv[j]))
3490 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3493 * Allocate and fill in the new argument vector, Some Unix's terminate
3494 * the list with an extra null pointer.
3496 New(1302, argv, item_count+1, char *);
3498 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3499 argv[j] = list_head->value;
3505 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3506 exit(LIB$_INVARGORD);
3508 pipe_and_fork(cmargv);
3511 /* Check for input from a pipe (mailbox) */
3513 if (in == NULL && 1 == isapipe(0))
3515 char mbxname[L_tmpnam];
3517 long int dvi_item = DVI$_DEVBUFSIZ;
3518 $DESCRIPTOR(mbxnam, "");
3519 $DESCRIPTOR(mbxdevnam, "");
3521 /* Input from a pipe, reopen it in binary mode to disable */
3522 /* carriage control processing. */
3524 PerlIO_getname(stdin, mbxname);
3525 mbxnam.dsc$a_pointer = mbxname;
3526 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3527 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3528 mbxdevnam.dsc$a_pointer = mbxname;
3529 mbxdevnam.dsc$w_length = sizeof(mbxname);
3530 dvi_item = DVI$_DEVNAM;
3531 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3532 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3535 freopen(mbxname, "rb", stdin);
3538 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3542 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3544 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3547 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3549 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3553 if (strcmp(err,"&1") == 0) {
3554 dup2(fileno(stdout), fileno(Perl_debug_log));
3557 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3559 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3563 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3569 #ifdef ARGPROC_DEBUG
3570 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3571 for (j = 0; j < *ac; ++j)
3572 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3574 /* Clear errors we may have hit expanding wildcards, so they don't
3575 show up in Perl's $! later */
3576 set_errno(0); set_vaxc_errno(1);
3577 } /* end of getredirection() */
3580 static void add_item(struct list_item **head,
3581 struct list_item **tail,
3587 New(1303,*head,1,struct list_item);
3591 New(1304,(*tail)->next,1,struct list_item);
3592 *tail = (*tail)->next;
3594 (*tail)->value = value;
3598 static void mp_expand_wild_cards(pTHX_ char *item,
3599 struct list_item **head,
3600 struct list_item **tail,
3604 unsigned long int context = 0;
3610 char vmsspec[NAM$C_MAXRSS+1];
3611 $DESCRIPTOR(filespec, "");
3612 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3613 $DESCRIPTOR(resultspec, "");
3614 unsigned long int zero = 0, sts;
3616 for (cp = item; *cp; cp++) {
3617 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3618 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3620 if (!*cp || isspace(*cp))
3622 add_item(head, tail, item, count);
3625 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3626 resultspec.dsc$b_class = DSC$K_CLASS_D;
3627 resultspec.dsc$a_pointer = NULL;
3628 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3629 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3630 if (!isunix || !filespec.dsc$a_pointer)
3631 filespec.dsc$a_pointer = item;
3632 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3634 * Only return version specs, if the caller specified a version
3636 had_version = strchr(item, ';');
3638 * Only return device and directory specs, if the caller specifed either.
3640 had_device = strchr(item, ':');
3641 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3643 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3644 &defaultspec, 0, 0, &zero))))
3649 New(1305,string,resultspec.dsc$w_length+1,char);
3650 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3651 string[resultspec.dsc$w_length] = '\0';
3652 if (NULL == had_version)
3653 *((char *)strrchr(string, ';')) = '\0';
3654 if ((!had_directory) && (had_device == NULL))
3656 if (NULL == (devdir = strrchr(string, ']')))
3657 devdir = strrchr(string, '>');
3658 strcpy(string, devdir + 1);
3661 * Be consistent with what the C RTL has already done to the rest of
3662 * the argv items and lowercase all of these names.
3664 for (c = string; *c; ++c)
3667 if (isunix) trim_unixpath(string,item,1);
3668 add_item(head, tail, string, count);
3671 if (sts != RMS$_NMF)
3673 set_vaxc_errno(sts);
3676 case RMS$_FNF: case RMS$_DNF:
3677 set_errno(ENOENT); break;
3679 set_errno(ENOTDIR); break;
3681 set_errno(ENODEV); break;
3682 case RMS$_FNM: case RMS$_SYN:
3683 set_errno(EINVAL); break;
3685 set_errno(EACCES); break;
3687 _ckvmssts_noperl(sts);
3691 add_item(head, tail, item, count);
3692 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3693 _ckvmssts_noperl(lib$find_file_end(&context));
3696 static int child_st[2];/* Event Flag set when child process completes */
3698 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3700 static unsigned long int exit_handler(int *status)
3704 if (0 == child_st[0])
3706 #ifdef ARGPROC_DEBUG
3707 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3709 fflush(stdout); /* Have to flush pipe for binary data to */
3710 /* terminate properly -- <tp@mccall.com> */
3711 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3712 sys$dassgn(child_chan);
3714 sys$synch(0, child_st);
3719 static void sig_child(int chan)
3721 #ifdef ARGPROC_DEBUG
3722 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3724 if (child_st[0] == 0)
3728 static struct exit_control_block exit_block =
3733 &exit_block.exit_status,
3737 static void pipe_and_fork(char **cmargv)
3740 $DESCRIPTOR(cmddsc, "");
3741 static char mbxname[64];
3742 $DESCRIPTOR(mbxdsc, mbxname);
3744 unsigned long int zero = 0, one = 1;
3746 strcpy(subcmd, cmargv[0]);
3747 for (j = 1; NULL != cmargv[j]; ++j)
3749 strcat(subcmd, " \"");
3750 strcat(subcmd, cmargv[j]);
3751 strcat(subcmd, "\"");
3753 cmddsc.dsc$a_pointer = subcmd;
3754 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3756 create_mbx(&child_chan,&mbxdsc);
3757 #ifdef ARGPROC_DEBUG
3758 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3759 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3761 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3762 0, &pid, child_st, &zero, sig_child,
3764 #ifdef ARGPROC_DEBUG
3765 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3767 sys$dclexh(&exit_block);
3768 if (NULL == freopen(mbxname, "wb", stdout))
3770 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3774 static int background_process(int argc, char **argv)
3776 char command[2048] = "$";
3777 $DESCRIPTOR(value, "");
3778 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3779 static $DESCRIPTOR(null, "NLA0:");
3780 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3782 $DESCRIPTOR(pidstr, "");
3784 unsigned long int flags = 17, one = 1, retsts;
3786 strcat(command, argv[0]);
3789 strcat(command, " \"");
3790 strcat(command, *(++argv));
3791 strcat(command, "\"");
3793 value.dsc$a_pointer = command;
3794 value.dsc$w_length = strlen(value.dsc$a_pointer);
3795 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3796 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3797 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3798 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3801 _ckvmssts_noperl(retsts);
3803 #ifdef ARGPROC_DEBUG
3804 PerlIO_printf(Perl_debug_log, "%s\n", command);
3806 sprintf(pidstring, "%08X", pid);
3807 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3808 pidstr.dsc$a_pointer = pidstring;
3809 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3810 lib$set_symbol(&pidsymbol, &pidstr);
3814 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3817 /* OS-specific initialization at image activation (not thread startup) */
3818 /* Older VAXC header files lack these constants */
3819 #ifndef JPI$_RIGHTS_SIZE
3820 # define JPI$_RIGHTS_SIZE 817
3822 #ifndef KGB$M_SUBSYSTEM
3823 # define KGB$M_SUBSYSTEM 0x8
3826 /*{{{void vms_image_init(int *, char ***)*/
3828 vms_image_init(int *argcp, char ***argvp)
3830 char eqv[LNM$C_NAMLENGTH+1] = "";
3831 unsigned int len, tabct = 8, tabidx = 0;
3832 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3833 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3834 unsigned short int dummy, rlen;
3835 struct dsc$descriptor_s **tabvec;
3837 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3838 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3839 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3842 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3844 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3845 if (iprv[i]) { /* Running image installed with privs? */
3846 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3851 /* Rights identifiers might trigger tainting as well. */
3852 if (!will_taint && (rlen || rsz)) {
3853 while (rlen < rsz) {
3854 /* We didn't get all the identifiers on the first pass. Allocate a
3855 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3856 * were needed to hold all identifiers at time of last call; we'll
3857 * allocate that many unsigned long ints), and go back and get 'em.
3858 * If it gave us less than it wanted to despite ample buffer space,
3859 * something's broken. Is your system missing a system identifier?
3861 if (rsz <= jpilist[1].buflen) {
3862 /* Perl_croak accvios when used this early in startup. */
3863 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3864 rsz, (unsigned long) jpilist[1].buflen,
3865 "Check your rights database for corruption.\n");
3868 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3869 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3870 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3871 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3874 mask = jpilist[1].bufadr;
3875 /* Check attribute flags for each identifier (2nd longword); protected
3876 * subsystem identifiers trigger tainting.
3878 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3879 if (mask[i] & KGB$M_SUBSYSTEM) {
3884 if (mask != rlst) Safefree(mask);
3886 /* We need to use this hack to tell Perl it should run with tainting,
3887 * since its tainting flag may be part of the PL_curinterp struct, which
3888 * hasn't been allocated when vms_image_init() is called.
3892 New(1320,newap,*argcp+2,char **);
3893 newap[0] = argvp[0];
3895 Copy(argvp[1],newap[2],*argcp-1,char **);
3896 /* We orphan the old argv, since we don't know where it's come from,
3897 * so we don't know how to free it.
3899 *argcp++; argvp = newap;
3901 else { /* Did user explicitly request tainting? */
3903 char *cp, **av = *argvp;
3904 for (i = 1; i < *argcp; i++) {
3905 if (*av[i] != '-') break;
3906 for (cp = av[i]+1; *cp; cp++) {
3907 if (*cp == 'T') { will_taint = 1; break; }
3908 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
3909 strchr("DFIiMmx",*cp)) break;
3911 if (will_taint) break;
3916 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
3918 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
3919 else if (tabidx >= tabct) {
3921 Renew(tabvec,tabct,struct dsc$descriptor_s *);
3923 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
3924 tabvec[tabidx]->dsc$w_length = 0;
3925 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
3926 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
3927 tabvec[tabidx]->dsc$a_pointer = NULL;
3928 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
3930 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
3932 getredirection(argcp,argvp);
3933 #if defined(USE_THREADS) && defined(__DECC)
3935 # include <reentrancy.h>
3936 (void) decc$set_reentrancy(C$C_MULTITHREAD);
3945 * Trim Unix-style prefix off filespec, so it looks like what a shell
3946 * glob expansion would return (i.e. from specified prefix on, not
3947 * full path). Note that returned filespec is Unix-style, regardless
3948 * of whether input filespec was VMS-style or Unix-style.
3950 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
3951 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
3952 * vector of options; at present, only bit 0 is used, and if set tells
3953 * trim unixpath to try the current default directory as a prefix when
3954 * presented with a possibly ambiguous ... wildcard.
3956 * Returns !=0 on success, with trimmed filespec replacing contents of
3957 * fspec, and 0 on failure, with contents of fpsec unchanged.
3959 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
3961 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
3963 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
3964 *template, *base, *end, *cp1, *cp2;
3965 register int tmplen, reslen = 0, dirs = 0;
3967 if (!wildspec || !fspec) return 0;
3968 if (strpbrk(wildspec,"]>:") != NULL) {
3969 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
3970 else template = unixwild;
3972 else template = wildspec;
3973 if (strpbrk(fspec,"]>:") != NULL) {
3974 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
3975 else base = unixified;
3976 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
3977 * check to see that final result fits into (isn't longer than) fspec */
3978 reslen = strlen(fspec);
3982 /* No prefix or absolute path on wildcard, so nothing to remove */
3983 if (!*template || *template == '/') {
3984 if (base == fspec) return 1;
3985 tmplen = strlen(unixified);
3986 if (tmplen > reslen) return 0; /* not enough space */
3987 /* Copy unixified resultant, including trailing NUL */
3988 memmove(fspec,unixified,tmplen+1);
3992 for (end = base; *end; end++) ; /* Find end of resultant filespec */
3993 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3994 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3995 for (cp1 = end ;cp1 >= base; cp1--)
3996 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3998 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4002 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4003 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4004 int ells = 1, totells, segdirs, match;
4005 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4006 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4008 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4010 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4011 if (ellipsis == template && opts & 1) {
4012 /* Template begins with an ellipsis. Since we can't tell how many
4013 * directory names at the front of the resultant to keep for an
4014 * arbitrary starting point, we arbitrarily choose the current
4015 * default directory as a starting point. If it's there as a prefix,
4016 * clip it off. If not, fall through and act as if the leading
4017 * ellipsis weren't there (i.e. return shortest possible path that
4018 * could match template).
4020 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4021 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4022 if (_tolower(*cp1) != _tolower(*cp2)) break;
4023 segdirs = dirs - totells; /* Min # of dirs we must have left */
4024 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4025 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4026 memcpy(fspec,cp2+1,end - cp2);
4030 /* First off, back up over constant elements at end of path */
4032 for (front = end ; front >= base; front--)
4033 if (*front == '/' && !dirs--) { front++; break; }
4035 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4036 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4037 if (cp1 != '\0') return 0; /* Path too long. */
4039 *cp2 = '\0'; /* Pick up with memcpy later */
4040 lcfront = lcres + (front - base);
4041 /* Now skip over each ellipsis and try to match the path in front of it. */
4043 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4044 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4045 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4046 if (cp1 < template) break; /* template started with an ellipsis */
4047 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4048 ellipsis = cp1; continue;
4050 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4052 for (segdirs = 0, cp2 = tpl;
4053 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4055 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4056 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4057 if (*cp2 == '/') segdirs++;
4059 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4060 /* Back up at least as many dirs as in template before matching */
4061 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4062 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4063 for (match = 0; cp1 > lcres;) {
4064 resdsc.dsc$a_pointer = cp1;
4065 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4067 if (match == 1) lcfront = cp1;
4069 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4071 if (!match) return 0; /* Can't find prefix ??? */
4072 if (match > 1 && opts & 1) {
4073 /* This ... wildcard could cover more than one set of dirs (i.e.
4074 * a set of similar dir names is repeated). If the template
4075 * contains more than 1 ..., upstream elements could resolve the
4076 * ambiguity, but it's not worth a full backtracking setup here.
4077 * As a quick heuristic, clip off the current default directory
4078 * if it's present to find the trimmed spec, else use the
4079 * shortest string that this ... could cover.
4081 char def[NAM$C_MAXRSS+1], *st;
4083 if (getcwd(def, sizeof def,0) == NULL) return 0;
4084 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4085 if (_tolower(*cp1) != _tolower(*cp2)) break;
4086 segdirs = dirs - totells; /* Min # of dirs we must have left */
4087 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4088 if (*cp1 == '\0' && *cp2 == '/') {
4089 memcpy(fspec,cp2+1,end - cp2);
4092 /* Nope -- stick with lcfront from above and keep going. */
4095 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4100 } /* end of trim_unixpath() */
4105 * VMS readdir() routines.
4106 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4108 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4109 * Minor modifications to original routines.
4112 /* Number of elements in vms_versions array */
4113 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4116 * Open a directory, return a handle for later use.
4118 /*{{{ DIR *opendir(char*name) */
4120 Perl_opendir(pTHX_ char *name)
4123 char dir[NAM$C_MAXRSS+1];
4126 if (do_tovmspath(name,dir,0) == NULL) {
4129 if (flex_stat(dir,&sb) == -1) return NULL;
4130 if (!S_ISDIR(sb.st_mode)) {
4131 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4134 if (!cando_by_name(S_IRUSR,0,dir)) {
4135 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4138 /* Get memory for the handle, and the pattern. */
4140 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4142 /* Fill in the fields; mainly playing with the descriptor. */
4143 (void)sprintf(dd->pattern, "%s*.*",dir);
4146 dd->vms_wantversions = 0;
4147 dd->pat.dsc$a_pointer = dd->pattern;
4148 dd->pat.dsc$w_length = strlen(dd->pattern);
4149 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4150 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4153 } /* end of opendir() */
4157 * Set the flag to indicate we want versions or not.
4159 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4161 vmsreaddirversions(DIR *dd, int flag)
4163 dd->vms_wantversions = flag;
4168 * Free up an opened directory.
4170 /*{{{ void closedir(DIR *dd)*/
4174 (void)lib$find_file_end(&dd->context);
4175 Safefree(dd->pattern);
4176 Safefree((char *)dd);
4181 * Collect all the version numbers for the current file.
4187 struct dsc$descriptor_s pat;
4188 struct dsc$descriptor_s res;
4190 char *p, *text, buff[sizeof dd->entry.d_name];
4192 unsigned long context, tmpsts;
4195 /* Convenient shorthand. */
4198 /* Add the version wildcard, ignoring the "*.*" put on before */
4199 i = strlen(dd->pattern);
4200 New(1308,text,i + e->d_namlen + 3,char);
4201 (void)strcpy(text, dd->pattern);
4202 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4204 /* Set up the pattern descriptor. */
4205 pat.dsc$a_pointer = text;
4206 pat.dsc$w_length = i + e->d_namlen - 1;
4207 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4208 pat.dsc$b_class = DSC$K_CLASS_S;
4210 /* Set up result descriptor. */
4211 res.dsc$a_pointer = buff;
4212 res.dsc$w_length = sizeof buff - 2;
4213 res.dsc$b_dtype = DSC$K_DTYPE_T;
4214 res.dsc$b_class = DSC$K_CLASS_S;
4216 /* Read files, collecting versions. */
4217 for (context = 0, e->vms_verscount = 0;
4218 e->vms_verscount < VERSIZE(e);
4219 e->vms_verscount++) {
4220 tmpsts = lib$find_file(&pat, &res, &context);
4221 if (tmpsts == RMS$_NMF || context == 0) break;
4223 buff[sizeof buff - 1] = '\0';
4224 if ((p = strchr(buff, ';')))
4225 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4227 e->vms_versions[e->vms_verscount] = -1;
4230 _ckvmssts(lib$find_file_end(&context));
4233 } /* end of collectversions() */
4236 * Read the next entry from the directory.
4238 /*{{{ struct dirent *readdir(DIR *dd)*/
4242 struct dsc$descriptor_s res;
4243 char *p, buff[sizeof dd->entry.d_name];
4244 unsigned long int tmpsts;
4246 /* Set up result descriptor, and get next file. */
4247 res.dsc$a_pointer = buff;
4248 res.dsc$w_length = sizeof buff - 2;
4249 res.dsc$b_dtype = DSC$K_DTYPE_T;
4250 res.dsc$b_class = DSC$K_CLASS_S;
4251 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4252 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4253 if (!(tmpsts & 1)) {
4254 set_vaxc_errno(tmpsts);
4257 set_errno(EACCES); break;
4259 set_errno(ENODEV); break;
4261 set_errno(ENOTDIR); break;
4262 case RMS$_FNF: case RMS$_DNF:
4263 set_errno(ENOENT); break;
4270 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4271 buff[sizeof buff - 1] = '\0';
4272 for (p = buff; *p; p++) *p = _tolower(*p);
4273 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4276 /* Skip any directory component and just copy the name. */
4277 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4278 else (void)strcpy(dd->entry.d_name, buff);
4280 /* Clobber the version. */
4281 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4283 dd->entry.d_namlen = strlen(dd->entry.d_name);
4284 dd->entry.vms_verscount = 0;
4285 if (dd->vms_wantversions) collectversions(dd);
4288 } /* end of readdir() */
4292 * Return something that can be used in a seekdir later.
4294 /*{{{ long telldir(DIR *dd)*/
4303 * Return to a spot where we used to be. Brute force.
4305 /*{{{ void seekdir(DIR *dd,long count)*/
4307 seekdir(DIR *dd, long count)
4309 int vms_wantversions;
4312 /* If we haven't done anything yet... */
4316 /* Remember some state, and clear it. */
4317 vms_wantversions = dd->vms_wantversions;
4318 dd->vms_wantversions = 0;
4319 _ckvmssts(lib$find_file_end(&dd->context));
4322 /* The increment is in readdir(). */
4323 for (dd->count = 0; dd->count < count; )
4326 dd->vms_wantversions = vms_wantversions;
4328 } /* end of seekdir() */
4331 /* VMS subprocess management
4333 * my_vfork() - just a vfork(), after setting a flag to record that
4334 * the current script is trying a Unix-style fork/exec.
4336 * vms_do_aexec() and vms_do_exec() are called in response to the
4337 * perl 'exec' function. If this follows a vfork call, then they
4338 * call out the the regular perl routines in doio.c which do an
4339 * execvp (for those who really want to try this under VMS).
4340 * Otherwise, they do exactly what the perl docs say exec should
4341 * do - terminate the current script and invoke a new command
4342 * (See below for notes on command syntax.)
4344 * do_aspawn() and do_spawn() implement the VMS side of the perl
4345 * 'system' function.
4347 * Note on command arguments to perl 'exec' and 'system': When handled
4348 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4349 * are concatenated to form a DCL command string. If the first arg
4350 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4351 * the the command string is handed off to DCL directly. Otherwise,
4352 * the first token of the command is taken as the filespec of an image
4353 * to run. The filespec is expanded using a default type of '.EXE' and
4354 * the process defaults for device, directory, etc., and if found, the resultant
4355 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4356 * the command string as parameters. This is perhaps a bit complicated,
4357 * but I hope it will form a happy medium between what VMS folks expect
4358 * from lib$spawn and what Unix folks expect from exec.
4361 static int vfork_called;
4363 /*{{{int my_vfork()*/
4374 vms_execfree(pTHX) {
4376 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4379 if (VMScmd.dsc$a_pointer) {
4380 Safefree(VMScmd.dsc$a_pointer);
4381 VMScmd.dsc$w_length = 0;
4382 VMScmd.dsc$a_pointer = Nullch;
4387 setup_argstr(SV *really, SV **mark, SV **sp)
4390 char *junk, *tmps = Nullch;
4391 register size_t cmdlen = 0;
4398 tmps = SvPV(really,rlen);
4405 for (idx++; idx <= sp; idx++) {
4407 junk = SvPVx(*idx,rlen);
4408 cmdlen += rlen ? rlen + 1 : 0;
4411 New(401,PL_Cmd,cmdlen+1,char);
4413 if (tmps && *tmps) {
4414 strcpy(PL_Cmd,tmps);
4417 else *PL_Cmd = '\0';
4418 while (++mark <= sp) {
4420 char *s = SvPVx(*mark,n_a);
4422 if (*PL_Cmd) strcat(PL_Cmd," ");
4428 } /* end of setup_argstr() */
4431 static unsigned long int
4432 setup_cmddsc(char *cmd, int check_img)
4434 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4435 $DESCRIPTOR(defdsc,".EXE");
4436 $DESCRIPTOR(defdsc2,".");
4437 $DESCRIPTOR(resdsc,resspec);
4438 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4439 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4440 register char *s, *rest, *cp, *wordbreak;
4445 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4448 while (*s && isspace(*s)) s++;
4450 if (*s == '@' || *s == '$') {
4451 vmsspec[0] = *s; rest = s + 1;
4452 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4454 else { cp = vmsspec; rest = s; }
4455 if (*rest == '.' || *rest == '/') {
4458 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4459 rest++, cp2++) *cp2 = *rest;
4461 if (do_tovmsspec(resspec,cp,0)) {
4464 for (cp2 = vmsspec + strlen(vmsspec);
4465 *rest && cp2 - vmsspec < sizeof vmsspec;
4466 rest++, cp2++) *cp2 = *rest;
4471 /* Intuit whether verb (first word of cmd) is a DCL command:
4472 * - if first nonspace char is '@', it's a DCL indirection
4474 * - if verb contains a filespec separator, it's not a DCL command
4475 * - if it doesn't, caller tells us whether to default to a DCL
4476 * command, or to a local image unless told it's DCL (by leading '$')
4478 if (*s == '@') isdcl = 1;
4480 register char *filespec = strpbrk(s,":<[.;");
4481 rest = wordbreak = strpbrk(s," \"\t/");
4482 if (!wordbreak) wordbreak = s + strlen(s);
4483 if (*s == '$') check_img = 0;
4484 if (filespec && (filespec < wordbreak)) isdcl = 0;
4485 else isdcl = !check_img;
4489 imgdsc.dsc$a_pointer = s;
4490 imgdsc.dsc$w_length = wordbreak - s;
4491 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4493 _ckvmssts(lib$find_file_end(&cxt));
4494 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4495 if (!(retsts & 1) && *s == '$') {
4496 _ckvmssts(lib$find_file_end(&cxt));
4497 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4498 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4500 _ckvmssts(lib$find_file_end(&cxt));
4501 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4505 _ckvmssts(lib$find_file_end(&cxt));
4510 while (*s && !isspace(*s)) s++;
4513 /* check that it's really not DCL with no file extension */
4514 fp = fopen(resspec,"r","ctx=bin,shr=get");
4516 char b[4] = {0,0,0,0};
4517 read(fileno(fp),b,4);
4518 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4521 if (check_img && isdcl) return RMS$_FNF;
4523 if (cando_by_name(S_IXUSR,0,resspec)) {
4524 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4526 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4528 strcpy(VMScmd.dsc$a_pointer,"@");
4530 strcat(VMScmd.dsc$a_pointer,resspec);
4531 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4532 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4535 else retsts = RMS$_PRV;
4538 /* It's either a DCL command or we couldn't find a suitable image */
4539 VMScmd.dsc$w_length = strlen(cmd);
4540 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4541 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4542 if (!(retsts & 1)) {
4543 /* just hand off status values likely to be due to user error */
4544 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4545 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4546 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4547 else { _ckvmssts(retsts); }
4550 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4552 } /* end of setup_cmddsc() */
4555 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4557 vms_do_aexec(SV *really,SV **mark,SV **sp)
4561 if (vfork_called) { /* this follows a vfork - act Unixish */
4563 if (vfork_called < 0) {
4564 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4567 else return do_aexec(really,mark,sp);
4569 /* no vfork - act VMSish */
4570 return vms_do_exec(setup_argstr(really,mark,sp));
4575 } /* end of vms_do_aexec() */
4578 /* {{{bool vms_do_exec(char *cmd) */
4580 vms_do_exec(char *cmd)
4584 if (vfork_called) { /* this follows a vfork - act Unixish */
4586 if (vfork_called < 0) {
4587 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4590 else return do_exec(cmd);
4593 { /* no vfork - act VMSish */
4594 unsigned long int retsts;
4597 TAINT_PROPER("exec");
4598 if ((retsts = setup_cmddsc(cmd,1)) & 1)
4599 retsts = lib$do_command(&VMScmd);
4602 case RMS$_FNF: case RMS$_DNF:
4603 set_errno(ENOENT); break;
4605 set_errno(ENOTDIR); break;
4607 set_errno(ENODEV); break;
4609 set_errno(EACCES); break;
4611 set_errno(EINVAL); break;
4613 set_errno(E2BIG); break;
4614 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4615 _ckvmssts(retsts); /* fall through */
4616 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4619 set_vaxc_errno(retsts);
4620 if (ckWARN(WARN_EXEC)) {
4621 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4622 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4629 } /* end of vms_do_exec() */
4632 unsigned long int do_spawn(char *);
4634 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4636 do_aspawn(void *really,void **mark,void **sp)
4639 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
4642 } /* end of do_aspawn() */
4645 /* {{{unsigned long int do_spawn(char *cmd) */
4649 unsigned long int sts, substs, hadcmd = 1;
4653 TAINT_PROPER("spawn");
4654 if (!cmd || !*cmd) {
4656 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4658 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
4659 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4664 case RMS$_FNF: case RMS$_DNF:
4665 set_errno(ENOENT); break;
4667 set_errno(ENOTDIR); break;
4669 set_errno(ENODEV); break;
4671 set_errno(EACCES); break;
4673 set_errno(EINVAL); break;
4675 set_errno(E2BIG); break;
4676 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4677 _ckvmssts(sts); /* fall through */
4678 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4681 set_vaxc_errno(sts);
4682 if (ckWARN(WARN_EXEC)) {
4683 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4684 hadcmd ? VMScmd.dsc$w_length : 0,
4685 hadcmd ? VMScmd.dsc$a_pointer : "",
4692 } /* end of do_spawn() */
4696 * A simple fwrite replacement which outputs itmsz*nitm chars without
4697 * introducing record boundaries every itmsz chars.
4699 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4701 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4703 register char *cp, *end;
4705 end = (char *)src + itmsz * nitm;
4707 while ((char *)src <= end) {
4708 for (cp = src; cp <= end; cp++) if (!*cp) break;
4709 if (fputs(src,dest) == EOF) return EOF;
4711 if (fputc('\0',dest) == EOF) return EOF;
4717 } /* end of my_fwrite() */
4720 /*{{{ int my_flush(FILE *fp)*/
4725 if ((res = fflush(fp)) == 0 && fp) {
4726 #ifdef VMS_DO_SOCKETS
4728 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4730 res = fsync(fileno(fp));
4733 * If the flush succeeded but set end-of-file, we need to clear
4734 * the error because our caller may check ferror(). BTW, this
4735 * probably means we just flushed an empty file.
4737 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4744 * Here are replacements for the following Unix routines in the VMS environment:
4745 * getpwuid Get information for a particular UIC or UID
4746 * getpwnam Get information for a named user
4747 * getpwent Get information for each user in the rights database
4748 * setpwent Reset search to the start of the rights database
4749 * endpwent Finish searching for users in the rights database
4751 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4752 * (defined in pwd.h), which contains the following fields:-
4754 * char *pw_name; Username (in lower case)
4755 * char *pw_passwd; Hashed password
4756 * unsigned int pw_uid; UIC
4757 * unsigned int pw_gid; UIC group number
4758 * char *pw_unixdir; Default device/directory (VMS-style)
4759 * char *pw_gecos; Owner name
4760 * char *pw_dir; Default device/directory (Unix-style)
4761 * char *pw_shell; Default CLI name (eg. DCL)
4763 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4765 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4766 * not the UIC member number (eg. what's returned by getuid()),
4767 * getpwuid() can accept either as input (if uid is specified, the caller's
4768 * UIC group is used), though it won't recognise gid=0.
4770 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4771 * information about other users in your group or in other groups, respectively.
4772 * If the required privilege is not available, then these routines fill only
4773 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4776 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4779 /* sizes of various UAF record fields */
4780 #define UAI$S_USERNAME 12
4781 #define UAI$S_IDENT 31
4782 #define UAI$S_OWNER 31
4783 #define UAI$S_DEFDEV 31
4784 #define UAI$S_DEFDIR 63
4785 #define UAI$S_DEFCLI 31
4788 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4789 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4790 (uic).uic$v_group != UIC$K_WILD_GROUP)
4792 static char __empty[]= "";
4793 static struct passwd __passwd_empty=
4794 {(char *) __empty, (char *) __empty, 0, 0,
4795 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4796 static int contxt= 0;
4797 static struct passwd __pwdcache;
4798 static char __pw_namecache[UAI$S_IDENT+1];
4801 * This routine does most of the work extracting the user information.
4803 static int fillpasswd (const char *name, struct passwd *pwd)
4807 unsigned char length;
4808 char pw_gecos[UAI$S_OWNER+1];
4810 static union uicdef uic;
4812 unsigned char length;
4813 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4816 unsigned char length;
4817 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4820 unsigned char length;
4821 char pw_shell[UAI$S_DEFCLI+1];
4823 static char pw_passwd[UAI$S_PWD+1];
4825 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4826 struct dsc$descriptor_s name_desc;
4827 unsigned long int sts;
4829 static struct itmlst_3 itmlst[]= {
4830 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4831 {sizeof(uic), UAI$_UIC, &uic, &luic},
4832 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
4833 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
4834 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
4835 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
4836 {0, 0, NULL, NULL}};
4838 name_desc.dsc$w_length= strlen(name);
4839 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4840 name_desc.dsc$b_class= DSC$K_CLASS_S;
4841 name_desc.dsc$a_pointer= (char *) name;
4843 /* Note that sys$getuai returns many fields as counted strings. */
4844 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
4845 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
4846 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
4848 else { _ckvmssts(sts); }
4849 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
4851 if ((int) owner.length < lowner) lowner= (int) owner.length;
4852 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
4853 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
4854 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
4855 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
4856 owner.pw_gecos[lowner]= '\0';
4857 defdev.pw_dir[ldefdev+ldefdir]= '\0';
4858 defcli.pw_shell[ldefcli]= '\0';
4859 if (valid_uic(uic)) {
4860 pwd->pw_uid= uic.uic$l_uic;
4861 pwd->pw_gid= uic.uic$v_group;
4864 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
4865 pwd->pw_passwd= pw_passwd;
4866 pwd->pw_gecos= owner.pw_gecos;
4867 pwd->pw_dir= defdev.pw_dir;
4868 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
4869 pwd->pw_shell= defcli.pw_shell;
4870 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
4872 ldir= strlen(pwd->pw_unixdir) - 1;
4873 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
4876 strcpy(pwd->pw_unixdir, pwd->pw_dir);
4877 __mystrtolower(pwd->pw_unixdir);
4882 * Get information for a named user.
4884 /*{{{struct passwd *getpwnam(char *name)*/
4885 struct passwd *my_getpwnam(char *name)
4887 struct dsc$descriptor_s name_desc;
4889 unsigned long int status, sts;
4892 __pwdcache = __passwd_empty;
4893 if (!fillpasswd(name, &__pwdcache)) {
4894 /* We still may be able to determine pw_uid and pw_gid */
4895 name_desc.dsc$w_length= strlen(name);
4896 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
4897 name_desc.dsc$b_class= DSC$K_CLASS_S;
4898 name_desc.dsc$a_pointer= (char *) name;
4899 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
4900 __pwdcache.pw_uid= uic.uic$l_uic;
4901 __pwdcache.pw_gid= uic.uic$v_group;
4904 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
4905 set_vaxc_errno(sts);
4906 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
4909 else { _ckvmssts(sts); }
4912 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
4913 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
4914 __pwdcache.pw_name= __pw_namecache;
4916 } /* end of my_getpwnam() */
4920 * Get information for a particular UIC or UID.
4921 * Called by my_getpwent with uid=-1 to list all users.
4923 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
4924 struct passwd *my_getpwuid(Uid_t uid)
4926 const $DESCRIPTOR(name_desc,__pw_namecache);
4927 unsigned short lname;
4929 unsigned long int status;
4932 if (uid == (unsigned int) -1) {
4934 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
4935 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
4936 set_vaxc_errno(status);
4937 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4941 else { _ckvmssts(status); }
4942 } while (!valid_uic (uic));
4946 if (!uic.uic$v_group)
4947 uic.uic$v_group= PerlProc_getgid();
4949 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
4950 else status = SS$_IVIDENT;
4951 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
4952 status == RMS$_PRV) {
4953 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
4956 else { _ckvmssts(status); }
4958 __pw_namecache[lname]= '\0';
4959 __mystrtolower(__pw_namecache);
4961 __pwdcache = __passwd_empty;
4962 __pwdcache.pw_name = __pw_namecache;
4964 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
4965 The identifier's value is usually the UIC, but it doesn't have to be,
4966 so if we can, we let fillpasswd update this. */
4967 __pwdcache.pw_uid = uic.uic$l_uic;
4968 __pwdcache.pw_gid = uic.uic$v_group;
4970 fillpasswd(__pw_namecache, &__pwdcache);
4973 } /* end of my_getpwuid() */
4977 * Get information for next user.
4979 /*{{{struct passwd *my_getpwent()*/
4980 struct passwd *my_getpwent()
4982 return (my_getpwuid((unsigned int) -1));
4987 * Finish searching rights database for users.
4989 /*{{{void my_endpwent()*/
4994 _ckvmssts(sys$finish_rdb(&contxt));
5000 #ifdef HOMEGROWN_POSIX_SIGNALS
5001 /* Signal handling routines, pulled into the core from POSIX.xs.
5003 * We need these for threads, so they've been rolled into the core,
5004 * rather than left in POSIX.xs.
5006 * (DRS, Oct 23, 1997)
5009 /* sigset_t is atomic under VMS, so these routines are easy */
5010 /*{{{int my_sigemptyset(sigset_t *) */
5011 int my_sigemptyset(sigset_t *set) {
5012 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5018 /*{{{int my_sigfillset(sigset_t *)*/
5019 int my_sigfillset(sigset_t *set) {
5021 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5022 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5028 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5029 int my_sigaddset(sigset_t *set, int sig) {
5030 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5031 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5032 *set |= (1 << (sig - 1));
5038 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5039 int my_sigdelset(sigset_t *set, int sig) {
5040 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5041 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5042 *set &= ~(1 << (sig - 1));
5048 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5049 int my_sigismember(sigset_t *set, int sig) {
5050 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5051 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5052 *set & (1 << (sig - 1));
5057 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5058 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5061 /* If set and oset are both null, then things are badly wrong. Bail out. */
5062 if ((oset == NULL) && (set == NULL)) {
5063 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5067 /* If set's null, then we're just handling a fetch. */
5069 tempmask = sigblock(0);
5074 tempmask = sigsetmask(*set);
5077 tempmask = sigblock(*set);
5080 tempmask = sigblock(0);
5081 sigsetmask(*oset & ~tempmask);
5084 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5089 /* Did they pass us an oset? If so, stick our holding mask into it */
5096 #endif /* HOMEGROWN_POSIX_SIGNALS */
5099 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5100 * my_utime(), and flex_stat(), all of which operate on UTC unless
5101 * VMSISH_TIMES is true.
5103 /* method used to handle UTC conversions:
5104 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5106 static int gmtime_emulation_type;
5107 /* number of secs to add to UTC POSIX-style time to get local time */
5108 static long int utc_offset_secs;
5110 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5111 * in vmsish.h. #undef them here so we can call the CRTL routines
5118 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
5119 # define RTL_USES_UTC 1
5123 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5124 * qualifier with the extern prefix pragma. This provisional
5125 * hack circumvents this prefix pragma problem in previous
5128 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5129 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5130 # pragma __extern_prefix save
5131 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5132 # define gmtime decc$__utctz_gmtime
5133 # define localtime decc$__utctz_localtime
5134 # define time decc$__utc_time
5135 # pragma __extern_prefix restore
5137 struct tm *gmtime(), *localtime();
5143 static time_t toutc_dst(time_t loc) {
5146 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5147 loc -= utc_offset_secs;
5148 if (rsltmp->tm_isdst) loc -= 3600;
5151 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5152 ((gmtime_emulation_type || my_time(NULL)), \
5153 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5154 ((secs) - utc_offset_secs))))
5156 static time_t toloc_dst(time_t utc) {
5159 utc += utc_offset_secs;
5160 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5161 if (rsltmp->tm_isdst) utc += 3600;
5164 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5165 ((gmtime_emulation_type || my_time(NULL)), \
5166 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5167 ((secs) + utc_offset_secs))))
5170 /* my_time(), my_localtime(), my_gmtime()
5171 * By default traffic in UTC time values, using CRTL gmtime() or
5172 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5173 * Note: We need to use these functions even when the CRTL has working
5174 * UTC support, since they also handle C<use vmsish qw(times);>
5176 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5177 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5180 /*{{{time_t my_time(time_t *timep)*/
5181 time_t my_time(time_t *timep)
5187 if (gmtime_emulation_type == 0) {
5189 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5190 /* results of calls to gmtime() and localtime() */
5191 /* for same &base */
5193 gmtime_emulation_type++;
5194 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5195 char off[LNM$C_NAMLENGTH+1];;
5197 gmtime_emulation_type++;
5198 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5199 gmtime_emulation_type++;
5200 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5202 else { utc_offset_secs = atol(off); }
5204 else { /* We've got a working gmtime() */
5205 struct tm gmt, local;
5208 tm_p = localtime(&base);
5210 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5211 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5212 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5213 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5219 # ifdef RTL_USES_UTC
5220 if (VMSISH_TIME) when = _toloc(when);
5222 if (!VMSISH_TIME) when = _toutc(when);
5225 if (timep != NULL) *timep = when;
5228 } /* end of my_time() */
5232 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5234 my_gmtime(const time_t *timep)
5241 if (timep == NULL) {
5242 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5245 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5249 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5251 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5252 return gmtime(&when);
5254 /* CRTL localtime() wants local time as input, so does no tz correction */
5255 rsltmp = localtime(&when);
5256 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5259 } /* end of my_gmtime() */
5263 /*{{{struct tm *my_localtime(const time_t *timep)*/
5265 my_localtime(const time_t *timep)
5271 if (timep == NULL) {
5272 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5275 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5276 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5279 # ifdef RTL_USES_UTC
5281 if (VMSISH_TIME) when = _toutc(when);
5283 /* CRTL localtime() wants UTC as input, does tz correction itself */
5284 return localtime(&when);
5287 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
5290 /* CRTL localtime() wants local time as input, so does no tz correction */
5291 rsltmp = localtime(&when);
5292 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
5295 } /* end of my_localtime() */
5298 /* Reset definitions for later calls */
5299 #define gmtime(t) my_gmtime(t)
5300 #define localtime(t) my_localtime(t)
5301 #define time(t) my_time(t)
5304 /* my_utime - update modification time of a file
5305 * calling sequence is identical to POSIX utime(), but under
5306 * VMS only the modification time is changed; ODS-2 does not
5307 * maintain access times. Restrictions differ from the POSIX
5308 * definition in that the time can be changed as long as the
5309 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5310 * no separate checks are made to insure that the caller is the
5311 * owner of the file or has special privs enabled.
5312 * Code here is based on Joe Meadows' FILE utility.
5315 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5316 * to VMS epoch (01-JAN-1858 00:00:00.00)
5317 * in 100 ns intervals.
5319 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5321 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5322 int my_utime(char *file, struct utimbuf *utimes)
5326 long int bintime[2], len = 2, lowbit, unixtime,
5327 secscale = 10000000; /* seconds --> 100 ns intervals */
5328 unsigned long int chan, iosb[2], retsts;
5329 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5330 struct FAB myfab = cc$rms_fab;
5331 struct NAM mynam = cc$rms_nam;
5332 #if defined (__DECC) && defined (__VAX)
5333 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5334 * at least through VMS V6.1, which causes a type-conversion warning.
5336 # pragma message save
5337 # pragma message disable cvtdiftypes
5339 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5340 struct fibdef myfib;
5341 #if defined (__DECC) && defined (__VAX)
5342 /* This should be right after the declaration of myatr, but due
5343 * to a bug in VAX DEC C, this takes effect a statement early.
5345 # pragma message restore
5347 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5348 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5349 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5351 if (file == NULL || *file == '\0') {
5353 set_vaxc_errno(LIB$_INVARG);
5356 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5358 if (utimes != NULL) {
5359 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5360 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5361 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5362 * as input, we force the sign bit to be clear by shifting unixtime right
5363 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5365 lowbit = (utimes->modtime & 1) ? secscale : 0;
5366 unixtime = (long int) utimes->modtime;
5368 /* If input was UTC; convert to local for sys svc */
5369 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5371 unixtime >>= 1; secscale <<= 1;
5372 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5373 if (!(retsts & 1)) {
5375 set_vaxc_errno(retsts);
5378 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5379 if (!(retsts & 1)) {
5381 set_vaxc_errno(retsts);
5386 /* Just get the current time in VMS format directly */
5387 retsts = sys$gettim(bintime);
5388 if (!(retsts & 1)) {
5390 set_vaxc_errno(retsts);
5395 myfab.fab$l_fna = vmsspec;
5396 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5397 myfab.fab$l_nam = &mynam;
5398 mynam.nam$l_esa = esa;
5399 mynam.nam$b_ess = (unsigned char) sizeof esa;
5400 mynam.nam$l_rsa = rsa;
5401 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5403 /* Look for the file to be affected, letting RMS parse the file
5404 * specification for us as well. I have set errno using only
5405 * values documented in the utime() man page for VMS POSIX.
5407 retsts = sys$parse(&myfab,0,0);
5408 if (!(retsts & 1)) {
5409 set_vaxc_errno(retsts);
5410 if (retsts == RMS$_PRV) set_errno(EACCES);
5411 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5412 else set_errno(EVMSERR);
5415 retsts = sys$search(&myfab,0,0);
5416 if (!(retsts & 1)) {
5417 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5418 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5419 set_vaxc_errno(retsts);
5420 if (retsts == RMS$_PRV) set_errno(EACCES);
5421 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5422 else set_errno(EVMSERR);
5426 devdsc.dsc$w_length = mynam.nam$b_dev;
5427 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5429 retsts = sys$assign(&devdsc,&chan,0,0);
5430 if (!(retsts & 1)) {
5431 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5432 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5433 set_vaxc_errno(retsts);
5434 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5435 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5436 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5437 else set_errno(EVMSERR);
5441 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5442 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5444 memset((void *) &myfib, 0, sizeof myfib);
5446 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5447 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5448 /* This prevents the revision time of the file being reset to the current
5449 * time as a result of our IO$_MODIFY $QIO. */
5450 myfib.fib$l_acctl = FIB$M_NORECORD;
5452 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5453 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5454 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5456 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5457 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5458 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5459 _ckvmssts(sys$dassgn(chan));
5460 if (retsts & 1) retsts = iosb[0];
5461 if (!(retsts & 1)) {
5462 set_vaxc_errno(retsts);
5463 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5464 else set_errno(EVMSERR);
5469 } /* end of my_utime() */
5473 * flex_stat, flex_fstat
5474 * basic stat, but gets it right when asked to stat
5475 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5478 /* encode_dev packs a VMS device name string into an integer to allow
5479 * simple comparisons. This can be used, for example, to check whether two
5480 * files are located on the same device, by comparing their encoded device
5481 * names. Even a string comparison would not do, because stat() reuses the
5482 * device name buffer for each call; so without encode_dev, it would be
5483 * necessary to save the buffer and use strcmp (this would mean a number of
5484 * changes to the standard Perl code, to say nothing of what a Perl script
5487 * The device lock id, if it exists, should be unique (unless perhaps compared
5488 * with lock ids transferred from other nodes). We have a lock id if the disk is
5489 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5490 * device names. Thus we use the lock id in preference, and only if that isn't
5491 * available, do we try to pack the device name into an integer (flagged by
5492 * the sign bit (LOCKID_MASK) being set).
5494 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5495 * name and its encoded form, but it seems very unlikely that we will find
5496 * two files on different disks that share the same encoded device names,
5497 * and even more remote that they will share the same file id (if the test
5498 * is to check for the same file).
5500 * A better method might be to use sys$device_scan on the first call, and to
5501 * search for the device, returning an index into the cached array.
5502 * The number returned would be more intelligable.
5503 * This is probably not worth it, and anyway would take quite a bit longer
5504 * on the first call.
5506 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5507 static mydev_t encode_dev (const char *dev)
5510 unsigned long int f;
5516 if (!dev || !dev[0]) return 0;
5520 struct dsc$descriptor_s dev_desc;
5521 unsigned long int status, lockid, item = DVI$_LOCKID;
5523 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5524 can try that first. */
5525 dev_desc.dsc$w_length = strlen (dev);
5526 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5527 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5528 dev_desc.dsc$a_pointer = (char *) dev;
5529 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5530 if (lockid) return (lockid & ~LOCKID_MASK);
5534 /* Otherwise we try to encode the device name */
5538 for (q = dev + strlen(dev); q--; q >= dev) {
5541 else if (isalpha (toupper (*q)))
5542 c= toupper (*q) - 'A' + (char)10;
5544 continue; /* Skip '$'s */
5546 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5548 enc += f * (unsigned long int) c;
5550 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
5552 } /* end of encode_dev() */
5554 static char namecache[NAM$C_MAXRSS+1];
5557 is_null_device(name)
5561 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
5562 The underscore prefix, controller letter, and unit number are
5563 independently optional; for our purposes, the colon punctuation
5564 is not. The colon can be trailed by optional directory and/or
5565 filename, but two consecutive colons indicates a nodename rather
5566 than a device. [pr] */
5567 if (*name == '_') ++name;
5568 if (tolower(*name++) != 'n') return 0;
5569 if (tolower(*name++) != 'l') return 0;
5570 if (tolower(*name) == 'a') ++name;
5571 if (*name == '0') ++name;
5572 return (*name++ == ':') && (*name != ':');
5575 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
5576 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
5577 * subset of the applicable information.
5580 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
5582 char fname_phdev[NAM$C_MAXRSS+1];
5583 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
5585 char fname[NAM$C_MAXRSS+1];
5586 unsigned long int retsts;
5587 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5588 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5590 /* If the struct mystat is stale, we're OOL; stat() overwrites the
5591 device name on successive calls */
5592 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
5593 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
5594 namdsc.dsc$a_pointer = fname;
5595 namdsc.dsc$w_length = sizeof fname - 1;
5597 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
5598 &namdsc,&namdsc.dsc$w_length,0,0);
5600 fname[namdsc.dsc$w_length] = '\0';
5602 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
5603 * but if someone has redefined that logical, Perl gets very lost. Since
5604 * we have the physical device name from the stat buffer, just paste it on.
5606 strcpy( fname_phdev, statbufp->st_devnam );
5607 strcat( fname_phdev, strrchr(fname, ':') );
5609 return cando_by_name(bit,effective,fname_phdev);
5611 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5612 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
5616 return FALSE; /* Should never get to here */
5618 } /* end of cando() */
5622 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
5624 cando_by_name(I32 bit, Uid_t effective, char *fname)
5626 static char usrname[L_cuserid];
5627 static struct dsc$descriptor_s usrdsc =
5628 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
5629 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
5630 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
5631 unsigned short int retlen;
5633 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5634 union prvdef curprv;
5635 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
5636 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
5637 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
5640 if (!fname || !*fname) return FALSE;
5641 /* Make sure we expand logical names, since sys$check_access doesn't */
5642 if (!strpbrk(fname,"/]>:")) {
5643 strcpy(fileified,fname);
5644 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
5647 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
5648 retlen = namdsc.dsc$w_length = strlen(vmsname);
5649 namdsc.dsc$a_pointer = vmsname;
5650 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
5651 vmsname[retlen-1] == ':') {
5652 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
5653 namdsc.dsc$w_length = strlen(fileified);
5654 namdsc.dsc$a_pointer = fileified;
5657 if (!usrdsc.dsc$w_length) {
5659 usrdsc.dsc$w_length = strlen(usrname);
5663 case S_IXUSR: case S_IXGRP: case S_IXOTH:
5664 access = ARM$M_EXECUTE; break;
5665 case S_IRUSR: case S_IRGRP: case S_IROTH:
5666 access = ARM$M_READ; break;
5667 case S_IWUSR: case S_IWGRP: case S_IWOTH:
5668 access = ARM$M_WRITE; break;
5669 case S_IDUSR: case S_IDGRP: case S_IDOTH:
5670 access = ARM$M_DELETE; break;
5675 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
5676 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
5677 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
5678 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
5679 set_vaxc_errno(retsts);
5680 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5681 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
5682 else set_errno(ENOENT);
5685 if (retsts == SS$_NORMAL) {
5686 if (!privused) return TRUE;
5687 /* We can get access, but only by using privs. Do we have the
5688 necessary privs currently enabled? */
5689 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
5690 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
5691 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
5692 !curprv.prv$v_bypass) return FALSE;
5693 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
5694 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
5695 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
5698 if (retsts == SS$_ACCONFLICT) {
5703 return FALSE; /* Should never get here */
5705 } /* end of cando_by_name() */
5709 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
5711 flex_fstat(int fd, Stat_t *statbufp)
5714 if (!fstat(fd,(stat_t *) statbufp)) {
5715 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
5716 statbufp->st_dev = encode_dev(statbufp->st_devnam);
5717 # ifdef RTL_USES_UTC
5720 statbufp->st_mtime = _toloc(statbufp->st_mtime);
5721 statbufp->st_atime = _toloc(statbufp->st_atime);
5722 statbufp->st_ctime = _toloc(statbufp->st_ctime);
5727 if (!VMSISH_TIME) { /* Return UTC instead of local time */
5731 statbufp->st_mtime = _toutc(statbufp->st_mtime);
5732 statbufp->st_atime = _toutc(statbufp->st_atime);
5733 statbufp->st_ctime = _toutc(statbufp->st_ctime);
5740 } /* end of flex_fstat() */
5743 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
5745 flex_stat(const char *fspec, Stat_t *statbufp)
5748 char fileified[NAM$C_MAXRSS+1];
5749 char temp_fspec[NAM$C_MAXRSS+300];
5752 strcpy(temp_fspec, fspec);
5753 if (statbufp == (Stat_t *) &PL_statcache)
5754 do_tovmsspec(temp_fspec,namecache,0);
5755 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
5756 memset(statbufp,0,sizeof *statbufp);
5757 statbufp->st_dev = encode_dev("_NLA0:");
5758 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
5759 statbufp->st_uid = 0x00010001;
5760 statbufp->st_gid = 0x0001;
5761 time((time_t *)&statbufp->st_mtime);
5762 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
5766 /* Try for a directory name first. If fspec contains a filename without
5767 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
5768 * and sea:[wine.dark]water. exist, we prefer the directory here.
5769 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
5770 * not sea:[wine.dark]., if the latter exists. If the intended target is
5771 * the file with null type, specify this by calling flex_stat() with
5772 * a '.' at the end of fspec.
5774 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
5775 retval = stat(fileified,(stat_t *) statbufp);
5776 if (!retval && statbufp == (Stat_t *) &PL_statcache)
5777 strcpy(namecache,fileified);
5779 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
5781 statbufp->st_dev = encode_dev(statbufp->st_devnam);
5782 # ifdef RTL_USES_UTC
5785 statbufp->st_mtime = _toloc(statbufp->st_mtime);
5786 statbufp->st_atime = _toloc(statbufp->st_atime);
5787 statbufp->st_ctime = _toloc(statbufp->st_ctime);
5792 if (!VMSISH_TIME) { /* Return UTC instead of local time */
5796 statbufp->st_mtime = _toutc(statbufp->st_mtime);
5797 statbufp->st_atime = _toutc(statbufp->st_atime);
5798 statbufp->st_ctime = _toutc(statbufp->st_ctime);
5804 } /* end of flex_stat() */
5808 /*{{{char *my_getlogin()*/
5809 /* VMS cuserid == Unix getlogin, except calling sequence */
5813 static char user[L_cuserid];
5814 return cuserid(user);
5819 /* rmscopy - copy a file using VMS RMS routines
5821 * Copies contents and attributes of spec_in to spec_out, except owner
5822 * and protection information. Name and type of spec_in are used as
5823 * defaults for spec_out. The third parameter specifies whether rmscopy()
5824 * should try to propagate timestamps from the input file to the output file.
5825 * If it is less than 0, no timestamps are preserved. If it is 0, then
5826 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
5827 * propagated to the output file at creation iff the output file specification
5828 * did not contain an explicit name or type, and the revision date is always
5829 * updated at the end of the copy operation. If it is greater than 0, then
5830 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
5831 * other than the revision date should be propagated, and bit 1 indicates
5832 * that the revision date should be propagated.
5834 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
5836 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
5837 * Incorporates, with permission, some code from EZCOPY by Tim Adye
5838 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
5839 * as part of the Perl standard distribution under the terms of the
5840 * GNU General Public License or the Perl Artistic License. Copies
5841 * of each may be found in the Perl standard distribution.
5843 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
5845 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
5847 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
5848 rsa[NAM$C_MAXRSS], ubf[32256];
5849 unsigned long int i, sts, sts2;
5850 struct FAB fab_in, fab_out;
5851 struct RAB rab_in, rab_out;
5853 struct XABDAT xabdat;
5854 struct XABFHC xabfhc;
5855 struct XABRDT xabrdt;
5856 struct XABSUM xabsum;
5858 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
5859 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
5860 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5864 fab_in = cc$rms_fab;
5865 fab_in.fab$l_fna = vmsin;
5866 fab_in.fab$b_fns = strlen(vmsin);
5867 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
5868 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
5869 fab_in.fab$l_fop = FAB$M_SQO;
5870 fab_in.fab$l_nam = &nam;
5871 fab_in.fab$l_xab = (void *) &xabdat;
5874 nam.nam$l_rsa = rsa;
5875 nam.nam$b_rss = sizeof(rsa);
5876 nam.nam$l_esa = esa;
5877 nam.nam$b_ess = sizeof (esa);
5878 nam.nam$b_esl = nam.nam$b_rsl = 0;
5880 xabdat = cc$rms_xabdat; /* To get creation date */
5881 xabdat.xab$l_nxt = (void *) &xabfhc;
5883 xabfhc = cc$rms_xabfhc; /* To get record length */
5884 xabfhc.xab$l_nxt = (void *) &xabsum;
5886 xabsum = cc$rms_xabsum; /* To get key and area information */
5888 if (!((sts = sys$open(&fab_in)) & 1)) {
5889 set_vaxc_errno(sts);
5891 case RMS$_FNF: case RMS$_DNF:
5892 set_errno(ENOENT); break;
5894 set_errno(ENOTDIR); break;
5896 set_errno(ENODEV); break;
5898 set_errno(EINVAL); break;
5900 set_errno(EACCES); break;
5908 fab_out.fab$w_ifi = 0;
5909 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
5910 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
5911 fab_out.fab$l_fop = FAB$M_SQO;
5912 fab_out.fab$l_fna = vmsout;
5913 fab_out.fab$b_fns = strlen(vmsout);
5914 fab_out.fab$l_dna = nam.nam$l_name;
5915 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
5917 if (preserve_dates == 0) { /* Act like DCL COPY */
5918 nam.nam$b_nop = NAM$M_SYNCHK;
5919 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
5920 if (!((sts = sys$parse(&fab_out)) & 1)) {
5921 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
5922 set_vaxc_errno(sts);
5925 fab_out.fab$l_xab = (void *) &xabdat;
5926 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
5928 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
5929 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
5930 preserve_dates =0; /* bitmask from this point forward */
5932 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
5933 if (!((sts = sys$create(&fab_out)) & 1)) {
5934 set_vaxc_errno(sts);
5937 set_errno(ENOENT); break;
5939 set_errno(ENOTDIR); break;
5941 set_errno(ENODEV); break;
5943 set_errno(EINVAL); break;
5945 set_errno(EACCES); break;
5951 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
5952 if (preserve_dates & 2) {
5953 /* sys$close() will process xabrdt, not xabdat */
5954 xabrdt = cc$rms_xabrdt;
5956 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
5958 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
5959 * is unsigned long[2], while DECC & VAXC use a struct */
5960 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
5962 fab_out.fab$l_xab = (void *) &xabrdt;
5965 rab_in = cc$rms_rab;
5966 rab_in.rab$l_fab = &fab_in;
5967 rab_in.rab$l_rop = RAB$M_BIO;
5968 rab_in.rab$l_ubf = ubf;
5969 rab_in.rab$w_usz = sizeof ubf;
5970 if (!((sts = sys$connect(&rab_in)) & 1)) {
5971 sys$close(&fab_in); sys$close(&fab_out);
5972 set_errno(EVMSERR); set_vaxc_errno(sts);
5976 rab_out = cc$rms_rab;
5977 rab_out.rab$l_fab = &fab_out;
5978 rab_out.rab$l_rbf = ubf;
5979 if (!((sts = sys$connect(&rab_out)) & 1)) {
5980 sys$close(&fab_in); sys$close(&fab_out);
5981 set_errno(EVMSERR); set_vaxc_errno(sts);
5985 while ((sts = sys$read(&rab_in))) { /* always true */
5986 if (sts == RMS$_EOF) break;
5987 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
5988 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
5989 sys$close(&fab_in); sys$close(&fab_out);
5990 set_errno(EVMSERR); set_vaxc_errno(sts);
5995 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
5996 sys$close(&fab_in); sys$close(&fab_out);
5997 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
5999 set_errno(EVMSERR); set_vaxc_errno(sts);
6005 } /* end of rmscopy() */
6009 /*** The following glue provides 'hooks' to make some of the routines
6010 * from this file available from Perl. These routines are sufficiently
6011 * basic, and are required sufficiently early in the build process,
6012 * that's it's nice to have them available to miniperl as well as the
6013 * full Perl, so they're set up here instead of in an extension. The
6014 * Perl code which handles importation of these names into a given
6015 * package lives in [.VMS]Filespec.pm in @INC.
6019 rmsexpand_fromperl(pTHX_ CV *cv)
6022 char *fspec, *defspec = NULL, *rslt;
6025 if (!items || items > 2)
6026 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6027 fspec = SvPV(ST(0),n_a);
6028 if (!fspec || !*fspec) XSRETURN_UNDEF;
6029 if (items == 2) defspec = SvPV(ST(1),n_a);
6031 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6032 ST(0) = sv_newmortal();
6033 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6038 vmsify_fromperl(pTHX_ CV *cv)
6044 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6045 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6046 ST(0) = sv_newmortal();
6047 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6052 unixify_fromperl(pTHX_ CV *cv)
6058 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6059 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6060 ST(0) = sv_newmortal();
6061 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6066 fileify_fromperl(pTHX_ CV *cv)
6072 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6073 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6074 ST(0) = sv_newmortal();
6075 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6080 pathify_fromperl(pTHX_ CV *cv)
6086 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6087 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6088 ST(0) = sv_newmortal();
6089 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6094 vmspath_fromperl(pTHX_ CV *cv)
6100 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6101 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6102 ST(0) = sv_newmortal();
6103 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6108 unixpath_fromperl(pTHX_ CV *cv)
6114 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6115 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6116 ST(0) = sv_newmortal();
6117 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6122 candelete_fromperl(pTHX_ CV *cv)
6125 char fspec[NAM$C_MAXRSS+1], *fsp;
6130 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6132 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6133 if (SvTYPE(mysv) == SVt_PVGV) {
6134 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6135 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6142 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6143 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6149 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6154 rmscopy_fromperl(pTHX_ CV *cv)
6157 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6159 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6160 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6161 unsigned long int sts;
6166 if (items < 2 || items > 3)
6167 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6169 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6170 if (SvTYPE(mysv) == SVt_PVGV) {
6171 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6172 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6179 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6180 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6185 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6186 if (SvTYPE(mysv) == SVt_PVGV) {
6187 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6188 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6195 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6196 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6201 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6203 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6212 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6213 workbuff[NAM$C_MAXRSS*1 + 1];
6214 int total_namelen = 3, counter, num_entries;
6215 /* ODS-5 ups this, but we want to be consistent, so... */
6216 int max_name_len = 39;
6217 AV *in_array = (AV *)SvRV(ST(0));
6219 num_entries = av_len(in_array);
6221 /* All the names start with PL_. */
6222 strcpy(ultimate_name, "PL_");
6224 /* Clean up our working buffer */
6225 Zero(work_name, sizeof(work_name), char);
6227 /* Run through the entries and build up a working name */
6228 for(counter = 0; counter <= num_entries; counter++) {
6229 /* If it's not the first name then tack on a __ */
6231 strcat(work_name, "__");
6233 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6237 /* Check to see if we actually have to bother...*/
6238 if (strlen(work_name) + 3 <= max_name_len) {
6239 strcat(ultimate_name, work_name);
6241 /* It's too darned big, so we need to go strip. We use the same */
6242 /* algorithm as xsubpp does. First, strip out doubled __ */
6243 char *source, *dest, last;
6246 for (source = work_name; *source; source++) {
6247 if (last == *source && last == '_') {
6253 /* Go put it back */
6254 strcpy(work_name, workbuff);
6255 /* Is it still too big? */
6256 if (strlen(work_name) + 3 > max_name_len) {
6257 /* Strip duplicate letters */
6260 for (source = work_name; *source; source++) {
6261 if (last == toupper(*source)) {
6265 last = toupper(*source);
6267 strcpy(work_name, workbuff);
6270 /* Is it *still* too big? */
6271 if (strlen(work_name) + 3 > max_name_len) {
6272 /* Too bad, we truncate */
6273 work_name[max_name_len - 2] = 0;
6275 strcat(ultimate_name, work_name);
6278 /* Okay, return it */
6279 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6286 char* file = __FILE__;
6288 char temp_buff[512];
6289 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6290 no_translate_barewords = TRUE;
6292 no_translate_barewords = FALSE;
6295 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6296 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6297 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6298 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6299 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6300 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6301 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6302 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6303 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6304 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);