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