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