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