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