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