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