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