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