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