This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Declaration nit in vms.c's Perl_my_fwrite.
[perl5.git] / vms / vms.c
CommitLineData
b429d381 1/* vms.c
a0d0e21e 2 *
82dd182c 3 * VMS-specific routines for perl5
748a9306 4 *
82dd182c
CB		 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.
a0d0e21e
LW		 12 */
13
7c884029 14/*
4ac71550
TC		 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
7c884029 22 *
4ac71550 23 * [p.162 of _The Lays of Beleriand_]
7c884029
CB		 24 */
25
a0d0e21e
LW		 26#include <acedef.h>
27#include <acldef.h>
28#include <armdef.h>
748a9306 29#include <atrdef.h>
a0d0e21e 30#include <chpdef.h>
8fde5078 31#include <clidef.h>
a3e9d8c9 32#include <climsgdef.h>
cd1191f1 33#include <dcdef.h>
a0d0e21e 34#include <descrip.h>
22d4bb9c 35#include <devdef.h>
a0d0e21e 36#include <dvidef.h>
748a9306 37#include <fibdef.h>
a0d0e21e
LW		 38#include <float.h>
39#include <fscndef.h>
40#include <iodef.h>
41#include <jpidef.h>
61bb5906 42#include <kgbdef.h>
f675dbe5 43#include <libclidef.h>
a0d0e21e
LW		 44#include <libdef.h>
45#include <lib$routines.h>
46#include <lnmdef.h>
aeb5cf3c 47#include <msgdef.h>
4fdf8f88 48#include <ossdef.h>
f7ddb74a
JM		 49#if __CRTL_VER >= 70301000 && !defined(__VAX)
50#include <ppropdef.h>
51#endif
748a9306 52#include <prvdef.h>
a0d0e21e
LW		 53#include <psldef.h>
54#include <rms.h>
55#include <shrdef.h>
56#include <ssdef.h>
57#include <starlet.h>
f86702cc 58#include <strdef.h>
59#include <str$routines.h>
a0d0e21e 60#include <syidef.h>
748a9306
LW		 61#include <uaidef.h>
62#include <uicdef.h>
2fbb330f
JM		 63#include <stsdef.h>
64#include <rmsdef.h>
cd1191f1 65#include <smgdef.h>
cfcfe586
JM		 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
a0d0e21e 72
f7ddb74a
JM		 73#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
74int decc$feature_get_index(const char *name);
75char* decc$feature_get_name(int index);
76int decc$feature_get_value(int index, int mode);
77int decc$feature_set_value(int index, int mode, int value);
78#else
79#include <unixlib.h>
80#endif
81
cfcfe586
JM		 82#pragma member_alignment save
83#pragma nomember_alignment longword
84struct 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
cfcfe586
JM		 97int 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);
7566800d 106#endif
cfcfe586 107
4fdf8f88
JM		 108#ifdef sys$get_security
109#undef sys$get_security
110int 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
122int 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
8cb5d3d5
JM		 132#ifdef lib$find_image_symbol
133#undef lib$find_image_symbol
134int 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);
4fdf8f88 140#endif
8cb5d3d5 141
4fdf8f88
JM		 142#ifdef lib$rename_file
143#undef lib$rename_file
144int 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);
8cb5d3d5
JM		 167#endif
168
7a7fd8e0 169#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 170
171static 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
188return 0;
189}
190#endif
f7ddb74a 191
740ce14c 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
b7ae7a0d 197# define SS$_NOSUCHOBJECT 2696
198#endif
199
a15cef0c
CB		 200/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
201#define PERLIO_NOT_STDIO 0
202
2497a41f 203/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 204 * code below needs to get to the underlying CRTL routines. */
205#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 206#include "EXTERN.h"
207#include "perl.h"
748a9306 208#include "XSUB.h"
3eeba6fb
CB		 209/* Anticipating future expansion in lexical warnings . . . */
210#ifndef WARN_INTERNAL
211# define WARN_INTERNAL WARN_MISC
212#endif
a0d0e21e 213
988c775c
JM		 214#ifdef VMS_LONGNAME_SUPPORT
215#include <libfildef.h>
216#endif
217
22d4bb9c
CB		 218#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
219# define RTL_USES_UTC 1
220#endif
221
58472d87
CB		 222#if !defined(__VAX) && __CRTL_VER >= 80200000
223#ifdef lstat
224#undef lstat
225#endif
226#else
227#ifdef lstat
228#undef lstat
229#endif
230#define lstat(_x, _y) stat(_x, _y)
231#endif
232
5f1992ed
CB		 233/* Routine to create a decterm for use with the Perl debugger */
234/* No headers, this information was found in the Programming Concepts Manual */
235
8cb5d3d5 236static int (*decw_term_port)
5f1992ed
CB		 237 (const struct dsc$descriptor_s * display,
238 const struct dsc$descriptor_s * setup_file,
239 const struct dsc$descriptor_s * customization,
240 struct dsc$descriptor_s * result_device_name,
241 unsigned short * result_device_name_length,
242 void * controller,
243 void * char_buffer,
8cb5d3d5 244 void * char_change_buffer) = 0;
22d4bb9c 245
c07a80fd 246/* gcc's header files don't #define direct access macros
247 * corresponding to VAXC's variant structs */
248#ifdef __GNUC__
482b294c 249# define uic$v_format uic$r_uic_form.uic$v_format
250# define uic$v_group uic$r_uic_form.uic$v_group
251# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 252# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
253# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
254# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
255# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
256#endif
257
c645ec3f
GS		 258#if defined(NEED_AN_H_ERRNO)
259dEXT int h_errno;
260#endif
c07a80fd 261
f7ddb74a
JM		 262#ifdef __DECC
263#pragma message disable pragma
264#pragma member_alignment save
265#pragma nomember_alignment longword
266#pragma message save
267#pragma message disable misalgndmem
268#endif
a0d0e21e
LW		 269struct itmlst_3 {
270 unsigned short int buflen;
271 unsigned short int itmcode;
272 void *bufadr;
748a9306 273 unsigned short int *retlen;
a0d0e21e 274};
657054d4
JM		 275
276struct filescan_itmlst_2 {
277 unsigned short length;
278 unsigned short itmcode;
279 char * component;
280};
281
dca5a913
JM		 282struct vs_str_st {
283 unsigned short length;
284 char str[65536];
285};
286
f7ddb74a
JM		 287#ifdef __DECC
288#pragma message restore
289#pragma member_alignment restore
290#endif
a0d0e21e 291
360732b5
JM		 292#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
293#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
294#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
295#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
296#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
297#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 298#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 299#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
300#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 301#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 302#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
303#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
304
360732b5
JM		 305static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
306static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
307static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
308static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 309
6fb6c614
JM		 310static char * int_rmsexpand_vms(
311 const char * filespec, char * outbuf, unsigned opts);
312static char * int_rmsexpand_tovms(
313 const char * filespec, char * outbuf, unsigned opts);
df278665
JM		 314static char *int_tovmsspec
315 (const char *path, char *buf, int dir_flag, int * utf8_flag);
a979ce91 316static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
0e5ce2c7 317static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
4846f1d7 318static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
df278665 319
0e06870b
CB		 320/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
321#define PERL_LNM_MAX_ALLOWED_INDEX 127
322
2d9f3838
CB		 323/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
324 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
325 * the Perl facility.
326 */
327#define PERL_LNM_MAX_ITER 10
328
2497a41f
JM		 329 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
330#if __CRTL_VER >= 70302000 && !defined(__VAX)
331#define MAX_DCL_SYMBOL (8192)
332#define MAX_DCL_LINE_LENGTH (4096 - 4)
333#else
334#define MAX_DCL_SYMBOL (1024)
335#define MAX_DCL_LINE_LENGTH (1024 - 4)
336#endif
ff7adb52 337
01b8edb6 338static char *__mystrtolower(char *str)
339{
340 if (str) for (; *str; ++str) *str= tolower(*str);
341 return str;
342}
343
f675dbe5
CB		 344static struct dsc$descriptor_s fildevdsc =
345 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
346static struct dsc$descriptor_s crtlenvdsc =
347 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
348static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
349static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
350static struct dsc$descriptor_s **env_tables = defenv;
351static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
352
93948341
CB		 353/* True if we shouldn't treat barewords as logicals during directory */
354/* munching */
355static int no_translate_barewords;
356
22d4bb9c
CB		 357#ifndef RTL_USES_UTC
358static int tz_updated = 1;
359#endif
360
f7ddb74a
JM		 361/* DECC Features that may need to affect how Perl interprets
362 * displays filename information
363 */
364static int decc_disable_to_vms_logname_translation = 1;
365static int decc_disable_posix_root = 1;
366int decc_efs_case_preserve = 0;
367static int decc_efs_charset = 0;
b53f3677 368static int decc_efs_charset_index = -1;
f7ddb74a
JM		 369static int decc_filename_unix_no_version = 0;
370static int decc_filename_unix_only = 0;
371int decc_filename_unix_report = 0;
372int decc_posix_compliant_pathnames = 0;
373int decc_readdir_dropdotnotype = 0;
374static int vms_process_case_tolerant = 1;
360732b5
JM		 375int vms_vtf7_filenames = 0;
376int gnv_unix_shell = 0;
e0e5e8d6 377static int vms_unlink_all_versions = 0;
1a3aec58 378static int vms_posix_exit = 0;
f7ddb74a 379
2497a41f 380/* bug workarounds if needed */
682e4b71 381int decc_bug_devnull = 1;
2497a41f 382int decc_dir_barename = 0;
b53f3677 383int vms_bug_stat_filename = 0;
2497a41f 384
9c1171d1 385static int vms_debug_on_exception = 0;
b53f3677
JM		 386static int vms_debug_fileify = 0;
387
388/* Simple logical name translation */
389static int simple_trnlnm
390 (const char * logname,
391 char * value,
392 int value_len)
393{
394 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
395 const unsigned long attr = LNM$M_CASE_BLIND;
396 struct dsc$descriptor_s name_dsc;
397 int status;
398 unsigned short result;
399 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
400 {0, 0, 0, 0}};
401
402 name_dsc.dsc$w_length = strlen(logname);
403 name_dsc.dsc$a_pointer = (char *)logname;
404 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
405 name_dsc.dsc$b_class = DSC$K_CLASS_S;
406
407 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
408
409 if ($VMS_STATUS_SUCCESS(status)) {
410
411 /* Null terminate and return the string */
412 /*--------------------------------------*/
413 value[result] = 0;
414 return result;
415 }
416
417 return 0;
418}
419
9c1171d1 420
f7ddb74a
JM		 421/* Is this a UNIX file specification?
422 * No longer a simple check with EFS file specs
423 * For now, not a full check, but need to
424 * handle POSIX ^UP^ specifications
425 * Fixing to handle ^/ cases would require
426 * changes to many other conversion routines.
427 */
428
657054d4 429static int is_unix_filespec(const char *path)
f7ddb74a
JM		 430{
431int ret_val;
432const char * pch1;
433
434 ret_val = 0;
435 if (strncmp(path,"\"^UP^",5) != 0) {
436 pch1 = strchr(path, '/');
437 if (pch1 != NULL)
438 ret_val = 1;
439 else {
440
441 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
442 if (decc_filename_unix_report || decc_filename_unix_only) {
443 if (strcmp(path,".") == 0)
444 ret_val = 1;
445 }
446 }
447 }
448 return ret_val;
449}
450
360732b5
JM		 451/* This routine converts a UCS-2 character to be VTF-7 encoded.
452 */
453
454static void ucs2_to_vtf7
455 (char *outspec,
456 unsigned long ucs2_char,
457 int * output_cnt)
458{
459unsigned char * ucs_ptr;
460int hex;
461
462 ucs_ptr = (unsigned char *)&ucs2_char;
463
464 outspec[0] = '^';
465 outspec[1] = 'U';
466 hex = (ucs_ptr[1] >> 4) & 0xf;
467 if (hex < 0xA)
468 outspec[2] = hex + '0';
469 else
470 outspec[2] = (hex - 9) + 'A';
471 hex = ucs_ptr[1] & 0xF;
472 if (hex < 0xA)
473 outspec[3] = hex + '0';
474 else {
475 outspec[3] = (hex - 9) + 'A';
476 }
477 hex = (ucs_ptr[0] >> 4) & 0xf;
478 if (hex < 0xA)
479 outspec[4] = hex + '0';
480 else
481 outspec[4] = (hex - 9) + 'A';
482 hex = ucs_ptr[1] & 0xF;
483 if (hex < 0xA)
484 outspec[5] = hex + '0';
485 else {
486 outspec[5] = (hex - 9) + 'A';
487 }
488 *output_cnt = 6;
489}
490
491
492/* This handles the conversion of a UNIX extended character set to a ^
493 * escaped VMS character.
494 * in a UNIX file specification.
495 *
496 * The output count variable contains the number of characters added
497 * to the output string.
498 *
499 * The return value is the number of characters read from the input string
500 */
501static int copy_expand_unix_filename_escape
502 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
503{
504int count;
505int scnt;
506int utf8_flag;
507
508 utf8_flag = 0;
509 if (utf8_fl)
510 utf8_flag = *utf8_fl;
511
512 count = 0;
513 *output_cnt = 0;
514 if (*inspec >= 0x80) {
515 if (utf8_fl && vms_vtf7_filenames) {
516 unsigned long ucs_char;
517
518 ucs_char = 0;
519
520 if ((*inspec & 0xE0) == 0xC0) {
521 /* 2 byte Unicode */
522 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
523 if (ucs_char >= 0x80) {
524 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
525 return 2;
526 }
527 } else if ((*inspec & 0xF0) == 0xE0) {
528 /* 3 byte Unicode */
529 ucs_char = ((inspec[0] & 0xF) << 12) +
530 ((inspec[1] & 0x3f) << 6) +
531 (inspec[2] & 0x3f);
532 if (ucs_char >= 0x800) {
533 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
534 return 3;
535 }
536
537#if 0 /* I do not see longer sequences supported by OpenVMS */
538 /* Maybe some one can fix this later */
539 } else if ((*inspec & 0xF8) == 0xF0) {
540 /* 4 byte Unicode */
541 /* UCS-4 to UCS-2 */
542 } else if ((*inspec & 0xFC) == 0xF8) {
543 /* 5 byte Unicode */
544 /* UCS-4 to UCS-2 */
545 } else if ((*inspec & 0xFE) == 0xFC) {
546 /* 6 byte Unicode */
547 /* UCS-4 to UCS-2 */
548#endif
549 }
550 }
551
38a44b82 552 /* High bit set, but not a Unicode character! */
360732b5
JM		 553
554 /* Non printing DECMCS or ISO Latin-1 character? */
555 if (*inspec <= 0x9F) {
556 int hex;
557 outspec[0] = '^';
558 outspec++;
559 hex = (*inspec >> 4) & 0xF;
560 if (hex < 0xA)
561 outspec[1] = hex + '0';
562 else {
563 outspec[1] = (hex - 9) + 'A';
564 }
565 hex = *inspec & 0xF;
566 if (hex < 0xA)
567 outspec[2] = hex + '0';
568 else {
569 outspec[2] = (hex - 9) + 'A';
570 }
571 *output_cnt = 3;
572 return 1;
573 } else if (*inspec == 0xA0) {
574 outspec[0] = '^';
575 outspec[1] = 'A';
576 outspec[2] = '0';
577 *output_cnt = 3;
578 return 1;
579 } else if (*inspec == 0xFF) {
580 outspec[0] = '^';
581 outspec[1] = 'F';
582 outspec[2] = 'F';
583 *output_cnt = 3;
584 return 1;
585 }
586 *outspec = *inspec;
587 *output_cnt = 1;
588 return 1;
589 }
590
591 /* Is this a macro that needs to be passed through?
592 * Macros start with $( and an alpha character, followed
593 * by a string of alpha numeric characters ending with a )
594 * If this does not match, then encode it as ODS-5.
595 */
596 if ((inspec[0] == '$') && (inspec[1] == '(')) {
597 int tcnt;
598
599 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
600 tcnt = 3;
601 outspec[0] = inspec[0];
602 outspec[1] = inspec[1];
603 outspec[2] = inspec[2];
604
605 while(isalnum(inspec[tcnt]) ||
606 (inspec[2] == '.') || (inspec[2] == '_')) {
607 outspec[tcnt] = inspec[tcnt];
608 tcnt++;
609 }
610 if (inspec[tcnt] == ')') {
611 outspec[tcnt] = inspec[tcnt];
612 tcnt++;
613 *output_cnt = tcnt;
614 return tcnt;
615 }
616 }
617 }
618
619 switch (*inspec) {
620 case 0x7f:
621 outspec[0] = '^';
622 outspec[1] = '7';
623 outspec[2] = 'F';
624 *output_cnt = 3;
625 return 1;
626 break;
627 case '?':
628 if (decc_efs_charset == 0)
629 outspec[0] = '%';
630 else
631 outspec[0] = '?';
632 *output_cnt = 1;
633 return 1;
634 break;
635 case '.':
636 case '~':
637 case '!':
638 case '#':
639 case '&':
640 case '\'':
641 case '`':
642 case '(':
643 case ')':
644 case '+':
645 case '@':
646 case '{':
647 case '}':
648 case ',':
649 case ';':
650 case '[':
651 case ']':
652 case '%':
653 case '^':
449de3c2 654 case '\\':
adc11f0b
CB		 655 /* Don't escape again if following character is
656 * already something we escape.
657 */
449de3c2 658 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 659 *outspec = *inspec;
660 *output_cnt = 1;
661 return 1;
662 break;
663 }
664 /* But otherwise fall through and escape it. */
360732b5
JM		 665 case '=':
666 /* Assume that this is to be escaped */
667 outspec[0] = '^';
668 outspec[1] = *inspec;
669 *output_cnt = 2;
670 return 1;
671 break;
672 case ' ': /* space */
673 /* Assume that this is to be escaped */
674 outspec[0] = '^';
675 outspec[1] = '_';
676 *output_cnt = 2;
677 return 1;
678 break;
679 default:
680 *outspec = *inspec;
681 *output_cnt = 1;
682 return 1;
683 break;
684 }
685}
686
687
657054d4
JM		 688/* This handles the expansion of a '^' prefix to the proper character
689 * in a UNIX file specification.
690 *
691 * The output count variable contains the number of characters added
692 * to the output string.
693 *
694 * The return value is the number of characters read from the input
695 * string
696 */
697static int copy_expand_vms_filename_escape
698 (char *outspec, const char *inspec, int *output_cnt)
699{
700int count;
701int scnt;
702
703 count = 0;
704 *output_cnt = 0;
705 if (*inspec == '^') {
706 inspec++;
707 switch (*inspec) {
adc11f0b
CB		 708 /* Spaces and non-trailing dots should just be passed through,
709 * but eat the escape character.
710 */
657054d4 711 case '.':
657054d4 712 *outspec = *inspec;
adc11f0b
CB		 713 count += 2;
714 (*output_cnt)++;
657054d4
JM		 715 break;
716 case '_': /* space */
717 *outspec = ' ';
adc11f0b 718 count += 2;
657054d4
JM		 719 (*output_cnt)++;
720 break;
adc11f0b
CB		 721 case '^':
722 /* Hmm. Better leave the escape escaped. */
723 outspec[0] = '^';
724 outspec[1] = '^';
725 count += 2;
726 (*output_cnt) += 2;
727 break;
360732b5 728 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 729 inspec++;
730 count++;
731 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
732 if (scnt == 4) {
2f4077ca
JM		 733 unsigned int c1, c2;
734 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
735 outspec[0] == c1 & 0xff;
736 outspec[1] == c2 & 0xff;
657054d4
JM		 737 if (scnt > 1) {
738 (*output_cnt) += 2;
739 count += 4;
740 }
741 }
742 else {
743 /* Error - do best we can to continue */
744 *outspec = 'U';
745 outspec++;
746 (*output_cnt++);
747 *outspec = *inspec;
748 count++;
749 (*output_cnt++);
750 }
751 break;
752 default:
753 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
754 if (scnt == 2) {
755 /* Hex encoded */
2f4077ca
JM		 756 unsigned int c1;
757 scnt = sscanf(inspec, "%2x", &c1);
758 outspec[0] = c1 & 0xff;
657054d4
JM		 759 if (scnt > 0) {
760 (*output_cnt++);
761 count += 2;
762 }
763 }
764 else {
765 *outspec = *inspec;
766 count++;
767 (*output_cnt++);
768 }
769 }
770 }
771 else {
772 *outspec = *inspec;
773 count++;
774 (*output_cnt)++;
775 }
776 return count;
777}
778
7566800d
CB		 779#ifdef sys$filescan
780#undef sys$filescan
781int sys$filescan
657054d4
JM		 782 (const struct dsc$descriptor_s * srcstr,
783 struct filescan_itmlst_2 * valuelist,
784 unsigned long * fldflags,
785 struct dsc$descriptor_s *auxout,
786 unsigned short * retlen);
7566800d 787#endif
657054d4
JM		 788
789/* vms_split_path - Verify that the input file specification is a
790 * VMS format file specification, and provide pointers to the components of
791 * it. With EFS format filenames, this is virtually the only way to
792 * parse a VMS path specification into components.
793 *
794 * If the sum of the components do not add up to the length of the
795 * string, then the passed file specification is probably a UNIX style
796 * path.
797 */
798static int vms_split_path
360732b5 799 (const char * path,
dca5a913 800 char * * volume,
657054d4 801 int * vol_len,
dca5a913 802 char * * root,
657054d4 803 int * root_len,
dca5a913 804 char * * dir,
657054d4 805 int * dir_len,
dca5a913 806 char * * name,
657054d4 807 int * name_len,
dca5a913 808 char * * ext,
657054d4 809 int * ext_len,
dca5a913 810 char * * version,
657054d4
JM		 811 int * ver_len)
812{
813struct dsc$descriptor path_desc;
814int status;
815unsigned long flags;
816int ret_stat;
817struct filescan_itmlst_2 item_list[9];
818const int filespec = 0;
819const int nodespec = 1;
820const int devspec = 2;
821const int rootspec = 3;
822const int dirspec = 4;
823const int namespec = 5;
824const int typespec = 6;
825const int verspec = 7;
826
827 /* Assume the worst for an easy exit */
828 ret_stat = -1;
829 *volume = NULL;
830 *vol_len = 0;
831 *root = NULL;
832 *root_len = 0;
833 *dir = NULL;
834 *dir_len;
835 *name = NULL;
836 *name_len = 0;
837 *ext = NULL;
838 *ext_len = 0;
839 *version = NULL;
840 *ver_len = 0;
841
842 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
843 path_desc.dsc$w_length = strlen(path);
844 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
845 path_desc.dsc$b_class = DSC$K_CLASS_S;
846
847 /* Get the total length, if it is shorter than the string passed
848 * then this was probably not a VMS formatted file specification
849 */
850 item_list[filespec].itmcode = FSCN$_FILESPEC;
851 item_list[filespec].length = 0;
852 item_list[filespec].component = NULL;
853
854 /* If the node is present, then it gets considered as part of the
855 * volume name to hopefully make things simple.
856 */
857 item_list[nodespec].itmcode = FSCN$_NODE;
858 item_list[nodespec].length = 0;
859 item_list[nodespec].component = NULL;
860
861 item_list[devspec].itmcode = FSCN$_DEVICE;
862 item_list[devspec].length = 0;
863 item_list[devspec].component = NULL;
864
865 /* root is a special case, adding it to either the directory or
866 * the device components will probalby complicate things for the
867 * callers of this routine, so leave it separate.
868 */
869 item_list[rootspec].itmcode = FSCN$_ROOT;
870 item_list[rootspec].length = 0;
871 item_list[rootspec].component = NULL;
872
873 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
874 item_list[dirspec].length = 0;
875 item_list[dirspec].component = NULL;
876
877 item_list[namespec].itmcode = FSCN$_NAME;
878 item_list[namespec].length = 0;
879 item_list[namespec].component = NULL;
880
881 item_list[typespec].itmcode = FSCN$_TYPE;
882 item_list[typespec].length = 0;
883 item_list[typespec].component = NULL;
884
885 item_list[verspec].itmcode = FSCN$_VERSION;
886 item_list[verspec].length = 0;
887 item_list[verspec].component = NULL;
888
889 item_list[8].itmcode = 0;
890 item_list[8].length = 0;
891 item_list[8].component = NULL;
892
7566800d 893 status = sys$filescan
657054d4
JM		 894 ((const struct dsc$descriptor_s *)&path_desc, item_list,
895 &flags, NULL, NULL);
360732b5 896 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 897
898 /* If we parsed it successfully these two lengths should be the same */
899 if (path_desc.dsc$w_length != item_list[filespec].length)
900 return ret_stat;
901
902 /* If we got here, then it is a VMS file specification */
903 ret_stat = 0;
904
905 /* set the volume name */
906 if (item_list[nodespec].length > 0) {
907 *volume = item_list[nodespec].component;
908 *vol_len = item_list[nodespec].length + item_list[devspec].length;
909 }
910 else {
911 *volume = item_list[devspec].component;
912 *vol_len = item_list[devspec].length;
913 }
914
915 *root = item_list[rootspec].component;
916 *root_len = item_list[rootspec].length;
917
918 *dir = item_list[dirspec].component;
919 *dir_len = item_list[dirspec].length;
920
921 /* Now fun with versions and EFS file specifications
922 * The parser can not tell the difference when a "." is a version
923 * delimiter or a part of the file specification.
924 */
925 if ((decc_efs_charset) &&
926 (item_list[verspec].length > 0) &&
927 (item_list[verspec].component[0] == '.')) {
928 *name = item_list[namespec].component;
929 *name_len = item_list[namespec].length + item_list[typespec].length;
930 *ext = item_list[verspec].component;
931 *ext_len = item_list[verspec].length;
932 *version = NULL;
933 *ver_len = 0;
934 }
935 else {
936 *name = item_list[namespec].component;
937 *name_len = item_list[namespec].length;
938 *ext = item_list[typespec].component;
939 *ext_len = item_list[typespec].length;
940 *version = item_list[verspec].component;
941 *ver_len = item_list[verspec].length;
942 }
943 return ret_stat;
944}
945
df278665
JM		 946/* Routine to determine if the file specification ends with .dir */
947static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
948
949 /* e_len must be 4, and version must be <= 2 characters */
950 if (e_len != 4 || vs_len > 2)
951 return 0;
952
953 /* If a version number is present, it needs to be one */
954 if ((vs_len == 2) && (vs_spec[1] != '1'))
955 return 0;
956
957 /* Look for the DIR on the extension */
958 if (vms_process_case_tolerant) {
959 if ((toupper(e_spec[1]) == 'D') &&
960 (toupper(e_spec[2]) == 'I') &&
961 (toupper(e_spec[3]) == 'R')) {
962 return 1;
963 }
964 } else {
965 /* Directory extensions are supposed to be in upper case only */
966 /* I would not be surprised if this rule can not be enforced */
967 /* if and when someone fully debugs the case sensitive mode */
968 if ((e_spec[1] == 'D') &&
969 (e_spec[2] == 'I') &&
970 (e_spec[3] == 'R')) {
971 return 1;
972 }
973 }
974 return 0;
975}
976
f7ddb74a 977
fa537f88
CB		 978/* my_maxidx
979 * Routine to retrieve the maximum equivalence index for an input
980 * logical name. Some calls to this routine have no knowledge if
981 * the variable is a logical or not. So on error we return a max
982 * index of zero.
983 */
f7ddb74a 984/*{{{int my_maxidx(const char *lnm) */
fa537f88 985static int
f7ddb74a 986my_maxidx(const char *lnm)
fa537f88
CB		 987{
988 int status;
989 int midx;
990 int attr = LNM$M_CASE_BLIND;
991 struct dsc$descriptor lnmdsc;
992 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
993 {0, 0, 0, 0}};
994
995 lnmdsc.dsc$w_length = strlen(lnm);
996 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
997 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 998 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 999
1000 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
1001 if ((status & 1) == 0)
1002 midx = 0;
1003
1004 return (midx);
1005}
1006/*}}}*/
1007
f675dbe5 1008/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 1009int
fd8cd3a3 1010Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 1011 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 1012{
f7ddb74a
JM		 1013 const char *cp1;
1014 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 1015 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 1016 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 1017 int midx;
f675dbe5
CB		 1018 unsigned char acmode;
1019 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1020 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1021 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1022 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 1023 {0, 0, 0, 0}};
f675dbe5 1024 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 1025#if defined(PERL_IMPLICIT_CONTEXT)
1026 pTHX = NULL;
fd8cd3a3
DS		 1027 if (PL_curinterp) {
1028 aTHX = PERL_GET_INTERP;
cc077a9f 1029 } else {
fd8cd3a3 1030 aTHX = NULL;
cc077a9f
HM		 1031 }
1032#endif
748a9306 1033
fa537f88 1034 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 1035 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1036 }
f7ddb74a 1037 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1038 *cp2 = _toupper(*cp1);
1039 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1040 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1041 return 0;
1042 }
1043 }
1044 lnmdsc.dsc$w_length = cp1 - lnm;
1045 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 1046 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 1047 secure = flags & PERL__TRNENV_SECURE;
1048 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1049 if (!tabvec || !*tabvec) tabvec = env_tables;
1050
1051 for (curtab = 0; tabvec[curtab]; curtab++) {
1052 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1053 if (!ivenv && !secure) {
1054 char *eq, *end;
1055 int i;
1056 if (!environ) {
1057 ivenv = 1;
ebd4d70b
JM		 1058#if defined(PERL_IMPLICIT_CONTEXT)
1059 if (aTHX == NULL) {
1060 fprintf(stderr,
873f5ddf 1061 "Can't read CRTL environ\n");
ebd4d70b
JM		 1062 } else
1063#endif
1064 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 1065 continue;
1066 }
1067 retsts = SS$_NOLOGNAM;
1068 for (i = 0; environ[i]; i++) {
1069 if ((eq = strchr(environ[i],'=')) &&
299d126a 1070 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 1071 !strncmp(environ[i],uplnm,eq - environ[i])) {
1072 eq++;
1073 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1074 if (!eqvlen) continue;
1075 retsts = SS$_NORMAL;
1076 break;
1077 }
1078 }
1079 if (retsts != SS$_NOLOGNAM) break;
1080 }
1081 }
1082 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1083 !str$case_blind_compare(&tmpdsc,&clisym)) {
1084 if (!ivsym && !secure) {
1085 unsigned short int deflen = LNM$C_NAMLENGTH;
1086 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1087 /* dynamic dsc to accomodate possible long value */
ebd4d70b 1088 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 1089 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1090 if (retsts & 1) {
2497a41f 1091 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 1092 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 1093 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 1094 /* Special hack--we might be called before the interpreter's */
1095 /* fully initialized, in which case either thr or PL_curcop */
1096 /* might be bogus. We have to check, since ckWARN needs them */
1097 /* both to be valid if running threaded */
8a646e0b
JM		 1098#if defined(PERL_IMPLICIT_CONTEXT)
1099 if (aTHX == NULL) {
1100 fprintf(stderr,
873f5ddf 1101 "Value of CLI symbol \"%s\" too long",lnm);
8a646e0b
JM		 1102 } else
1103#endif
cc077a9f 1104 if (ckWARN(WARN_MISC)) {
f98bc0c6 1105 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 1106 }
f675dbe5
CB		 1107 }
1108 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1109 }
ebd4d70b 1110 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 1111 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1112 if (retsts == LIB$_NOSUCHSYM) continue;
1113 break;
1114 }
1115 }
1116 else if (!ivlnm) {
843027b0 1117 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1118 midx = my_maxidx(lnm);
1119 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1120 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1121 eqvlen = 0;
1122 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1123 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1124 if (retsts == SS$_NOLOGNAM) break;
1125 /* PPFs have a prefix */
1126 if (
fd7385b9 1127#if INTSIZE == 4
fa537f88 1128 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1129#endif
fa537f88
CB		 1130 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1131 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1132 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1133 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1134 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1135 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1136 eqvlen -= 4;
1137 }
f7ddb74a
JM		 1138 cp2 += eqvlen;
1139 *cp2 = '\0';
fa537f88
CB		 1140 }
1141 if ((retsts == SS$_IVLOGNAM) ||
1142 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1143 }
fa537f88 1144 else {
fa537f88
CB		 1145 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1146 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1147 if (retsts == SS$_NOLOGNAM) continue;
1148 eqv[eqvlen] = '\0';
1149 }
1150 eqvlen = strlen(eqv);
f675dbe5
CB		 1151 break;
1152 }
c07a80fd 1153 }
f675dbe5
CB		 1154 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1155 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1156 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1157 retsts == SS$_NOLOGNAM) {
1158 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1159 }
ebd4d70b 1160 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1161 return 0;
1162} /* end of vmstrnenv */
1163/*}}}*/
c07a80fd 1164
f675dbe5
CB		 1165/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1166/* Define as a function so we can access statics. */
4b19af01 1167int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1168{
8a646e0b
JM		 1169 int flags = 0;
1170
1171#if defined(PERL_IMPLICIT_CONTEXT)
1172 if (aTHX != NULL)
1173#endif
f675dbe5 1174#ifdef SECURE_INTERNAL_GETENV
8a646e0b
JM		 1175 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1176 PERL__TRNENV_SECURE : 0;
f675dbe5 1177#endif
8a646e0b
JM		 1178
1179 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1180}
1181/*}}}*/
a0d0e21e
LW		 1182
1183/* my_getenv
61bb5906
CB		 1184 * Note: Uses Perl temp to store result so char * can be returned to
1185 * caller; this pointer will be invalidated at next Perl statement
1186 * transition.
a6c40364 1187 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1188 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1189 * allocate SVs).
a0d0e21e 1190 */
f675dbe5 1191/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1192char *
5c84aa53 1193Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1194{
f7ddb74a 1195 const char *cp1;
fa537f88 1196 static char *__my_getenv_eqv = NULL;
f7ddb74a 1197 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1198 unsigned long int idx = 0;
bc10a425 1199 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 1200 int midx, flags;
61bb5906 1201 SV *tmpsv;
a0d0e21e 1202
f7ddb74a 1203 midx = my_maxidx(lnm) + 1;
fa537f88 1204
6b88bc9c 1205 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1206 /* Set up a temporary buffer for the return value; Perl will
1207 * clean it up at the next statement transition */
fa537f88 1208 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1209 if (!tmpsv) return NULL;
1210 eqv = SvPVX(tmpsv);
1211 }
fa537f88
CB		 1212 else {
1213 /* Assume no interpreter ==> single thread */
1214 if (__my_getenv_eqv != NULL) {
1215 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216 }
1217 else {
a02a5408 1218 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1219 }
1220 eqv = __my_getenv_eqv;
1221 }
1222
f7ddb74a 1223 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1224 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1225 int len;
61bb5906 1226 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1227
1228 len = strlen(eqv);
1229
1230 /* Get rid of "000000/ in rooted filespecs */
1231 if (len > 7) {
1232 char * zeros;
1233 zeros = strstr(eqv, "/000000/");
1234 if (zeros != NULL) {
1235 int mlen;
1236 mlen = len - (zeros - eqv) - 7;
1237 memmove(zeros, &zeros[7], mlen);
1238 len = len - 7;
1239 eqv[len] = '\0';
1240 }
1241 }
61bb5906 1242 return eqv;
748a9306 1243 }
a0d0e21e 1244 else {
2512681b 1245 /* Impose security constraints only if tainting */
bc10a425
CB		 1246 if (sys) {
1247 /* Impose security constraints only if tainting */
1248 secure = PL_curinterp ? PL_tainting : will_taint;
1249 saverr = errno; savvmserr = vaxc$errno;
1250 }
843027b0
CB		 1251 else {
1252 secure = 0;
1253 }
1254
1255 flags =
f675dbe5 1256#ifdef SECURE_INTERNAL_GETENV
843027b0 1257 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1258#else
843027b0 1259 0
f675dbe5 1260#endif
843027b0
CB		 1261 ;
1262
1263 /* For the getenv interface we combine all the equivalence names
1264 * of a search list logical into one value to acquire a maximum
1265 * value length of 255*128 (assuming %ENV is using logicals).
1266 */
1267 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1268
1269 /* If the name contains a semicolon-delimited index, parse it
1270 * off and make sure we only retrieve the equivalence name for
1271 * that index. */
1272 if ((cp2 = strchr(lnm,';')) != NULL) {
1273 strcpy(uplnm,lnm);
1274 uplnm[cp2-lnm] = '\0';
1275 idx = strtoul(cp2+1,NULL,0);
1276 lnm = uplnm;
1277 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1278 }
1279
1280 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1281
bc10a425
CB		 1282 /* Discard NOLOGNAM on internal calls since we're often looking
1283 * for an optional name, and this "error" often shows up as the
1284 * (bogus) exit status for a die() call later on. */
1285 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1286 return success ? eqv : NULL;
a0d0e21e 1287 }
a0d0e21e
LW		 1288
1289} /* end of my_getenv() */
1290/*}}}*/
1291
f675dbe5 1292
a6c40364
GS		 1293/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1294char *
fd8cd3a3 1295Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1296{
f7ddb74a
JM		 1297 const char *cp1;
1298 char *buf, *cp2;
a6c40364 1299 unsigned long idx = 0;
843027b0 1300 int midx, flags;
fa537f88 1301 static char *__my_getenv_len_eqv = NULL;
bc10a425 1302 int secure, saverr, savvmserr;
cc077a9f
HM		 1303 SV *tmpsv;
1304
f7ddb74a 1305 midx = my_maxidx(lnm) + 1;
fa537f88 1306
cc077a9f
HM		 1307 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1308 /* Set up a temporary buffer for the return value; Perl will
1309 * clean it up at the next statement transition */
fa537f88 1310 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1311 if (!tmpsv) return NULL;
1312 buf = SvPVX(tmpsv);
1313 }
fa537f88
CB		 1314 else {
1315 /* Assume no interpreter ==> single thread */
1316 if (__my_getenv_len_eqv != NULL) {
1317 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1318 }
1319 else {
a02a5408 1320 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1321 }
1322 buf = __my_getenv_len_eqv;
1323 }
1324
f7ddb74a 1325 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1326 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1327 char * zeros;
1328
f675dbe5 1329 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1330 *len = strlen(buf);
f7ddb74a
JM		 1331
1332 /* Get rid of "000000/ in rooted filespecs */
1333 if (*len > 7) {
1334 zeros = strstr(buf, "/000000/");
1335 if (zeros != NULL) {
1336 int mlen;
1337 mlen = *len - (zeros - buf) - 7;
1338 memmove(zeros, &zeros[7], mlen);
1339 *len = *len - 7;
1340 buf[*len] = '\0';
1341 }
1342 }
a6c40364 1343 return buf;
f675dbe5
CB		 1344 }
1345 else {
bc10a425
CB		 1346 if (sys) {
1347 /* Impose security constraints only if tainting */
1348 secure = PL_curinterp ? PL_tainting : will_taint;
1349 saverr = errno; savvmserr = vaxc$errno;
1350 }
843027b0
CB		 1351 else {
1352 secure = 0;
1353 }
1354
1355 flags =
f675dbe5 1356#ifdef SECURE_INTERNAL_GETENV
843027b0 1357 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1358#else
843027b0 1359 0
f675dbe5 1360#endif
843027b0
CB		 1361 ;
1362
1363 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1364
1365 if ((cp2 = strchr(lnm,';')) != NULL) {
1366 strcpy(buf,lnm);
1367 buf[cp2-lnm] = '\0';
1368 idx = strtoul(cp2+1,NULL,0);
1369 lnm = buf;
1370 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1371 }
1372
1373 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1374
f7ddb74a
JM		 1375 /* Get rid of "000000/ in rooted filespecs */
1376 if (*len > 7) {
1377 char * zeros;
1378 zeros = strstr(buf, "/000000/");
1379 if (zeros != NULL) {
1380 int mlen;
1381 mlen = *len - (zeros - buf) - 7;
1382 memmove(zeros, &zeros[7], mlen);
1383 *len = *len - 7;
1384 buf[*len] = '\0';
1385 }
1386 }
1387
bc10a425
CB		 1388 /* Discard NOLOGNAM on internal calls since we're often looking
1389 * for an optional name, and this "error" often shows up as the
1390 * (bogus) exit status for a die() call later on. */
1391 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1392 return *len ? buf : NULL;
f675dbe5
CB		 1393 }
1394
a6c40364 1395} /* end of my_getenv_len() */
f675dbe5
CB		 1396/*}}}*/
1397
8a646e0b 1398static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1399
1400static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1401
740ce14c 1402/*{{{ void prime_env_iter() */
1403void
1404prime_env_iter(void)
1405/* Fill the %ENV associative array with all logical names we can
1406 * find, in preparation for iterating over it.
1407 */
1408{
17f28c40 1409 static int primed = 0;
3eeba6fb 1410 HV *seenhv = NULL, *envhv;
22be8b3c 1411 SV *sv = NULL;
4e205ed6 1412 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1413 unsigned short int chan;
1414#ifndef CLI$M_TRUSTED
1415# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1416#endif
f675dbe5
CB		 1417 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1418 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1419 long int i;
1420 bool have_sym = FALSE, have_lnm = FALSE;
1421 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1422 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1423 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1424 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1425 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1426#if defined(PERL_IMPLICIT_CONTEXT)
1427 pTHX;
1428#endif
3db8f154 1429#if defined(USE_ITHREADS)
b2b3adea
HM		 1430 static perl_mutex primenv_mutex;
1431 MUTEX_INIT(&primenv_mutex);
61bb5906 1432#endif
740ce14c 1433
fd8cd3a3
DS		 1434#if defined(PERL_IMPLICIT_CONTEXT)
1435 /* We jump through these hoops because we can be called at */
1436 /* platform-specific initialization time, which is before anything is */
1437 /* set up--we can't even do a plain dTHX since that relies on the */
1438 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1439 if (PL_curinterp) {
1440 aTHX = PERL_GET_INTERP;
1441 } else {
ebd4d70b
JM		 1442 /* we never get here because the NULL pointer will cause the */
1443 /* several of the routines called by this routine to access violate */
1444
1445 /* This routine is only called by hv.c/hv_iterinit which has a */
1446 /* context, so the real fix may be to pass it through instead of */
1447 /* the hoops above */
fd8cd3a3
DS		 1448 aTHX = NULL;
1449 }
1450#endif
fd8cd3a3 1451
3eeba6fb 1452 if (primed || !PL_envgv) return;
61bb5906
CB		 1453 MUTEX_LOCK(&primenv_mutex);
1454 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1455 envhv = GvHVn(PL_envgv);
740ce14c 1456 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1457 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1458 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1459
f675dbe5
CB		 1460 for (i = 0; env_tables[i]; i++) {
1461 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1462 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1463 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1464 }
f675dbe5
CB		 1465 if (have_sym || have_lnm) {
1466 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1467 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1468 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1469 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1470 }
f675dbe5
CB		 1471
1472 for (i--; i >= 0; i--) {
1473 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1474 char *start;
1475 int j;
1476 for (j = 0; environ[j]; j++) {
1477 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1478 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1479 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1480 }
1481 else {
1482 start++;
22be8b3c
CB		 1483 sv = newSVpv(start,0);
1484 SvTAINTED_on(sv);
1485 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1486 }
1487 }
1488 continue;
740ce14c 1489 }
f675dbe5
CB		 1490 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1491 !str$case_blind_compare(&tmpdsc,&clisym)) {
1492 strcpy(cmd,"Show Symbol/Global *");
1493 cmddsc.dsc$w_length = 20;
1494 if (env_tables[i]->dsc$w_length == 12 &&
1495 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1496 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1497 flags = defflags | CLI$M_NOLOGNAM;
1498 }
1499 else {
1500 strcpy(cmd,"Show Logical *");
1501 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1502 strcat(cmd," /Table=");
1503 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1504 cmddsc.dsc$w_length = strlen(cmd);
1505 }
1506 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1507 flags = defflags | CLI$M_NOCLISYM;
1508 }
1509
1510 /* Create a new subprocess to execute each command, to exclude the
1511 * remote possibility that someone could subvert a mbx or file used
1512 * to write multiple commands to a single subprocess.
1513 */
1514 do {
1515 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1516 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1517 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1518 defflags &= ~CLI$M_TRUSTED;
1519 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1520 _ckvmssts(retsts);
a02a5408 1521 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1522 if (seenhv) SvREFCNT_dec(seenhv);
1523 seenhv = newHV();
1524 while (1) {
1525 char *cp1, *cp2, *key;
1526 unsigned long int sts, iosb[2], retlen, keylen;
1527 register U32 hash;
1528
1529 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1530 if (sts & 1) sts = iosb[0] & 0xffff;
1531 if (sts == SS$_ENDOFFILE) {
1532 int wakect = 0;
1533 while (substs == 0) { sys$hiber(); wakect++;}
1534 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1535 _ckvmssts(substs);
1536 break;
1537 }
1538 _ckvmssts(sts);
1539 retlen = iosb[0] >> 16;
1540 if (!retlen) continue; /* blank line */
1541 buf[retlen] = '\0';
1542 if (iosb[1] != subpid) {
1543 if (iosb[1]) {
5c84aa53 1544 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1545 }
1546 continue;
1547 }
3eeba6fb 1548 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1549 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1550
1551 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1552 if (*cp1 == '(' || /* Logical name table name */
1553 *cp1 == '=' /* Next eqv of searchlist */) continue;
1554 if (*cp1 == '"') cp1++;
1555 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1556 key = cp1; keylen = cp2 - cp1;
1557 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1558 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1559 while (*cp2 && *cp2 == '=') cp2++;
1560 while (*cp2 && *cp2 == ' ') cp2++;
1561 if (*cp2 == '"') { /* String translation; may embed "" */
1562 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1563 cp2++; cp1--; /* Skip "" surrounding translation */
1564 }
1565 else { /* Numeric translation */
1566 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1567 cp1--; /* stop on last non-space char */
1568 }
1569 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1570 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1571 continue;
1572 }
5afd6d42 1573 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1574
1575 if (cp1 == cp2 && *cp2 == '.') {
1576 /* A single dot usually means an unprintable character, such as a null
1577 * to indicate a zero-length value. Get the actual value to make sure.
1578 */
1579 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1580 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1581 int trnlen;
ff79d39d 1582 strncpy(lnm, key, keylen);
0faef845 1583 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1584 sv = newSVpvn(eqv, strlen(eqv));
1585 }
1586 else {
1587 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1588 }
1589
22be8b3c
CB		 1590 SvTAINTED_on(sv);
1591 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1592 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1593 }
f675dbe5
CB		 1594 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1595 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1596 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1597 char eqv[LNM$C_NAMLENGTH+1];
1598 int trnlen, i;
1599 for (i = 0; ppfs[i]; i++) {
1600 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1601 sv = newSVpv(eqv,trnlen);
1602 SvTAINTED_on(sv);
1603 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1604 }
740ce14c 1605 }
1606 }
f675dbe5
CB		 1607 primed = 1;
1608 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1609 if (buf) Safefree(buf);
1610 if (seenhv) SvREFCNT_dec(seenhv);
1611 MUTEX_UNLOCK(&primenv_mutex);
1612 return;
1613
740ce14c 1614} /* end of prime_env_iter */
1615/*}}}*/
740ce14c 1616
f675dbe5 1617
2c590a56 1618/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1619/* Define or delete an element in the same "environment" as
1620 * vmstrnenv(). If an element is to be deleted, it's removed from
1621 * the first place it's found. If it's to be set, it's set in the
1622 * place designated by the first element of the table vector.
3eeba6fb 1623 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1624 */
f675dbe5 1625int
2c590a56 1626Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1627{
f7ddb74a
JM		 1628 const char *cp1;
1629 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1630 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1631 int nseg = 0, j;
a0d0e21e 1632 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1633 struct itmlst_3 *ile, *ilist;
a0d0e21e 1634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1638 $DESCRIPTOR(local,"_LOCAL");
1639
ed253963
CB		 1640 if (!lnm) {
1641 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1642 return SS$_IVLOGNAM;
1643 }
1644
f7ddb74a 1645 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1646 *cp2 = _toupper(*cp1);
1647 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1648 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1649 return SS$_IVLOGNAM;
1650 }
1651 }
a0d0e21e 1652 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1653 if (!tabvec || !*tabvec) tabvec = env_tables;
1654
3eeba6fb 1655 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1656 for (curtab = 0; tabvec[curtab]; curtab++) {
1657 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1658 int i;
299d126a 1659 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1660 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1661 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1662 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1663#ifdef HAS_SETENV
0e06870b 1664 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1665 }
1666 }
1667 ivenv = 1; retsts = SS$_NOLOGNAM;
1668#else
3eeba6fb 1669 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1671 ivenv = 1; retsts = SS$_NOSUCHPGM;
1672 break;
1673 }
1674 }
f675dbe5
CB		 1675#endif
1676 }
1677 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1678 !str$case_blind_compare(&tmpdsc,&clisym)) {
1679 unsigned int symtype;
1680 if (tabvec[curtab]->dsc$w_length == 12 &&
1681 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1682 !str$case_blind_compare(&tmpdsc,&local))
1683 symtype = LIB$K_CLI_LOCAL_SYM;
1684 else symtype = LIB$K_CLI_GLOBAL_SYM;
1685 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1686 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1687 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1688 break;
1689 }
1690 else if (!ivlnm) {
1691 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1692 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1693 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1694 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1695 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1696 }
a0d0e21e
LW		 1697 }
1698 }
f675dbe5
CB		 1699 else { /* we're defining a value */
1700 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1701#ifdef HAS_SETENV
3eeba6fb 1702 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1703#else
3eeba6fb 1704 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1705 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1706 retsts = SS$_NOSUCHPGM;
1707#endif
1708 }
1709 else {
f7ddb74a 1710 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1711 eqvdsc.dsc$w_length = strlen(eqv);
1712 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1713 !str$case_blind_compare(&tmpdsc,&clisym)) {
1714 unsigned int symtype;
1715 if (tabvec[0]->dsc$w_length == 12 &&
1716 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1717 !str$case_blind_compare(&tmpdsc,&local))
1718 symtype = LIB$K_CLI_LOCAL_SYM;
1719 else symtype = LIB$K_CLI_GLOBAL_SYM;
1720 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1721 }
3eeba6fb
CB		 1722 else {
1723 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1724 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1725
1726 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1727 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1728 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1729 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1730 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1731 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1732 }
1733
a02a5408 1734 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1735 ile = ilist;
1736 if (!ile) {
1737 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1738 return SS$_INSFMEM;
a1dfe751 1739 }
fa537f88
CB		 1740 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1741
1742 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1743 ile->itmcode = LNM$_STRING;
1744 ile->bufadr = c;
1745 if ((j+1) == nseg) {
1746 ile->buflen = strlen(c);
1747 /* in case we are truncating one that's too long */
1748 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1749 }
1750 else {
1751 ile->buflen = LNM$C_NAMLENGTH;
1752 }
1753 }
1754
1755 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1756 Safefree (ilist);
1757 }
1758 else {
1759 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1760 }
3eeba6fb 1761 }
f675dbe5
CB		 1762 }
1763 }
1764 if (!(retsts & 1)) {
1765 switch (retsts) {
1766 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1767 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1768 set_errno(EVMSERR); break;
1769 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1770 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1771 set_errno(EINVAL); break;
1772 case SS$_NOPRIV:
7d2497bf 1773 set_errno(EACCES); break;
f675dbe5
CB		 1774 default:
1775 _ckvmssts(retsts);
1776 set_errno(EVMSERR);
1777 }
1778 set_vaxc_errno(retsts);
1779 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1780 }
3eeba6fb
CB		 1781 else {
1782 /* We reset error values on success because Perl does an hv_fetch()
1783 * before each hv_store(), and if the thing we're setting didn't
1784 * previously exist, we've got a leftover error message. (Of course,
1785 * this fails in the face of
1786 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1787 * in that the error reported in $! isn't spurious,
1788 * but it's right more often than not.)
1789 */
f675dbe5
CB		 1790 set_errno(0); set_vaxc_errno(retsts);
1791 return 0;
1792 }
1793
1794} /* end of vmssetenv() */
1795/*}}}*/
a0d0e21e 1796
2c590a56 1797/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1798/* This has to be a function since there's a prototype for it in proto.h */
1799void
2c590a56 1800Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1801{
bc10a425
CB		 1802 if (lnm && *lnm) {
1803 int len = strlen(lnm);
1804 if (len == 7) {
1805 char uplnm[8];
22d4bb9c
CB		 1806 int i;
1807 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1808 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1809 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1810 return;
1811 }
1812 }
1813#ifndef RTL_USES_UTC
1814 if (len == 6 || len == 2) {
1815 char uplnm[7];
1816 int i;
1817 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1818 uplnm[len] = '\0';
1819 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1820 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1821 }
1822#endif
1823 }
f675dbe5
CB		 1824 (void) vmssetenv(lnm,eqv,NULL);
1825}
a0d0e21e
LW		 1826/*}}}*/
1827
27c67b75 1828/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1829/* vmssetuserlnm
1830 * sets a user-mode logical in the process logical name table
1831 * used for redirection of sys$error
4d9538c1
JM		 1832 *
1833 * Fix-me: The pTHX is not needed for this routine, however doio.c
1834 * is calling it with one instead of using a macro.
1835 * A macro needs to be added to vmsish.h and doio.c updated to use it.
1836 *
0e06870b
CB		 1837 */
1838void
2fbb330f 1839Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1840{
1841 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1842 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1843 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1844 unsigned char acmode = PSL$C_USER;
1845 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1846 {0, 0, 0, 0}};
2fbb330f 1847 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1848 d_name.dsc$w_length = strlen(name);
1849
1850 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1851 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1852
1853 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1854 if (!(iss&1)) lib$signal(iss);
1855}
1856/*}}}*/
c07a80fd 1857
f675dbe5 1858
c07a80fd 1859/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1860/* my_crypt - VMS password hashing
1861 * my_crypt() provides an interface compatible with the Unix crypt()
1862 * C library function, and uses sys$hash_password() to perform VMS
1863 * password hashing. The quadword hashed password value is returned
1864 * as a NUL-terminated 8 character string. my_crypt() does not change
1865 * the case of its string arguments; in order to match the behavior
1866 * of LOGINOUT et al., alphabetic characters in both arguments must
1867 * be upcased by the caller.
2497a41f
JM		 1868 *
1869 * - fix me to call ACM services when available
c07a80fd 1870 */
1871char *
fd8cd3a3 1872Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1873{
1874# ifndef UAI$C_PREFERRED_ALGORITHM
1875# define UAI$C_PREFERRED_ALGORITHM 127
1876# endif
1877 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1878 unsigned short int salt = 0;
1879 unsigned long int sts;
1880 struct const_dsc {
1881 unsigned short int dsc$w_length;
1882 unsigned char dsc$b_type;
1883 unsigned char dsc$b_class;
1884 const char * dsc$a_pointer;
1885 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1886 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1887 struct itmlst_3 uailst[3] = {
1888 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1889 { sizeof salt, UAI$_SALT, &salt, 0},
1890 { 0, 0, NULL, NULL}};
1891 static char hash[9];
1892
1893 usrdsc.dsc$w_length = strlen(usrname);
1894 usrdsc.dsc$a_pointer = usrname;
1895 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1896 switch (sts) {
f282b18d 1897 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1898 set_errno(EACCES);
1899 break;
1900 case RMS$_RNF:
1901 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1902 break;
1903 default:
1904 set_errno(EVMSERR);
1905 }
1906 set_vaxc_errno(sts);
1907 if (sts != RMS$_RNF) return NULL;
1908 }
1909
1910 txtdsc.dsc$w_length = strlen(textpasswd);
1911 txtdsc.dsc$a_pointer = textpasswd;
1912 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1913 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1914 }
1915
1916 return (char *) hash;
1917
1918} /* end of my_crypt() */
1919/*}}}*/
1920
1921
360732b5
JM		 1922static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1923static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1924static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1925
2497a41f
JM		 1926/* fixup barenames that are directories for internal use.
1927 * There have been problems with the consistent handling of UNIX
1928 * style directory names when routines are presented with a name that
1929 * has no directory delimitors at all. So this routine will eventually
1930 * fix the issue.
1931 */
1932static char * fixup_bare_dirnames(const char * name)
1933{
1934 if (decc_disable_to_vms_logname_translation) {
1935/* fix me */
1936 }
1937 return NULL;
1938}
1939
e0e5e8d6
JM		 1940/* 8.3, remove() is now broken on symbolic links */
1941static int rms_erase(const char * vmsname);
1942
1943
2497a41f
JM		 1944/* mp_do_kill_file
1945 * A little hack to get around a bug in some implemenation of remove()
1946 * that do not know how to delete a directory
1947 *
1948 * Delete any file to which user has control access, regardless of whether
1949 * delete access is explicitly allowed.
1950 * Limitations: User must have write access to parent directory.
1951 * Does not block signals or ASTs; if interrupted in midstream
1952 * may leave file with an altered ACL.
1953 * HANDLE WITH CARE!
1954 */
1955/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1956static int
1957mp_do_kill_file(pTHX_ const char *name, int dirflag)
1958{
e0e5e8d6
JM		 1959 char *vmsname;
1960 char *rslt;
2497a41f
JM		 1961 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1962 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1963 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1964 struct myacedef {
1965 unsigned char myace$b_length;
1966 unsigned char myace$b_type;
1967 unsigned short int myace$w_flags;
1968 unsigned long int myace$l_access;
1969 unsigned long int myace$l_ident;
1970 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1971 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1972 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1973 struct itmlst_3
1974 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1975 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1976 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1977 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1978 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1979 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1980
1981 /* Expand the input spec using RMS, since the CRTL remove() and
1982 * system services won't do this by themselves, so we may miss
1983 * a file "hiding" behind a logical name or search list. */
c5375c28 1984 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1985 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1986
6fb6c614 1987 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1988 if (rslt == NULL) {
c5375c28 1989 PerlMem_free(vmsname);
2497a41f
JM		 1990 return -1;
1991 }
c5375c28 1992
e0e5e8d6
JM		 1993 /* Erase the file */
1994 rmsts = rms_erase(vmsname);
2497a41f 1995
e0e5e8d6
JM		 1996 /* Did it succeed */
1997 if ($VMS_STATUS_SUCCESS(rmsts)) {
1998 PerlMem_free(vmsname);
1999 return 0;
2497a41f
JM		 2000 }
2001
2002 /* If not, can changing protections help? */
e0e5e8d6
JM		 2003 if (rmsts != RMS$_PRV) {
2004 set_vaxc_errno(rmsts);
2005 PerlMem_free(vmsname);
2497a41f
JM		 2006 return -1;
2007 }
2008
2009 /* No, so we get our own UIC to use as a rights identifier,
2010 * and the insert an ACE at the head of the ACL which allows us
2011 * to delete the file.
2012 */
ebd4d70b 2013 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 2014 fildsc.dsc$w_length = strlen(vmsname);
2015 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 2016 cxt = 0;
2017 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 2018 rmsts = -1;
2497a41f
JM		 2019 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2020 switch (aclsts) {
2021 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2022 set_errno(ENOENT); break;
2023 case RMS$_DIR:
2024 set_errno(ENOTDIR); break;
2025 case RMS$_DEV:
2026 set_errno(ENODEV); break;
2027 case RMS$_SYN: case SS$_INVFILFOROP:
2028 set_errno(EINVAL); break;
2029 case RMS$_PRV:
2030 set_errno(EACCES); break;
2031 default:
ebd4d70b 2032 _ckvmssts_noperl(aclsts);
2497a41f
JM		 2033 }
2034 set_vaxc_errno(aclsts);
e0e5e8d6 2035 PerlMem_free(vmsname);
2497a41f
JM		 2036 return -1;
2037 }
2038 /* Grab any existing ACEs with this identifier in case we fail */
2039 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2040 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2041 || fndsts == SS$_NOMOREACE ) {
2042 /* Add the new ACE . . . */
2043 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2044 goto yourroom;
2045
e0e5e8d6
JM		 2046 rmsts = rms_erase(vmsname);
2047 if ($VMS_STATUS_SUCCESS(rmsts)) {
2048 rmsts = 0;
2497a41f
JM		 2049 }
2050 else {
e0e5e8d6 2051 rmsts = -1;
2497a41f
JM		 2052 /* We blew it - dir with files in it, no write priv for
2053 * parent directory, etc. Put things back the way they were. */
2054 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2055 goto yourroom;
2056 if (fndsts & 1) {
2057 addlst[0].bufadr = &oldace;
2058 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2059 goto yourroom;
2060 }
2061 }
2062 }
2063
2064 yourroom:
2065 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2066 /* We just deleted it, so of course it's not there. Some versions of
2067 * VMS seem to return success on the unlock operation anyhow (after all
2068 * the unlock is successful), but others don't.
2069 */
2070 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2071 if (aclsts & 1) aclsts = fndsts;
2072 if (!(aclsts & 1)) {
2073 set_errno(EVMSERR);
2074 set_vaxc_errno(aclsts);
2497a41f
JM		 2075 }
2076
e0e5e8d6 2077 PerlMem_free(vmsname);
2497a41f
JM		 2078 return rmsts;
2079
2080} /* end of kill_file() */
2081/*}}}*/
2082
2083
a0d0e21e
LW		 2084/*{{{int do_rmdir(char *name)*/
2085int
b8ffc8df 2086Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 2087{
e0e5e8d6 2088 char * dirfile;
a0d0e21e 2089 int retval;
61bb5906 2090 Stat_t st;
a0d0e21e 2091
d94c5a78
JM		 2092 /* lstat returns a VMS fileified specification of the name */
2093 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 2094
46c05374 2095 retval = flex_lstat(name, &st);
d94c5a78
JM		 2096 if (retval != 0) {
2097 char * ret_spec;
2098
2099 /* Due to a historical feature, flex_stat/lstat can not see some */
2100 /* Unix format file names that the rest of the CRTL can see */
2101 /* Fixing that feature will cause some perl tests to fail */
2102 /* So try this one more time. */
2103
2104 retval = lstat(name, &st.crtl_stat);
2105 if (retval != 0)
2106 return -1;
2107
2108 /* force it to a file spec for the kill file to work. */
2109 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2110 if (ret_spec == NULL) {
2111 errno = EIO;
2112 return -1;
2113 }
e0e5e8d6 2114 }
d94c5a78
JM		 2115
2116 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 2117 errno = ENOTDIR;
2118 retval = -1;
2119 }
d94c5a78
JM		 2120 else {
2121 dirfile = st.st_devnam;
2122
2123 /* It may be possible for flex_stat to find a file and vmsify() to */
2124 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
2125 /* with that case, so fail it */
2126 if (dirfile[0] == 0) {
2127 errno = EIO;
2128 return -1;
2129 }
2130
e0e5e8d6 2131 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 2132 }
e0e5e8d6 2133
a0d0e21e
LW		 2134 return retval;
2135
2136} /* end of do_rmdir */
2137/*}}}*/
2138
2139/* kill_file
2140 * Delete any file to which user has control access, regardless of whether
2141 * delete access is explicitly allowed.
2142 * Limitations: User must have write access to parent directory.
2143 * Does not block signals or ASTs; if interrupted in midstream
2144 * may leave file with an altered ACL.
2145 * HANDLE WITH CARE!
2146 */
2147/*{{{int kill_file(char *name)*/
2148int
b8ffc8df 2149Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2150{
d94c5a78 2151 char * vmsfile;
e0e5e8d6
JM		 2152 Stat_t st;
2153 int rmsts;
a0d0e21e 2154
d94c5a78
JM		 2155 /* Convert the filename to VMS format and see if it is a directory */
2156 /* flex_lstat returns a vmsified file specification */
46c05374 2157 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 2158 if (rmsts != 0) {
2159
2160 /* Due to a historical feature, flex_stat/lstat can not see some */
2161 /* Unix format file names that the rest of the CRTL can see when */
2162 /* ODS-2 file specifications are in use. */
2163 /* Fixing that feature will cause some perl tests to fail */
2164 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2165 st.st_mode = 0;
2166 vmsfile = (char *) name; /* cast ok */
2167
2168 } else {
2169 vmsfile = st.st_devnam;
2170 if (vmsfile[0] == 0) {
2171 /* It may be possible for flex_stat to find a file and vmsify() */
2172 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2173 /* deal with that case, so fail it */
2174 errno = EIO;
2175 return -1;
2176 }
2177 }
2178
2179 /* Remove() is allowed to delete directories, according to the X/Open
2180 * specifications.
2181 * This may need special handling to work with the ACL hacks.
a0d0e21e 2182 */
d94c5a78
JM		 2183 if (S_ISDIR(st.st_mode)) {
2184 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2185 return rmsts;
a0d0e21e
LW		 2186 }
2187
d94c5a78
JM		 2188 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2189
2190 /* Need to delete all versions ? */
2191 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2192 int i = 0;
2193
2194 /* Just use lstat() here as do not need st_dev */
2195 /* and we know that the file is in VMS format or that */
2196 /* because of a historical bug, flex_stat can not see the file */
2197 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2198 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2199 if (rmsts != 0)
2200 break;
2201 i++;
2202
2203 /* Make sure that we do not loop forever */
2204 if (i > 32767) {
2205 errno = EIO;
2206 rmsts = -1;
2207 break;
2208 }
2209 }
2210 }
a0d0e21e
LW		 2211
2212 return rmsts;
2213
2214} /* end of kill_file() */
2215/*}}}*/
2216
8cc95fdb 2217
84902520 2218/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2219int
b8ffc8df 2220Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2221{
2222 STRLEN dirlen = strlen(dir);
2223
a2a90019
CB		 2224 /* zero length string sometimes gives ACCVIO */
2225 if (dirlen == 0) return -1;
2226
8cc95fdb 2227 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2228 * null file name/type. However, it's commonplace under Unix,
2229 * so we'll allow it for a gain in portability.
2230 */
2231 if (dir[dirlen-1] == '/') {
2232 char *newdir = savepvn(dir,dirlen-1);
2233 int ret = mkdir(newdir,mode);
2234 Safefree(newdir);
2235 return ret;
2236 }
2237 else return mkdir(dir,mode);
2238} /* end of my_mkdir */
2239/*}}}*/
2240
ee8c7f54
CB		 2241/*{{{int my_chdir(char *)*/
2242int
b8ffc8df 2243Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2244{
2245 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2246
2247 /* zero length string sometimes gives ACCVIO */
2248 if (dirlen == 0) return -1;
f7ddb74a
JM		 2249 const char *dir1;
2250
2251 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2252 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2253 * so that existing scripts do not need to be changed.
2254 */
2255 dir1 = dir;
2256 while ((dirlen > 0) && (*dir1 == ' ')) {
2257 dir1++;
2258 dirlen--;
2259 }
ee8c7f54
CB		 2260
2261 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2262 * that implies
2263 * null file name/type. However, it's commonplace under Unix,
2264 * so we'll allow it for a gain in portability.
f7ddb74a 2265 *
4d9538c1 2266 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2267 */
f7ddb74a 2268 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2269 char *newdir;
2270 int ret;
2271 newdir = PerlMem_malloc(dirlen);
2272 if (newdir ==NULL)
2273 _ckvmssts_noperl(SS$_INSFMEM);
2274 strncpy(newdir, dir1, dirlen-1);
2275 newdir[dirlen-1] = '\0';
2276 ret = chdir(newdir);
2277 PerlMem_free(newdir);
2278 return ret;
ee8c7f54 2279 }
dca5a913 2280 else return chdir(dir1);
ee8c7f54
CB		 2281} /* end of my_chdir */
2282/*}}}*/
8cc95fdb 2283
674d6c38 2284
f1db9cda
JM		 2285/*{{{int my_chmod(char *, mode_t)*/
2286int
2287Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2288{
4d9538c1
JM		 2289 Stat_t st;
2290 int ret = -1;
2291 char * changefile;
f1db9cda
JM		 2292 STRLEN speclen = strlen(file_spec);
2293
2294 /* zero length string sometimes gives ACCVIO */
2295 if (speclen == 0) return -1;
2296
2297 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2298 * that implies null file name/type. However, it's commonplace under Unix,
2299 * so we'll allow it for a gain in portability.
2300 *
2301 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2302 * in VMS file.dir notation.
2303 */
4d9538c1
JM		 2304 changefile = (char *) file_spec; /* cast ok */
2305 ret = flex_lstat(file_spec, &st);
2306 if (ret != 0) {
f1db9cda 2307
4d9538c1
JM		 2308 /* Due to a historical feature, flex_stat/lstat can not see some */
2309 /* Unix format file names that the rest of the CRTL can see when */
2310 /* ODS-2 file specifications are in use. */
2311 /* Fixing that feature will cause some perl tests to fail */
2312 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2313 st.st_mode = 0;
f1db9cda 2314
4d9538c1
JM		 2315 } else {
2316 /* It may be possible to get here with nothing in st_devname */
2317 /* chmod still may work though */
2318 if (st.st_devnam[0] != 0) {
2319 changefile = st.st_devnam;
2320 }
f1db9cda 2321 }
4d9538c1
JM		 2322 ret = chmod(changefile, mode);
2323 return ret;
f1db9cda
JM		 2324} /* end of my_chmod */
2325/*}}}*/
2326
2327
674d6c38
CB		 2328/*{{{FILE *my_tmpfile()*/
2329FILE *
2330my_tmpfile(void)
2331{
2332 FILE *fp;
2333 char *cp;
674d6c38
CB		 2334
2335 if ((fp = tmpfile())) return fp;
2336
c5375c28
JM		 2337 cp = PerlMem_malloc(L_tmpnam+24);
2338 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2339
2497a41f
JM		 2340 if (decc_filename_unix_only == 0)
2341 strcpy(cp,"Sys$Scratch:");
2342 else
2343 strcpy(cp,"/tmp/");
674d6c38
CB		 2344 tmpnam(cp+strlen(cp));
2345 strcat(cp,".Perltmp");
2346 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2347 PerlMem_free(cp);
674d6c38
CB		 2348 return fp;
2349}
2350/*}}}*/
2351
5c2d7af2
CB		 2352
2353#ifndef HOMEGROWN_POSIX_SIGNALS
2354/*
2355 * The C RTL's sigaction fails to check for invalid signal numbers so we
2356 * help it out a bit. The docs are correct, but the actual routine doesn't
2357 * do what the docs say it will.
2358 */
2359/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2360int
2361Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2362 struct sigaction* oact)
2363{
2364 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2365 SETERRNO(EINVAL, SS$_INVARG);
2366 return -1;
2367 }
2368 return sigaction(sig, act, oact);
2369}
2370/*}}}*/
2371#endif
2372
f2610a60
CL		 2373#ifdef KILL_BY_SIGPRC
2374#include <errnodef.h>
2375
05c058bc
CB		 2376/* We implement our own kill() using the undocumented system service
2377 sys$sigprc for one of two reasons:
2378
2379 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2380 target process to do a sys$exit, which usually can't be handled
2381 gracefully...certainly not by Perl and the %SIG{} mechanism.
2382
05c058bc
CB		 2383 2.) If the kill() in the CRTL can't be called from a signal
2384 handler without disappearing into the ether, i.e., the signal
2385 it purportedly sends is never trapped. Still true as of VMS 7.3.
2386
2387 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2388 in the target process rather than calling sys$exit.
2389
2390 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2391 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2392 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2393 with condition codes C$_SIG0+nsig*8, catching the exception on the
2394 target process and resignaling with appropriate arguments.
2395
2396 But we don't have that VMS 7.0+ exception handler, so if you
2397 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2398
2399 Also note that SIGTERM is listed in the docs as being "unimplemented",
2400 yet always seems to be signaled with a VMS condition code of 4 (and
2401 correctly handled for that code). So we hardwire it in.
2402
2403 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2404 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2405 than signalling with an unrecognized (and unhandled by CRTL) code.
2406*/
2407
fe1de8ce 2408#define _MY_SIG_MAX 28
f2610a60 2409
9c1171d1
JM		 2410static unsigned int
2411Perl_sig_to_vmscondition_int(int sig)
f2610a60 2412{
2e34cc90 2413 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2414 {
2415 0, /* 0 ZERO */
2416 SS$_HANGUP, /* 1 SIGHUP */
2417 SS$_CONTROLC, /* 2 SIGINT */
2418 SS$_CONTROLY, /* 3 SIGQUIT */
2419 SS$_RADRMOD, /* 4 SIGILL */
2420 SS$_BREAK, /* 5 SIGTRAP */
2421 SS$_OPCCUS, /* 6 SIGABRT */
2422 SS$_COMPAT, /* 7 SIGEMT */
2423#ifdef __VAX
2424 SS$_FLTOVF, /* 8 SIGFPE VAX */
2425#else
2426 SS$_HPARITH, /* 8 SIGFPE AXP */
2427#endif
2428 SS$_ABORT, /* 9 SIGKILL */
2429 SS$_ACCVIO, /* 10 SIGBUS */
2430 SS$_ACCVIO, /* 11 SIGSEGV */
2431 SS$_BADPARAM, /* 12 SIGSYS */
2432 SS$_NOMBX, /* 13 SIGPIPE */
2433 SS$_ASTFLT, /* 14 SIGALRM */
2434 4, /* 15 SIGTERM */
2435 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2436 0, /* 17 SIGUSR2 */
2437 0, /* 18 */
2438 0, /* 19 */
2439 0, /* 20 SIGCHLD */
2440 0, /* 21 SIGCONT */
2441 0, /* 22 SIGSTOP */
2442 0, /* 23 SIGTSTP */
2443 0, /* 24 SIGTTIN */
2444 0, /* 25 SIGTTOU */
2445 0, /* 26 */
2446 0, /* 27 */
2447 0 /* 28 SIGWINCH */
f2610a60
CL		 2448 };
2449
2450#if __VMS_VER >= 60200000
2451 static int initted = 0;
2452 if (!initted) {
2453 initted = 1;
2454 sig_code[16] = C$_SIGUSR1;
2455 sig_code[17] = C$_SIGUSR2;
fe1de8ce
CB		 2456#if __CRTL_VER >= 70000000
2457 sig_code[20] = C$_SIGCHLD;
2458#endif
2459#if __CRTL_VER >= 70300000
2460 sig_code[28] = C$_SIGWINCH;
2461#endif
f2610a60
CL		 2462 }
2463#endif
2464
2e34cc90
CL		 2465 if (sig < _SIG_MIN) return 0;
2466 if (sig > _MY_SIG_MAX) return 0;
2467 return sig_code[sig];
2468}
2469
9c1171d1
JM		 2470unsigned int
2471Perl_sig_to_vmscondition(int sig)
2472{
2473#ifdef SS$_DEBUG
2474 if (vms_debug_on_exception != 0)
2475 lib$signal(SS$_DEBUG);
2476#endif
2477 return Perl_sig_to_vmscondition_int(sig);
2478}
2479
2480
2e34cc90
CL		 2481int
2482Perl_my_kill(int pid, int sig)
2483{
218fdd94 2484 dTHX;
2e34cc90
CL		 2485 int iss;
2486 unsigned int code;
2487 int sys$sigprc(unsigned int *pidadr,
2488 struct dsc$descriptor_s *prcname,
2489 unsigned int code);
2490
7a7fd8e0
JM		 2491 /* sig 0 means validate the PID */
2492 /*------------------------------*/
2493 if (sig == 0) {
2494 const unsigned long int jpicode = JPI$_PID;
2495 pid_t ret_pid;
2496 int status;
2497 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2498 if ($VMS_STATUS_SUCCESS(status))
2499 return 0;
2500 switch (status) {
2501 case SS$_NOSUCHNODE:
2502 case SS$_UNREACHABLE:
2503 case SS$_NONEXPR:
2504 errno = ESRCH;
2505 break;
2506 case SS$_NOPRIV:
2507 errno = EPERM;
2508 break;
2509 default:
2510 errno = EVMSERR;
2511 }
2512 vaxc$errno=status;
2513 return -1;
2514 }
2515
9c1171d1 2516 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2517
7a7fd8e0
JM		 2518 if (!code) {
2519 SETERRNO(EINVAL, SS$_BADPARAM);
2520 return -1;
2521 }
2522
2523 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2524 * signals are to be sent to multiple processes.
2525 * pid = 0 - all processes in group except ones that the system exempts
2526 * pid = -1 - all processes except ones that the system exempts
2527 * pid = -n - all processes in group (abs(n)) except ...
2528 * For now, just report as not supported.
2529 */
2530
2531 if (pid <= 0) {
2532 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2533 return -1;
2534 }
2535
2e34cc90 2536 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2537 if (iss&1) return 0;
2538
2539 switch (iss) {
2540 case SS$_NOPRIV:
2541 set_errno(EPERM); break;
2542 case SS$_NONEXPR:
2543 case SS$_NOSUCHNODE:
2544 case SS$_UNREACHABLE:
2545 set_errno(ESRCH); break;
2546 case SS$_INSFMEM:
2547 set_errno(ENOMEM); break;
2548 default:
ebd4d70b 2549 _ckvmssts_noperl(iss);
f2610a60
CL		 2550 set_errno(EVMSERR);
2551 }
2552 set_vaxc_errno(iss);
2553
2554 return -1;
2555}
2556#endif
2557
2fbb330f
JM		 2558/* Routine to convert a VMS status code to a UNIX status code.
2559** More tricky than it appears because of conflicting conventions with
2560** existing code.
2561**
2562** VMS status codes are a bit mask, with the least significant bit set for
2563** success.
2564**
2565** Special UNIX status of EVMSERR indicates that no translation is currently
2566** available, and programs should check the VMS status code.
2567**
2568** Programs compiled with _POSIX_EXIT have a special encoding that requires
2569** decoding.
2570*/
2571
2572#ifndef C_FACILITY_NO
2573#define C_FACILITY_NO 0x350000
2574#endif
2575#ifndef DCL_IVVERB
2576#define DCL_IVVERB 0x38090
2577#endif
2578
7a7fd8e0 2579int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2580{
2581int facility;
2582int fac_sp;
2583int msg_no;
2584int msg_status;
2585int unix_status;
2586
2587 /* Assume the best or the worst */
2588 if (vms_status & STS$M_SUCCESS)
2589 unix_status = 0;
2590 else
2591 unix_status = EVMSERR;
2592
2593 msg_status = vms_status & ~STS$M_CONTROL;
2594
2595 facility = vms_status & STS$M_FAC_NO;
2596 fac_sp = vms_status & STS$M_FAC_SP;
2597 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2598
0968cdad 2599 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2600 switch(msg_no) {
2601 case SS$_NORMAL:
2602 unix_status = 0;
2603 break;
2604 case SS$_ACCVIO:
2605 unix_status = EFAULT;
2606 break;
7a7fd8e0
JM		 2607 case SS$_DEVOFFLINE:
2608 unix_status = EBUSY;
2609 break;
2610 case SS$_CLEARED:
2611 unix_status = ENOTCONN;
2612 break;
2613 case SS$_IVCHAN:
2fbb330f
JM		 2614 case SS$_IVLOGNAM:
2615 case SS$_BADPARAM:
2616 case SS$_IVLOGTAB:
2617 case SS$_NOLOGNAM:
2618 case SS$_NOLOGTAB:
2619 case SS$_INVFILFOROP:
2620 case SS$_INVARG:
2621 case SS$_NOSUCHID:
2622 case SS$_IVIDENT:
2623 unix_status = EINVAL;
2624 break;
7a7fd8e0
JM		 2625 case SS$_UNSUPPORTED:
2626 unix_status = ENOTSUP;
2627 break;
2fbb330f
JM		 2628 case SS$_FILACCERR:
2629 case SS$_NOGRPPRV:
2630 case SS$_NOSYSPRV:
2631 unix_status = EACCES;
2632 break;
2633 case SS$_DEVICEFULL:
2634 unix_status = ENOSPC;
2635 break;
2636 case SS$_NOSUCHDEV:
2637 unix_status = ENODEV;
2638 break;
2639 case SS$_NOSUCHFILE:
2640 case SS$_NOSUCHOBJECT:
2641 unix_status = ENOENT;
2642 break;
fb38d079
JM		 2643 case SS$_ABORT: /* Fatal case */
2644 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2645 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2646 unix_status = EINTR;
2647 break;
2648 case SS$_BUFFEROVF:
2649 unix_status = E2BIG;
2650 break;
2651 case SS$_INSFMEM:
2652 unix_status = ENOMEM;
2653 break;
2654 case SS$_NOPRIV:
2655 unix_status = EPERM;
2656 break;
2657 case SS$_NOSUCHNODE:
2658 case SS$_UNREACHABLE:
2659 unix_status = ESRCH;
2660 break;
2661 case SS$_NONEXPR:
2662 unix_status = ECHILD;
2663 break;
2664 default:
2665 if ((facility == 0) && (msg_no < 8)) {
2666 /* These are not real VMS status codes so assume that they are
2667 ** already UNIX status codes
2668 */
2669 unix_status = msg_no;
2670 break;
2671 }
2672 }
2673 }
2674 else {
2675 /* Translate a POSIX exit code to a UNIX exit code */
2676 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2677 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2678 }
2679 else {
7a7fd8e0
JM		 2680
2681 /* Documented traditional behavior for handling VMS child exits */
2682 /*--------------------------------------------------------------*/
2683 if (child_flag != 0) {
2684
2685 /* Success / Informational return 0 */
2686 /*----------------------------------*/
2687 if (msg_no & STS$K_SUCCESS)
2688 return 0;
2689
2690 /* Warning returns 1 */
2691 /*-------------------*/
2692 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2693 return 1;
2694
2695 /* Everything else pass through the severity bits */
2696 /*------------------------------------------------*/
2697 return (msg_no & STS$M_SEVERITY);
2698 }
2699
2700 /* Normal VMS status to ERRNO mapping attempt */
2701 /*--------------------------------------------*/
2fbb330f
JM		 2702 switch(msg_status) {
2703 /* case RMS$_EOF: */ /* End of File */
2704 case RMS$_FNF: /* File Not Found */
2705 case RMS$_DNF: /* Dir Not Found */
2706 unix_status = ENOENT;
2707 break;
2708 case RMS$_RNF: /* Record Not Found */
2709 unix_status = ESRCH;
2710 break;
2711 case RMS$_DIR:
2712 unix_status = ENOTDIR;
2713 break;
2714 case RMS$_DEV:
2715 unix_status = ENODEV;
2716 break;
7a7fd8e0
JM		 2717 case RMS$_IFI:
2718 case RMS$_FAC:
2719 case RMS$_ISI:
2720 unix_status = EBADF;
2721 break;
2722 case RMS$_FEX:
2723 unix_status = EEXIST;
2724 break;
2fbb330f
JM		 2725 case RMS$_SYN:
2726 case RMS$_FNM:
2727 case LIB$_INVSTRDES:
2728 case LIB$_INVARG:
2729 case LIB$_NOSUCHSYM:
2730 case LIB$_INVSYMNAM:
2731 case DCL_IVVERB:
2732 unix_status = EINVAL;
2733 break;
2734 case CLI$_BUFOVF:
2735 case RMS$_RTB:
2736 case CLI$_TKNOVF:
2737 case CLI$_RSLOVF:
2738 unix_status = E2BIG;
2739 break;
2740 case RMS$_PRV: /* No privilege */
2741 case RMS$_ACC: /* ACP file access failed */
2742 case RMS$_WLK: /* Device write locked */
2743 unix_status = EACCES;
2744 break;
ed1b9de0
JM		 2745 case RMS$_MKD: /* Failed to mark for delete */
2746 unix_status = EPERM;
2747 break;
2fbb330f
JM		 2748 /* case RMS$_NMF: */ /* No more files */
2749 }
2750 }
2751 }
2752
2753 return unix_status;
2754}
2755
7a7fd8e0
JM		 2756/* Try to guess at what VMS error status should go with a UNIX errno
2757 * value. This is hard to do as there could be many possible VMS
2758 * error statuses that caused the errno value to be set.
2759 */
2760
2761int Perl_unix_status_to_vms(int unix_status)
2762{
2763int test_unix_status;
2764
2765 /* Trivial cases first */
2766 /*---------------------*/
2767 if (unix_status == EVMSERR)
2768 return vaxc$errno;
2769
2770 /* Is vaxc$errno sane? */
2771 /*---------------------*/
2772 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2773 if (test_unix_status == unix_status)
2774 return vaxc$errno;
2775
2776 /* If way out of range, must be VMS code already */
2777 /*-----------------------------------------------*/
2778 if (unix_status > EVMSERR)
2779 return unix_status;
2780
2781 /* If out of range, punt */
2782 /*-----------------------*/
2783 if (unix_status > __ERRNO_MAX)
2784 return SS$_ABORT;
2785
2786
2787 /* Ok, now we have to do it the hard way. */
2788 /*----------------------------------------*/
2789 switch(unix_status) {
2790 case 0: return SS$_NORMAL;
2791 case EPERM: return SS$_NOPRIV;
2792 case ENOENT: return SS$_NOSUCHOBJECT;
2793 case ESRCH: return SS$_UNREACHABLE;
2794 case EINTR: return SS$_ABORT;
2795 /* case EIO: */
2796 /* case ENXIO: */
2797 case E2BIG: return SS$_BUFFEROVF;
2798 /* case ENOEXEC */
2799 case EBADF: return RMS$_IFI;
2800 case ECHILD: return SS$_NONEXPR;
2801 /* case EAGAIN */
2802 case ENOMEM: return SS$_INSFMEM;
2803 case EACCES: return SS$_FILACCERR;
2804 case EFAULT: return SS$_ACCVIO;
2805 /* case ENOTBLK */
0968cdad 2806 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2807 case EEXIST: return RMS$_FEX;
2808 /* case EXDEV */
2809 case ENODEV: return SS$_NOSUCHDEV;
2810 case ENOTDIR: return RMS$_DIR;
2811 /* case EISDIR */
2812 case EINVAL: return SS$_INVARG;
2813 /* case ENFILE */
2814 /* case EMFILE */
2815 /* case ENOTTY */
2816 /* case ETXTBSY */
2817 /* case EFBIG */
2818 case ENOSPC: return SS$_DEVICEFULL;
2819 case ESPIPE: return LIB$_INVARG;
2820 /* case EROFS: */
2821 /* case EMLINK: */
2822 /* case EPIPE: */
2823 /* case EDOM */
2824 case ERANGE: return LIB$_INVARG;
2825 /* case EWOULDBLOCK */
2826 /* case EINPROGRESS */
2827 /* case EALREADY */
2828 /* case ENOTSOCK */
2829 /* case EDESTADDRREQ */
2830 /* case EMSGSIZE */
2831 /* case EPROTOTYPE */
2832 /* case ENOPROTOOPT */
2833 /* case EPROTONOSUPPORT */
2834 /* case ESOCKTNOSUPPORT */
2835 /* case EOPNOTSUPP */
2836 /* case EPFNOSUPPORT */
2837 /* case EAFNOSUPPORT */
2838 /* case EADDRINUSE */
2839 /* case EADDRNOTAVAIL */
2840 /* case ENETDOWN */
2841 /* case ENETUNREACH */
2842 /* case ENETRESET */
2843 /* case ECONNABORTED */
2844 /* case ECONNRESET */
2845 /* case ENOBUFS */
2846 /* case EISCONN */
2847 case ENOTCONN: return SS$_CLEARED;
2848 /* case ESHUTDOWN */
2849 /* case ETOOMANYREFS */
2850 /* case ETIMEDOUT */
2851 /* case ECONNREFUSED */
2852 /* case ELOOP */
2853 /* case ENAMETOOLONG */
2854 /* case EHOSTDOWN */
2855 /* case EHOSTUNREACH */
2856 /* case ENOTEMPTY */
2857 /* case EPROCLIM */
2858 /* case EUSERS */
2859 /* case EDQUOT */
2860 /* case ENOMSG */
2861 /* case EIDRM */
2862 /* case EALIGN */
2863 /* case ESTALE */
2864 /* case EREMOTE */
2865 /* case ENOLCK */
2866 /* case ENOSYS */
2867 /* case EFTYPE */
2868 /* case ECANCELED */
2869 /* case EFAIL */
2870 /* case EINPROG */
2871 case ENOTSUP:
2872 return SS$_UNSUPPORTED;
2873 /* case EDEADLK */
2874 /* case ENWAIT */
2875 /* case EILSEQ */
2876 /* case EBADCAT */
2877 /* case EBADMSG */
2878 /* case EABANDONED */
2879 default:
2880 return SS$_ABORT; /* punt */
2881 }
2882
2883 return SS$_ABORT; /* Should not get here */
2884}
2fbb330f
JM		 2885
2886
22d4bb9c
CB		 2887/* default piping mailbox size */
2888#define PERL_BUFSIZ 512
2889
674d6c38 2890
a0d0e21e 2891static void
8a646e0b 2892create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2893{
22d4bb9c
CB		 2894 unsigned long int mbxbufsiz;
2895 static unsigned long int syssize = 0;
2896 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2897 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2898 int sts;
2899
22d4bb9c
CB		 2900 if (!syssize) {
2901 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2902 /*
22d4bb9c
CB		 2903 * Get the SYSGEN parameter MAXBUF
2904 *
2905 * If the logical 'PERL_MBX_SIZE' is defined
2906 * use the value of the logical instead of PERL_BUFSIZ, but
2907 * keep the size between 128 and MAXBUF.
2908 *
a0d0e21e 2909 */
ebd4d70b 2910 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2911 }
2912
2913 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2914 mbxbufsiz = atoi(csize);
2915 } else {
2916 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2917 }
22d4bb9c
CB		 2918 if (mbxbufsiz < 128) mbxbufsiz = 128;
2919 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2920
ebd4d70b 2921 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2922
ebd4d70b
JM		 2923 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2924 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2925 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2926
2927} /* end of create_mbx() */
2928
22d4bb9c 2929
a0d0e21e 2930/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2931
2932typedef struct _iosb IOSB;
2933typedef struct _iosb* pIOSB;
2934typedef struct _pipe Pipe;
2935typedef struct _pipe* pPipe;
2936typedef struct pipe_details Info;
2937typedef struct pipe_details* pInfo;
2938typedef struct _srqp RQE;
2939typedef struct _srqp* pRQE;
2940typedef struct _tochildbuf CBuf;
2941typedef struct _tochildbuf* pCBuf;
2942
2943struct _iosb {
2944 unsigned short status;
2945 unsigned short count;
2946 unsigned long dvispec;
2947};
2948
2949#pragma member_alignment save
2950#pragma nomember_alignment quadword
2951struct _srqp { /* VMS self-relative queue entry */
2952 unsigned long qptr[2];
2953};
2954#pragma member_alignment restore
2955static RQE RQE_ZERO = {0,0};
2956
2957struct _tochildbuf {
2958 RQE q;
2959 int eof;
2960 unsigned short size;
2961 char *buf;
2962};
2963
2964struct _pipe {
2965 RQE free;
2966 RQE wait;
2967 int fd_out;
2968 unsigned short chan_in;
2969 unsigned short chan_out;
2970 char *buf;
2971 unsigned int bufsize;
2972 IOSB iosb;
2973 IOSB iosb2;
2974 int *pipe_done;
2975 int retry;
2976 int type;
2977 int shut_on_empty;
2978 int need_wake;
2979 pPipe *home;
2980 pInfo info;
2981 pCBuf curr;
2982 pCBuf curr2;
fd8cd3a3
DS		 2983#if defined(PERL_IMPLICIT_CONTEXT)
2984 void *thx; /* Either a thread or an interpreter */
2985 /* pointer, depending on how we're built */
2986#endif
22d4bb9c
CB		 2987};
2988
2989
a0d0e21e
LW		 2990struct pipe_details
2991{
22d4bb9c 2992 pInfo next;
ff7adb52
CL		 2993 PerlIO *fp; /* file pointer to pipe mailbox */
2994 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2995 int pid; /* PID of subprocess */
2996 int mode; /* == 'r' if pipe open for reading */
2997 int done; /* subprocess has completed */
ff7adb52 2998 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2999 int closing; /* my_pclose is closing this pipe */
3000 unsigned long completion; /* termination status of subprocess */
3001 pPipe in; /* pipe in to sub */
3002 pPipe out; /* pipe out of sub */
3003 pPipe err; /* pipe of sub's sys$error */
3004 int in_done; /* true when in pipe finished */
3005 int out_done;
3006 int err_done;
cd1191f1
CB		 3007 unsigned short xchan; /* channel to debug xterm */
3008 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 3009};
3010
748a9306
LW		 3011struct exit_control_block
3012{
3013 struct exit_control_block *flink;
3014 unsigned long int (*exit_routine)();
3015 unsigned long int arg_count;
3016 unsigned long int *status_address;
3017 unsigned long int exit_status;
3018};
3019
d85f548a
JH		 3020typedef struct _closed_pipes Xpipe;
3021typedef struct _closed_pipes* pXpipe;
3022
3023struct _closed_pipes {
3024 int pid; /* PID of subprocess */
3025 unsigned long completion; /* termination status of subprocess */
3026};
3027#define NKEEPCLOSED 50
3028static Xpipe closed_list[NKEEPCLOSED];
3029static int closed_index = 0;
3030static int closed_num = 0;
3031
22d4bb9c
CB		 3032#define RETRY_DELAY "0 ::0.20"
3033#define MAX_RETRY 50
a0d0e21e 3034
22d4bb9c
CB		 3035static int pipe_ef = 0; /* first call to safe_popen inits these*/
3036static unsigned long mypid;
3037static unsigned long delaytime[2];
3038
3039static pInfo open_pipes = NULL;
3040static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 3041
ff7adb52
CL		 3042#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
3043
3044
3eeba6fb 3045
748a9306 3046static unsigned long int
ebd4d70b 3047pipe_exit_routine()
748a9306 3048{
22d4bb9c 3049 pInfo info;
1e422769 3050 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 3051 int sts, did_stuff, need_eof, j;
3052
5ce486e0
CB		 3053 /*
3054 * Flush any pending i/o, but since we are in process run-down, be
3055 * careful about referencing PerlIO structures that may already have
3056 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 3057 */
3058 info = open_pipes;
3059 while (info) {
3060 if (info->fp) {
ebd4d70b
JM		 3061#if defined(PERL_IMPLICIT_CONTEXT)
3062 /* We need to use the Perl context of the thread that created */
3063 /* the pipe. */
3064 pTHX;
3065 if (info->err)
3066 aTHX = info->err->thx;
3067 else if (info->out)
3068 aTHX = info->out->thx;
3069 else if (info->in)
3070 aTHX = info->in->thx;
3071#endif
5ce486e0
CB		 3072 if (!info->useFILE
3073#if defined(USE_ITHREADS)
3074 && my_perl
3075#endif
3076 && PL_perlio_fd_refcnt)
3077 PerlIO_flush(info->fp);
ff7adb52
CL		 3078 else
3079 fflush((FILE *)info->fp);
3080 }
3081 info = info->next;
3082 }
3eeba6fb
CB		 3083
3084 /*
ff7adb52 3085 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 3086 don't hang
3087 */
3088 did_stuff = 0;
3089 info = open_pipes;
748a9306 3090
3eeba6fb 3091 while (info) {
b2b89246 3092 int need_eof;
d4c83939 3093 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 3094 if (info->in && !info->in->shut_on_empty) {
d4c83939 3095 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 3096 0, 0, 0, 0, 0, 0));
ff7adb52 3097 info->waiting = 1;
22d4bb9c 3098 did_stuff = 1;
748a9306 3099 }
d4c83939 3100 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3101 info = info->next;
3102 }
ff7adb52
CL		 3103
3104 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3105
3106 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3107 int nwait = 0;
3108
3109 info = open_pipes;
3110 while (info) {
d4c83939 3111 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3112 if (info->waiting && info->done)
3113 info->waiting = 0;
3114 nwait += info->waiting;
d4c83939 3115 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3116 info = info->next;
3117 }
3118 if (!nwait) break;
3119 sleep(1);
3120 }
3eeba6fb
CB		 3121
3122 did_stuff = 0;
3123 info = open_pipes;
3124 while (info) {
d4c83939 3125 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3126 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3127 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3128 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3129 did_stuff = 1;
3130 }
d4c83939 3131 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3132 info = info->next;
3133 }
ff7adb52
CL		 3134
3135 /* again, wait for effect */
3136
3137 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3138 int nwait = 0;
3139
3140 info = open_pipes;
3141 while (info) {
d4c83939 3142 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3143 if (info->waiting && info->done)
3144 info->waiting = 0;
3145 nwait += info->waiting;
d4c83939 3146 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3147 info = info->next;
3148 }
3149 if (!nwait) break;
3150 sleep(1);
3151 }
3eeba6fb
CB		 3152
3153 info = open_pipes;
3154 while (info) {
d4c83939 3155 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3156 if (!info->done) { /* We tried to be nice . . . */
3157 sts = sys$delprc(&info->pid,0);
d4c83939 3158 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3159 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3160 }
d4c83939 3161 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3162 info = info->next;
3163 }
3164
3165 while(open_pipes) {
ebd4d70b
JM		 3166
3167#if defined(PERL_IMPLICIT_CONTEXT)
3168 /* We need to use the Perl context of the thread that created */
3169 /* the pipe. */
3170 pTHX;
36b6faa8
CB		 3171 if (open_pipes->err)
3172 aTHX = open_pipes->err->thx;
3173 else if (open_pipes->out)
3174 aTHX = open_pipes->out->thx;
3175 else if (open_pipes->in)
3176 aTHX = open_pipes->in->thx;
ebd4d70b 3177#endif
1e422769 3178 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3179 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3180 }
3181 return retsts;
3182}
3183
3184static struct exit_control_block pipe_exitblock =
3185 {(struct exit_control_block *) 0,
3186 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3187
22d4bb9c
CB		 3188static void pipe_mbxtofd_ast(pPipe p);
3189static void pipe_tochild1_ast(pPipe p);
3190static void pipe_tochild2_ast(pPipe p);
748a9306 3191
a0d0e21e 3192static void
22d4bb9c 3193popen_completion_ast(pInfo info)
a0d0e21e 3194{
22d4bb9c
CB		 3195 pInfo i = open_pipes;
3196 int iss;
f7ddb74a 3197 int sts;
d85f548a
JH		 3198 pXpipe x;
3199
3200 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3201 closed_list[closed_index].pid = info->pid;
3202 closed_list[closed_index].completion = info->completion;
3203 closed_index++;
3204 if (closed_index == NKEEPCLOSED)
3205 closed_index = 0;
3206 closed_num++;
22d4bb9c
CB		 3207
3208 while (i) {
3209 if (i == info) break;
3210 i = i->next;
3211 }
3212 if (!i) return; /* unlinked, probably freed too */
3213
22d4bb9c
CB		 3214 info->done = TRUE;
3215
3216/*
3217 Writing to subprocess ...
3218 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3219
3220 chan_out may be waiting for "done" flag, or hung waiting
3221 for i/o completion to child...cancel the i/o. This will
3222 put it into "snarf mode" (done but no EOF yet) that discards
3223 input.
3224
3225 Output from subprocess (stdout, stderr) needs to be flushed and
3226 shut down. We try sending an EOF, but if the mbx is full the pipe
3227 routine should still catch the "shut_on_empty" flag, telling it to
3228 use immediate-style reads so that "mbx empty" -> EOF.
3229
3230
3231*/
3232 if (info->in && !info->in_done) { /* only for mode=w */
3233 if (info->in->shut_on_empty && info->in->need_wake) {
3234 info->in->need_wake = FALSE;
fd8cd3a3 3235 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3236 } else {
fd8cd3a3 3237 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3238 }
3239 }
3240
3241 if (info->out && !info->out_done) { /* were we also piping output? */
3242 info->out->shut_on_empty = TRUE;
3243 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3244 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3245 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3246 }
3247
3248 if (info->err && !info->err_done) { /* we were piping stderr */
3249 info->err->shut_on_empty = TRUE;
3250 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3252 _ckvmssts_noperl(iss);
a0d0e21e 3253 }
fd8cd3a3 3254 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3255
a0d0e21e
LW		 3256}
3257
2fbb330f 3258static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3259static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 3260
22d4bb9c
CB		 3261/*
3262 we actually differ from vmstrnenv since we use this to
3263 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3264 are pointing to the same thing
3265*/
3266
3267static unsigned short
fd8cd3a3 3268popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 3269{
3270 int iss;
3271 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3272 $DESCRIPTOR(d_log,"");
3273 struct _il3 {
3274 unsigned short length;
3275 unsigned short code;
3276 char * buffer_addr;
3277 unsigned short *retlenaddr;
3278 } itmlst[2];
3279 unsigned short l, ifi;
3280
3281 d_log.dsc$a_pointer = logical;
3282 d_log.dsc$w_length = strlen(logical);
3283
3284 itmlst[0].code = LNM$_STRING;
3285 itmlst[0].length = 255;
3286 itmlst[0].buffer_addr = result;
3287 itmlst[0].retlenaddr = &l;
3288
3289 itmlst[1].code = 0;
3290 itmlst[1].length = 0;
3291 itmlst[1].buffer_addr = 0;
3292 itmlst[1].retlenaddr = 0;
3293
3294 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3295 if (iss == SS$_NOLOGNAM) {
3296 iss = SS$_NORMAL;
3297 l = 0;
3298 }
3299 if (!(iss&1)) lib$signal(iss);
3300 result[l] = '\0';
3301/*
3302 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3303 strip it off and return the ifi, if any
3304*/
3305 ifi = 0;
3306 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 3307 memmove(&ifi,result+2,2);
22d4bb9c
CB		 3308 strcpy(result,result+4);
3309 }
3310 return ifi; /* this is the RMS internal file id */
3311}
3312
22d4bb9c
CB		 3313static void pipe_infromchild_ast(pPipe p);
3314
3315/*
3316 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3317 inside an AST routine without worrying about reentrancy and which Perl
3318 memory allocator is being used.
3319
3320 We read data and queue up the buffers, then spit them out one at a
3321 time to the output mailbox when the output mailbox is ready for one.
3322
3323*/
3324#define INITIAL_TOCHILDQUEUE 2
3325
3326static pPipe
fd8cd3a3 3327pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3328{
22d4bb9c
CB		 3329 pPipe p;
3330 pCBuf b;
3331 char mbx1[64], mbx2[64];
3332 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3333 DSC$K_CLASS_S, mbx1},
3334 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3335 DSC$K_CLASS_S, mbx2};
3336 unsigned int dviitm = DVI$_DEVBUFSIZ;
3337 int j, n;
3338
d4c83939 3339 n = sizeof(Pipe);
ebd4d70b 3340 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3341
8a646e0b
JM		 3342 create_mbx(&p->chan_in , &d_mbx1);
3343 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3344 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3345
3346 p->buf = 0;
3347 p->shut_on_empty = FALSE;
3348 p->need_wake = FALSE;
3349 p->type = 0;
3350 p->retry = 0;
3351 p->iosb.status = SS$_NORMAL;
3352 p->iosb2.status = SS$_NORMAL;
3353 p->free = RQE_ZERO;
3354 p->wait = RQE_ZERO;
3355 p->curr = 0;
3356 p->curr2 = 0;
3357 p->info = 0;
fd8cd3a3
DS		 3358#ifdef PERL_IMPLICIT_CONTEXT
3359 p->thx = aTHX;
3360#endif
22d4bb9c
CB		 3361
3362 n = sizeof(CBuf) + p->bufsize;
3363
3364 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3365 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3366 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3367 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3368 }
3369
3370 pipe_tochild2_ast(p);
3371 pipe_tochild1_ast(p);
3372 strcpy(wmbx, mbx1);
3373 strcpy(rmbx, mbx2);
3374 return p;
3375}
3376
3377/* reads the MBX Perl is writing, and queues */
3378
3379static void
3380pipe_tochild1_ast(pPipe p)
3381{
22d4bb9c
CB		 3382 pCBuf b = p->curr;
3383 int iss = p->iosb.status;
3384 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3385 int sts;
fd8cd3a3
DS		 3386#ifdef PERL_IMPLICIT_CONTEXT
3387 pTHX = p->thx;
3388#endif
22d4bb9c
CB		 3389
3390 if (p->retry) {
3391 if (eof) {
3392 p->shut_on_empty = TRUE;
3393 b->eof = TRUE;
ebd4d70b 3394 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3395 } else {
ebd4d70b 3396 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3397 }
3398
3399 b->eof = eof;
3400 b->size = p->iosb.count;
ebd4d70b 3401 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3402 if (p->need_wake) {
3403 p->need_wake = FALSE;
ebd4d70b 3404 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3405 }
3406 } else {
3407 p->retry = 1; /* initial call */
3408 }
3409
3410 if (eof) { /* flush the free queue, return when done */
3411 int n = sizeof(CBuf) + p->bufsize;
3412 while (1) {
3413 iss = lib$remqti(&p->free, &b);
3414 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3415 _ckvmssts_noperl(iss);
3416 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3417 }
3418 }
3419
3420 iss = lib$remqti(&p->free, &b);
3421 if (iss == LIB$_QUEWASEMP) {
3422 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3423 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3424 b->buf = (char *) b + sizeof(CBuf);
3425 } else {
ebd4d70b 3426 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3427 }
3428
3429 p->curr = b;
3430 iss = sys$qio(0,p->chan_in,
3431 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3432 &p->iosb,
3433 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3434 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3435 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3436}
3437
3438
3439/* writes queued buffers to output, waits for each to complete before
3440 doing the next */
3441
3442static void
3443pipe_tochild2_ast(pPipe p)
3444{
22d4bb9c
CB		 3445 pCBuf b = p->curr2;
3446 int iss = p->iosb2.status;
3447 int n = sizeof(CBuf) + p->bufsize;
3448 int done = (p->info && p->info->done) ||
3449 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3450#if defined(PERL_IMPLICIT_CONTEXT)
3451 pTHX = p->thx;
3452#endif
22d4bb9c
CB		 3453
3454 do {
3455 if (p->type) { /* type=1 has old buffer, dispose */
3456 if (p->shut_on_empty) {
ebd4d70b 3457 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3458 } else {
ebd4d70b 3459 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3460 }
3461 p->type = 0;
3462 }
3463
3464 iss = lib$remqti(&p->wait, &b);
3465 if (iss == LIB$_QUEWASEMP) {
3466 if (p->shut_on_empty) {
3467 if (done) {
ebd4d70b 3468 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3469 *p->pipe_done = TRUE;
ebd4d70b 3470 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3471 } else {
ebd4d70b 3472 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3473 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3474 }
3475 return;
3476 }
3477 p->need_wake = TRUE;
3478 return;
3479 }
ebd4d70b 3480 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3481 p->type = 1;
3482 } while (done);
3483
3484
3485 p->curr2 = b;
3486 if (b->eof) {
ebd4d70b 3487 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3488 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3489 } else {
ebd4d70b 3490 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3491 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3492 }
3493
3494 return;
3495
3496}
3497
3498
3499static pPipe
fd8cd3a3 3500pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3501{
22d4bb9c
CB		 3502 pPipe p;
3503 char mbx1[64], mbx2[64];
3504 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3505 DSC$K_CLASS_S, mbx1},
3506 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3507 DSC$K_CLASS_S, mbx2};
3508 unsigned int dviitm = DVI$_DEVBUFSIZ;
3509
d4c83939 3510 int n = sizeof(Pipe);
ebd4d70b 3511 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3512 create_mbx(&p->chan_in , &d_mbx1);
3513 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3514
ebd4d70b 3515 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3516 n = p->bufsize * sizeof(char);
ebd4d70b 3517 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3518 p->shut_on_empty = FALSE;
3519 p->info = 0;
3520 p->type = 0;
3521 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3522#if defined(PERL_IMPLICIT_CONTEXT)
3523 p->thx = aTHX;
3524#endif
22d4bb9c
CB		 3525 pipe_infromchild_ast(p);
3526
3527 strcpy(wmbx, mbx1);
3528 strcpy(rmbx, mbx2);
3529 return p;
3530}
3531
3532static void
3533pipe_infromchild_ast(pPipe p)
3534{
22d4bb9c
CB		 3535 int iss = p->iosb.status;
3536 int eof = (iss == SS$_ENDOFFILE);
3537 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3538 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3539#if defined(PERL_IMPLICIT_CONTEXT)
3540 pTHX = p->thx;
3541#endif
22d4bb9c
CB		 3542
3543 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3544 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3545 p->chan_out = 0;
3546 }
3547
3548 /* read completed:
3549 input shutdown if EOF from self (done or shut_on_empty)
3550 output shutdown if closing flag set (my_pclose)
3551 send data/eof from child or eof from self
3552 otherwise, re-read (snarf of data from child)
3553 */
3554
3555 if (p->type == 1) {
3556 p->type = 0;
3557 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3558 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3559 p->chan_in = 0;
3560 }
3561
3562 if (p->chan_out) {
3563 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3564 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3565 pipe_infromchild_ast, p,
3566 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3567 return;
3568 } else if (eof) { /* eat EOF --- fall through to read*/
3569
3570 } else { /* transmit data */
ebd4d70b
JM		 3571 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3572 pipe_infromchild_ast,p,
3573 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3574 return;
3575 }
3576 }
3577 }
3578
3579 /* everything shut? flag as done */
3580
3581 if (!p->chan_in && !p->chan_out) {
3582 *p->pipe_done = TRUE;
ebd4d70b 3583 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3584 return;
3585 }
3586
3587 /* write completed (or read, if snarfing from child)
3588 if still have input active,
3589 queue read...immediate mode if shut_on_empty so we get EOF if empty
3590 otherwise,
3591 check if Perl reading, generate EOFs as needed
3592 */
3593
3594 if (p->type == 0) {
3595 p->type = 1;
3596 if (p->chan_in) {
3597 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3598 pipe_infromchild_ast,p,
3599 p->buf, p->bufsize, 0, 0, 0, 0);
3600 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3601 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3602 } else { /* send EOFs for extra reads */
3603 p->iosb.status = SS$_ENDOFFILE;
3604 p->iosb.dvispec = 0;
ebd4d70b
JM		 3605 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3606 0, 0, 0,
3607 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3608 }
3609 }
3610}
3611
3612static pPipe
fd8cd3a3 3613pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3614{
22d4bb9c
CB		 3615 pPipe p;
3616 char mbx[64];
3617 unsigned long dviitm = DVI$_DEVBUFSIZ;
3618 struct stat s;
3619 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3620 DSC$K_CLASS_S, mbx};
a480973c 3621 int n = sizeof(Pipe);
22d4bb9c
CB		 3622
3623 /* things like terminals and mbx's don't need this filter */
3624 if (fd && fstat(fd,&s) == 0) {
3625 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3626 char device[65];
3627 unsigned short dev_len;
3628 struct dsc$descriptor_s d_dev;
3629 char * cptr;
3630 struct item_list_3 items[3];
3631 int status;
3632 unsigned short dvi_iosb[4];
3633
3634 cptr = getname(fd, out, 1);
ebd4d70b 3635 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3636 d_dev.dsc$a_pointer = out;
3637 d_dev.dsc$w_length = strlen(out);
3638 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3639 d_dev.dsc$b_class = DSC$K_CLASS_S;
3640
3641 items[0].len = 4;
3642 items[0].code = DVI$_DEVCHAR;
3643 items[0].bufadr = &devchar;
3644 items[0].retadr = NULL;
3645 items[1].len = 64;
3646 items[1].code = DVI$_FULLDEVNAM;
3647 items[1].bufadr = device;
3648 items[1].retadr = &dev_len;
3649 items[2].len = 0;
3650 items[2].code = 0;
3651
3652 status = sys$getdviw
3653 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3654 _ckvmssts_noperl(status);
cfcfe586
JM		 3655 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3656 device[dev_len] = 0;
3657
3658 if (!(devchar & DEV$M_DIR)) {
3659 strcpy(out, device);
3660 return 0;
3661 }
3662 }
22d4bb9c
CB		 3663 }
3664
ebd4d70b 3665 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3666 p->fd_out = dup(fd);
8a646e0b 3667 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3668 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3669 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3670 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3671 p->shut_on_empty = FALSE;
3672 p->retry = 0;
3673 p->info = 0;
3674 strcpy(out, mbx);
3675
ebd4d70b
JM		 3676 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3677 pipe_mbxtofd_ast, p,
3678 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3679
3680 return p;
3681}
3682
3683static void
3684pipe_mbxtofd_ast(pPipe p)
3685{
22d4bb9c
CB		 3686 int iss = p->iosb.status;
3687 int done = p->info->done;
3688 int iss2;
3689 int eof = (iss == SS$_ENDOFFILE);
3690 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3691 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3692#if defined(PERL_IMPLICIT_CONTEXT)
3693 pTHX = p->thx;
3694#endif
22d4bb9c
CB		 3695
3696 if (done && myeof) { /* end piping */
3697 close(p->fd_out);
3698 sys$dassgn(p->chan_in);
3699 *p->pipe_done = TRUE;
ebd4d70b 3700 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3701 return;
3702 }
3703
3704 if (!err && !eof) { /* good data to send to file */
3705 p->buf[p->iosb.count] = '\n';
3706 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3707 if (iss2 < 0) {
3708 p->retry++;
3709 if (p->retry < MAX_RETRY) {
ebd4d70b 3710 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3711 return;
3712 }
3713 }
3714 p->retry = 0;
3715 } else if (err) {
ebd4d70b 3716 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3717 }
3718
3719
3720 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3721 pipe_mbxtofd_ast, p,
3722 p->buf, p->bufsize, 0, 0, 0, 0);
3723 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3724 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3725}
3726
3727
3728typedef struct _pipeloc PLOC;
3729typedef struct _pipeloc* pPLOC;
3730
3731struct _pipeloc {
3732 pPLOC next;
3733 char dir[NAM$C_MAXRSS+1];
3734};
3735static pPLOC head_PLOC = 0;
3736
5c0ae288 3737void
fd8cd3a3 3738free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3739{
3740 pPLOC p, pnext;
ff7adb52 3741 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3742
ff7adb52 3743 p = *pHead;
5c0ae288
CL		 3744 while (p) {
3745 pnext = p->next;
e0ef6b43 3746 PerlMem_free(p);
5c0ae288
CL		 3747 p = pnext;
3748 }
ff7adb52 3749 *pHead = 0;
5c0ae288 3750}
22d4bb9c
CB		 3751
3752static void
fd8cd3a3 3753store_pipelocs(pTHX)
22d4bb9c
CB		 3754{
3755 int i;
3756 pPLOC p;
ff7adb52 3757 AV *av = 0;
22d4bb9c
CB		 3758 SV *dirsv;
3759 GV *gv;
3760 char *dir, *x;
3761 char *unixdir;
3762 char temp[NAM$C_MAXRSS+1];
3763 STRLEN n_a;
3764
ff7adb52 3765 if (head_PLOC)
218fdd94 3766 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3767
22d4bb9c
CB		 3768/* the . directory from @INC comes last */
3769
e0ef6b43 3770 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3771 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3772 p->next = head_PLOC;
3773 head_PLOC = p;
3774 strcpy(p->dir,"./");
3775
3776/* get the directory from $^X */
3777
c5375c28 3778 unixdir = PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3779 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3780
218fdd94
CL		 3781#ifdef PERL_IMPLICIT_CONTEXT
3782 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3783#else
22d4bb9c 3784 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3785#endif
22d4bb9c
CB		 3786 strcpy(temp, PL_origargv[0]);
3787 x = strrchr(temp,']');
2497a41f
JM		 3788 if (x == NULL) {
3789 x = strrchr(temp,'>');
3790 if (x == NULL) {
3791 /* It could be a UNIX path */
3792 x = strrchr(temp,'/');
3793 }
3794 }
3795 if (x)
3796 x[1] = '\0';
3797 else {
3798 /* Got a bare name, so use default directory */
3799 temp[0] = '.';
3800 temp[1] = '\0';
3801 }
22d4bb9c 3802
4e205ed6 3803 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3804 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3805 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3806 p->next = head_PLOC;
3807 head_PLOC = p;
3808 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3809 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3810 }
22d4bb9c
CB		 3811 }
3812
3813/* reverse order of @INC entries, skip "." since entered above */
3814
218fdd94
CL		 3815#ifdef PERL_IMPLICIT_CONTEXT
3816 if (aTHX)
3817#endif
ff7adb52
CL		 3818 if (PL_incgv) av = GvAVn(PL_incgv);
3819
3820 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3821 dirsv = *av_fetch(av,i,TRUE);
3822
3823 if (SvROK(dirsv)) continue;
3824 dir = SvPVx(dirsv,n_a);
3825 if (strcmp(dir,".") == 0) continue;
4e205ed6 3826 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3827 continue;
3828
e0ef6b43 3829 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3830 p->next = head_PLOC;
3831 head_PLOC = p;
3832 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3833 p->dir[NAM$C_MAXRSS] = '\0';
3834 }
3835
3836/* most likely spot (ARCHLIB) put first in the list */
3837
3838#ifdef ARCHLIB_EXP
4e205ed6 3839 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3840 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3841 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3842 p->next = head_PLOC;
3843 head_PLOC = p;
3844 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3845 p->dir[NAM$C_MAXRSS] = '\0';
3846 }
3847#endif
c5375c28 3848 PerlMem_free(unixdir);
22d4bb9c
CB		 3849}
3850
a1887106
JM		 3851static I32
3852Perl_cando_by_name_int
3853 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3854#if !defined(PERL_IMPLICIT_CONTEXT)
3855#define cando_by_name_int Perl_cando_by_name_int
3856#else
3857#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3858#endif
22d4bb9c
CB		 3859
3860static char *
fd8cd3a3 3861find_vmspipe(pTHX)
22d4bb9c
CB		 3862{
3863 static int vmspipe_file_status = 0;
3864 static char vmspipe_file[NAM$C_MAXRSS+1];
3865
3866 /* already found? Check and use ... need read+execute permission */
3867
3868 if (vmspipe_file_status == 1) {
a1887106
JM		 3869 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3870 && cando_by_name_int
3871 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3872 return vmspipe_file;
3873 }
3874 vmspipe_file_status = 0;
3875 }
3876
3877 /* scan through stored @INC, $^X */
3878
3879 if (vmspipe_file_status == 0) {
3880 char file[NAM$C_MAXRSS+1];
3881 pPLOC p = head_PLOC;
3882
3883 while (p) {
2f4077ca 3884 char * exp_res;
4d743a9b 3885 int dirlen;
22d4bb9c 3886 strcpy(file, p->dir);
4d743a9b
JM		 3887 dirlen = strlen(file);
3888 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3889 file[NAM$C_MAXRSS] = '\0';
3890 p = p->next;
3891
6fb6c614 3892 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3893 if (!exp_res) continue;
22d4bb9c 3894
a1887106
JM		 3895 if (cando_by_name_int
3896 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3897 && cando_by_name_int
3898 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3899 vmspipe_file_status = 1;
3900 return vmspipe_file;
3901 }
3902 }
3903 vmspipe_file_status = -1; /* failed, use tempfiles */
3904 }
3905
3906 return 0;
3907}
3908
3909static FILE *
fd8cd3a3 3910vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3911{
3912 char file[NAM$C_MAXRSS+1];
3913 FILE *fp;
3914 static int index = 0;
2497a41f
JM		 3915 Stat_t s0, s1;
3916 int cmp_result;
22d4bb9c
CB		 3917
3918 /* create a tempfile */
3919
3920 /* we can't go from W, shr=get to R, shr=get without
3921 an intermediate vulnerable state, so don't bother trying...
3922
3923 and lib$spawn doesn't shr=put, so have to close the write
3924
3925 So... match up the creation date/time and the FID to
3926 make sure we're dealing with the same file
3927
3928 */
3929
3930 index++;
2497a41f
JM		 3931 if (!decc_filename_unix_only) {
3932 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3933 fp = fopen(file,"w");
3934 if (!fp) {
22d4bb9c
CB		 3935 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3936 fp = fopen(file,"w");
3937 if (!fp) {
3938 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3939 fp = fopen(file,"w");
2497a41f
JM		 3940 }
3941 }
3942 }
3943 else {
3944 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3945 fp = fopen(file,"w");
3946 if (!fp) {
3947 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3948 fp = fopen(file,"w");
3949 if (!fp) {
3950 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3951 fp = fopen(file,"w");
3952 }
3953 }
22d4bb9c
CB		 3954 }
3955 if (!fp) return 0; /* we're hosed */
3956
f9ecfa39 3957 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3958 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3959 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3960 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3961 fprintf(fp,"$ perl_on = \"set noon\"\n");
3962 fprintf(fp,"$ perl_exit = \"exit\"\n");
3963 fprintf(fp,"$ perl_del = \"delete\"\n");
3964 fprintf(fp,"$ pif = \"if\"\n");
3965 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3966 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3967 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3968 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3969 fprintf(fp,"$! --- build command line to get max possible length\n");
3970 fprintf(fp,"$c=perl_popen_cmd0\n");
3971 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3972 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3973 fprintf(fp,"$x=perl_popen_cmd3\n");
3974 fprintf(fp,"$c=c+x\n");
22d4bb9c 3975 fprintf(fp,"$ perl_on\n");
f9ecfa39 3976 fprintf(fp,"$ 'c'\n");
22d4bb9c 3977 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3978 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3979 fprintf(fp,"$ perl_exit 'perl_status'\n");
3980 fsync(fileno(fp));
3981
3982 fgetname(fp, file, 1);
312ac60b 3983 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3984 fclose(fp);
3985
2497a41f 3986 if (decc_filename_unix_only