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