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