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