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