This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PerlIO for VMS
[perl5.git] / vms / vms.c
1 /* vms.c
2  *
3  * VMS-specific routines for perl5
4  * Version: 5.7.0
5  *
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
10  */
11
12 #include <acedef.h>
13 #include <acldef.h>
14 #include <armdef.h>
15 #include <atrdef.h>
16 #include <chpdef.h>
17 #include <clidef.h>
18 #include <climsgdef.h>
19 #include <descrip.h>
20 #include <devdef.h>
21 #include <dvidef.h>
22 #include <fibdef.h>
23 #include <float.h>
24 #include <fscndef.h>
25 #include <iodef.h>
26 #include <jpidef.h>
27 #include <kgbdef.h>
28 #include <libclidef.h>
29 #include <libdef.h>
30 #include <lib$routines.h>
31 #include <lnmdef.h>
32 #include <prvdef.h>
33 #include <psldef.h>
34 #include <rms.h>
35 #include <shrdef.h>
36 #include <ssdef.h>
37 #include <starlet.h>
38 #include <strdef.h>
39 #include <str$routines.h>
40 #include <syidef.h>
41 #include <uaidef.h>
42 #include <uicdef.h>
43
44 /* Older versions of ssdef.h don't have these */
45 #ifndef SS$_INVFILFOROP
46 #  define SS$_INVFILFOROP 3930
47 #endif
48 #ifndef SS$_NOSUCHOBJECT
49 #  define SS$_NOSUCHOBJECT 2696
50 #endif
51
52 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
53 #define PERLIO_NOT_STDIO 0 
54
55 /* Don't replace system definitions of vfork, getenv, and stat, 
56  * code below needs to get to the underlying CRTL routines. */
57 #define DONT_MASK_RTL_CALLS
58 #include "EXTERN.h"
59 #include "perl.h"
60 #include "XSUB.h"
61 /* Anticipating future expansion in lexical warnings . . . */
62 #ifndef WARN_INTERNAL
63 #  define WARN_INTERNAL WARN_MISC
64 #endif
65
66 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
67 #  define RTL_USES_UTC 1
68 #endif
69
70
71 /* gcc's header files don't #define direct access macros
72  * corresponding to VAXC's variant structs */
73 #ifdef __GNUC__
74 #  define uic$v_format uic$r_uic_form.uic$v_format
75 #  define uic$v_group uic$r_uic_form.uic$v_group
76 #  define uic$v_member uic$r_uic_form.uic$v_member
77 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
78 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
79 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
80 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
81 #endif
82
83 #if defined(NEED_AN_H_ERRNO)
84 dEXT int h_errno;
85 #endif
86
87 struct itmlst_3 {
88   unsigned short int buflen;
89   unsigned short int itmcode;
90   void *bufadr;
91   unsigned short int *retlen;
92 };
93
94 #define do_fileify_dirspec(a,b,c)       mp_do_fileify_dirspec(aTHX_ a,b,c)
95 #define do_pathify_dirspec(a,b,c)       mp_do_pathify_dirspec(aTHX_ a,b,c)
96 #define do_tovmsspec(a,b,c)             mp_do_tovmsspec(aTHX_ a,b,c)
97 #define do_tovmspath(a,b,c)             mp_do_tovmspath(aTHX_ a,b,c)
98 #define do_rmsexpand(a,b,c,d,e)         mp_do_rmsexpand(aTHX_ a,b,c,d,e)
99 #define do_tounixspec(a,b,c)            mp_do_tounixspec(aTHX_ a,b,c)
100 #define do_tounixpath(a,b,c)            mp_do_tounixpath(aTHX_ a,b,c)
101 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
102 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
103
104 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
105 #define PERL_LNM_MAX_ALLOWED_INDEX 127
106
107 static char *__mystrtolower(char *str)
108 {
109   if (str) for (; *str; ++str) *str= tolower(*str);
110   return str;
111 }
112
113 static struct dsc$descriptor_s fildevdsc = 
114   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
115 static struct dsc$descriptor_s crtlenvdsc = 
116   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
117 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
118 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
119 static struct dsc$descriptor_s **env_tables = defenv;
120 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
121
122 /* True if we shouldn't treat barewords as logicals during directory */
123 /* munching */ 
124 static int no_translate_barewords;
125
126 /* Temp for subprocess commands */
127 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
128
129 #ifndef RTL_USES_UTC
130 static int tz_updated = 1;
131 #endif
132
133 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
134 int
135 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
136   struct dsc$descriptor_s **tabvec, unsigned long int flags)
137 {
138     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
139     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
140     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
141     unsigned char acmode;
142     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
143                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
144     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
145                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
146                                  {0, 0, 0, 0}};
147     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
148 #if defined(PERL_IMPLICIT_CONTEXT)
149     pTHX = NULL;
150 #  if defined(USE_5005THREADS)
151     /* We jump through these hoops because we can be called at */
152     /* platform-specific initialization time, which is before anything is */
153     /* set up--we can't even do a plain dTHX since that relies on the */
154     /* interpreter structure to be initialized */
155     if (PL_curinterp) {
156       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
157     } else {
158       aTHX = NULL;
159     }
160 # else
161     if (PL_curinterp) {
162       aTHX = PERL_GET_INTERP;
163     } else {
164       aTHX = NULL;
165     }
166
167 #  endif
168 #endif
169
170     if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
171       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
172     }
173     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
174       *cp2 = _toupper(*cp1);
175       if (cp1 - lnm > LNM$C_NAMLENGTH) {
176         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
177         return 0;
178       }
179     }
180     lnmdsc.dsc$w_length = cp1 - lnm;
181     lnmdsc.dsc$a_pointer = uplnm;
182     uplnm[lnmdsc.dsc$w_length] = '\0';
183     secure = flags & PERL__TRNENV_SECURE;
184     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
185     if (!tabvec || !*tabvec) tabvec = env_tables;
186
187     for (curtab = 0; tabvec[curtab]; curtab++) {
188       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
189         if (!ivenv && !secure) {
190           char *eq, *end;
191           int i;
192           if (!environ) {
193             ivenv = 1; 
194             Perl_warn(aTHX_ "Can't read CRTL environ\n");
195             continue;
196           }
197           retsts = SS$_NOLOGNAM;
198           for (i = 0; environ[i]; i++) { 
199             if ((eq = strchr(environ[i],'=')) && 
200                 !strncmp(environ[i],uplnm,eq - environ[i])) {
201               eq++;
202               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
203               if (!eqvlen) continue;
204               retsts = SS$_NORMAL;
205               break;
206             }
207           }
208           if (retsts != SS$_NOLOGNAM) break;
209         }
210       }
211       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
212                !str$case_blind_compare(&tmpdsc,&clisym)) {
213         if (!ivsym && !secure) {
214           unsigned short int deflen = LNM$C_NAMLENGTH;
215           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
216           /* dynamic dsc to accomodate possible long value */
217           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
218           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
219           if (retsts & 1) { 
220             if (eqvlen > 1024) {
221               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
222               eqvlen = 1024;
223               /* Special hack--we might be called before the interpreter's */
224               /* fully initialized, in which case either thr or PL_curcop */
225               /* might be bogus. We have to check, since ckWARN needs them */
226               /* both to be valid if running threaded */
227 #if defined(USE_THREADS)
228               if (thr && PL_curcop) {
229 #endif
230                 if (ckWARN(WARN_MISC)) {
231                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
232                 }
233 #if defined(USE_THREADS)
234               } else {
235                   Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
236               }
237 #endif
238               
239             }
240             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
241           }
242           _ckvmssts(lib$sfree1_dd(&eqvdsc));
243           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
244           if (retsts == LIB$_NOSUCHSYM) continue;
245           break;
246         }
247       }
248       else if (!ivlnm) {
249         retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
250         if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
251         if (retsts == SS$_NOLOGNAM) continue;
252         /* PPFs have a prefix */
253         if (
254 #if INTSIZE == 4
255              *((int *)uplnm) == *((int *)"SYS$")                    &&
256 #endif
257              eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
258              ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
259                (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
260                (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
261                (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
262           memcpy(eqv,eqv+4,eqvlen-4);
263           eqvlen -= 4;
264         }
265         break;
266       }
267     }
268     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
269     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
270              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
271              retsts == SS$_NOLOGNAM) {
272       set_errno(EINVAL);  set_vaxc_errno(retsts);
273     }
274     else _ckvmssts(retsts);
275     return 0;
276 }  /* end of vmstrnenv */
277 /*}}}*/
278
279 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
280 /* Define as a function so we can access statics. */
281 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
282 {
283   return vmstrnenv(lnm,eqv,idx,fildev,                                   
284 #ifdef SECURE_INTERNAL_GETENV
285                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
286 #else
287                    0
288 #endif
289                                                                               );
290 }
291 /*}}}*/
292
293 /* my_getenv
294  * Note: Uses Perl temp to store result so char * can be returned to
295  * caller; this pointer will be invalidated at next Perl statement
296  * transition.
297  * We define this as a function rather than a macro in terms of my_getenv_len()
298  * so that it'll work when PL_curinterp is undefined (and we therefore can't
299  * allocate SVs).
300  */
301 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
302 char *
303 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
304 {
305     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
306     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
307     unsigned long int idx = 0;
308     int trnsuccess, success, secure, saverr, savvmserr;
309     SV *tmpsv;
310
311     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
312       /* Set up a temporary buffer for the return value; Perl will
313        * clean it up at the next statement transition */
314       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
315       if (!tmpsv) return NULL;
316       eqv = SvPVX(tmpsv);
317     }
318     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
319     for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
320     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
321       getcwd(eqv,LNM$C_NAMLENGTH);
322       return eqv;
323     }
324     else {
325       if ((cp2 = strchr(lnm,';')) != NULL) {
326         strcpy(uplnm,lnm);
327         uplnm[cp2-lnm] = '\0';
328         idx = strtoul(cp2+1,NULL,0);
329         lnm = uplnm;
330       }
331       /* Impose security constraints only if tainting */
332       if (sys) {
333         /* Impose security constraints only if tainting */
334         secure = PL_curinterp ? PL_tainting : will_taint;
335         saverr = errno;  savvmserr = vaxc$errno;
336       }
337       else secure = 0;
338       success = vmstrnenv(lnm,eqv,idx,
339                           secure ? fildev : NULL,
340 #ifdef SECURE_INTERNAL_GETENV
341                           secure ? PERL__TRNENV_SECURE : 0
342 #else
343                           0
344 #endif
345                                                              );
346       /* Discard NOLOGNAM on internal calls since we're often looking
347        * for an optional name, and this "error" often shows up as the
348        * (bogus) exit status for a die() call later on.  */
349       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
350       return success ? eqv : Nullch;
351     }
352
353 }  /* end of my_getenv() */
354 /*}}}*/
355
356
357 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
358 char *
359 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
360 {
361     char *buf, *cp1, *cp2;
362     unsigned long idx = 0;
363     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
364     int secure, saverr, savvmserr;
365     SV *tmpsv;
366     
367     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
368       /* Set up a temporary buffer for the return value; Perl will
369        * clean it up at the next statement transition */
370       tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
371       if (!tmpsv) return NULL;
372       buf = SvPVX(tmpsv);
373     }
374     else buf = __my_getenv_len_eqv;  /* Assume no interpreter ==> single thread */
375     for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
376     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
377       getcwd(buf,LNM$C_NAMLENGTH);
378       *len = strlen(buf);
379       return buf;
380     }
381     else {
382       if ((cp2 = strchr(lnm,';')) != NULL) {
383         strcpy(buf,lnm);
384         buf[cp2-lnm] = '\0';
385         idx = strtoul(cp2+1,NULL,0);
386         lnm = buf;
387       }
388       if (sys) {
389         /* Impose security constraints only if tainting */
390         secure = PL_curinterp ? PL_tainting : will_taint;
391         saverr = errno;  savvmserr = vaxc$errno;
392       }
393       else secure = 0;
394       *len = vmstrnenv(lnm,buf,idx,
395                        secure ? fildev : NULL,
396 #ifdef SECURE_INTERNAL_GETENV
397                        secure ? PERL__TRNENV_SECURE : 0
398 #else
399                                                       0
400 #endif
401                                                        );
402       /* Discard NOLOGNAM on internal calls since we're often looking
403        * for an optional name, and this "error" often shows up as the
404        * (bogus) exit status for a die() call later on.  */
405       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
406       return *len ? buf : Nullch;
407     }
408
409 }  /* end of my_getenv_len() */
410 /*}}}*/
411
412 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
413
414 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
415
416 /*{{{ void prime_env_iter() */
417 void
418 prime_env_iter(void)
419 /* Fill the %ENV associative array with all logical names we can
420  * find, in preparation for iterating over it.
421  */
422 {
423   static int primed = 0;
424   HV *seenhv = NULL, *envhv;
425   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
426   unsigned short int chan;
427 #ifndef CLI$M_TRUSTED
428 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
429 #endif
430   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
431   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
432   long int i;
433   bool have_sym = FALSE, have_lnm = FALSE;
434   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
435   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
436   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
437   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
438   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 
439 #if defined(PERL_IMPLICIT_CONTEXT)
440   pTHX;
441 #endif
442 #if defined(USE_THREADS) || defined(USE_ITHREADS)
443   static perl_mutex primenv_mutex;
444   MUTEX_INIT(&primenv_mutex);
445 #endif
446
447 #if defined(PERL_IMPLICIT_CONTEXT)
448     /* We jump through these hoops because we can be called at */
449     /* platform-specific initialization time, which is before anything is */
450     /* set up--we can't even do a plain dTHX since that relies on the */
451     /* interpreter structure to be initialized */
452 #if defined(USE_5005THREADS)
453     if (PL_curinterp) {
454       aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
455     } else {
456       aTHX = NULL;
457     }
458 #else
459     if (PL_curinterp) {
460       aTHX = PERL_GET_INTERP;
461     } else {
462       aTHX = NULL;
463     }
464 #endif
465 #endif
466
467   if (primed || !PL_envgv) return;
468   MUTEX_LOCK(&primenv_mutex);
469   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
470   envhv = GvHVn(PL_envgv);
471   /* Perform a dummy fetch as an lval to insure that the hash table is
472    * set up.  Otherwise, the hv_store() will turn into a nullop. */
473   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
474
475   for (i = 0; env_tables[i]; i++) {
476      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
477          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
478      if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
479   }
480   if (have_sym || have_lnm) {
481     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
482     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
483     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
484     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
485   }
486
487   for (i--; i >= 0; i--) {
488     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
489       char *start;
490       int j;
491       for (j = 0; environ[j]; j++) { 
492         if (!(start = strchr(environ[j],'='))) {
493           if (ckWARN(WARN_INTERNAL)) 
494             Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
495         }
496         else {
497           start++;
498           (void) hv_store(envhv,environ[j],start - environ[j] - 1,
499                           newSVpv(start,0),0);
500         }
501       }
502       continue;
503     }
504     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
505              !str$case_blind_compare(&tmpdsc,&clisym)) {
506       strcpy(cmd,"Show Symbol/Global *");
507       cmddsc.dsc$w_length = 20;
508       if (env_tables[i]->dsc$w_length == 12 &&
509           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
510           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
511       flags = defflags | CLI$M_NOLOGNAM;
512     }
513     else {
514       strcpy(cmd,"Show Logical *");
515       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
516         strcat(cmd," /Table=");
517         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
518         cmddsc.dsc$w_length = strlen(cmd);
519       }
520       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
521       flags = defflags | CLI$M_NOCLISYM;
522     }
523     
524     /* Create a new subprocess to execute each command, to exclude the
525      * remote possibility that someone could subvert a mbx or file used
526      * to write multiple commands to a single subprocess.
527      */
528     do {
529       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
530                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
531       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
532       defflags &= ~CLI$M_TRUSTED;
533     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
534     _ckvmssts(retsts);
535     if (!buf) New(1322,buf,mbxbufsiz + 1,char);
536     if (seenhv) SvREFCNT_dec(seenhv);
537     seenhv = newHV();
538     while (1) {
539       char *cp1, *cp2, *key;
540       unsigned long int sts, iosb[2], retlen, keylen;
541       register U32 hash;
542
543       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
544       if (sts & 1) sts = iosb[0] & 0xffff;
545       if (sts == SS$_ENDOFFILE) {
546         int wakect = 0;
547         while (substs == 0) { sys$hiber(); wakect++;}
548         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
549         _ckvmssts(substs);
550         break;
551       }
552       _ckvmssts(sts);
553       retlen = iosb[0] >> 16;      
554       if (!retlen) continue;  /* blank line */
555       buf[retlen] = '\0';
556       if (iosb[1] != subpid) {
557         if (iosb[1]) {
558           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
559         }
560         continue;
561       }
562       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
563         Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
564
565       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
566       if (*cp1 == '(' || /* Logical name table name */
567           *cp1 == '='    /* Next eqv of searchlist  */) continue;
568       if (*cp1 == '"') cp1++;
569       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
570       key = cp1;  keylen = cp2 - cp1;
571       if (keylen && hv_exists(seenhv,key,keylen)) continue;
572       while (*cp2 && *cp2 != '=') cp2++;
573       while (*cp2 && *cp2 == '=') cp2++;
574       while (*cp2 && *cp2 == ' ') cp2++;
575       if (*cp2 == '"') {  /* String translation; may embed "" */
576         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
577         cp2++;  cp1--; /* Skip "" surrounding translation */
578       }
579       else {  /* Numeric translation */
580         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
581         cp1--;  /* stop on last non-space char */
582       }
583       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
584         Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
585         continue;
586       }
587       PERL_HASH(hash,key,keylen);
588       hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
589       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
590     }
591     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
592       /* get the PPFs for this process, not the subprocess */
593       char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
594       char eqv[LNM$C_NAMLENGTH+1];
595       int trnlen, i;
596       for (i = 0; ppfs[i]; i++) {
597         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
598         hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
599       }
600     }
601   }
602   primed = 1;
603   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
604   if (buf) Safefree(buf);
605   if (seenhv) SvREFCNT_dec(seenhv);
606   MUTEX_UNLOCK(&primenv_mutex);
607   return;
608
609 }  /* end of prime_env_iter */
610 /*}}}*/
611
612
613 /*{{{ int  vmssetenv(char *lnm, char *eqv)*/
614 /* Define or delete an element in the same "environment" as
615  * vmstrnenv().  If an element is to be deleted, it's removed from
616  * the first place it's found.  If it's to be set, it's set in the
617  * place designated by the first element of the table vector.
618  * Like setenv() returns 0 for success, non-zero on error.
619  */
620 int
621 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
622 {
623     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
624     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
625     unsigned long int retsts, usermode = PSL$C_USER;
626     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
627                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
628                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
629     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
630     $DESCRIPTOR(local,"_LOCAL");
631
632     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
633       *cp2 = _toupper(*cp1);
634       if (cp1 - lnm > LNM$C_NAMLENGTH) {
635         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
636         return SS$_IVLOGNAM;
637       }
638     }
639     lnmdsc.dsc$w_length = cp1 - lnm;
640     if (!tabvec || !*tabvec) tabvec = env_tables;
641
642     if (!eqv) {  /* we're deleting n element */
643       for (curtab = 0; tabvec[curtab]; curtab++) {
644         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
645         int i;
646           for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
647             if ((cp1 = strchr(environ[i],'=')) && 
648                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
649 #ifdef HAS_SETENV
650               return setenv(lnm,"",1) ? vaxc$errno : 0;
651             }
652           }
653           ivenv = 1; retsts = SS$_NOLOGNAM;
654 #else
655               if (ckWARN(WARN_INTERNAL))
656                 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
657               ivenv = 1; retsts = SS$_NOSUCHPGM;
658               break;
659             }
660           }
661 #endif
662         }
663         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
664                  !str$case_blind_compare(&tmpdsc,&clisym)) {
665           unsigned int symtype;
666           if (tabvec[curtab]->dsc$w_length == 12 &&
667               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
668               !str$case_blind_compare(&tmpdsc,&local)) 
669             symtype = LIB$K_CLI_LOCAL_SYM;
670           else symtype = LIB$K_CLI_GLOBAL_SYM;
671           retsts = lib$delete_symbol(&lnmdsc,&symtype);
672           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
673           if (retsts == LIB$_NOSUCHSYM) continue;
674           break;
675         }
676         else if (!ivlnm) {
677           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
678           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
679           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
680           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
681           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
682         }
683       }
684     }
685     else {  /* we're defining a value */
686       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
687 #ifdef HAS_SETENV
688         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
689 #else
690         if (ckWARN(WARN_INTERNAL))
691           Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
692         retsts = SS$_NOSUCHPGM;
693 #endif
694       }
695       else {
696         eqvdsc.dsc$a_pointer = eqv;
697         eqvdsc.dsc$w_length  = strlen(eqv);
698         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
699             !str$case_blind_compare(&tmpdsc,&clisym)) {
700           unsigned int symtype;
701           if (tabvec[0]->dsc$w_length == 12 &&
702               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
703                !str$case_blind_compare(&tmpdsc,&local)) 
704             symtype = LIB$K_CLI_LOCAL_SYM;
705           else symtype = LIB$K_CLI_GLOBAL_SYM;
706           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
707         }
708         else {
709           if (!*eqv) eqvdsc.dsc$w_length = 1;
710           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
711             eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
712             if (ckWARN(WARN_MISC)) {
713               Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
714             }
715           }
716           retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
717         }
718       }
719     }
720     if (!(retsts & 1)) {
721       switch (retsts) {
722         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
723         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
724           set_errno(EVMSERR); break;
725         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: 
726         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
727           set_errno(EINVAL); break;
728         case SS$_NOPRIV:
729           set_errno(EACCES);
730         default:
731           _ckvmssts(retsts);
732           set_errno(EVMSERR);
733        }
734        set_vaxc_errno(retsts);
735        return (int) retsts || 44; /* retsts should never be 0, but just in case */
736     }
737     else {
738       /* We reset error values on success because Perl does an hv_fetch()
739        * before each hv_store(), and if the thing we're setting didn't
740        * previously exist, we've got a leftover error message.  (Of course,
741        * this fails in the face of
742        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
743        * in that the error reported in $! isn't spurious, 
744        * but it's right more often than not.)
745        */
746       set_errno(0); set_vaxc_errno(retsts);
747       return 0;
748     }
749
750 }  /* end of vmssetenv() */
751 /*}}}*/
752
753 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
754 /* This has to be a function since there's a prototype for it in proto.h */
755 void
756 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
757 {
758     if (lnm && *lnm) {
759       int len = strlen(lnm);
760       if  (len == 7) {
761         char uplnm[8];
762         int i;
763         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
764         if (!strcmp(uplnm,"DEFAULT")) {
765           if (eqv && *eqv) chdir(eqv);
766           return;
767         }
768     } 
769 #ifndef RTL_USES_UTC
770     if (len == 6 || len == 2) {
771       char uplnm[7];
772       int i;
773       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
774       uplnm[len] = '\0';
775       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
776       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
777     }
778 #endif
779   }
780   (void) vmssetenv(lnm,eqv,NULL);
781 }
782 /*}}}*/
783
784 /*{{{static void vmssetuserlnm(char *name, char *eqv);
785 /*  vmssetuserlnm
786  *  sets a user-mode logical in the process logical name table
787  *  used for redirection of sys$error
788  */
789 void
790 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
791 {
792     $DESCRIPTOR(d_tab, "LNM$PROCESS");
793     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
794     unsigned long int iss, attr = LNM$M_CONFINE;
795     unsigned char acmode = PSL$C_USER;
796     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
797                                  {0, 0, 0, 0}};
798     d_name.dsc$a_pointer = name;
799     d_name.dsc$w_length = strlen(name);
800
801     lnmlst[0].buflen = strlen(eqv);
802     lnmlst[0].bufadr = eqv;
803
804     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
805     if (!(iss&1)) lib$signal(iss);
806 }
807 /*}}}*/
808
809
810 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
811 /* my_crypt - VMS password hashing
812  * my_crypt() provides an interface compatible with the Unix crypt()
813  * C library function, and uses sys$hash_password() to perform VMS
814  * password hashing.  The quadword hashed password value is returned
815  * as a NUL-terminated 8 character string.  my_crypt() does not change
816  * the case of its string arguments; in order to match the behavior
817  * of LOGINOUT et al., alphabetic characters in both arguments must
818  *  be upcased by the caller.
819  */
820 char *
821 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
822 {
823 #   ifndef UAI$C_PREFERRED_ALGORITHM
824 #     define UAI$C_PREFERRED_ALGORITHM 127
825 #   endif
826     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
827     unsigned short int salt = 0;
828     unsigned long int sts;
829     struct const_dsc {
830         unsigned short int dsc$w_length;
831         unsigned char      dsc$b_type;
832         unsigned char      dsc$b_class;
833         const char *       dsc$a_pointer;
834     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
835        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
836     struct itmlst_3 uailst[3] = {
837         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
838         { sizeof salt, UAI$_SALT,    &salt, 0},
839         { 0,           0,            NULL,  NULL}};
840     static char hash[9];
841
842     usrdsc.dsc$w_length = strlen(usrname);
843     usrdsc.dsc$a_pointer = usrname;
844     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
845       switch (sts) {
846         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
847           set_errno(EACCES);
848           break;
849         case RMS$_RNF:
850           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
851           break;
852         default:
853           set_errno(EVMSERR);
854       }
855       set_vaxc_errno(sts);
856       if (sts != RMS$_RNF) return NULL;
857     }
858
859     txtdsc.dsc$w_length = strlen(textpasswd);
860     txtdsc.dsc$a_pointer = textpasswd;
861     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
862       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
863     }
864
865     return (char *) hash;
866
867 }  /* end of my_crypt() */
868 /*}}}*/
869
870
871 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
872 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
873 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
874
875 /*{{{int do_rmdir(char *name)*/
876 int
877 Perl_do_rmdir(pTHX_ char *name)
878 {
879     char dirfile[NAM$C_MAXRSS+1];
880     int retval;
881     Stat_t st;
882
883     if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
884     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
885     else retval = kill_file(dirfile);
886     return retval;
887
888 }  /* end of do_rmdir */
889 /*}}}*/
890
891 /* kill_file
892  * Delete any file to which user has control access, regardless of whether
893  * delete access is explicitly allowed.
894  * Limitations: User must have write access to parent directory.
895  *              Does not block signals or ASTs; if interrupted in midstream
896  *              may leave file with an altered ACL.
897  * HANDLE WITH CARE!
898  */
899 /*{{{int kill_file(char *name)*/
900 int
901 Perl_kill_file(pTHX_ char *name)
902 {
903     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
904     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
905     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
906     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
907     struct myacedef {
908       unsigned char myace$b_length;
909       unsigned char myace$b_type;
910       unsigned short int myace$w_flags;
911       unsigned long int myace$l_access;
912       unsigned long int myace$l_ident;
913     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
914                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
915       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
916      struct itmlst_3
917        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
918                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
919        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
920        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
921        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
922        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
923       
924     /* Expand the input spec using RMS, since the CRTL remove() and
925      * system services won't do this by themselves, so we may miss
926      * a file "hiding" behind a logical name or search list. */
927     if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
928     if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
929     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
930     /* If not, can changing protections help? */
931     if (vaxc$errno != RMS$_PRV) return -1;
932
933     /* No, so we get our own UIC to use as a rights identifier,
934      * and the insert an ACE at the head of the ACL which allows us
935      * to delete the file.
936      */
937     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
938     fildsc.dsc$w_length = strlen(rspec);
939     fildsc.dsc$a_pointer = rspec;
940     cxt = 0;
941     newace.myace$l_ident = oldace.myace$l_ident;
942     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
943       switch (aclsts) {
944         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
945           set_errno(ENOENT); break;
946         case RMS$_DIR:
947           set_errno(ENOTDIR); break;
948         case RMS$_DEV:
949           set_errno(ENODEV); break;
950         case RMS$_SYN: case SS$_INVFILFOROP:
951           set_errno(EINVAL); break;
952         case RMS$_PRV:
953           set_errno(EACCES); break;
954         default:
955           _ckvmssts(aclsts);
956       }
957       set_vaxc_errno(aclsts);
958       return -1;
959     }
960     /* Grab any existing ACEs with this identifier in case we fail */
961     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
962     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
963                     || fndsts == SS$_NOMOREACE ) {
964       /* Add the new ACE . . . */
965       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
966         goto yourroom;
967       if ((rmsts = remove(name))) {
968         /* We blew it - dir with files in it, no write priv for
969          * parent directory, etc.  Put things back the way they were. */
970         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
971           goto yourroom;
972         if (fndsts & 1) {
973           addlst[0].bufadr = &oldace;
974           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
975             goto yourroom;
976         }
977       }
978     }
979
980     yourroom:
981     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
982     /* We just deleted it, so of course it's not there.  Some versions of
983      * VMS seem to return success on the unlock operation anyhow (after all
984      * the unlock is successful), but others don't.
985      */
986     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
987     if (aclsts & 1) aclsts = fndsts;
988     if (!(aclsts & 1)) {
989       set_errno(EVMSERR);
990       set_vaxc_errno(aclsts);
991       return -1;
992     }
993
994     return rmsts;
995
996 }  /* end of kill_file() */
997 /*}}}*/
998
999
1000 /*{{{int my_mkdir(char *,Mode_t)*/
1001 int
1002 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1003 {
1004   STRLEN dirlen = strlen(dir);
1005
1006   /* zero length string sometimes gives ACCVIO */
1007   if (dirlen == 0) return -1;
1008
1009   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1010    * null file name/type.  However, it's commonplace under Unix,
1011    * so we'll allow it for a gain in portability.
1012    */
1013   if (dir[dirlen-1] == '/') {
1014     char *newdir = savepvn(dir,dirlen-1);
1015     int ret = mkdir(newdir,mode);
1016     Safefree(newdir);
1017     return ret;
1018   }
1019   else return mkdir(dir,mode);
1020 }  /* end of my_mkdir */
1021 /*}}}*/
1022
1023 /*{{{int my_chdir(char *)*/
1024 int
1025 Perl_my_chdir(pTHX_ char *dir)
1026 {
1027   STRLEN dirlen = strlen(dir);
1028
1029   /* zero length string sometimes gives ACCVIO */
1030   if (dirlen == 0) return -1;
1031
1032   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1033    * that implies
1034    * null file name/type.  However, it's commonplace under Unix,
1035    * so we'll allow it for a gain in portability.
1036    */
1037   if (dir[dirlen-1] == '/') {
1038     char *newdir = savepvn(dir,dirlen-1);
1039     int ret = chdir(newdir);
1040     Safefree(newdir);
1041     return ret;
1042   }
1043   else return chdir(dir);
1044 }  /* end of my_chdir */
1045 /*}}}*/
1046
1047
1048 /*{{{FILE *my_tmpfile()*/
1049 FILE *
1050 my_tmpfile(void)
1051 {
1052   FILE *fp;
1053   char *cp;
1054
1055   if ((fp = tmpfile())) return fp;
1056
1057   New(1323,cp,L_tmpnam+24,char);
1058   strcpy(cp,"Sys$Scratch:");
1059   tmpnam(cp+strlen(cp));
1060   strcat(cp,".Perltmp");
1061   fp = fopen(cp,"w+","fop=dlt");
1062   Safefree(cp);
1063   return fp;
1064 }
1065 /*}}}*/
1066
1067 /* default piping mailbox size */
1068 #define PERL_BUFSIZ        512
1069
1070
1071 static void
1072 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1073 {
1074   unsigned long int mbxbufsiz;
1075   static unsigned long int syssize = 0;
1076   unsigned long int dviitm = DVI$_DEVNAM;
1077   char csize[LNM$C_NAMLENGTH+1];
1078   
1079   if (!syssize) {
1080     unsigned long syiitm = SYI$_MAXBUF;
1081     /*
1082      * Get the SYSGEN parameter MAXBUF
1083      *
1084      * If the logical 'PERL_MBX_SIZE' is defined
1085      * use the value of the logical instead of PERL_BUFSIZ, but 
1086      * keep the size between 128 and MAXBUF.
1087      *
1088      */
1089     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1090   }
1091
1092   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1093       mbxbufsiz = atoi(csize);
1094   } else {
1095       mbxbufsiz = PERL_BUFSIZ;
1096   }
1097   if (mbxbufsiz < 128) mbxbufsiz = 128;
1098   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1099
1100   _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1101
1102   _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1103   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1104
1105 }  /* end of create_mbx() */
1106
1107
1108 /*{{{  my_popen and my_pclose*/
1109
1110 typedef struct _iosb           IOSB;
1111 typedef struct _iosb*         pIOSB;
1112 typedef struct _pipe           Pipe;
1113 typedef struct _pipe*         pPipe;
1114 typedef struct pipe_details    Info;
1115 typedef struct pipe_details*  pInfo;
1116 typedef struct _srqp            RQE;
1117 typedef struct _srqp*          pRQE;
1118 typedef struct _tochildbuf      CBuf;
1119 typedef struct _tochildbuf*    pCBuf;
1120
1121 struct _iosb {
1122     unsigned short status;
1123     unsigned short count;
1124     unsigned long  dvispec;
1125 };
1126
1127 #pragma member_alignment save
1128 #pragma nomember_alignment quadword
1129 struct _srqp {          /* VMS self-relative queue entry */
1130     unsigned long qptr[2];
1131 };
1132 #pragma member_alignment restore
1133 static RQE  RQE_ZERO = {0,0};
1134
1135 struct _tochildbuf {
1136     RQE             q;
1137     int             eof;
1138     unsigned short  size;
1139     char            *buf;
1140 };
1141
1142 struct _pipe {
1143     RQE            free;
1144     RQE            wait;
1145     int            fd_out;
1146     unsigned short chan_in;
1147     unsigned short chan_out;
1148     char          *buf;
1149     unsigned int   bufsize;
1150     IOSB           iosb;
1151     IOSB           iosb2;
1152     int           *pipe_done;
1153     int            retry;
1154     int            type;
1155     int            shut_on_empty;
1156     int            need_wake;
1157     pPipe         *home;
1158     pInfo          info;
1159     pCBuf          curr;
1160     pCBuf          curr2;
1161 #if defined(PERL_IMPLICIT_CONTEXT)
1162     void            *thx;           /* Either a thread or an interpreter */
1163                                     /* pointer, depending on how we're built */
1164 #endif
1165 };
1166
1167
1168 struct pipe_details
1169 {
1170     pInfo           next;
1171     PerlIO *fp;  /* stdio file pointer to pipe mailbox */
1172     int pid;   /* PID of subprocess */
1173     int mode;  /* == 'r' if pipe open for reading */
1174     int done;  /* subprocess has completed */
1175     int             closing;        /* my_pclose is closing this pipe */
1176     unsigned long   completion;     /* termination status of subprocess */
1177     pPipe           in;             /* pipe in to sub */
1178     pPipe           out;            /* pipe out of sub */
1179     pPipe           err;            /* pipe of sub's sys$error */
1180     int             in_done;        /* true when in pipe finished */
1181     int             out_done;
1182     int             err_done;
1183 };
1184
1185 struct exit_control_block
1186 {
1187     struct exit_control_block *flink;
1188     unsigned long int   (*exit_routine)();
1189     unsigned long int arg_count;
1190     unsigned long int *status_address;
1191     unsigned long int exit_status;
1192 }; 
1193
1194 #define RETRY_DELAY     "0 ::0.20"
1195 #define MAX_RETRY              50
1196
1197 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
1198 static unsigned long mypid;
1199 static unsigned long delaytime[2];
1200
1201 static pInfo open_pipes = NULL;
1202 static $DESCRIPTOR(nl_desc, "NL:");
1203
1204
1205 static unsigned long int
1206 pipe_exit_routine(pTHX)
1207 {
1208     pInfo info;
1209     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1210     int sts, did_stuff, need_eof;
1211
1212     /* 
1213      first we try sending an EOF...ignore if doesn't work, make sure we
1214      don't hang
1215     */
1216     did_stuff = 0;
1217     info = open_pipes;
1218
1219     while (info) {
1220       int need_eof;
1221       _ckvmssts(sys$setast(0));
1222       if (info->in && !info->in->shut_on_empty) {
1223         _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1224                           0, 0, 0, 0, 0, 0));
1225         did_stuff = 1;
1226       }
1227       _ckvmssts(sys$setast(1));
1228       info = info->next;
1229     }
1230     if (did_stuff) sleep(1);   /* wait for EOF to have an effect */
1231
1232     did_stuff = 0;
1233     info = open_pipes;
1234     while (info) {
1235       _ckvmssts(sys$setast(0));
1236       if (!info->done) { /* Tap them gently on the shoulder . . .*/
1237         sts = sys$forcex(&info->pid,0,&abort);
1238         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
1239         did_stuff = 1;
1240       }
1241       _ckvmssts(sys$setast(1));
1242       info = info->next;
1243     }
1244     if (did_stuff) sleep(1);    /* wait for them to respond */
1245
1246     info = open_pipes;
1247     while (info) {
1248       _ckvmssts(sys$setast(0));
1249       if (!info->done) {  /* We tried to be nice . . . */
1250         sts = sys$delprc(&info->pid,0);
1251         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); 
1252       }
1253       _ckvmssts(sys$setast(1));
1254       info = info->next;
1255     }
1256
1257     while(open_pipes) {
1258       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1259       else if (!(sts & 1)) retsts = sts;
1260     }
1261     return retsts;
1262 }
1263
1264 static struct exit_control_block pipe_exitblock = 
1265        {(struct exit_control_block *) 0,
1266         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1267
1268 static void pipe_mbxtofd_ast(pPipe p);
1269 static void pipe_tochild1_ast(pPipe p);
1270 static void pipe_tochild2_ast(pPipe p);
1271
1272 static void
1273 popen_completion_ast(pInfo info)
1274 {
1275   pInfo i = open_pipes;
1276   int iss;
1277
1278   while (i) {
1279     if (i == info) break;
1280     i = i->next;
1281   }
1282   if (!i) return;       /* unlinked, probably freed too */
1283
1284   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1285   info->done = TRUE;
1286
1287 /*
1288     Writing to subprocess ...
1289             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1290
1291             chan_out may be waiting for "done" flag, or hung waiting
1292             for i/o completion to child...cancel the i/o.  This will
1293             put it into "snarf mode" (done but no EOF yet) that discards
1294             input.
1295
1296     Output from subprocess (stdout, stderr) needs to be flushed and
1297     shut down.   We try sending an EOF, but if the mbx is full the pipe
1298     routine should still catch the "shut_on_empty" flag, telling it to
1299     use immediate-style reads so that "mbx empty" -> EOF.
1300
1301
1302 */
1303   if (info->in && !info->in_done) {               /* only for mode=w */
1304         if (info->in->shut_on_empty && info->in->need_wake) {
1305             info->in->need_wake = FALSE;
1306             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1307         } else {
1308             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1309         }
1310   }
1311
1312   if (info->out && !info->out_done) {             /* were we also piping output? */
1313       info->out->shut_on_empty = TRUE;
1314       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1315       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1316       _ckvmssts_noperl(iss);
1317   }
1318
1319   if (info->err && !info->err_done) {        /* we were piping stderr */
1320         info->err->shut_on_empty = TRUE;
1321         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1322         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1323         _ckvmssts_noperl(iss);
1324   }
1325   _ckvmssts_noperl(sys$setef(pipe_ef));
1326
1327 }
1328
1329 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1330 static void vms_execfree(pTHX);
1331
1332 /*
1333     we actually differ from vmstrnenv since we use this to
1334     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1335     are pointing to the same thing
1336 */
1337
1338 static unsigned short
1339 popen_translate(pTHX_ char *logical, char *result)
1340 {
1341     int iss;
1342     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1343     $DESCRIPTOR(d_log,"");
1344     struct _il3 {
1345         unsigned short length;
1346         unsigned short code;
1347         char *         buffer_addr;
1348         unsigned short *retlenaddr;
1349     } itmlst[2];
1350     unsigned short l, ifi;
1351
1352     d_log.dsc$a_pointer = logical;
1353     d_log.dsc$w_length  = strlen(logical);
1354
1355     itmlst[0].code = LNM$_STRING;
1356     itmlst[0].length = 255;
1357     itmlst[0].buffer_addr = result;
1358     itmlst[0].retlenaddr = &l;
1359
1360     itmlst[1].code = 0;
1361     itmlst[1].length = 0;
1362     itmlst[1].buffer_addr = 0;
1363     itmlst[1].retlenaddr = 0;
1364
1365     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1366     if (iss == SS$_NOLOGNAM) {
1367         iss = SS$_NORMAL;
1368         l = 0;
1369     }
1370     if (!(iss&1)) lib$signal(iss);
1371     result[l] = '\0';
1372 /*
1373     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
1374     strip it off and return the ifi, if any
1375 */
1376     ifi  = 0;
1377     if (result[0] == 0x1b && result[1] == 0x00) {
1378         memcpy(&ifi,result+2,2);
1379         strcpy(result,result+4);
1380     }
1381     return ifi;     /* this is the RMS internal file id */
1382 }
1383
1384 #define MAX_DCL_SYMBOL        255
1385 static void pipe_infromchild_ast(pPipe p);
1386
1387 /*
1388     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1389     inside an AST routine without worrying about reentrancy and which Perl
1390     memory allocator is being used.
1391
1392     We read data and queue up the buffers, then spit them out one at a
1393     time to the output mailbox when the output mailbox is ready for one.
1394
1395 */
1396 #define INITIAL_TOCHILDQUEUE  2
1397
1398 static pPipe
1399 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1400 {
1401     pPipe p;
1402     pCBuf b;
1403     char mbx1[64], mbx2[64];
1404     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1405                                       DSC$K_CLASS_S, mbx1},
1406                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1407                                       DSC$K_CLASS_S, mbx2};
1408     unsigned int dviitm = DVI$_DEVBUFSIZ;
1409     int j, n;
1410
1411     New(1368, p, 1, Pipe);
1412
1413     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1414     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1415     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1416
1417     p->buf           = 0;
1418     p->shut_on_empty = FALSE;
1419     p->need_wake     = FALSE;
1420     p->type          = 0;
1421     p->retry         = 0;
1422     p->iosb.status   = SS$_NORMAL;
1423     p->iosb2.status  = SS$_NORMAL;
1424     p->free          = RQE_ZERO;
1425     p->wait          = RQE_ZERO;
1426     p->curr          = 0;
1427     p->curr2         = 0;
1428     p->info          = 0;
1429 #ifdef PERL_IMPLICIT_CONTEXT
1430     p->thx           = aTHX;
1431 #endif
1432
1433     n = sizeof(CBuf) + p->bufsize;
1434
1435     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1436         _ckvmssts(lib$get_vm(&n, &b));
1437         b->buf = (char *) b + sizeof(CBuf);
1438         _ckvmssts(lib$insqhi(b, &p->free));
1439     }
1440
1441     pipe_tochild2_ast(p);
1442     pipe_tochild1_ast(p);
1443     strcpy(wmbx, mbx1);
1444     strcpy(rmbx, mbx2);
1445     return p;
1446 }
1447
1448 /*  reads the MBX Perl is writing, and queues */
1449
1450 static void
1451 pipe_tochild1_ast(pPipe p)
1452 {
1453     pCBuf b = p->curr;
1454     int iss = p->iosb.status;
1455     int eof = (iss == SS$_ENDOFFILE);
1456 #ifdef PERL_IMPLICIT_CONTEXT
1457     pTHX = p->thx;
1458 #endif
1459
1460     if (p->retry) {
1461         if (eof) {
1462             p->shut_on_empty = TRUE;
1463             b->eof     = TRUE;
1464             _ckvmssts(sys$dassgn(p->chan_in));
1465         } else  {
1466             _ckvmssts(iss);
1467         }
1468
1469         b->eof  = eof;
1470         b->size = p->iosb.count;
1471         _ckvmssts(lib$insqhi(b, &p->wait));
1472         if (p->need_wake) {
1473             p->need_wake = FALSE;
1474             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1475         }
1476     } else {
1477         p->retry = 1;   /* initial call */
1478     }
1479
1480     if (eof) {                  /* flush the free queue, return when done */
1481         int n = sizeof(CBuf) + p->bufsize;
1482         while (1) {
1483             iss = lib$remqti(&p->free, &b);
1484             if (iss == LIB$_QUEWASEMP) return;
1485             _ckvmssts(iss);
1486             _ckvmssts(lib$free_vm(&n, &b));
1487         }
1488     }
1489
1490     iss = lib$remqti(&p->free, &b);
1491     if (iss == LIB$_QUEWASEMP) {
1492         int n = sizeof(CBuf) + p->bufsize;
1493         _ckvmssts(lib$get_vm(&n, &b));
1494         b->buf = (char *) b + sizeof(CBuf);
1495     } else {
1496        _ckvmssts(iss);
1497     }
1498
1499     p->curr = b;
1500     iss = sys$qio(0,p->chan_in,
1501              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1502              &p->iosb,
1503              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1504     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1505     _ckvmssts(iss);
1506 }
1507
1508
1509 /* writes queued buffers to output, waits for each to complete before
1510    doing the next */
1511
1512 static void
1513 pipe_tochild2_ast(pPipe p)
1514 {
1515     pCBuf b = p->curr2;
1516     int iss = p->iosb2.status;
1517     int n = sizeof(CBuf) + p->bufsize;
1518     int done = (p->info && p->info->done) ||
1519               iss == SS$_CANCEL || iss == SS$_ABORT;
1520 #if defined(PERL_IMPLICIT_CONTEXT)
1521     pTHX = p->thx;
1522 #endif
1523
1524     do {
1525         if (p->type) {         /* type=1 has old buffer, dispose */
1526             if (p->shut_on_empty) {
1527                 _ckvmssts(lib$free_vm(&n, &b));
1528             } else {
1529                 _ckvmssts(lib$insqhi(b, &p->free));
1530             }
1531             p->type = 0;
1532         }
1533
1534         iss = lib$remqti(&p->wait, &b);
1535         if (iss == LIB$_QUEWASEMP) {
1536             if (p->shut_on_empty) {
1537                 if (done) {
1538                     _ckvmssts(sys$dassgn(p->chan_out));
1539                     *p->pipe_done = TRUE;
1540                     _ckvmssts(sys$setef(pipe_ef));
1541                 } else {
1542                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1543                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1544                 }
1545                 return;
1546             }
1547             p->need_wake = TRUE;
1548             return;
1549         }
1550         _ckvmssts(iss);
1551         p->type = 1;
1552     } while (done);
1553
1554
1555     p->curr2 = b;
1556     if (b->eof) {
1557         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1558             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1559     } else {
1560         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1561             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1562     }
1563
1564     return;
1565
1566 }
1567
1568
1569 static pPipe
1570 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1571 {
1572     pPipe p;
1573     char mbx1[64], mbx2[64];
1574     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1575                                       DSC$K_CLASS_S, mbx1},
1576                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1577                                       DSC$K_CLASS_S, mbx2};
1578     unsigned int dviitm = DVI$_DEVBUFSIZ;
1579
1580     New(1367, p, 1, Pipe);
1581     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1582     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1583
1584     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1585     New(1367, p->buf, p->bufsize, char);
1586     p->shut_on_empty = FALSE;
1587     p->info   = 0;
1588     p->type   = 0;
1589     p->iosb.status = SS$_NORMAL;
1590 #if defined(PERL_IMPLICIT_CONTEXT)
1591     p->thx = aTHX;
1592 #endif
1593     pipe_infromchild_ast(p);
1594
1595     strcpy(wmbx, mbx1);
1596     strcpy(rmbx, mbx2);
1597     return p;
1598 }
1599
1600 static void
1601 pipe_infromchild_ast(pPipe p)
1602 {
1603     int iss = p->iosb.status;
1604     int eof = (iss == SS$_ENDOFFILE);
1605     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1606     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1607 #if defined(PERL_IMPLICIT_CONTEXT)
1608     pTHX = p->thx;
1609 #endif
1610
1611     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
1612         _ckvmssts(sys$dassgn(p->chan_out));
1613         p->chan_out = 0;
1614     }
1615
1616     /* read completed:
1617             input shutdown if EOF from self (done or shut_on_empty)
1618             output shutdown if closing flag set (my_pclose)
1619             send data/eof from child or eof from self
1620             otherwise, re-read (snarf of data from child)
1621     */
1622
1623     if (p->type == 1) {
1624         p->type = 0;
1625         if (myeof && p->chan_in) {                  /* input shutdown */
1626             _ckvmssts(sys$dassgn(p->chan_in));
1627             p->chan_in = 0;
1628         }
1629
1630         if (p->chan_out) {
1631             if (myeof || kideof) {      /* pass EOF to parent */
1632                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1633                               pipe_infromchild_ast, p,
1634                               0, 0, 0, 0, 0, 0));
1635                 return;
1636             } else if (eof) {       /* eat EOF --- fall through to read*/
1637
1638             } else {                /* transmit data */
1639                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1640                               pipe_infromchild_ast,p,
1641                               p->buf, p->iosb.count, 0, 0, 0, 0));
1642                 return;
1643             }
1644         }
1645     }
1646
1647     /*  everything shut? flag as done */
1648
1649     if (!p->chan_in && !p->chan_out) {
1650         *p->pipe_done = TRUE;
1651         _ckvmssts(sys$setef(pipe_ef));
1652         return;
1653     }
1654
1655     /* write completed (or read, if snarfing from child)
1656             if still have input active,
1657                queue read...immediate mode if shut_on_empty so we get EOF if empty
1658             otherwise,
1659                check if Perl reading, generate EOFs as needed
1660     */
1661
1662     if (p->type == 0) {
1663         p->type = 1;
1664         if (p->chan_in) {
1665             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1666                           pipe_infromchild_ast,p,
1667                           p->buf, p->bufsize, 0, 0, 0, 0);
1668             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1669             _ckvmssts(iss);
1670         } else {           /* send EOFs for extra reads */
1671             p->iosb.status = SS$_ENDOFFILE;
1672             p->iosb.dvispec = 0;
1673             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1674                       0, 0, 0,
1675                       pipe_infromchild_ast, p, 0, 0, 0, 0));
1676         }
1677     }
1678 }
1679
1680 static pPipe
1681 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1682 {
1683     pPipe p;
1684     char mbx[64];
1685     unsigned long dviitm = DVI$_DEVBUFSIZ;
1686     struct stat s;
1687     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1688                                       DSC$K_CLASS_S, mbx};
1689
1690     /* things like terminals and mbx's don't need this filter */
1691     if (fd && fstat(fd,&s) == 0) {
1692         unsigned long dviitm = DVI$_DEVCHAR, devchar;
1693         struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1694                                          DSC$K_CLASS_S, s.st_dev};
1695
1696         _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1697         if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
1698             strcpy(out, s.st_dev);
1699             return 0;
1700         }
1701     }
1702
1703     New(1366, p, 1, Pipe);
1704     p->fd_out = dup(fd);
1705     create_mbx(aTHX_ &p->chan_in, &d_mbx);
1706     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1707     New(1366, p->buf, p->bufsize+1, char);
1708     p->shut_on_empty = FALSE;
1709     p->retry = 0;
1710     p->info  = 0;
1711     strcpy(out, mbx);
1712
1713     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1714                   pipe_mbxtofd_ast, p,
1715                   p->buf, p->bufsize, 0, 0, 0, 0));
1716
1717     return p;
1718 }
1719
1720 static void
1721 pipe_mbxtofd_ast(pPipe p)
1722 {
1723     int iss = p->iosb.status;
1724     int done = p->info->done;
1725     int iss2;
1726     int eof = (iss == SS$_ENDOFFILE);
1727     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1728     int err = !(iss&1) && !eof;
1729 #if defined(PERL_IMPLICIT_CONTEXT)
1730     pTHX = p->thx;
1731 #endif
1732
1733     if (done && myeof) {               /* end piping */
1734         close(p->fd_out);
1735         sys$dassgn(p->chan_in);
1736         *p->pipe_done = TRUE;
1737         _ckvmssts(sys$setef(pipe_ef));
1738         return;
1739     }
1740
1741     if (!err && !eof) {             /* good data to send to file */
1742         p->buf[p->iosb.count] = '\n';
1743         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1744         if (iss2 < 0) {
1745             p->retry++;
1746             if (p->retry < MAX_RETRY) {
1747                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1748                 return;
1749             }
1750         }
1751         p->retry = 0;
1752     } else if (err) {
1753         _ckvmssts(iss);
1754     }
1755
1756
1757     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1758           pipe_mbxtofd_ast, p,
1759           p->buf, p->bufsize, 0, 0, 0, 0);
1760     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1761     _ckvmssts(iss);
1762 }
1763
1764
1765 typedef struct _pipeloc     PLOC;
1766 typedef struct _pipeloc*   pPLOC;
1767
1768 struct _pipeloc {
1769     pPLOC   next;
1770     char    dir[NAM$C_MAXRSS+1];
1771 };
1772 static pPLOC  head_PLOC = 0;
1773
1774 void
1775 free_pipelocs(pTHX_ void *head)
1776 {
1777     pPLOC p, pnext;
1778
1779     p = (pPLOC) head;
1780     while (p) {
1781         pnext = p->next;
1782         Safefree(p);
1783         p = pnext;
1784     }
1785 }
1786
1787 static void
1788 store_pipelocs(pTHX)
1789 {
1790     int    i;
1791     pPLOC  p;
1792     AV    *av = GvAVn(PL_incgv);
1793     SV    *dirsv;
1794     GV    *gv;
1795     char  *dir, *x;
1796     char  *unixdir;
1797     char  temp[NAM$C_MAXRSS+1];
1798     STRLEN n_a;
1799
1800 /*  the . directory from @INC comes last */
1801
1802     New(1370,p,1,PLOC);
1803     p->next = head_PLOC;
1804     head_PLOC = p;
1805     strcpy(p->dir,"./");
1806
1807 /*  get the directory from $^X */
1808
1809     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
1810         strcpy(temp, PL_origargv[0]);
1811         x = strrchr(temp,']');
1812         if (x) x[1] = '\0';
1813
1814         if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1815             New(1370,p,1,PLOC);
1816             p->next = head_PLOC;
1817             head_PLOC = p;
1818             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1819             p->dir[NAM$C_MAXRSS] = '\0';
1820         }
1821     }
1822
1823 /*  reverse order of @INC entries, skip "." since entered above */
1824
1825     for (i = 0; i <= AvFILL(av); i++) {
1826         dirsv = *av_fetch(av,i,TRUE);
1827
1828         if (SvROK(dirsv)) continue;
1829         dir = SvPVx(dirsv,n_a);
1830         if (strcmp(dir,".") == 0) continue;
1831         if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1832             continue;
1833
1834         New(1370,p,1,PLOC);
1835         p->next = head_PLOC;
1836         head_PLOC = p;
1837         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1838         p->dir[NAM$C_MAXRSS] = '\0';
1839     }
1840
1841 /* most likely spot (ARCHLIB) put first in the list */
1842
1843 #ifdef ARCHLIB_EXP
1844     if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1845         New(1370,p,1,PLOC);
1846         p->next = head_PLOC;
1847         head_PLOC = p;
1848         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1849         p->dir[NAM$C_MAXRSS] = '\0';
1850     }
1851 #endif
1852     Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1853 }
1854
1855
1856 static char *
1857 find_vmspipe(pTHX)
1858 {
1859     static int   vmspipe_file_status = 0;
1860     static char  vmspipe_file[NAM$C_MAXRSS+1];
1861
1862     /* already found? Check and use ... need read+execute permission */
1863
1864     if (vmspipe_file_status == 1) {
1865         if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1866          && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1867             return vmspipe_file;
1868         }
1869         vmspipe_file_status = 0;
1870     }
1871
1872     /* scan through stored @INC, $^X */
1873
1874     if (vmspipe_file_status == 0) {
1875         char file[NAM$C_MAXRSS+1];
1876         pPLOC  p = head_PLOC;
1877
1878         while (p) {
1879             strcpy(file, p->dir);
1880             strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1881             file[NAM$C_MAXRSS] = '\0';
1882             p = p->next;
1883
1884             if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1885
1886             if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1887              && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1888                 vmspipe_file_status = 1;
1889                 return vmspipe_file;
1890             }
1891         }
1892         vmspipe_file_status = -1;   /* failed, use tempfiles */
1893     }
1894
1895     return 0;
1896 }
1897
1898 static FILE *
1899 vmspipe_tempfile(pTHX)
1900 {
1901     char file[NAM$C_MAXRSS+1];
1902     FILE *fp;
1903     static int index = 0;
1904     stat_t s0, s1;
1905
1906     /* create a tempfile */
1907
1908     /* we can't go from   W, shr=get to  R, shr=get without
1909        an intermediate vulnerable state, so don't bother trying...
1910
1911        and lib$spawn doesn't shr=put, so have to close the write
1912
1913        So... match up the creation date/time and the FID to
1914        make sure we're dealing with the same file
1915
1916     */
1917
1918     index++;
1919     sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1920     fp = fopen(file,"w");
1921     if (!fp) {
1922         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1923         fp = fopen(file,"w");
1924         if (!fp) {
1925             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1926             fp = fopen(file,"w");
1927         }
1928     }
1929     if (!fp) return 0;  /* we're hosed */
1930
1931     fprintf(fp,"$! 'f$verify(0)\n");
1932     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
1933     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
1934     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1935     fprintf(fp,"$ perl_on     = \"set noon\"\n");
1936     fprintf(fp,"$ perl_exit   = \"exit\"\n");
1937     fprintf(fp,"$ perl_del    = \"delete\"\n");
1938     fprintf(fp,"$ pif         = \"if\"\n");
1939     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
1940     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
1941     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
1942     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
1943     fprintf(fp,"$ cmd = perl_popen_cmd\n");
1944     fprintf(fp,"$!  --- get rid of global symbols\n");
1945     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1946     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1947     fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1948     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1949     fprintf(fp,"$ perl_on\n");
1950     fprintf(fp,"$ 'cmd\n");
1951     fprintf(fp,"$ perl_status = $STATUS\n");
1952     fprintf(fp,"$ perl_del  'perl_cfile'\n");
1953     fprintf(fp,"$ perl_exit 'perl_status'\n");
1954     fsync(fileno(fp));
1955
1956     fgetname(fp, file, 1);
1957     fstat(fileno(fp), &s0);
1958     fclose(fp);
1959
1960     fp = fopen(file,"r","shr=get");
1961     if (!fp) return 0;
1962     fstat(fileno(fp), &s1);
1963
1964     if (s0.st_ino[0] != s1.st_ino[0] ||
1965         s0.st_ino[1] != s1.st_ino[1] ||
1966         s0.st_ino[2] != s1.st_ino[2] ||
1967         s0.st_ctime  != s1.st_ctime  )  {
1968         fclose(fp);
1969         return 0;
1970     }
1971
1972     return fp;
1973 }
1974
1975
1976
1977 static PerlIO *
1978 safe_popen(pTHX_ char *cmd, char *mode)
1979 {
1980     static int handler_set_up = FALSE;
1981     unsigned long int sts, flags=1;  /* nowait - gnu c doesn't allow &1 */
1982     unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1983     char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1984     char in[512], out[512], err[512], mbx[512];
1985     FILE *tpipe = 0;
1986     char tfilebuf[NAM$C_MAXRSS+1];
1987     pInfo info;
1988     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1989                                       DSC$K_CLASS_S, symbol};
1990     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1991                                       DSC$K_CLASS_S, 0};
1992
1993     $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1994     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1995     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1996     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1997                             
1998     /* once-per-program initialization...
1999        note that the SETAST calls and the dual test of pipe_ef
2000        makes sure that only the FIRST thread through here does
2001        the initialization...all other threads wait until it's
2002        done.
2003
2004        Yeah, uglier than a pthread call, it's got all the stuff inline
2005        rather than in a separate routine.
2006     */
2007
2008     if (!pipe_ef) {
2009         _ckvmssts(sys$setast(0));
2010         if (!pipe_ef) {
2011             unsigned long int pidcode = JPI$_PID;
2012             $DESCRIPTOR(d_delay, RETRY_DELAY);
2013             _ckvmssts(lib$get_ef(&pipe_ef));
2014             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2015             _ckvmssts(sys$bintim(&d_delay, delaytime));
2016         }
2017         if (!handler_set_up) {
2018           _ckvmssts(sys$dclexh(&pipe_exitblock));
2019           handler_set_up = TRUE;
2020         }
2021         _ckvmssts(sys$setast(1));
2022     }
2023
2024     /* see if we can find a VMSPIPE.COM */
2025
2026     tfilebuf[0] = '@';
2027     vmspipe = find_vmspipe(aTHX);
2028     if (vmspipe) {
2029         strcpy(tfilebuf+1,vmspipe);
2030     } else {        /* uh, oh...we're in tempfile hell */
2031         tpipe = vmspipe_tempfile(aTHX);
2032         if (!tpipe) {       /* a fish popular in Boston */
2033             if (ckWARN(WARN_PIPE)) {
2034                 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2035             }
2036         return Nullfp;
2037         }
2038         fgetname(tpipe,tfilebuf+1,1);
2039     }
2040     vmspipedsc.dsc$a_pointer = tfilebuf;
2041     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
2042
2043     if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
2044     New(1301,info,1,Info);
2045         
2046     info->mode = *mode;
2047     info->done = FALSE;
2048     info->completion = 0;
2049     info->closing    = FALSE;
2050     info->in         = 0;
2051     info->out        = 0;
2052     info->err        = 0;
2053     info->in_done    = TRUE;
2054     info->out_done   = TRUE;
2055     info->err_done   = TRUE;
2056     in[0] = out[0] = err[0] = '\0';
2057
2058     if (*mode == 'r') {             /* piping from subroutine */
2059
2060         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2061         if (info->out) {
2062             info->out->pipe_done = &info->out_done;
2063             info->out_done = FALSE;
2064             info->out->info = info;
2065         }
2066         info->fp  = PerlIO_open(mbx, mode);
2067         if (!info->fp && info->out) {
2068             sys$cancel(info->out->chan_out);
2069         
2070             while (!info->out_done) {
2071                 int done;
2072                 _ckvmssts(sys$setast(0));
2073                 done = info->out_done;
2074                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2075                 _ckvmssts(sys$setast(1));
2076                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2077             }
2078
2079             if (info->out->buf) Safefree(info->out->buf);
2080             Safefree(info->out);
2081             Safefree(info);
2082             return Nullfp;
2083         }
2084
2085         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2086         if (info->err) {
2087             info->err->pipe_done = &info->err_done;
2088             info->err_done = FALSE;
2089             info->err->info = info;
2090         }
2091
2092     } else {                        /* piping to subroutine , mode=w*/
2093
2094         info->in = pipe_tochild_setup(aTHX_ in,mbx);
2095         info->fp  = PerlIO_open(mbx, mode);
2096         if (info->in) {
2097             info->in->pipe_done = &info->in_done;
2098             info->in_done = FALSE;
2099             info->in->info = info;
2100         }
2101
2102         /* error cleanup */
2103         if (!info->fp && info->in) {
2104             info->done = TRUE;
2105             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2106                               0, 0, 0, 0, 0, 0, 0, 0));
2107
2108             while (!info->in_done) {
2109                 int done;
2110                 _ckvmssts(sys$setast(0));
2111                 done = info->in_done;
2112                 if (!done) _ckvmssts(sys$clref(pipe_ef));
2113                 _ckvmssts(sys$setast(1));
2114                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2115             }
2116
2117             if (info->in->buf) Safefree(info->in->buf);
2118             Safefree(info->in);
2119             Safefree(info);
2120             return Nullfp;
2121         }
2122         
2123
2124         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2125         if (info->out) {
2126             info->out->pipe_done = &info->out_done;
2127             info->out_done = FALSE;
2128             info->out->info = info;
2129         }
2130
2131         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2132         if (info->err) {
2133             info->err->pipe_done = &info->err_done;
2134             info->err_done = FALSE;
2135             info->err->info = info;
2136         }
2137     }
2138
2139     symbol[MAX_DCL_SYMBOL] = '\0';
2140
2141     strncpy(symbol, in, MAX_DCL_SYMBOL);
2142     d_symbol.dsc$w_length = strlen(symbol);
2143     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2144
2145     strncpy(symbol, err, MAX_DCL_SYMBOL);
2146     d_symbol.dsc$w_length = strlen(symbol);
2147     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2148
2149     strncpy(symbol, out, MAX_DCL_SYMBOL);
2150     d_symbol.dsc$w_length = strlen(symbol);
2151     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2152
2153     p = VMScmd.dsc$a_pointer;
2154     while (*p && *p != '\n') p++;
2155     *p = '\0';                                  /* truncate on \n */
2156     p = VMScmd.dsc$a_pointer;
2157     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
2158     if (*p == '$') p++;                         /* remove leading $ */
2159     while (*p == ' ' || *p == '\t') p++;
2160     strncpy(symbol, p, MAX_DCL_SYMBOL);
2161     d_symbol.dsc$w_length = strlen(symbol);
2162     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2163
2164     _ckvmssts(sys$setast(0));
2165     info->next=open_pipes;  /* prepend to list */
2166     open_pipes=info;
2167     _ckvmssts(sys$setast(1));
2168     _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2169                       0, &info->pid, &info->completion,
2170                       0, popen_completion_ast,info,0,0,0));
2171
2172     /* if we were using a tempfile, close it now */
2173
2174     if (tpipe) fclose(tpipe);
2175
2176     /* once the subprocess is spawned, its copied the symbols and
2177        we can get rid of ours */
2178
2179     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2180     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
2181     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2182     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2183     vms_execfree(aTHX);
2184         
2185     PL_forkprocess = info->pid;
2186     return info->fp;
2187 }  /* end of safe_popen */
2188
2189
2190 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
2191 PerlIO *
2192 Perl_my_popen(pTHX_ char *cmd, char *mode)
2193 {
2194     TAINT_ENV();
2195     TAINT_PROPER("popen");
2196     PERL_FLUSHALL_FOR_CHILD;
2197     return safe_popen(aTHX_ cmd,mode);
2198 }
2199
2200 /*}}}*/
2201
2202 /*{{{  I32 my_pclose(PerlIO *fp)*/
2203 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2204 {
2205     pInfo info, last = NULL;
2206     unsigned long int retsts;
2207     int done, iss;
2208     
2209     for (info = open_pipes; info != NULL; last = info, info = info->next)
2210         if (info->fp == fp) break;
2211
2212     if (info == NULL) {  /* no such pipe open */
2213       set_errno(ECHILD); /* quoth POSIX */
2214       set_vaxc_errno(SS$_NONEXPR);
2215       return -1;
2216     }
2217
2218     /* If we were writing to a subprocess, insure that someone reading from
2219      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
2220      * produce an EOF record in the mailbox.
2221      *
2222      *  well, at least sometimes it *does*, so we have to watch out for
2223      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
2224      */
2225
2226      PerlIO_flush(info->fp);   /* first, flush data */
2227
2228     _ckvmssts(sys$setast(0));
2229      info->closing = TRUE;
2230      done = info->done && info->in_done && info->out_done && info->err_done;
2231      /* hanging on write to Perl's input? cancel it */
2232      if (info->mode == 'r' && info->out && !info->out_done) {
2233         if (info->out->chan_out) {
2234             _ckvmssts(sys$cancel(info->out->chan_out));
2235             if (!info->out->chan_in) {   /* EOF generation, need AST */
2236                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2237             }
2238         }
2239      }
2240      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
2241          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2242                            0, 0, 0, 0, 0, 0));
2243     _ckvmssts(sys$setast(1));
2244     PerlIO_close(info->fp);
2245
2246      /*
2247         we have to wait until subprocess completes, but ALSO wait until all
2248         the i/o completes...otherwise we'll be freeing the "info" structure
2249         that the i/o ASTs could still be using...
2250      */
2251
2252      while (!done) {
2253          _ckvmssts(sys$setast(0));
2254          done = info->done && info->in_done && info->out_done && info->err_done;
2255          if (!done) _ckvmssts(sys$clref(pipe_ef));
2256          _ckvmssts(sys$setast(1));
2257          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2258      }
2259      retsts = info->completion;
2260
2261     /* remove from list of open pipes */
2262     _ckvmssts(sys$setast(0));
2263     if (last) last->next = info->next;
2264     else open_pipes = info->next;
2265     _ckvmssts(sys$setast(1));
2266
2267     /* free buffers and structures */
2268
2269     if (info->in) {
2270         if (info->in->buf) Safefree(info->in->buf);
2271         Safefree(info->in);
2272     }
2273     if (info->out) {
2274         if (info->out->buf) Safefree(info->out->buf);
2275         Safefree(info->out);
2276     }
2277     if (info->err) {
2278         if (info->err->buf) Safefree(info->err->buf);
2279         Safefree(info->err);
2280     }
2281     Safefree(info);
2282
2283     return retsts;
2284
2285 }  /* end of my_pclose() */
2286
2287 /* sort-of waitpid; use only with popen() */
2288 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2289 Pid_t
2290 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2291 {
2292     pInfo info;
2293     int done;
2294     
2295     for (info = open_pipes; info != NULL; info = info->next)
2296         if (info->pid == pid) break;
2297
2298     if (info != NULL) {  /* we know about this child */
2299       while (!info->done) {
2300           _ckvmssts(sys$setast(0));
2301           done = info->done;
2302           if (!done) _ckvmssts(sys$clref(pipe_ef));
2303           _ckvmssts(sys$setast(1));
2304           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2305       }
2306
2307       *statusp = info->completion;
2308       return pid;
2309     }
2310     else {  /* we haven't heard of this child */
2311       $DESCRIPTOR(intdsc,"0 00:00:01");
2312       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2313       unsigned long int interval[2],sts;
2314
2315       if (ckWARN(WARN_EXEC)) {
2316         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2317         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2318         if (ownerpid != mypid)
2319           Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2320       }
2321
2322       _ckvmssts(sys$bintim(&intdsc,interval));
2323       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2324         _ckvmssts(sys$schdwk(0,0,interval,0));
2325         _ckvmssts(sys$hiber());
2326       }
2327       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2328       _ckvmssts(sts);
2329
2330       /* There's no easy way to find the termination status a child we're
2331        * not aware of beforehand.  If we're really interested in the future,
2332        * we can go looking for a termination mailbox, or chase after the
2333        * accounting record for the process.
2334        */
2335       *statusp = 0;
2336       return pid;
2337     }
2338                     
2339 }  /* end of waitpid() */
2340 /*}}}*/
2341 /*}}}*/
2342 /*}}}*/
2343
2344 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2345 char *
2346 my_gconvert(double val, int ndig, int trail, char *buf)
2347 {
2348   static char __gcvtbuf[DBL_DIG+1];
2349   char *loc;
2350
2351   loc = buf ? buf : __gcvtbuf;
2352
2353 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
2354   if (val < 1) {
2355     sprintf(loc,"%.*g",ndig,val);
2356     return loc;
2357   }
2358 #endif
2359
2360   if (val) {
2361     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2362     return gcvt(val,ndig,loc);
2363   }
2364   else {
2365     loc[0] = '0'; loc[1] = '\0';
2366     return loc;
2367   }
2368
2369 }
2370 /*}}}*/
2371
2372
2373 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2374 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2375  * to expand file specification.  Allows for a single default file
2376  * specification and a simple mask of options.  If outbuf is non-NULL,
2377  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2378  * the resultant file specification is placed.  If outbuf is NULL, the
2379  * resultant file specification is placed into a static buffer.
2380  * The third argument, if non-NULL, is taken to be a default file
2381  * specification string.  The fourth argument is unused at present.
2382  * rmesexpand() returns the address of the resultant string if
2383  * successful, and NULL on error.
2384  */
2385 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2386
2387 static char *
2388 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2389 {
2390   static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2391   char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2392   char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2393   struct FAB myfab = cc$rms_fab;
2394   struct NAM mynam = cc$rms_nam;
2395   STRLEN speclen;
2396   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2397
2398   if (!filespec || !*filespec) {
2399     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2400     return NULL;
2401   }
2402   if (!outbuf) {
2403     if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2404     else    outbuf = __rmsexpand_retbuf;
2405   }
2406   if ((isunix = (strchr(filespec,'/') != NULL))) {
2407     if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2408     filespec = vmsfspec;
2409   }
2410
2411   myfab.fab$l_fna = filespec;
2412   myfab.fab$b_fns = strlen(filespec);
2413   myfab.fab$l_nam = &mynam;
2414
2415   if (defspec && *defspec) {
2416     if (strchr(defspec,'/') != NULL) {
2417       if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2418       defspec = tmpfspec;
2419     }
2420     myfab.fab$l_dna = defspec;
2421     myfab.fab$b_dns = strlen(defspec);
2422   }
2423
2424   mynam.nam$l_esa = esa;
2425   mynam.nam$b_ess = sizeof esa;
2426   mynam.nam$l_rsa = outbuf;
2427   mynam.nam$b_rss = NAM$C_MAXRSS;
2428
2429   retsts = sys$parse(&myfab,0,0);
2430   if (!(retsts & 1)) {
2431     mynam.nam$b_nop |= NAM$M_SYNCHK;
2432     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2433       retsts = sys$parse(&myfab,0,0);
2434       if (retsts & 1) goto expanded;
2435     }  
2436     mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2437     (void) sys$parse(&myfab,0,0);  /* Free search context */
2438     if (out) Safefree(out);
2439     set_vaxc_errno(retsts);
2440     if      (retsts == RMS$_PRV) set_errno(EACCES);
2441     else if (retsts == RMS$_DEV) set_errno(ENODEV);
2442     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2443     else                         set_errno(EVMSERR);
2444     return NULL;
2445   }
2446   retsts = sys$search(&myfab,0,0);
2447   if (!(retsts & 1) && retsts != RMS$_FNF) {
2448     mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2449     myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2450     if (out) Safefree(out);
2451     set_vaxc_errno(retsts);
2452     if      (retsts == RMS$_PRV) set_errno(EACCES);
2453     else                         set_errno(EVMSERR);
2454     return NULL;
2455   }
2456
2457   /* If the input filespec contained any lowercase characters,
2458    * downcase the result for compatibility with Unix-minded code. */
2459   expanded:
2460   for (out = myfab.fab$l_fna; *out; out++)
2461     if (islower(*out)) { haslower = 1; break; }
2462   if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2463   else                 { out = esa;    speclen = mynam.nam$b_esl; }
2464   /* Trim off null fields added by $PARSE
2465    * If type > 1 char, must have been specified in original or default spec
2466    * (not true for version; $SEARCH may have added version of existing file).
2467    */
2468   trimver  = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2469   trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2470              (mynam.nam$l_ver - mynam.nam$l_type == 1);
2471   if (trimver || trimtype) {
2472     if (defspec && *defspec) {
2473       char defesa[NAM$C_MAXRSS];
2474       struct FAB deffab = cc$rms_fab;
2475       struct NAM defnam = cc$rms_nam;
2476      
2477       deffab.fab$l_nam = &defnam;
2478       deffab.fab$l_fna = defspec;  deffab.fab$b_fns = myfab.fab$b_dns;
2479       defnam.nam$l_esa = defesa;   defnam.nam$b_ess = sizeof defesa;
2480       defnam.nam$b_nop = NAM$M_SYNCHK;
2481       if (sys$parse(&deffab,0,0) & 1) {
2482         if (trimver)  trimver  = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2483         if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); 
2484       }
2485     }
2486     if (trimver) speclen = mynam.nam$l_ver - out;
2487     if (trimtype) {
2488       /* If we didn't already trim version, copy down */
2489       if (speclen > mynam.nam$l_ver - out)
2490         memcpy(mynam.nam$l_type, mynam.nam$l_ver, 
2491                speclen - (mynam.nam$l_ver - out));
2492       speclen -= mynam.nam$l_ver - mynam.nam$l_type; 
2493     }
2494   }
2495   /* If we just had a directory spec on input, $PARSE "helpfully"
2496    * adds an empty name and type for us */
2497   if (mynam.nam$l_name == mynam.nam$l_type &&
2498       mynam.nam$l_ver  == mynam.nam$l_type + 1 &&
2499       !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2500     speclen = mynam.nam$l_name - out;
2501   out[speclen] = '\0';
2502   if (haslower) __mystrtolower(out);
2503
2504   /* Have we been working with an expanded, but not resultant, spec? */
2505   /* Also, convert back to Unix syntax if necessary. */
2506   if (!mynam.nam$b_rsl) {
2507     if (isunix) {
2508       if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2509     }
2510     else strcpy(outbuf,esa);
2511   }
2512   else if (isunix) {
2513     if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2514     strcpy(outbuf,tmpfspec);
2515   }
2516   mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2517   mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2518   myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);  /* Free search context */
2519   return outbuf;
2520 }
2521 /*}}}*/
2522 /* External entry points */
2523 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2524 { return do_rmsexpand(spec,buf,0,def,opt); }
2525 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2526 { return do_rmsexpand(spec,buf,1,def,opt); }
2527
2528
2529 /*
2530 ** The following routines are provided to make life easier when
2531 ** converting among VMS-style and Unix-style directory specifications.
2532 ** All will take input specifications in either VMS or Unix syntax. On
2533 ** failure, all return NULL.  If successful, the routines listed below
2534 ** return a pointer to a buffer containing the appropriately
2535 ** reformatted spec (and, therefore, subsequent calls to that routine
2536 ** will clobber the result), while the routines of the same names with
2537 ** a _ts suffix appended will return a pointer to a mallocd string
2538 ** containing the appropriately reformatted spec.
2539 ** In all cases, only explicit syntax is altered; no check is made that
2540 ** the resulting string is valid or that the directory in question
2541 ** actually exists.
2542 **
2543 **   fileify_dirspec() - convert a directory spec into the name of the
2544 **     directory file (i.e. what you can stat() to see if it's a dir).
2545 **     The style (VMS or Unix) of the result is the same as the style
2546 **     of the parameter passed in.
2547 **   pathify_dirspec() - convert a directory spec into a path (i.e.
2548 **     what you prepend to a filename to indicate what directory it's in).
2549 **     The style (VMS or Unix) of the result is the same as the style
2550 **     of the parameter passed in.
2551 **   tounixpath() - convert a directory spec into a Unix-style path.
2552 **   tovmspath() - convert a directory spec into a VMS-style path.
2553 **   tounixspec() - convert any file spec into a Unix-style file spec.
2554 **   tovmsspec() - convert any file spec into a VMS-style spec.
2555 **
2556 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
2557 ** Permission is given to distribute this code as part of the Perl
2558 ** standard distribution under the terms of the GNU General Public
2559 ** License or the Perl Artistic License.  Copies of each may be
2560 ** found in the Perl standard distribution.
2561  */
2562
2563 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2564 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2565 {
2566     static char __fileify_retbuf[NAM$C_MAXRSS+1];
2567     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2568     char *retspec, *cp1, *cp2, *lastdir;
2569     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2570
2571     if (!dir || !*dir) {
2572       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2573     }
2574     dirlen = strlen(dir);
2575     while (dirlen && dir[dirlen-1] == '/') --dirlen;
2576     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2577       strcpy(trndir,"/sys$disk/000000");
2578       dir = trndir;
2579       dirlen = 16;
2580     }
2581     if (dirlen > NAM$C_MAXRSS) {
2582       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2583     }
2584     if (!strpbrk(dir+1,"/]>:")) {
2585       strcpy(trndir,*dir == '/' ? dir + 1: dir);
2586       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2587       dir = trndir;
2588       dirlen = strlen(dir);
2589     }
2590     else {
2591       strncpy(trndir,dir,dirlen);
2592       trndir[dirlen] = '\0';
2593       dir = trndir;
2594     }
2595     /* If we were handed a rooted logical name or spec, treat it like a
2596      * simple directory, so that
2597      *    $ Define myroot dev:[dir.]
2598      *    ... do_fileify_dirspec("myroot",buf,1) ...
2599      * does something useful.
2600      */
2601     if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2602       dir[--dirlen] = '\0';
2603       dir[dirlen-1] = ']';
2604     }
2605
2606     if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2607       /* If we've got an explicit filename, we can just shuffle the string. */
2608       if (*(cp1+1)) hasfilename = 1;
2609       /* Similarly, we can just back up a level if we've got multiple levels
2610          of explicit directories in a VMS spec which ends with directories. */
2611       else {
2612         for (cp2 = cp1; cp2 > dir; cp2--) {
2613           if (*cp2 == '.') {
2614             *cp2 = *cp1; *cp1 = '\0';
2615             hasfilename = 1;
2616             break;
2617           }
2618           if (*cp2 == '[' || *cp2 == '<') break;
2619         }
2620       }
2621     }
2622
2623     if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2624       if (dir[0] == '.') {
2625         if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2626           return do_fileify_dirspec("[]",buf,ts);
2627         else if (dir[1] == '.' &&
2628                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2629           return do_fileify_dirspec("[-]",buf,ts);
2630       }
2631       if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
2632         dirlen -= 1;                 /* to last element */
2633         lastdir = strrchr(dir,'/');
2634       }
2635       else if ((cp1 = strstr(dir,"/.")) != NULL) {
2636         /* If we have "/." or "/..", VMSify it and let the VMS code
2637          * below expand it, rather than repeating the code to handle
2638          * relative components of a filespec here */
2639         do {
2640           if (*(cp1+2) == '.') cp1++;
2641           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2642             if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2643             if (strchr(vmsdir,'/') != NULL) {
2644               /* If do_tovmsspec() returned it, it must have VMS syntax
2645                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
2646                * the time to check this here only so we avoid a recursion
2647                * loop; otherwise, gigo.
2648                */
2649               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);  return NULL;
2650             }
2651             if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2652             return do_tounixspec(trndir,buf,ts);
2653           }
2654           cp1++;
2655         } while ((cp1 = strstr(cp1,"/.")) != NULL);
2656         lastdir = strrchr(dir,'/');
2657       }
2658       else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2659         /* Ditto for specs that end in an MFD -- let the VMS code
2660          * figure out whether it's a real device or a rooted logical. */
2661         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2662         if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2663         if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2664         return do_tounixspec(trndir,buf,ts);
2665       }
2666       else {
2667         if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2668              !(lastdir = cp1 = strrchr(dir,']')) &&
2669              !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2670         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
2671           int ver; char *cp3;
2672           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2673               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2674               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2675               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2676               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2677                             (ver || *cp3)))))) {
2678             set_errno(ENOTDIR);
2679             set_vaxc_errno(RMS$_DIR);
2680             return NULL;
2681           }
2682           dirlen = cp2 - dir;
2683         }
2684       }
2685       /* If we lead off with a device or rooted logical, add the MFD
2686          if we're specifying a top-level directory. */
2687       if (lastdir && *dir == '/') {
2688         addmfd = 1;
2689         for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2690           if (*cp1 == '/') {
2691             addmfd = 0;
2692             break;
2693           }
2694         }
2695       }
2696       retlen = dirlen + (addmfd ? 13 : 6);
2697       if (buf) retspec = buf;
2698       else if (ts) New(1309,retspec,retlen+1,char);
2699       else retspec = __fileify_retbuf;
2700       if (addmfd) {
2701         dirlen = lastdir - dir;
2702         memcpy(retspec,dir,dirlen);
2703         strcpy(&retspec[dirlen],"/000000");
2704         strcpy(&retspec[dirlen+7],lastdir);
2705       }
2706       else {
2707         memcpy(retspec,dir,dirlen);
2708         retspec[dirlen] = '\0';
2709       }
2710       /* We've picked up everything up to the directory file name.
2711          Now just add the type and version, and we're set. */
2712       strcat(retspec,".dir;1");
2713       return retspec;
2714     }
2715     else {  /* VMS-style directory spec */
2716       char esa[NAM$C_MAXRSS+1], term, *cp;
2717       unsigned long int sts, cmplen, haslower = 0;
2718       struct FAB dirfab = cc$rms_fab;
2719       struct NAM savnam, dirnam = cc$rms_nam;
2720
2721       dirfab.fab$b_fns = strlen(dir);
2722       dirfab.fab$l_fna = dir;
2723       dirfab.fab$l_nam = &dirnam;
2724       dirfab.fab$l_dna = ".DIR;1";
2725       dirfab.fab$b_dns = 6;
2726       dirnam.nam$b_ess = NAM$C_MAXRSS;
2727       dirnam.nam$l_esa = esa;
2728
2729       for (cp = dir; *cp; cp++)
2730         if (islower(*cp)) { haslower = 1; break; }
2731       if (!((sts = sys$parse(&dirfab))&1)) {
2732         if (dirfab.fab$l_sts == RMS$_DIR) {
2733           dirnam.nam$b_nop |= NAM$M_SYNCHK;
2734           sts = sys$parse(&dirfab) & 1;
2735         }
2736         if (!sts) {
2737           set_errno(EVMSERR);
2738           set_vaxc_errno(dirfab.fab$l_sts);
2739           return NULL;
2740         }
2741       }
2742       else {
2743         savnam = dirnam;
2744         if (sys$search(&dirfab)&1) {  /* Does the file really exist? */
2745           /* Yes; fake the fnb bits so we'll check type below */
2746           dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2747         }
2748         else { /* No; just work with potential name */
2749           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2750           else { 
2751             set_errno(EVMSERR);  set_vaxc_errno(dirfab.fab$l_sts);
2752             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2753             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2754             return NULL;
2755           }
2756         }
2757       }
2758       if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2759         cp1 = strchr(esa,']');
2760         if (!cp1) cp1 = strchr(esa,'>');
2761         if (cp1) {  /* Should always be true */
2762           dirnam.nam$b_esl -= cp1 - esa - 1;
2763           memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2764         }
2765       }
2766       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
2767         /* Yep; check version while we're at it, if it's there. */
2768         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2769         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
2770           /* Something other than .DIR[;1].  Bzzt. */
2771           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2772           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2773           set_errno(ENOTDIR);
2774           set_vaxc_errno(RMS$_DIR);
2775           return NULL;
2776         }
2777       }
2778       esa[dirnam.nam$b_esl] = '\0';
2779       if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2780         /* They provided at least the name; we added the type, if necessary, */
2781         if (buf) retspec = buf;                            /* in sys$parse() */
2782         else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2783         else retspec = __fileify_retbuf;
2784         strcpy(retspec,esa);
2785         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2786         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2787         return retspec;
2788       }
2789       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2790         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2791         *cp1 = '\0';
2792         dirnam.nam$b_esl -= 9;
2793       }
2794       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2795       if (cp1 == NULL) { /* should never happen */
2796         dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2797         dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2798         return NULL;
2799       }
2800       term = *cp1;
2801       *cp1 = '\0';
2802       retlen = strlen(esa);
2803       if ((cp1 = strrchr(esa,'.')) != NULL) {
2804         /* There's more than one directory in the path.  Just roll back. */
2805         *cp1 = term;
2806         if (buf) retspec = buf;
2807         else if (ts) New(1311,retspec,retlen+7,char);
2808         else retspec = __fileify_retbuf;
2809         strcpy(retspec,esa);
2810       }
2811       else {
2812         if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2813           /* Go back and expand rooted logical name */
2814           dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2815           if (!(sys$parse(&dirfab) & 1)) {
2816             dirnam.nam$l_rlf = NULL;
2817             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2818             set_errno(EVMSERR);
2819             set_vaxc_errno(dirfab.fab$l_sts);
2820             return NULL;
2821           }
2822           retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2823           if (buf) retspec = buf;
2824           else if (ts) New(1312,retspec,retlen+16,char);
2825           else retspec = __fileify_retbuf;
2826           cp1 = strstr(esa,"][");
2827           dirlen = cp1 - esa;
2828           memcpy(retspec,esa,dirlen);
2829           if (!strncmp(cp1+2,"000000]",7)) {
2830             retspec[dirlen-1] = '\0';
2831             for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2832             if (*cp1 == '.') *cp1 = ']';
2833             else {
2834               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2835               memcpy(cp1+1,"000000]",7);
2836             }
2837           }
2838           else {
2839             memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2840             retspec[retlen] = '\0';
2841             /* Convert last '.' to ']' */
2842             for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2843             if (*cp1 == '.') *cp1 = ']';
2844             else {
2845               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2846               memcpy(cp1+1,"000000]",7);
2847             }
2848           }
2849         }
2850         else {  /* This is a top-level dir.  Add the MFD to the path. */
2851           if (buf) retspec = buf;
2852           else if (ts) New(1312,retspec,retlen+16,char);
2853           else retspec = __fileify_retbuf;
2854           cp1 = esa;
2855           cp2 = retspec;
2856           while (*cp1 != ':') *(cp2++) = *(cp1++);
2857           strcpy(cp2,":[000000]");
2858           cp1 += 2;
2859           strcpy(cp2+9,cp1);
2860         }
2861       }
2862       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
2863       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
2864       /* We've set up the string up through the filename.  Add the
2865          type and version, and we're done. */
2866       strcat(retspec,".DIR;1");
2867
2868       /* $PARSE may have upcased filespec, so convert output to lower
2869        * case if input contained any lowercase characters. */
2870       if (haslower) __mystrtolower(retspec);
2871       return retspec;
2872     }
2873 }  /* end of do_fileify_dirspec() */
2874 /*}}}*/
2875 /* External entry points */
2876 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2877 { return do_fileify_dirspec(dir,buf,0); }
2878 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2879 { return do_fileify_dirspec(dir,buf,1); }
2880
2881 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2882 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2883 {
2884     static char __pathify_retbuf[NAM$C_MAXRSS+1];
2885     unsigned long int retlen;
2886     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2887
2888     if (!dir || !*dir) {
2889       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2890     }
2891
2892     if (*dir) strcpy(trndir,dir);
2893     else getcwd(trndir,sizeof trndir - 1);
2894
2895     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2896            && my_trnlnm(trndir,trndir,0)) {
2897       STRLEN trnlen = strlen(trndir);
2898
2899       /* Trap simple rooted lnms, and return lnm:[000000] */
2900       if (!strcmp(trndir+trnlen-2,".]")) {
2901         if (buf) retpath = buf;
2902         else if (ts) New(1318,retpath,strlen(dir)+10,char);
2903         else retpath = __pathify_retbuf;
2904         strcpy(retpath,dir);
2905         strcat(retpath,":[000000]");
2906         return retpath;
2907       }
2908     }
2909     dir = trndir;
2910
2911     if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2912       if (*dir == '.' && (*(dir+1) == '\0' ||
2913                           (*(dir+1) == '.' && *(dir+2) == '\0')))
2914         retlen = 2 + (*(dir+1) != '\0');
2915       else {
2916         if ( !(cp1 = strrchr(dir,'/')) &&
2917              !(cp1 = strrchr(dir,']')) &&
2918              !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2919         if ((cp2 = strchr(cp1,'.')) != NULL &&
2920             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
2921              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
2922               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2923               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2924           int ver; char *cp3;
2925           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2926               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2927               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2928               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2929               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2930                             (ver || *cp3)))))) {
2931             set_errno(ENOTDIR);
2932             set_vaxc_errno(RMS$_DIR);
2933             return NULL;
2934           }
2935           retlen = cp2 - dir + 1;
2936         }
2937         else {  /* No file type present.  Treat the filename as a directory. */
2938           retlen = strlen(dir) + 1;
2939         }
2940       }
2941       if (buf) retpath = buf;
2942       else if (ts) New(1313,retpath,retlen+1,char);
2943       else retpath = __pathify_retbuf;
2944       strncpy(retpath,dir,retlen-1);
2945       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2946         retpath[retlen-1] = '/';      /* with '/', add it. */
2947         retpath[retlen] = '\0';
2948       }
2949       else retpath[retlen-1] = '\0';
2950     }
2951     else {  /* VMS-style directory spec */
2952       char esa[NAM$C_MAXRSS+1], *cp;
2953       unsigned long int sts, cmplen, haslower;
2954       struct FAB dirfab = cc$rms_fab;
2955       struct NAM savnam, dirnam = cc$rms_nam;
2956
2957       /* If we've got an explicit filename, we can just shuffle the string. */
2958       if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2959              (cp1 = strrchr(dir,'>')) != NULL     ) && *(cp1+1)) {
2960         if ((cp2 = strchr(cp1,'.')) != NULL) {
2961           int ver; char *cp3;
2962           if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
2963               !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
2964               !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2965               (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
2966               (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2967                             (ver || *cp3)))))) {
2968             set_errno(ENOTDIR);
2969             set_vaxc_errno(RMS$_DIR);
2970             return NULL;
2971           }
2972         }
2973         else {  /* No file type, so just draw name into directory part */
2974           for (cp2 = cp1; *cp2; cp2++) ;
2975         }
2976         *cp2 = *cp1;
2977         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
2978         *cp1 = '.';
2979         /* We've now got a VMS 'path'; fall through */
2980       }
2981       dirfab.fab$b_fns = strlen(dir);
2982       dirfab.fab$l_fna = dir;
2983       if (dir[dirfab.fab$b_fns-1] == ']' ||
2984           dir[dirfab.fab$b_fns-1] == '>' ||
2985           dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2986         if (buf) retpath = buf;
2987         else if (ts) New(1314,retpath,strlen(dir)+1,char);
2988         else retpath = __pathify_retbuf;
2989         strcpy(retpath,dir);
2990         return retpath;
2991       } 
2992       dirfab.fab$l_dna = ".DIR;1";
2993       dirfab.fab$b_dns = 6;
2994       dirfab.fab$l_nam = &dirnam;
2995       dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2996       dirnam.nam$l_esa = esa;
2997
2998       for (cp = dir; *cp; cp++)
2999         if (islower(*cp)) { haslower = 1; break; }
3000
3001       if (!(sts = (sys$parse(&dirfab)&1))) {
3002         if (dirfab.fab$l_sts == RMS$_DIR) {
3003           dirnam.nam$b_nop |= NAM$M_SYNCHK;
3004           sts = sys$parse(&dirfab) & 1;
3005         }
3006         if (!sts) {
3007           set_errno(EVMSERR);
3008           set_vaxc_errno(dirfab.fab$l_sts);
3009           return NULL;
3010         }
3011       }
3012       else {
3013         savnam = dirnam;
3014         if (!(sys$search(&dirfab)&1)) {  /* Does the file really exist? */
3015           if (dirfab.fab$l_sts != RMS$_FNF) {
3016             dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3017             dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3018             set_errno(EVMSERR);
3019             set_vaxc_errno(dirfab.fab$l_sts);
3020             return NULL;
3021           }
3022           dirnam = savnam; /* No; just work with potential name */
3023         }
3024       }
3025       if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) {  /* Was type specified? */
3026         /* Yep; check version while we're at it, if it's there. */
3027         cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3028         if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { 
3029           /* Something other than .DIR[;1].  Bzzt. */
3030           dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3031           dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3032           set_errno(ENOTDIR);
3033           set_vaxc_errno(RMS$_DIR);
3034           return NULL;
3035         }
3036       }
3037       /* OK, the type was fine.  Now pull any file name into the
3038          directory path. */
3039       if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3040       else {
3041         cp1 = strrchr(esa,'>');
3042         *dirnam.nam$l_type = '>';
3043       }
3044       *cp1 = '.';
3045       *(dirnam.nam$l_type + 1) = '\0';
3046       retlen = dirnam.nam$l_type - esa + 2;
3047       if (buf) retpath = buf;
3048       else if (ts) New(1314,retpath,retlen,char);
3049       else retpath = __pathify_retbuf;
3050       strcpy(retpath,esa);
3051       dirnam.nam$b_nop |= NAM$M_SYNCHK;  dirnam.nam$l_rlf = NULL;
3052       dirfab.fab$b_dns = 0;  (void) sys$parse(&dirfab,0,0);
3053       /* $PARSE may have upcased filespec, so convert output to lower
3054        * case if input contained any lowercase characters. */
3055       if (haslower) __mystrtolower(retpath);
3056     }
3057
3058     return retpath;
3059 }  /* end of do_pathify_dirspec() */
3060 /*}}}*/
3061 /* External entry points */
3062 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3063 { return do_pathify_dirspec(dir,buf,0); }
3064 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3065 { return do_pathify_dirspec(dir,buf,1); }
3066
3067 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3068 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3069 {
3070   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3071   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3072   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3073
3074   if (spec == NULL) return NULL;
3075   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3076   if (buf) rslt = buf;
3077   else if (ts) {
3078     retlen = strlen(spec);
3079     cp1 = strchr(spec,'[');
3080     if (!cp1) cp1 = strchr(spec,'<');
3081     if (cp1) {
3082       for (cp1++; *cp1; cp1++) {
3083         if (*cp1 == '-') expand++; /* VMS  '-' ==> Unix '../' */
3084         if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3085           { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3086       }
3087     }
3088     New(1315,rslt,retlen+2+2*expand,char);
3089   }
3090   else rslt = __tounixspec_retbuf;
3091   if (strchr(spec,'/') != NULL) {
3092     strcpy(rslt,spec);
3093     return rslt;
3094   }
3095
3096   cp1 = rslt;
3097   cp2 = spec;
3098   dirend = strrchr(spec,']');
3099   if (dirend == NULL) dirend = strrchr(spec,'>');
3100   if (dirend == NULL) dirend = strchr(spec,':');
3101   if (dirend == NULL) {
3102     strcpy(rslt,spec);
3103     return rslt;
3104   }
3105   if (*cp2 != '[' && *cp2 != '<') {
3106     *(cp1++) = '/';
3107   }
3108   else {  /* the VMS spec begins with directories */
3109     cp2++;
3110     if (*cp2 == ']' || *cp2 == '>') {
3111       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3112       return rslt;
3113     }
3114     else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3115       if (getcwd(tmp,sizeof tmp,1) == NULL) {
3116         if (ts) Safefree(rslt);
3117         return NULL;
3118       }
3119       do {
3120         cp3 = tmp;
3121         while (*cp3 != ':' && *cp3) cp3++;
3122         *(cp3++) = '\0';
3123         if (strchr(cp3,']') != NULL) break;
3124       } while (vmstrnenv(tmp,tmp,0,fildev,0));
3125       if (ts && !buf &&
3126           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3127         retlen = devlen + dirlen;
3128         Renew(rslt,retlen+1+2*expand,char);
3129         cp1 = rslt;
3130       }
3131       cp3 = tmp;
3132       *(cp1++) = '/';
3133       while (*cp3) {
3134         *(cp1++) = *(cp3++);
3135         if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3136       }
3137       *(cp1++) = '/';
3138     }
3139     else if ( *cp2 == '.') {
3140       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3141         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3142         cp2 += 3;
3143       }
3144       else cp2++;
3145     }
3146   }
3147   for (; cp2 <= dirend; cp2++) {
3148     if (*cp2 == ':') {
3149       *(cp1++) = '/';
3150       if (*(cp2+1) == '[') cp2++;
3151     }
3152     else if (*cp2 == ']' || *cp2 == '>') {
3153       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3154     }
3155     else if (*cp2 == '.') {
3156       *(cp1++) = '/';
3157       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3158         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3159                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3160         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3161             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3162       }
3163       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3164         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3165         cp2 += 2;
3166       }
3167     }
3168     else if (*cp2 == '-') {
3169       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3170         while (*cp2 == '-') {
3171           cp2++;
3172           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3173         }
3174         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3175           if (ts) Safefree(rslt);                        /* filespecs like */
3176           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
3177           return NULL;
3178         }
3179       }
3180       else *(cp1++) = *cp2;
3181     }
3182     else *(cp1++) = *cp2;
3183   }
3184   while (*cp2) *(cp1++) = *(cp2++);
3185   *cp1 = '\0';
3186
3187   return rslt;
3188
3189 }  /* end of do_tounixspec() */
3190 /*}}}*/
3191 /* External entry points */
3192 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3193 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3194
3195 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3196 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3197   static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3198   char *rslt, *dirend;
3199   register char *cp1, *cp2;
3200   unsigned long int infront = 0, hasdir = 1;
3201
3202   if (path == NULL) return NULL;
3203   if (buf) rslt = buf;
3204   else if (ts) New(1316,rslt,strlen(path)+9,char);
3205   else rslt = __tovmsspec_retbuf;
3206   if (strpbrk(path,"]:>") ||
3207       (dirend = strrchr(path,'/')) == NULL) {
3208     if (path[0] == '.') {
3209       if (path[1] == '\0') strcpy(rslt,"[]");
3210       else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3211       else strcpy(rslt,path); /* probably garbage */
3212     }
3213     else strcpy(rslt,path);
3214     return rslt;
3215   }
3216   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
3217     if (!*(dirend+2)) dirend +=2;
3218     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3219     if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3220   }
3221   cp1 = rslt;
3222   cp2 = path;
3223   if (*cp2 == '/') {
3224     char trndev[NAM$C_MAXRSS+1];
3225     int islnm, rooted;
3226     STRLEN trnend;
3227
3228     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
3229     if (!*(cp2+1)) {
3230       if (!buf & ts) Renew(rslt,18,char);
3231       strcpy(rslt,"sys$disk:[000000]");
3232       return rslt;
3233     }
3234     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3235     *cp1 = '\0';
3236     islnm =  my_trnlnm(rslt,trndev,0);
3237     trnend = islnm ? strlen(trndev) - 1 : 0;
3238     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3239     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3240     /* If the first element of the path is a logical name, determine
3241      * whether it has to be translated so we can add more directories. */
3242     if (!islnm || rooted) {
3243       *(cp1++) = ':';
3244       *(cp1++) = '[';
3245       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3246       else cp2++;
3247     }
3248     else {
3249       if (cp2 != dirend) {
3250         if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3251         strcpy(rslt,trndev);
3252         cp1 = rslt + trnend;
3253         *(cp1++) = '.';
3254         cp2++;
3255       }
3256       else {
3257         *(cp1++) = ':';
3258         hasdir = 0;
3259       }
3260     }
3261   }
3262   else {
3263     *(cp1++) = '[';
3264     if (*cp2 == '.') {
3265       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3266         cp2 += 2;         /* skip over "./" - it's redundant */
3267         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
3268       }
3269       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3270         *(cp1++) = '-';                                 /* "../" --> "-" */
3271         cp2 += 3;
3272       }
3273       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3274                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3275         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3276         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3277         cp2 += 4;
3278       }
3279       if (cp2 > dirend) cp2 = dirend;
3280     }
3281     else *(cp1++) = '.';
3282   }
3283   for (; cp2 < dirend; cp2++) {
3284     if (*cp2 == '/') {
3285       if (*(cp2-1) == '/') continue;
3286       if (*(cp1-1) != '.') *(cp1++) = '.';
3287       infront = 0;
3288     }
3289     else if (!infront && *cp2 == '.') {
3290       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3291       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
3292       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3293         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3294         else if (*(cp1-2) == '[') *(cp1-1) = '-';
3295         else {  /* back up over previous directory name */
3296           cp1--;
3297           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3298           if (*(cp1-1) == '[') {
3299             memcpy(cp1,"000000.",7);
3300             cp1 += 7;
3301           }
3302         }
3303         cp2 += 2;
3304         if (cp2 == dirend) break;
3305       }
3306       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3307                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3308         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3309         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3310         if (!*(cp2+3)) { 
3311           *(cp1++) = '.';  /* Simulate trailing '/' */
3312           cp2 += 2;  /* for loop will incr this to == dirend */
3313         }
3314         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
3315       }
3316       else *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
3317     }
3318     else {
3319       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
3320       if (*cp2 == '.')      *(cp1++) = '_';
3321       else                  *(cp1++) =  *cp2;
3322       infront = 1;
3323     }
3324   }
3325   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3326   if (hasdir) *(cp1++) = ']';
3327   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
3328   while (*cp2) *(cp1++) = *(cp2++);
3329   *cp1 = '\0';
3330
3331   return rslt;
3332
3333 }  /* end of do_tovmsspec() */
3334 /*}}}*/
3335 /* External entry points */
3336 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3337 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3338
3339 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3340 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3341   static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3342   int vmslen;
3343   char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3344
3345   if (path == NULL) return NULL;
3346   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3347   if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3348   if (buf) return buf;
3349   else if (ts) {
3350     vmslen = strlen(vmsified);
3351     New(1317,cp,vmslen+1,char);
3352     memcpy(cp,vmsified,vmslen);
3353     cp[vmslen] = '\0';
3354     return cp;
3355   }
3356   else {
3357     strcpy(__tovmspath_retbuf,vmsified);
3358     return __tovmspath_retbuf;
3359   }
3360
3361 }  /* end of do_tovmspath() */
3362 /*}}}*/
3363 /* External entry points */
3364 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3365 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3366
3367
3368 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3369 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3370   static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3371   int unixlen;
3372   char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3373
3374   if (path == NULL) return NULL;
3375   if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3376   if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3377   if (buf) return buf;
3378   else if (ts) {
3379     unixlen = strlen(unixified);
3380     New(1317,cp,unixlen+1,char);
3381     memcpy(cp,unixified,unixlen);
3382     cp[unixlen] = '\0';
3383     return cp;
3384   }
3385   else {
3386     strcpy(__tounixpath_retbuf,unixified);
3387     return __tounixpath_retbuf;
3388   }
3389
3390 }  /* end of do_tounixpath() */
3391 /*}}}*/
3392 /* External entry points */
3393 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3394 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3395
3396 /*
3397  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
3398  *
3399  *****************************************************************************
3400  *                                                                           *
3401  *  Copyright (C) 1989-1994 by                                               *
3402  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
3403  *                                                                           *
3404  *  Permission is hereby  granted for the reproduction of this software,     *
3405  *  on condition that this copyright notice is included in the reproduction, *
3406  *  and that such reproduction is not for purposes of profit or material     *
3407  *  gain.                                                                    *
3408  *                                                                           *
3409  *  27-Aug-1994 Modified for inclusion in perl5                              *
3410  *              by Charles Bailey  bailey@newman.upenn.edu                   *
3411  *****************************************************************************
3412  */
3413
3414 /*
3415  * getredirection() is intended to aid in porting C programs
3416  * to VMS (Vax-11 C).  The native VMS environment does not support 
3417  * '>' and '<' I/O redirection, or command line wild card expansion, 
3418  * or a command line pipe mechanism using the '|' AND background 
3419  * command execution '&'.  All of these capabilities are provided to any
3420  * C program which calls this procedure as the first thing in the 
3421  * main program.
3422  * The piping mechanism will probably work with almost any 'filter' type
3423  * of program.  With suitable modification, it may useful for other
3424  * portability problems as well.
3425  *
3426  * Author:  Mark Pizzolato      mark@infocomm.com
3427  */
3428 struct list_item
3429     {
3430     struct list_item *next;
3431     char *value;
3432     };
3433
3434 static void add_item(struct list_item **head,
3435                      struct list_item **tail,
3436                      char *value,
3437                      int *count);
3438
3439 static void mp_expand_wild_cards(pTHX_ char *item,
3440                                 struct list_item **head,
3441                                 struct list_item **tail,
3442                                 int *count);
3443
3444 static int background_process(int argc, char **argv);
3445
3446 static void pipe_and_fork(pTHX_ char **cmargv);
3447
3448 /*{{{ void getredirection(int *ac, char ***av)*/
3449 static void
3450 mp_getredirection(pTHX_ int *ac, char ***av)
3451 /*
3452  * Process vms redirection arg's.  Exit if any error is seen.
3453  * If getredirection() processes an argument, it is erased
3454  * from the vector.  getredirection() returns a new argc and argv value.
3455  * In the event that a background command is requested (by a trailing "&"),
3456  * this routine creates a background subprocess, and simply exits the program.
3457  *
3458  * Warning: do not try to simplify the code for vms.  The code
3459  * presupposes that getredirection() is called before any data is
3460  * read from stdin or written to stdout.
3461  *
3462  * Normal usage is as follows:
3463  *
3464  *      main(argc, argv)
3465  *      int             argc;
3466  *      char            *argv[];
3467  *      {
3468  *              getredirection(&argc, &argv);
3469  *      }
3470  */
3471 {
3472     int                 argc = *ac;     /* Argument Count         */
3473     char                **argv = *av;   /* Argument Vector        */
3474     char                *ap;            /* Argument pointer       */
3475     int                 j;              /* argv[] index           */
3476     int                 item_count = 0; /* Count of Items in List */
3477     struct list_item    *list_head = 0; /* First Item in List       */
3478     struct list_item    *list_tail;     /* Last Item in List        */
3479     char                *in = NULL;     /* Input File Name          */
3480     char                *out = NULL;    /* Output File Name         */
3481     char                *outmode = "w"; /* Mode to Open Output File */
3482     char                *err = NULL;    /* Error File Name          */
3483     char                *errmode = "w"; /* Mode to Open Error File  */
3484     int                 cmargc = 0;     /* Piped Command Arg Count  */
3485     char                **cmargv = NULL;/* Piped Command Arg Vector */
3486
3487     /*
3488      * First handle the case where the last thing on the line ends with
3489      * a '&'.  This indicates the desire for the command to be run in a
3490      * subprocess, so we satisfy that desire.
3491      */
3492     ap = argv[argc-1];
3493     if (0 == strcmp("&", ap))
3494         exit(background_process(--argc, argv));
3495     if (*ap && '&' == ap[strlen(ap)-1])
3496         {
3497         ap[strlen(ap)-1] = '\0';
3498         exit(background_process(argc, argv));
3499         }
3500     /*
3501      * Now we handle the general redirection cases that involve '>', '>>',
3502      * '<', and pipes '|'.
3503      */
3504     for (j = 0; j < argc; ++j)
3505         {
3506         if (0 == strcmp("<", argv[j]))
3507             {
3508             if (j+1 >= argc)
3509                 {
3510                 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3511                 exit(LIB$_WRONUMARG);
3512                 }
3513             in = argv[++j];
3514             continue;
3515             }
3516         if ('<' == *(ap = argv[j]))
3517             {
3518             in = 1 + ap;
3519             continue;
3520             }
3521         if (0 == strcmp(">", ap))
3522             {
3523             if (j+1 >= argc)
3524                 {
3525                 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3526                 exit(LIB$_WRONUMARG);
3527                 }
3528             out = argv[++j];
3529             continue;
3530             }
3531         if ('>' == *ap)
3532             {
3533             if ('>' == ap[1])
3534                 {
3535                 outmode = "a";
3536                 if ('\0' == ap[2])
3537                     out = argv[++j];
3538                 else
3539                     out = 2 + ap;
3540                 }
3541             else
3542                 out = 1 + ap;
3543             if (j >= argc)
3544                 {
3545                 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3546                 exit(LIB$_WRONUMARG);
3547                 }
3548             continue;
3549             }
3550         if (('2' == *ap) && ('>' == ap[1]))
3551             {
3552             if ('>' == ap[2])
3553                 {
3554                 errmode = "a";
3555                 if ('\0' == ap[3])
3556                     err = argv[++j];
3557                 else
3558                     err = 3 + ap;
3559                 }
3560             else
3561                 if ('\0' == ap[2])
3562                     err = argv[++j];
3563                 else
3564                     err = 2 + ap;
3565             if (j >= argc)
3566                 {
3567                 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3568                 exit(LIB$_WRONUMARG);
3569                 }
3570             continue;
3571             }
3572         if (0 == strcmp("|", argv[j]))
3573             {
3574             if (j+1 >= argc)
3575                 {
3576                 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3577                 exit(LIB$_WRONUMARG);
3578                 }
3579             cmargc = argc-(j+1);
3580             cmargv = &argv[j+1];
3581             argc = j;
3582             continue;
3583             }
3584         if ('|' == *(ap = argv[j]))
3585             {
3586             ++argv[j];
3587             cmargc = argc-j;
3588             cmargv = &argv[j];
3589             argc = j;
3590             continue;
3591             }
3592         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3593         }
3594     /*
3595      * Allocate and fill in the new argument vector, Some Unix's terminate
3596      * the list with an extra null pointer.
3597      */
3598     New(1302, argv, item_count+1, char *);
3599     *av = argv;
3600     for (j = 0; j < item_count; ++j, list_head = list_head->next)
3601         argv[j] = list_head->value;
3602     *ac = item_count;
3603     if (cmargv != NULL)
3604         {
3605         if (out != NULL)
3606             {
3607             PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3608             exit(LIB$_INVARGORD);
3609             }
3610         pipe_and_fork(aTHX_ cmargv);
3611         }
3612         
3613     /* Check for input from a pipe (mailbox) */
3614
3615     if (in == NULL && 1 == isapipe(0))
3616         {
3617         char mbxname[L_tmpnam];
3618         long int bufsize;
3619         long int dvi_item = DVI$_DEVBUFSIZ;
3620         $DESCRIPTOR(mbxnam, "");
3621         $DESCRIPTOR(mbxdevnam, "");
3622
3623         /* Input from a pipe, reopen it in binary mode to disable       */
3624         /* carriage control processing.                                 */
3625
3626        fgetname(stdin, mbxname);
3627         mbxnam.dsc$a_pointer = mbxname;
3628         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);     
3629         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3630         mbxdevnam.dsc$a_pointer = mbxname;
3631         mbxdevnam.dsc$w_length = sizeof(mbxname);
3632         dvi_item = DVI$_DEVNAM;
3633         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3634         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3635         set_errno(0);
3636         set_vaxc_errno(1);
3637         freopen(mbxname, "rb", stdin);
3638         if (errno != 0)
3639             {
3640             PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3641             exit(vaxc$errno);
3642             }
3643         }
3644     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3645         {
3646         PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3647         exit(vaxc$errno);
3648         }
3649     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3650         {       
3651         PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3652         exit(vaxc$errno);
3653         }
3654         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3655
3656     if (err != NULL) {
3657         if (strcmp(err,"&1") == 0) {
3658             dup2(fileno(stdout), fileno(stderr));
3659             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3660         } else {
3661         FILE *tmperr;
3662         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3663             {
3664             PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3665             exit(vaxc$errno);
3666             }
3667             fclose(tmperr);
3668            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3669                 {
3670                 exit(vaxc$errno);
3671                 }
3672             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3673         }
3674         }
3675 #ifdef ARGPROC_DEBUG
3676     PerlIO_printf(Perl_debug_log, "Arglist:\n");
3677     for (j = 0; j < *ac;  ++j)
3678         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3679 #endif
3680    /* Clear errors we may have hit expanding wildcards, so they don't
3681       show up in Perl's $! later */
3682    set_errno(0); set_vaxc_errno(1);
3683 }  /* end of getredirection() */
3684 /*}}}*/
3685
3686 static void add_item(struct list_item **head,
3687                      struct list_item **tail,
3688                      char *value,
3689                      int *count)
3690 {
3691     if (*head == 0)
3692         {
3693         New(1303,*head,1,struct list_item);
3694         *tail = *head;
3695         }
3696     else {
3697         New(1304,(*tail)->next,1,struct list_item);
3698         *tail = (*tail)->next;
3699         }
3700     (*tail)->value = value;
3701     ++(*count);
3702 }
3703
3704 static void mp_expand_wild_cards(pTHX_ char *item,
3705                               struct list_item **head,
3706                               struct list_item **tail,
3707                               int *count)
3708 {
3709 int expcount = 0;
3710 unsigned long int context = 0;
3711 int isunix = 0;
3712 char *had_version;
3713 char *had_device;
3714 int had_directory;
3715 char *devdir,*cp;
3716 char vmsspec[NAM$C_MAXRSS+1];
3717 $DESCRIPTOR(filespec, "");
3718 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3719 $DESCRIPTOR(resultspec, "");
3720 unsigned long int zero = 0, sts;
3721
3722     for (cp = item; *cp; cp++) {
3723         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3724         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3725     }
3726     if (!*cp || isspace(*cp))
3727         {
3728         add_item(head, tail, item, count);
3729         return;
3730         }
3731     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3732     resultspec.dsc$b_class = DSC$K_CLASS_D;
3733     resultspec.dsc$a_pointer = NULL;
3734     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3735       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3736     if (!isunix || !filespec.dsc$a_pointer)
3737       filespec.dsc$a_pointer = item;
3738     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3739     /*
3740      * Only return version specs, if the caller specified a version
3741      */
3742     had_version = strchr(item, ';');
3743     /*
3744      * Only return device and directory specs, if the caller specifed either.
3745      */
3746     had_device = strchr(item, ':');
3747     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3748     
3749     while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3750                                   &defaultspec, 0, 0, &zero))))
3751         {
3752         char *string;
3753         char *c;
3754
3755         New(1305,string,resultspec.dsc$w_length+1,char);
3756         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3757         string[resultspec.dsc$w_length] = '\0';
3758         if (NULL == had_version)
3759             *((char *)strrchr(string, ';')) = '\0';
3760         if ((!had_directory) && (had_device == NULL))
3761             {
3762             if (NULL == (devdir = strrchr(string, ']')))
3763                 devdir = strrchr(string, '>');
3764             strcpy(string, devdir + 1);
3765             }
3766         /*
3767          * Be consistent with what the C RTL has already done to the rest of
3768          * the argv items and lowercase all of these names.
3769          */
3770         for (c = string; *c; ++c)
3771             if (isupper(*c))
3772                 *c = tolower(*c);
3773         if (isunix) trim_unixpath(string,item,1);
3774         add_item(head, tail, string, count);
3775         ++expcount;
3776         }
3777     if (sts != RMS$_NMF)
3778         {
3779         set_vaxc_errno(sts);
3780         switch (sts)
3781             {
3782             case RMS$_FNF: case RMS$_DNF:
3783                 set_errno(ENOENT); break;
3784             case RMS$_DIR:
3785                 set_errno(ENOTDIR); break;
3786             case RMS$_DEV:
3787                 set_errno(ENODEV); break;
3788             case RMS$_FNM: case RMS$_SYN:
3789                 set_errno(EINVAL); break;
3790             case RMS$_PRV:
3791                 set_errno(EACCES); break;
3792             default:
3793                 _ckvmssts_noperl(sts);
3794             }
3795         }
3796     if (expcount == 0)
3797         add_item(head, tail, item, count);
3798     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3799     _ckvmssts_noperl(lib$find_file_end(&context));
3800 }
3801
3802 static int child_st[2];/* Event Flag set when child process completes   */
3803
3804 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
3805
3806 static unsigned long int exit_handler(int *status)
3807 {
3808 short iosb[4];
3809
3810     if (0 == child_st[0])
3811         {
3812 #ifdef ARGPROC_DEBUG
3813         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3814 #endif
3815         fflush(stdout);     /* Have to flush pipe for binary data to    */
3816                             /* terminate properly -- <tp@mccall.com>    */
3817         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3818         sys$dassgn(child_chan);
3819         fclose(stdout);
3820         sys$synch(0, child_st);
3821         }
3822     return(1);
3823 }
3824
3825 static void sig_child(int chan)
3826 {
3827 #ifdef ARGPROC_DEBUG
3828     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3829 #endif
3830     if (child_st[0] == 0)
3831         child_st[0] = 1;
3832 }
3833
3834 static struct exit_control_block exit_block =
3835     {
3836     0,
3837     exit_handler,
3838     1,
3839     &exit_block.exit_status,
3840     0
3841     };
3842
3843 static void pipe_and_fork(pTHX_ char **cmargv)
3844 {
3845     char subcmd[2048];
3846     $DESCRIPTOR(cmddsc, "");
3847     static char mbxname[64];
3848     $DESCRIPTOR(mbxdsc, mbxname);
3849     int pid, j;
3850     unsigned long int zero = 0, one = 1;
3851
3852     strcpy(subcmd, cmargv[0]);
3853     for (j = 1; NULL != cmargv[j]; ++j)
3854         {
3855         strcat(subcmd, " \"");
3856         strcat(subcmd, cmargv[j]);
3857         strcat(subcmd, "\"");
3858         }
3859     cmddsc.dsc$a_pointer = subcmd;
3860     cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3861
3862         create_mbx(aTHX_ &child_chan,&mbxdsc);
3863 #ifdef ARGPROC_DEBUG
3864     PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3865     PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3866 #endif
3867     _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3868                                0, &pid, child_st, &zero, sig_child,
3869                                &child_chan));
3870 #ifdef ARGPROC_DEBUG
3871     PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3872 #endif
3873     sys$dclexh(&exit_block);
3874     if (NULL == freopen(mbxname, "wb", stdout))
3875         {
3876         PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3877         }
3878 }
3879
3880 static int background_process(int argc, char **argv)
3881 {
3882 char command[2048] = "$";
3883 $DESCRIPTOR(value, "");
3884 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3885 static $DESCRIPTOR(null, "NLA0:");
3886 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3887 char pidstring[80];
3888 $DESCRIPTOR(pidstr, "");
3889 int pid;
3890 unsigned long int flags = 17, one = 1, retsts;
3891
3892     strcat(command, argv[0]);
3893     while (--argc)
3894         {
3895         strcat(command, " \"");
3896         strcat(command, *(++argv));
3897         strcat(command, "\"");
3898         }
3899     value.dsc$a_pointer = command;
3900     value.dsc$w_length = strlen(value.dsc$a_pointer);
3901     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3902     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3903     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3904         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3905     }
3906     else {
3907         _ckvmssts_noperl(retsts);
3908     }
3909 #ifdef ARGPROC_DEBUG
3910     PerlIO_printf(Perl_debug_log, "%s\n", command);
3911 #endif
3912     sprintf(pidstring, "%08X", pid);
3913     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3914     pidstr.dsc$a_pointer = pidstring;
3915     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3916     lib$set_symbol(&pidsymbol, &pidstr);
3917     return(SS$_NORMAL);
3918 }
3919 /*}}}*/
3920 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3921
3922
3923 /* OS-specific initialization at image activation (not thread startup) */
3924 /* Older VAXC header files lack these constants */
3925 #ifndef JPI$_RIGHTS_SIZE
3926 #  define JPI$_RIGHTS_SIZE 817
3927 #endif
3928 #ifndef KGB$M_SUBSYSTEM
3929 #  define KGB$M_SUBSYSTEM 0x8
3930 #endif
3931
3932 /*{{{void vms_image_init(int *, char ***)*/
3933 void
3934 vms_image_init(int *argcp, char ***argvp)
3935 {
3936   char eqv[LNM$C_NAMLENGTH+1] = "";
3937   unsigned int len, tabct = 8, tabidx = 0;
3938   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3939   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3940   unsigned short int dummy, rlen;
3941   struct dsc$descriptor_s **tabvec;
3942 #if defined(PERL_IMPLICIT_CONTEXT)
3943   pTHX = NULL;
3944 #endif
3945   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
3946                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
3947                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3948                                  {          0,                0,    0,      0} };
3949
3950   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3951   _ckvmssts_noperl(iosb[0]);
3952   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3953     if (iprv[i]) {           /* Running image installed with privs? */
3954       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
3955       will_taint = TRUE;
3956       break;
3957     }
3958   }
3959   /* Rights identifiers might trigger tainting as well. */
3960   if (!will_taint && (rlen || rsz)) {
3961     while (rlen < rsz) {
3962       /* We didn't get all the identifiers on the first pass.  Allocate a
3963        * buffer much larger than $GETJPI wants (rsz is size in bytes that
3964        * were needed to hold all identifiers at time of last call; we'll
3965        * allocate that many unsigned long ints), and go back and get 'em.
3966        * If it gave us less than it wanted to despite ample buffer space, 
3967        * something's broken.  Is your system missing a system identifier?
3968        */
3969       if (rsz <= jpilist[1].buflen) { 
3970          /* Perl_croak accvios when used this early in startup. */
3971          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s", 
3972                          rsz, (unsigned long) jpilist[1].buflen,
3973                          "Check your rights database for corruption.\n");
3974          exit(SS$_ABORT);
3975       }
3976       if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3977       jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3978       jpilist[1].buflen = rsz * sizeof(unsigned long int);
3979       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3980       _ckvmssts_noperl(iosb[0]);
3981     }
3982     mask = jpilist[1].bufadr;
3983     /* Check attribute flags for each identifier (2nd longword); protected
3984      * subsystem identifiers trigger tainting.
3985      */
3986     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3987       if (mask[i] & KGB$M_SUBSYSTEM) {
3988         will_taint = TRUE;
3989         break;
3990       }
3991     }
3992     if (mask != rlst) Safefree(mask);
3993   }
3994   /* We need to use this hack to tell Perl it should run with tainting,
3995    * since its tainting flag may be part of the PL_curinterp struct, which
3996    * hasn't been allocated when vms_image_init() is called.
3997    */
3998   if (will_taint) {
3999     char ***newap;
4000     New(1320,newap,*argcp+2,char **);
4001     newap[0] = argvp[0];
4002     *newap[1] = "-T";
4003     Copy(argvp[1],newap[2],*argcp-1,char **);
4004     /* We orphan the old argv, since we don't know where it's come from,
4005      * so we don't know how to free it.
4006      */
4007     *argcp++; argvp = newap;
4008   }
4009   else {  /* Did user explicitly request tainting? */
4010     int i;
4011     char *cp, **av = *argvp;
4012     for (i = 1; i < *argcp; i++) {
4013       if (*av[i] != '-') break;
4014       for (cp = av[i]+1; *cp; cp++) {
4015         if (*cp == 'T') { will_taint = 1; break; }
4016         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4017                   strchr("DFIiMmx",*cp)) break;
4018       }
4019       if (will_taint) break;
4020     }
4021   }
4022
4023   for (tabidx = 0;
4024        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4025        tabidx++) {
4026     if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4027     else if (tabidx >= tabct) {
4028       tabct += 8;
4029       Renew(tabvec,tabct,struct dsc$descriptor_s *);
4030     }
4031     New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4032     tabvec[tabidx]->dsc$w_length  = 0;
4033     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
4034     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
4035     tabvec[tabidx]->dsc$a_pointer = NULL;
4036     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4037   }
4038   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4039
4040   getredirection(argcp,argvp);
4041 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4042   {
4043 # include <reentrancy.h>
4044   (void) decc$set_reentrancy(C$C_MULTITHREAD);
4045   }
4046 #endif
4047   return;
4048 }
4049 /*}}}*/
4050
4051
4052 /* trim_unixpath()
4053  * Trim Unix-style prefix off filespec, so it looks like what a shell
4054  * glob expansion would return (i.e. from specified prefix on, not
4055  * full path).  Note that returned filespec is Unix-style, regardless
4056  * of whether input filespec was VMS-style or Unix-style.
4057  *
4058  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4059  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
4060  * vector of options; at present, only bit 0 is used, and if set tells
4061  * trim unixpath to try the current default directory as a prefix when
4062  * presented with a possibly ambiguous ... wildcard.
4063  *
4064  * Returns !=0 on success, with trimmed filespec replacing contents of
4065  * fspec, and 0 on failure, with contents of fpsec unchanged.
4066  */
4067 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4068 int
4069 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4070 {
4071   char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4072        *template, *base, *end, *cp1, *cp2;
4073   register int tmplen, reslen = 0, dirs = 0;
4074
4075   if (!wildspec || !fspec) return 0;
4076   if (strpbrk(wildspec,"]>:") != NULL) {
4077     if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4078     else template = unixwild;
4079   }
4080   else template = wildspec;
4081   if (strpbrk(fspec,"]>:") != NULL) {
4082     if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4083     else base = unixified;
4084     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4085      * check to see that final result fits into (isn't longer than) fspec */
4086     reslen = strlen(fspec);
4087   }
4088   else base = fspec;
4089
4090   /* No prefix or absolute path on wildcard, so nothing to remove */
4091   if (!*template || *template == '/') {
4092     if (base == fspec) return 1;
4093     tmplen = strlen(unixified);
4094     if (tmplen > reslen) return 0;  /* not enough space */
4095     /* Copy unixified resultant, including trailing NUL */
4096     memmove(fspec,unixified,tmplen+1);
4097     return 1;
4098   }
4099
4100   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
4101   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4102     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4103     for (cp1 = end ;cp1 >= base; cp1--)
4104       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4105         { cp1++; break; }
4106     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4107     return 1;
4108   }
4109   else {
4110     char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4111     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4112     int ells = 1, totells, segdirs, match;
4113     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4114                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4115
4116     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4117     totells = ells;
4118     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4119     if (ellipsis == template && opts & 1) {
4120       /* Template begins with an ellipsis.  Since we can't tell how many
4121        * directory names at the front of the resultant to keep for an
4122        * arbitrary starting point, we arbitrarily choose the current
4123        * default directory as a starting point.  If it's there as a prefix,
4124        * clip it off.  If not, fall through and act as if the leading
4125        * ellipsis weren't there (i.e. return shortest possible path that
4126        * could match template).
4127        */
4128       if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4129       for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4130         if (_tolower(*cp1) != _tolower(*cp2)) break;
4131       segdirs = dirs - totells;  /* Min # of dirs we must have left */
4132       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4133       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4134         memcpy(fspec,cp2+1,end - cp2);
4135         return 1;
4136       }
4137     }
4138     /* First off, back up over constant elements at end of path */
4139     if (dirs) {
4140       for (front = end ; front >= base; front--)
4141          if (*front == '/' && !dirs--) { front++; break; }
4142     }
4143     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4144          cp1++,cp2++) *cp2 = _tolower(*cp1);  /* Make lc copy for match */
4145     if (cp1 != '\0') return 0;  /* Path too long. */
4146     lcend = cp2;
4147     *cp2 = '\0';  /* Pick up with memcpy later */
4148     lcfront = lcres + (front - base);
4149     /* Now skip over each ellipsis and try to match the path in front of it. */
4150     while (ells--) {
4151       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4152         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
4153             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
4154       if (cp1 < template) break; /* template started with an ellipsis */
4155       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4156         ellipsis = cp1; continue;
4157       }
4158       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4159       nextell = cp1;
4160       for (segdirs = 0, cp2 = tpl;
4161            cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4162            cp1++, cp2++) {
4163          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4164          else *cp2 = _tolower(*cp1);  /* else lowercase for match */
4165          if (*cp2 == '/') segdirs++;
4166       }
4167       if (cp1 != ellipsis - 1) return 0; /* Path too long */
4168       /* Back up at least as many dirs as in template before matching */
4169       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4170         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4171       for (match = 0; cp1 > lcres;) {
4172         resdsc.dsc$a_pointer = cp1;
4173         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) { 
4174           match++;
4175           if (match == 1) lcfront = cp1;
4176         }
4177         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4178       }
4179       if (!match) return 0;  /* Can't find prefix ??? */
4180       if (match > 1 && opts & 1) {
4181         /* This ... wildcard could cover more than one set of dirs (i.e.
4182          * a set of similar dir names is repeated).  If the template
4183          * contains more than 1 ..., upstream elements could resolve the
4184          * ambiguity, but it's not worth a full backtracking setup here.
4185          * As a quick heuristic, clip off the current default directory
4186          * if it's present to find the trimmed spec, else use the
4187          * shortest string that this ... could cover.
4188          */
4189         char def[NAM$C_MAXRSS+1], *st;
4190
4191         if (getcwd(def, sizeof def,0) == NULL) return 0;
4192         for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4193           if (_tolower(*cp1) != _tolower(*cp2)) break;
4194         segdirs = dirs - totells;  /* Min # of dirs we must have left */
4195         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4196         if (*cp1 == '\0' && *cp2 == '/') {
4197           memcpy(fspec,cp2+1,end - cp2);
4198           return 1;
4199         }
4200         /* Nope -- stick with lcfront from above and keep going. */
4201       }
4202     }
4203     memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4204     return 1;
4205     ellipsis = nextell;
4206   }
4207
4208 }  /* end of trim_unixpath() */
4209 /*}}}*/
4210
4211
4212 /*
4213  *  VMS readdir() routines.
4214  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4215  *
4216  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
4217  *  Minor modifications to original routines.
4218  */
4219
4220     /* Number of elements in vms_versions array */
4221 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
4222
4223 /*
4224  *  Open a directory, return a handle for later use.
4225  */
4226 /*{{{ DIR *opendir(char*name) */
4227 DIR *
4228 Perl_opendir(pTHX_ char *name)
4229 {
4230     DIR *dd;
4231     char dir[NAM$C_MAXRSS+1];
4232     Stat_t sb;
4233
4234     if (do_tovmspath(name,dir,0) == NULL) {
4235       return NULL;
4236     }
4237     if (flex_stat(dir,&sb) == -1) return NULL;
4238     if (!S_ISDIR(sb.st_mode)) {
4239       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
4240       return NULL;
4241     }
4242     if (!cando_by_name(S_IRUSR,0,dir)) {
4243       set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4244       return NULL;
4245     }
4246     /* Get memory for the handle, and the pattern. */
4247     New(1306,dd,1,DIR);
4248     New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4249
4250     /* Fill in the fields; mainly playing with the descriptor. */
4251     (void)sprintf(dd->pattern, "%s*.*",dir);
4252     dd->context = 0;
4253     dd->count = 0;
4254     dd->vms_wantversions = 0;
4255     dd->pat.dsc$a_pointer = dd->pattern;
4256     dd->pat.dsc$w_length = strlen(dd->pattern);
4257     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4258     dd->pat.dsc$b_class = DSC$K_CLASS_S;
4259
4260     return dd;
4261 }  /* end of opendir() */
4262 /*}}}*/
4263
4264 /*
4265  *  Set the flag to indicate we want versions or not.
4266  */
4267 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4268 void
4269 vmsreaddirversions(DIR *dd, int flag)
4270 {
4271     dd->vms_wantversions = flag;
4272 }
4273 /*}}}*/
4274
4275 /*
4276  *  Free up an opened directory.
4277  */
4278 /*{{{ void closedir(DIR *dd)*/
4279 void
4280 closedir(DIR *dd)
4281 {
4282     (void)lib$find_file_end(&dd->context);
4283     Safefree(dd->pattern);
4284     Safefree((char *)dd);
4285 }
4286 /*}}}*/
4287
4288 /*
4289  *  Collect all the version numbers for the current file.
4290  */
4291 static void
4292 collectversions(pTHX_ DIR *dd)
4293 {
4294     struct dsc$descriptor_s     pat;
4295     struct dsc$descriptor_s     res;
4296     struct dirent *e;
4297     char *p, *text, buff[sizeof dd->entry.d_name];
4298     int i;
4299     unsigned long context, tmpsts;
4300
4301     /* Convenient shorthand. */
4302     e = &dd->entry;
4303
4304     /* Add the version wildcard, ignoring the "*.*" put on before */
4305     i = strlen(dd->pattern);
4306     New(1308,text,i + e->d_namlen + 3,char);
4307     (void)strcpy(text, dd->pattern);
4308     (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4309
4310     /* Set up the pattern descriptor. */
4311     pat.dsc$a_pointer = text;
4312     pat.dsc$w_length = i + e->d_namlen - 1;
4313     pat.dsc$b_dtype = DSC$K_DTYPE_T;
4314     pat.dsc$b_class = DSC$K_CLASS_S;
4315
4316     /* Set up result descriptor. */
4317     res.dsc$a_pointer = buff;
4318     res.dsc$w_length = sizeof buff - 2;
4319     res.dsc$b_dtype = DSC$K_DTYPE_T;
4320     res.dsc$b_class = DSC$K_CLASS_S;
4321
4322     /* Read files, collecting versions. */
4323     for (context = 0, e->vms_verscount = 0;
4324          e->vms_verscount < VERSIZE(e);
4325          e->vms_verscount++) {
4326         tmpsts = lib$find_file(&pat, &res, &context);
4327         if (tmpsts == RMS$_NMF || context == 0) break;
4328         _ckvmssts(tmpsts);
4329         buff[sizeof buff - 1] = '\0';
4330         if ((p = strchr(buff, ';')))
4331             e->vms_versions[e->vms_verscount] = atoi(p + 1);
4332         else
4333             e->vms_versions[e->vms_verscount] = -1;
4334     }
4335
4336     _ckvmssts(lib$find_file_end(&context));
4337     Safefree(text);
4338
4339 }  /* end of collectversions() */
4340
4341 /*
4342  *  Read the next entry from the directory.
4343  */
4344 /*{{{ struct dirent *readdir(DIR *dd)*/
4345 struct dirent *
4346 Perl_readdir(pTHX_ DIR *dd)
4347 {
4348     struct dsc$descriptor_s     res;
4349     char *p, buff[sizeof dd->entry.d_name];
4350     unsigned long int tmpsts;
4351
4352     /* Set up result descriptor, and get next file. */
4353     res.dsc$a_pointer = buff;
4354     res.dsc$w_length = sizeof buff - 2;
4355     res.dsc$b_dtype = DSC$K_DTYPE_T;
4356     res.dsc$b_class = DSC$K_CLASS_S;
4357     tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4358     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
4359     if (!(tmpsts & 1)) {
4360       set_vaxc_errno(tmpsts);
4361       switch (tmpsts) {
4362         case RMS$_PRV:
4363           set_errno(EACCES); break;
4364         case RMS$_DEV:
4365           set_errno(ENODEV); break;
4366         case RMS$_DIR:
4367           set_errno(ENOTDIR); break;
4368         case RMS$_FNF: case RMS$_DNF:
4369           set_errno(ENOENT); break;
4370         default:
4371           set_errno(EVMSERR);
4372       }
4373       return NULL;
4374     }
4375     dd->count++;
4376     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4377     buff[sizeof buff - 1] = '\0';
4378     for (p = buff; *p; p++) *p = _tolower(*p);
4379     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
4380     *p = '\0';
4381
4382     /* Skip any directory component and just copy the name. */
4383     if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4384     else (void)strcpy(dd->entry.d_name, buff);
4385
4386     /* Clobber the version. */
4387     if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4388
4389     dd->entry.d_namlen = strlen(dd->entry.d_name);
4390     dd->entry.vms_verscount = 0;
4391     if (dd->vms_wantversions) collectversions(aTHX_ dd);
4392     return &dd->entry;
4393
4394 }  /* end of readdir() */
4395 /*}}}*/
4396
4397 /*
4398  *  Return something that can be used in a seekdir later.
4399  */
4400 /*{{{ long telldir(DIR *dd)*/
4401 long
4402 telldir(DIR *dd)
4403 {
4404     return dd->count;
4405 }
4406 /*}}}*/
4407
4408 /*
4409  *  Return to a spot where we used to be.  Brute force.
4410  */
4411 /*{{{ void seekdir(DIR *dd,long count)*/
4412 void
4413 Perl_seekdir(pTHX_ DIR *dd, long count)
4414 {
4415     int vms_wantversions;
4416
4417     /* If we haven't done anything yet... */
4418     if (dd->count == 0)
4419         return;
4420
4421     /* Remember some state, and clear it. */
4422     vms_wantversions = dd->vms_wantversions;
4423     dd->vms_wantversions = 0;
4424     _ckvmssts(lib$find_file_end(&dd->context));
4425     dd->context = 0;
4426
4427     /* The increment is in readdir(). */
4428     for (dd->count = 0; dd->count < count; )
4429         (void)readdir(dd);
4430
4431     dd->vms_wantversions = vms_wantversions;
4432
4433 }  /* end of seekdir() */
4434 /*}}}*/
4435
4436 /* VMS subprocess management
4437  *
4438  * my_vfork() - just a vfork(), after setting a flag to record that
4439  * the current script is trying a Unix-style fork/exec.
4440  *
4441  * vms_do_aexec() and vms_do_exec() are called in response to the
4442  * perl 'exec' function.  If this follows a vfork call, then they
4443  * call out the the regular perl routines in doio.c which do an
4444  * execvp (for those who really want to try this under VMS).
4445  * Otherwise, they do exactly what the perl docs say exec should
4446  * do - terminate the current script and invoke a new command
4447  * (See below for notes on command syntax.)
4448  *
4449  * do_aspawn() and do_spawn() implement the VMS side of the perl
4450  * 'system' function.
4451  *
4452  * Note on command arguments to perl 'exec' and 'system': When handled
4453  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4454  * are concatenated to form a DCL command string.  If the first arg
4455  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4456  * the the command string is handed off to DCL directly.  Otherwise,
4457  * the first token of the command is taken as the filespec of an image
4458  * to run.  The filespec is expanded using a default type of '.EXE' and
4459  * the process defaults for device, directory, etc., and if found, the resultant
4460  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4461  * the command string as parameters.  This is perhaps a bit complicated,
4462  * but I hope it will form a happy medium between what VMS folks expect
4463  * from lib$spawn and what Unix folks expect from exec.
4464  */
4465
4466 static int vfork_called;
4467
4468 /*{{{int my_vfork()*/
4469 int
4470 my_vfork()
4471 {
4472   vfork_called++;
4473   return vfork();
4474 }
4475 /*}}}*/
4476
4477
4478 static void
4479 vms_execfree(pTHX) {
4480   if (PL_Cmd) {
4481     if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4482     PL_Cmd = Nullch;
4483   }
4484   if (VMScmd.dsc$a_pointer) {
4485     Safefree(VMScmd.dsc$a_pointer);
4486     VMScmd.dsc$w_length = 0;
4487     VMScmd.dsc$a_pointer = Nullch;
4488   }
4489 }
4490
4491 static char *
4492 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4493 {
4494   char *junk, *tmps = Nullch;
4495   register size_t cmdlen = 0;
4496   size_t rlen;
4497   register SV **idx;
4498   STRLEN n_a;
4499
4500   idx = mark;
4501   if (really) {
4502     tmps = SvPV(really,rlen);
4503     if (*tmps) {
4504       cmdlen += rlen + 1;
4505       idx++;
4506     }
4507   }
4508   
4509   for (idx++; idx <= sp; idx++) {
4510     if (*idx) {
4511       junk = SvPVx(*idx,rlen);
4512       cmdlen += rlen ? rlen + 1 : 0;
4513     }
4514   }
4515   New(401,PL_Cmd,cmdlen+1,char);
4516
4517   if (tmps && *tmps) {
4518     strcpy(PL_Cmd,tmps);
4519     mark++;
4520   }
4521   else *PL_Cmd = '\0';
4522   while (++mark <= sp) {
4523     if (*mark) {
4524       char *s = SvPVx(*mark,n_a);
4525       if (!*s) continue;
4526       if (*PL_Cmd) strcat(PL_Cmd," ");
4527       strcat(PL_Cmd,s);
4528     }
4529   }
4530   return PL_Cmd;
4531
4532 }  /* end of setup_argstr() */
4533
4534
4535 static unsigned long int
4536 setup_cmddsc(pTHX_ char *cmd, int check_img)
4537 {
4538   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4539   $DESCRIPTOR(defdsc,".EXE");
4540   $DESCRIPTOR(defdsc2,".");
4541   $DESCRIPTOR(resdsc,resspec);
4542   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4543   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4544   register char *s, *rest, *cp, *wordbreak;
4545   register int isdcl;
4546
4547   if (strlen(cmd) >
4548       (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4549     return LIB$_INVARG;
4550   s = cmd;
4551   while (*s && isspace(*s)) s++;
4552
4553   if (*s == '@' || *s == '$') {
4554     vmsspec[0] = *s;  rest = s + 1;
4555     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4556   }
4557   else { cp = vmsspec; rest = s; }
4558   if (*rest == '.' || *rest == '/') {
4559     char *cp2;
4560     for (cp2 = resspec;
4561          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4562          rest++, cp2++) *cp2 = *rest;
4563     *cp2 = '\0';
4564     if (do_tovmsspec(resspec,cp,0)) { 
4565       s = vmsspec;
4566       if (*rest) {
4567         for (cp2 = vmsspec + strlen(vmsspec);
4568              *rest && cp2 - vmsspec < sizeof vmsspec;
4569              rest++, cp2++) *cp2 = *rest;
4570         *cp2 = '\0';
4571       }
4572     }
4573   }
4574   /* Intuit whether verb (first word of cmd) is a DCL command:
4575    *   - if first nonspace char is '@', it's a DCL indirection
4576    * otherwise
4577    *   - if verb contains a filespec separator, it's not a DCL command
4578    *   - if it doesn't, caller tells us whether to default to a DCL
4579    *     command, or to a local image unless told it's DCL (by leading '$')
4580    */
4581   if (*s == '@') isdcl = 1;
4582   else {
4583     register char *filespec = strpbrk(s,":<[.;");
4584     rest = wordbreak = strpbrk(s," \"\t/");
4585     if (!wordbreak) wordbreak = s + strlen(s);
4586     if (*s == '$') check_img = 0;
4587     if (filespec && (filespec < wordbreak)) isdcl = 0;
4588     else isdcl = !check_img;
4589   }
4590
4591   if (!isdcl) {
4592     imgdsc.dsc$a_pointer = s;
4593     imgdsc.dsc$w_length = wordbreak - s;
4594     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4595     if (!(retsts&1)) {
4596         _ckvmssts(lib$find_file_end(&cxt));
4597         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4598     if (!(retsts & 1) && *s == '$') {
4599           _ckvmssts(lib$find_file_end(&cxt));
4600       imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4601       retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4602           if (!(retsts&1)) {
4603       _ckvmssts(lib$find_file_end(&cxt));
4604             retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4605           }
4606     }
4607     }
4608     _ckvmssts(lib$find_file_end(&cxt));
4609
4610     if (retsts & 1) {
4611       FILE *fp;
4612       s = resspec;
4613       while (*s && !isspace(*s)) s++;
4614       *s = '\0';
4615
4616       /* check that it's really not DCL with no file extension */
4617       fp = fopen(resspec,"r","ctx=bin,shr=get");
4618       if (fp) {
4619         char b[4] = {0,0,0,0};
4620         read(fileno(fp),b,4);
4621         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4622         fclose(fp);
4623       }
4624       if (check_img && isdcl) return RMS$_FNF;
4625
4626       if (cando_by_name(S_IXUSR,0,resspec)) {
4627         New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4628         if (!isdcl) {
4629         strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4630         } else {
4631             strcpy(VMScmd.dsc$a_pointer,"@");
4632         }
4633         strcat(VMScmd.dsc$a_pointer,resspec);
4634         if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4635         VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4636         return retsts;
4637       }
4638       else retsts = RMS$_PRV;
4639     }
4640   }
4641   /* It's either a DCL command or we couldn't find a suitable image */
4642   VMScmd.dsc$w_length = strlen(cmd);
4643   if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4644   else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4645   if (!(retsts & 1)) {
4646     /* just hand off status values likely to be due to user error */
4647     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4648         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4649        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4650     else { _ckvmssts(retsts); }
4651   }
4652
4653   return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4654
4655 }  /* end of setup_cmddsc() */
4656
4657
4658 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4659 bool
4660 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4661 {
4662   if (sp > mark) {
4663     if (vfork_called) {           /* this follows a vfork - act Unixish */
4664       vfork_called--;
4665       if (vfork_called < 0) {
4666         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4667         vfork_called = 0;
4668       }
4669       else return do_aexec(really,mark,sp);
4670     }
4671                                            /* no vfork - act VMSish */
4672     return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4673
4674   }
4675
4676   return FALSE;
4677 }  /* end of vms_do_aexec() */
4678 /*}}}*/
4679
4680 /* {{{bool vms_do_exec(char *cmd) */
4681 bool
4682 Perl_vms_do_exec(pTHX_ char *cmd)
4683 {
4684
4685   if (vfork_called) {             /* this follows a vfork - act Unixish */
4686     vfork_called--;
4687     if (vfork_called < 0) {
4688       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4689       vfork_called = 0;
4690     }
4691     else return do_exec(cmd);
4692   }
4693
4694   {                               /* no vfork - act VMSish */
4695     unsigned long int retsts;
4696
4697     TAINT_ENV();
4698     TAINT_PROPER("exec");
4699     if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4700       retsts = lib$do_command(&VMScmd);
4701
4702     switch (retsts) {
4703       case RMS$_FNF: case RMS$_DNF:
4704         set_errno(ENOENT); break;
4705       case RMS$_DIR:
4706         set_errno(ENOTDIR); break;
4707       case RMS$_DEV:
4708         set_errno(ENODEV); break;
4709       case RMS$_PRV:
4710         set_errno(EACCES); break;
4711       case RMS$_SYN:
4712         set_errno(EINVAL); break;
4713       case CLI$_BUFOVF:
4714         set_errno(E2BIG); break;
4715       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4716         _ckvmssts(retsts); /* fall through */
4717       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4718         set_errno(EVMSERR); 
4719     }
4720     set_vaxc_errno(retsts);
4721     if (ckWARN(WARN_EXEC)) {
4722       Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4723              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));