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