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