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