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