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