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