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