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