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