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