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