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