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