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