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