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
Merge branch 'blead' of ssh://perl5.git.perl.org/gitroot/perl into blead
[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;
5c84aa53 971 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 972 continue;
973 }
974 retsts = SS$_NOLOGNAM;
975 for (i = 0; environ[i]; i++) {
976 if ((eq = strchr(environ[i],'=')) &&
299d126a 977 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 978 !strncmp(environ[i],uplnm,eq - environ[i])) {
979 eq++;
980 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
981 if (!eqvlen) continue;
982 retsts = SS$_NORMAL;
983 break;
984 }
985 }
986 if (retsts != SS$_NOLOGNAM) break;
987 }
988 }
989 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
990 !str$case_blind_compare(&tmpdsc,&clisym)) {
991 if (!ivsym && !secure) {
992 unsigned short int deflen = LNM$C_NAMLENGTH;
993 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
994 /* dynamic dsc to accomodate possible long value */
995 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
996 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
997 if (retsts & 1) {
2497a41f 998 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 999 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 1000 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 1001 /* Special hack--we might be called before the interpreter's */
1002 /* fully initialized, in which case either thr or PL_curcop */
1003 /* might be bogus. We have to check, since ckWARN needs them */
1004 /* both to be valid if running threaded */
cc077a9f 1005 if (ckWARN(WARN_MISC)) {
f98bc0c6 1006 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 1007 }
f675dbe5
CB		 1008 }
1009 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1010 }
1011 _ckvmssts(lib$sfree1_dd(&eqvdsc));
1012 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1013 if (retsts == LIB$_NOSUCHSYM) continue;
1014 break;
1015 }
1016 }
1017 else if (!ivlnm) {
843027b0 1018 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1019 midx = my_maxidx(lnm);
1020 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1021 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1022 eqvlen = 0;
1023 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1024 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1025 if (retsts == SS$_NOLOGNAM) break;
1026 /* PPFs have a prefix */
1027 if (
fd7385b9 1028#if INTSIZE == 4
fa537f88 1029 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1030#endif
fa537f88
CB		 1031 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1032 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1033 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1034 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1035 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1036 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1037 eqvlen -= 4;
1038 }
f7ddb74a
JM		 1039 cp2 += eqvlen;
1040 *cp2 = '\0';
fa537f88
CB		 1041 }
1042 if ((retsts == SS$_IVLOGNAM) ||
1043 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1044 }
fa537f88 1045 else {
fa537f88
CB		 1046 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1047 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1048 if (retsts == SS$_NOLOGNAM) continue;
1049 eqv[eqvlen] = '\0';
1050 }
1051 eqvlen = strlen(eqv);
f675dbe5
CB		 1052 break;
1053 }
c07a80fd 1054 }
f675dbe5
CB		 1055 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1056 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1057 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1058 retsts == SS$_NOLOGNAM) {
1059 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1060 }
f675dbe5
CB		 1061 else _ckvmssts(retsts);
1062 return 0;
1063} /* end of vmstrnenv */
1064/*}}}*/
c07a80fd 1065
f675dbe5
CB		 1066/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1067/* Define as a function so we can access statics. */
4b19af01 1068int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 1069{
1070 return vmstrnenv(lnm,eqv,idx,fildev,
1071#ifdef SECURE_INTERNAL_GETENV
1072 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1073#else
1074 0
1075#endif
1076 );
1077}
1078/*}}}*/
a0d0e21e
LW		 1079
1080/* my_getenv
61bb5906
CB		 1081 * Note: Uses Perl temp to store result so char * can be returned to
1082 * caller; this pointer will be invalidated at next Perl statement
1083 * transition.
a6c40364 1084 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1085 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1086 * allocate SVs).
a0d0e21e 1087 */
f675dbe5 1088/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1089char *
5c84aa53 1090Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1091{
f7ddb74a 1092 const char *cp1;
fa537f88 1093 static char *__my_getenv_eqv = NULL;
f7ddb74a 1094 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1095 unsigned long int idx = 0;
bc10a425 1096 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 1097 int midx, flags;
61bb5906 1098 SV *tmpsv;
a0d0e21e 1099
f7ddb74a 1100 midx = my_maxidx(lnm) + 1;
fa537f88 1101
6b88bc9c 1102 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1103 /* Set up a temporary buffer for the return value; Perl will
1104 * clean it up at the next statement transition */
fa537f88 1105 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1106 if (!tmpsv) return NULL;
1107 eqv = SvPVX(tmpsv);
1108 }
fa537f88
CB		 1109 else {
1110 /* Assume no interpreter ==> single thread */
1111 if (__my_getenv_eqv != NULL) {
1112 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1113 }
1114 else {
a02a5408 1115 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1116 }
1117 eqv = __my_getenv_eqv;
1118 }
1119
f7ddb74a 1120 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1121 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1122 int len;
61bb5906 1123 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1124
1125 len = strlen(eqv);
1126
1127 /* Get rid of "000000/ in rooted filespecs */
1128 if (len > 7) {
1129 char * zeros;
1130 zeros = strstr(eqv, "/000000/");
1131 if (zeros != NULL) {
1132 int mlen;
1133 mlen = len - (zeros - eqv) - 7;
1134 memmove(zeros, &zeros[7], mlen);
1135 len = len - 7;
1136 eqv[len] = '\0';
1137 }
1138 }
61bb5906 1139 return eqv;
748a9306 1140 }
a0d0e21e 1141 else {
2512681b 1142 /* Impose security constraints only if tainting */
bc10a425
CB		 1143 if (sys) {
1144 /* Impose security constraints only if tainting */
1145 secure = PL_curinterp ? PL_tainting : will_taint;
1146 saverr = errno; savvmserr = vaxc$errno;
1147 }
843027b0
CB		 1148 else {
1149 secure = 0;
1150 }
1151
1152 flags =
f675dbe5 1153#ifdef SECURE_INTERNAL_GETENV
843027b0 1154 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1155#else
843027b0 1156 0
f675dbe5 1157#endif
843027b0
CB		 1158 ;
1159
1160 /* For the getenv interface we combine all the equivalence names
1161 * of a search list logical into one value to acquire a maximum
1162 * value length of 255*128 (assuming %ENV is using logicals).
1163 */
1164 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1165
1166 /* If the name contains a semicolon-delimited index, parse it
1167 * off and make sure we only retrieve the equivalence name for
1168 * that index. */
1169 if ((cp2 = strchr(lnm,';')) != NULL) {
1170 strcpy(uplnm,lnm);
1171 uplnm[cp2-lnm] = '\0';
1172 idx = strtoul(cp2+1,NULL,0);
1173 lnm = uplnm;
1174 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1175 }
1176
1177 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1178
bc10a425
CB		 1179 /* Discard NOLOGNAM on internal calls since we're often looking
1180 * for an optional name, and this "error" often shows up as the
1181 * (bogus) exit status for a die() call later on. */
1182 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1183 return success ? eqv : NULL;
a0d0e21e 1184 }
a0d0e21e
LW		 1185
1186} /* end of my_getenv() */
1187/*}}}*/
1188
f675dbe5 1189
a6c40364
GS		 1190/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1191char *
fd8cd3a3 1192Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1193{
f7ddb74a
JM		 1194 const char *cp1;
1195 char *buf, *cp2;
a6c40364 1196 unsigned long idx = 0;
843027b0 1197 int midx, flags;
fa537f88 1198 static char *__my_getenv_len_eqv = NULL;
bc10a425 1199 int secure, saverr, savvmserr;
cc077a9f
HM		 1200 SV *tmpsv;
1201
f7ddb74a 1202 midx = my_maxidx(lnm) + 1;
fa537f88 1203
cc077a9f
HM		 1204 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1205 /* Set up a temporary buffer for the return value; Perl will
1206 * clean it up at the next statement transition */
fa537f88 1207 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1208 if (!tmpsv) return NULL;
1209 buf = SvPVX(tmpsv);
1210 }
fa537f88
CB		 1211 else {
1212 /* Assume no interpreter ==> single thread */
1213 if (__my_getenv_len_eqv != NULL) {
1214 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1215 }
1216 else {
a02a5408 1217 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1218 }
1219 buf = __my_getenv_len_eqv;
1220 }
1221
f7ddb74a 1222 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1223 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1224 char * zeros;
1225
f675dbe5 1226 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1227 *len = strlen(buf);
f7ddb74a
JM		 1228
1229 /* Get rid of "000000/ in rooted filespecs */
1230 if (*len > 7) {
1231 zeros = strstr(buf, "/000000/");
1232 if (zeros != NULL) {
1233 int mlen;
1234 mlen = *len - (zeros - buf) - 7;
1235 memmove(zeros, &zeros[7], mlen);
1236 *len = *len - 7;
1237 buf[*len] = '\0';
1238 }
1239 }
a6c40364 1240 return buf;
f675dbe5
CB		 1241 }
1242 else {
bc10a425
CB		 1243 if (sys) {
1244 /* Impose security constraints only if tainting */
1245 secure = PL_curinterp ? PL_tainting : will_taint;
1246 saverr = errno; savvmserr = vaxc$errno;
1247 }
843027b0
CB		 1248 else {
1249 secure = 0;
1250 }
1251
1252 flags =
f675dbe5 1253#ifdef SECURE_INTERNAL_GETENV
843027b0 1254 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1255#else
843027b0 1256 0
f675dbe5 1257#endif
843027b0
CB		 1258 ;
1259
1260 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1261
1262 if ((cp2 = strchr(lnm,';')) != NULL) {
1263 strcpy(buf,lnm);
1264 buf[cp2-lnm] = '\0';
1265 idx = strtoul(cp2+1,NULL,0);
1266 lnm = buf;
1267 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268 }
1269
1270 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1271
f7ddb74a
JM		 1272 /* Get rid of "000000/ in rooted filespecs */
1273 if (*len > 7) {
1274 char * zeros;
1275 zeros = strstr(buf, "/000000/");
1276 if (zeros != NULL) {
1277 int mlen;
1278 mlen = *len - (zeros - buf) - 7;
1279 memmove(zeros, &zeros[7], mlen);
1280 *len = *len - 7;
1281 buf[*len] = '\0';
1282 }
1283 }
1284
bc10a425
CB		 1285 /* Discard NOLOGNAM on internal calls since we're often looking
1286 * for an optional name, and this "error" often shows up as the
1287 * (bogus) exit status for a die() call later on. */
1288 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1289 return *len ? buf : NULL;
f675dbe5
CB		 1290 }
1291
a6c40364 1292} /* end of my_getenv_len() */
f675dbe5
CB		 1293/*}}}*/
1294
fd8cd3a3 1295static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1296
1297static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1298
740ce14c 1299/*{{{ void prime_env_iter() */
1300void
1301prime_env_iter(void)
1302/* Fill the %ENV associative array with all logical names we can
1303 * find, in preparation for iterating over it.
1304 */
1305{
17f28c40 1306 static int primed = 0;
3eeba6fb 1307 HV *seenhv = NULL, *envhv;
22be8b3c 1308 SV *sv = NULL;
4e205ed6 1309 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1310 unsigned short int chan;
1311#ifndef CLI$M_TRUSTED
1312# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1313#endif
f675dbe5
CB		 1314 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1315 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1316 long int i;
1317 bool have_sym = FALSE, have_lnm = FALSE;
1318 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1320 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1322 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1323#if defined(PERL_IMPLICIT_CONTEXT)
1324 pTHX;
1325#endif
3db8f154 1326#if defined(USE_ITHREADS)
b2b3adea
HM		 1327 static perl_mutex primenv_mutex;
1328 MUTEX_INIT(&primenv_mutex);
61bb5906 1329#endif
740ce14c 1330
fd8cd3a3
DS		 1331#if defined(PERL_IMPLICIT_CONTEXT)
1332 /* We jump through these hoops because we can be called at */
1333 /* platform-specific initialization time, which is before anything is */
1334 /* set up--we can't even do a plain dTHX since that relies on the */
1335 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1336 if (PL_curinterp) {
1337 aTHX = PERL_GET_INTERP;
1338 } else {
1339 aTHX = NULL;
1340 }
1341#endif
fd8cd3a3 1342
3eeba6fb 1343 if (primed || !PL_envgv) return;
61bb5906
CB		 1344 MUTEX_LOCK(&primenv_mutex);
1345 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1346 envhv = GvHVn(PL_envgv);
740ce14c 1347 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1348 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1349 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1350
f675dbe5
CB		 1351 for (i = 0; env_tables[i]; i++) {
1352 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1353 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1354 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1355 }
f675dbe5
CB		 1356 if (have_sym || have_lnm) {
1357 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1358 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1359 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1360 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1361 }
f675dbe5
CB		 1362
1363 for (i--; i >= 0; i--) {
1364 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1365 char *start;
1366 int j;
1367 for (j = 0; environ[j]; j++) {
1368 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1369 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1370 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1371 }
1372 else {
1373 start++;
22be8b3c
CB		 1374 sv = newSVpv(start,0);
1375 SvTAINTED_on(sv);
1376 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1377 }
1378 }
1379 continue;
740ce14c 1380 }
f675dbe5
CB		 1381 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1382 !str$case_blind_compare(&tmpdsc,&clisym)) {
1383 strcpy(cmd,"Show Symbol/Global *");
1384 cmddsc.dsc$w_length = 20;
1385 if (env_tables[i]->dsc$w_length == 12 &&
1386 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1387 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1388 flags = defflags | CLI$M_NOLOGNAM;
1389 }
1390 else {
1391 strcpy(cmd,"Show Logical *");
1392 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1393 strcat(cmd," /Table=");
1394 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1395 cmddsc.dsc$w_length = strlen(cmd);
1396 }
1397 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1398 flags = defflags | CLI$M_NOCLISYM;
1399 }
1400
1401 /* Create a new subprocess to execute each command, to exclude the
1402 * remote possibility that someone could subvert a mbx or file used
1403 * to write multiple commands to a single subprocess.
1404 */
1405 do {
1406 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1407 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1408 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1409 defflags &= ~CLI$M_TRUSTED;
1410 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1411 _ckvmssts(retsts);
a02a5408 1412 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1413 if (seenhv) SvREFCNT_dec(seenhv);
1414 seenhv = newHV();
1415 while (1) {
1416 char *cp1, *cp2, *key;
1417 unsigned long int sts, iosb[2], retlen, keylen;
1418 register U32 hash;
1419
1420 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1421 if (sts & 1) sts = iosb[0] & 0xffff;
1422 if (sts == SS$_ENDOFFILE) {
1423 int wakect = 0;
1424 while (substs == 0) { sys$hiber(); wakect++;}
1425 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1426 _ckvmssts(substs);
1427 break;
1428 }
1429 _ckvmssts(sts);
1430 retlen = iosb[0] >> 16;
1431 if (!retlen) continue; /* blank line */
1432 buf[retlen] = '\0';
1433 if (iosb[1] != subpid) {
1434 if (iosb[1]) {
5c84aa53 1435 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1436 }
1437 continue;
1438 }
3eeba6fb 1439 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1440 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1441
1442 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1443 if (*cp1 == '(' || /* Logical name table name */
1444 *cp1 == '=' /* Next eqv of searchlist */) continue;
1445 if (*cp1 == '"') cp1++;
1446 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1447 key = cp1; keylen = cp2 - cp1;
1448 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1449 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1450 while (*cp2 && *cp2 == '=') cp2++;
1451 while (*cp2 && *cp2 == ' ') cp2++;
1452 if (*cp2 == '"') { /* String translation; may embed "" */
1453 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1454 cp2++; cp1--; /* Skip "" surrounding translation */
1455 }
1456 else { /* Numeric translation */
1457 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1458 cp1--; /* stop on last non-space char */
1459 }
1460 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1461 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1462 continue;
1463 }
5afd6d42 1464 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1465
1466 if (cp1 == cp2 && *cp2 == '.') {
1467 /* A single dot usually means an unprintable character, such as a null
1468 * to indicate a zero-length value. Get the actual value to make sure.
1469 */
1470 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1471 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1472 int trnlen;
ff79d39d 1473 strncpy(lnm, key, keylen);
0faef845 1474 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1475 sv = newSVpvn(eqv, strlen(eqv));
1476 }
1477 else {
1478 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1479 }
1480
22be8b3c
CB		 1481 SvTAINTED_on(sv);
1482 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1483 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1484 }
f675dbe5
CB		 1485 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1486 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1487 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1488 char eqv[LNM$C_NAMLENGTH+1];
1489 int trnlen, i;
1490 for (i = 0; ppfs[i]; i++) {
1491 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1492 sv = newSVpv(eqv,trnlen);
1493 SvTAINTED_on(sv);
1494 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1495 }
740ce14c 1496 }
1497 }
f675dbe5
CB		 1498 primed = 1;
1499 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1500 if (buf) Safefree(buf);
1501 if (seenhv) SvREFCNT_dec(seenhv);
1502 MUTEX_UNLOCK(&primenv_mutex);
1503 return;
1504
740ce14c 1505} /* end of prime_env_iter */
1506/*}}}*/
740ce14c 1507
f675dbe5 1508
2c590a56 1509/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1510/* Define or delete an element in the same "environment" as
1511 * vmstrnenv(). If an element is to be deleted, it's removed from
1512 * the first place it's found. If it's to be set, it's set in the
1513 * place designated by the first element of the table vector.
3eeba6fb 1514 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1515 */
f675dbe5 1516int
2c590a56 1517Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1518{
f7ddb74a
JM		 1519 const char *cp1;
1520 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1521 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1522 int nseg = 0, j;
a0d0e21e 1523 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1524 struct itmlst_3 *ile, *ilist;
a0d0e21e 1525 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1526 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1527 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1528 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1529 $DESCRIPTOR(local,"_LOCAL");
1530
ed253963
CB		 1531 if (!lnm) {
1532 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1533 return SS$_IVLOGNAM;
1534 }
1535
f7ddb74a 1536 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1537 *cp2 = _toupper(*cp1);
1538 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1539 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1540 return SS$_IVLOGNAM;
1541 }
1542 }
a0d0e21e 1543 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1544 if (!tabvec || !*tabvec) tabvec = env_tables;
1545
3eeba6fb 1546 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1547 for (curtab = 0; tabvec[curtab]; curtab++) {
1548 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1549 int i;
299d126a 1550 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1551 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1552 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1553 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1554#ifdef HAS_SETENV
0e06870b 1555 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1556 }
1557 }
1558 ivenv = 1; retsts = SS$_NOLOGNAM;
1559#else
3eeba6fb 1560 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1561 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1562 ivenv = 1; retsts = SS$_NOSUCHPGM;
1563 break;
1564 }
1565 }
f675dbe5
CB		 1566#endif
1567 }
1568 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1569 !str$case_blind_compare(&tmpdsc,&clisym)) {
1570 unsigned int symtype;
1571 if (tabvec[curtab]->dsc$w_length == 12 &&
1572 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1573 !str$case_blind_compare(&tmpdsc,&local))
1574 symtype = LIB$K_CLI_LOCAL_SYM;
1575 else symtype = LIB$K_CLI_GLOBAL_SYM;
1576 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1577 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1578 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1579 break;
1580 }
1581 else if (!ivlnm) {
1582 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1583 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1584 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1585 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1586 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1587 }
a0d0e21e
LW		 1588 }
1589 }
f675dbe5
CB		 1590 else { /* we're defining a value */
1591 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1592#ifdef HAS_SETENV
3eeba6fb 1593 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1594#else
3eeba6fb 1595 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1597 retsts = SS$_NOSUCHPGM;
1598#endif
1599 }
1600 else {
f7ddb74a 1601 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1602 eqvdsc.dsc$w_length = strlen(eqv);
1603 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1604 !str$case_blind_compare(&tmpdsc,&clisym)) {
1605 unsigned int symtype;
1606 if (tabvec[0]->dsc$w_length == 12 &&
1607 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1608 !str$case_blind_compare(&tmpdsc,&local))
1609 symtype = LIB$K_CLI_LOCAL_SYM;
1610 else symtype = LIB$K_CLI_GLOBAL_SYM;
1611 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1612 }
3eeba6fb
CB		 1613 else {
1614 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1615 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1616
1617 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1618 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1619 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1620 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1621 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1622 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1623 }
1624
a02a5408 1625 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1626 ile = ilist;
1627 if (!ile) {
1628 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1629 return SS$_INSFMEM;
a1dfe751 1630 }
fa537f88
CB		 1631 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1632
1633 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1634 ile->itmcode = LNM$_STRING;
1635 ile->bufadr = c;
1636 if ((j+1) == nseg) {
1637 ile->buflen = strlen(c);
1638 /* in case we are truncating one that's too long */
1639 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1640 }
1641 else {
1642 ile->buflen = LNM$C_NAMLENGTH;
1643 }
1644 }
1645
1646 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1647 Safefree (ilist);
1648 }
1649 else {
1650 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1651 }
3eeba6fb 1652 }
f675dbe5
CB		 1653 }
1654 }
1655 if (!(retsts & 1)) {
1656 switch (retsts) {
1657 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1658 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1659 set_errno(EVMSERR); break;
1660 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1661 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1662 set_errno(EINVAL); break;
1663 case SS$_NOPRIV:
7d2497bf 1664 set_errno(EACCES); break;
f675dbe5
CB		 1665 default:
1666 _ckvmssts(retsts);
1667 set_errno(EVMSERR);
1668 }
1669 set_vaxc_errno(retsts);
1670 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1671 }
3eeba6fb
CB		 1672 else {
1673 /* We reset error values on success because Perl does an hv_fetch()
1674 * before each hv_store(), and if the thing we're setting didn't
1675 * previously exist, we've got a leftover error message. (Of course,
1676 * this fails in the face of
1677 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1678 * in that the error reported in $! isn't spurious,
1679 * but it's right more often than not.)
1680 */
f675dbe5
CB		 1681 set_errno(0); set_vaxc_errno(retsts);
1682 return 0;
1683 }
1684
1685} /* end of vmssetenv() */
1686/*}}}*/
a0d0e21e 1687
2c590a56 1688/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1689/* This has to be a function since there's a prototype for it in proto.h */
1690void
2c590a56 1691Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1692{
bc10a425
CB		 1693 if (lnm && *lnm) {
1694 int len = strlen(lnm);
1695 if (len == 7) {
1696 char uplnm[8];
22d4bb9c
CB		 1697 int i;
1698 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1699 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1700 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1701 return;
1702 }
1703 }
1704#ifndef RTL_USES_UTC
1705 if (len == 6 || len == 2) {
1706 char uplnm[7];
1707 int i;
1708 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1709 uplnm[len] = '\0';
1710 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1711 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1712 }
1713#endif
1714 }
f675dbe5
CB		 1715 (void) vmssetenv(lnm,eqv,NULL);
1716}
a0d0e21e
LW		 1717/*}}}*/
1718
27c67b75 1719/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1720/* vmssetuserlnm
1721 * sets a user-mode logical in the process logical name table
1722 * used for redirection of sys$error
1723 */
1724void
2fbb330f 1725Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1726{
1727 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1729 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1730 unsigned char acmode = PSL$C_USER;
1731 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1732 {0, 0, 0, 0}};
2fbb330f 1733 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1734 d_name.dsc$w_length = strlen(name);
1735
1736 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1737 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1738
1739 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740 if (!(iss&1)) lib$signal(iss);
1741}
1742/*}}}*/
c07a80fd 1743
f675dbe5 1744
c07a80fd 1745/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746/* my_crypt - VMS password hashing
1747 * my_crypt() provides an interface compatible with the Unix crypt()
1748 * C library function, and uses sys$hash_password() to perform VMS
1749 * password hashing. The quadword hashed password value is returned
1750 * as a NUL-terminated 8 character string. my_crypt() does not change
1751 * the case of its string arguments; in order to match the behavior
1752 * of LOGINOUT et al., alphabetic characters in both arguments must
1753 * be upcased by the caller.
2497a41f
JM		 1754 *
1755 * - fix me to call ACM services when available
c07a80fd 1756 */
1757char *
fd8cd3a3 1758Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1759{
1760# ifndef UAI$C_PREFERRED_ALGORITHM
1761# define UAI$C_PREFERRED_ALGORITHM 127
1762# endif
1763 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764 unsigned short int salt = 0;
1765 unsigned long int sts;
1766 struct const_dsc {
1767 unsigned short int dsc$w_length;
1768 unsigned char dsc$b_type;
1769 unsigned char dsc$b_class;
1770 const char * dsc$a_pointer;
1771 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773 struct itmlst_3 uailst[3] = {
1774 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1775 { sizeof salt, UAI$_SALT, &salt, 0},
1776 { 0, 0, NULL, NULL}};
1777 static char hash[9];
1778
1779 usrdsc.dsc$w_length = strlen(usrname);
1780 usrdsc.dsc$a_pointer = usrname;
1781 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1782 switch (sts) {
f282b18d 1783 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1784 set_errno(EACCES);
1785 break;
1786 case RMS$_RNF:
1787 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1788 break;
1789 default:
1790 set_errno(EVMSERR);
1791 }
1792 set_vaxc_errno(sts);
1793 if (sts != RMS$_RNF) return NULL;
1794 }
1795
1796 txtdsc.dsc$w_length = strlen(textpasswd);
1797 txtdsc.dsc$a_pointer = textpasswd;
1798 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1800 }
1801
1802 return (char *) hash;
1803
1804} /* end of my_crypt() */
1805/*}}}*/
1806
1807
360732b5
JM		 1808static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1811
2497a41f
JM		 1812/* fixup barenames that are directories for internal use.
1813 * There have been problems with the consistent handling of UNIX
1814 * style directory names when routines are presented with a name that
1815 * has no directory delimitors at all. So this routine will eventually
1816 * fix the issue.
1817 */
1818static char * fixup_bare_dirnames(const char * name)
1819{
1820 if (decc_disable_to_vms_logname_translation) {
1821/* fix me */
1822 }
1823 return NULL;
1824}
1825
e0e5e8d6
JM		 1826/* 8.3, remove() is now broken on symbolic links */
1827static int rms_erase(const char * vmsname);
1828
1829
2497a41f
JM		 1830/* mp_do_kill_file
1831 * A little hack to get around a bug in some implemenation of remove()
1832 * that do not know how to delete a directory
1833 *
1834 * Delete any file to which user has control access, regardless of whether
1835 * delete access is explicitly allowed.
1836 * Limitations: User must have write access to parent directory.
1837 * Does not block signals or ASTs; if interrupted in midstream
1838 * may leave file with an altered ACL.
1839 * HANDLE WITH CARE!
1840 */
1841/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1842static int
1843mp_do_kill_file(pTHX_ const char *name, int dirflag)
1844{
e0e5e8d6
JM		 1845 char *vmsname;
1846 char *rslt;
2497a41f
JM		 1847 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1850 struct myacedef {
1851 unsigned char myace$b_length;
1852 unsigned char myace$b_type;
1853 unsigned short int myace$w_flags;
1854 unsigned long int myace$l_access;
1855 unsigned long int myace$l_ident;
1856 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1859 struct itmlst_3
1860 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1862 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1866
1867 /* Expand the input spec using RMS, since the CRTL remove() and
1868 * system services won't do this by themselves, so we may miss
1869 * a file "hiding" behind a logical name or search list. */
c5375c28
JM		 1870 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1871 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1872
e0e5e8d6
JM		 1873 rslt = do_rmsexpand(name,
1874 vmsname,
1875 0,
1876 NULL,
1877 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1878 NULL,
1879 NULL);
1880 if (rslt == NULL) {
c5375c28 1881 PerlMem_free(vmsname);
2497a41f
JM		 1882 return -1;
1883 }
c5375c28 1884
e0e5e8d6
JM		 1885 /* Erase the file */
1886 rmsts = rms_erase(vmsname);
2497a41f 1887
e0e5e8d6
JM		 1888 /* Did it succeed */
1889 if ($VMS_STATUS_SUCCESS(rmsts)) {
1890 PerlMem_free(vmsname);
1891 return 0;
2497a41f
JM		 1892 }
1893
1894 /* If not, can changing protections help? */
e0e5e8d6
JM		 1895 if (rmsts != RMS$_PRV) {
1896 set_vaxc_errno(rmsts);
1897 PerlMem_free(vmsname);
2497a41f
JM		 1898 return -1;
1899 }
1900
1901 /* No, so we get our own UIC to use as a rights identifier,
1902 * and the insert an ACE at the head of the ACL which allows us
1903 * to delete the file.
1904 */
1905 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1906 fildsc.dsc$w_length = strlen(vmsname);
1907 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1908 cxt = 0;
1909 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1910 rmsts = -1;
2497a41f
JM		 1911 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1912 switch (aclsts) {
1913 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1914 set_errno(ENOENT); break;
1915 case RMS$_DIR:
1916 set_errno(ENOTDIR); break;
1917 case RMS$_DEV:
1918 set_errno(ENODEV); break;
1919 case RMS$_SYN: case SS$_INVFILFOROP:
1920 set_errno(EINVAL); break;
1921 case RMS$_PRV:
1922 set_errno(EACCES); break;
1923 default:
1924 _ckvmssts(aclsts);
1925 }
1926 set_vaxc_errno(aclsts);
e0e5e8d6 1927 PerlMem_free(vmsname);
2497a41f
JM		 1928 return -1;
1929 }
1930 /* Grab any existing ACEs with this identifier in case we fail */
1931 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1932 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1933 || fndsts == SS$_NOMOREACE ) {
1934 /* Add the new ACE . . . */
1935 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1936 goto yourroom;
1937
e0e5e8d6
JM		 1938 rmsts = rms_erase(vmsname);
1939 if ($VMS_STATUS_SUCCESS(rmsts)) {
1940 rmsts = 0;
2497a41f
JM		 1941 }
1942 else {
e0e5e8d6 1943 rmsts = -1;
2497a41f
JM		 1944 /* We blew it - dir with files in it, no write priv for
1945 * parent directory, etc. Put things back the way they were. */
1946 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1947 goto yourroom;
1948 if (fndsts & 1) {
1949 addlst[0].bufadr = &oldace;
1950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1951 goto yourroom;
1952 }
1953 }
1954 }
1955
1956 yourroom:
1957 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1958 /* We just deleted it, so of course it's not there. Some versions of
1959 * VMS seem to return success on the unlock operation anyhow (after all
1960 * the unlock is successful), but others don't.
1961 */
1962 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1963 if (aclsts & 1) aclsts = fndsts;
1964 if (!(aclsts & 1)) {
1965 set_errno(EVMSERR);
1966 set_vaxc_errno(aclsts);
2497a41f
JM		 1967 }
1968
e0e5e8d6 1969 PerlMem_free(vmsname);
2497a41f
JM		 1970 return rmsts;
1971
1972} /* end of kill_file() */
1973/*}}}*/
1974
1975
a0d0e21e
LW		 1976/*{{{int do_rmdir(char *name)*/
1977int
b8ffc8df 1978Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1979{
e0e5e8d6 1980 char * dirfile;
a0d0e21e 1981 int retval;
61bb5906 1982 Stat_t st;
a0d0e21e 1983
e0e5e8d6
JM		 1984 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1985 if (dirfile == NULL)
1986 _ckvmssts(SS$_INSFMEM);
1987
1988 /* Force to a directory specification */
1989 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1990 PerlMem_free(dirfile);
1991 return -1;
1992 }
dffb32cf 1993 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1994 errno = ENOTDIR;
1995 retval = -1;
1996 }
1997 else
1998 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1999
2000 PerlMem_free(dirfile);
a0d0e21e
LW		 2001 return retval;
2002
2003} /* end of do_rmdir */
2004/*}}}*/
2005
2006/* kill_file
2007 * Delete any file to which user has control access, regardless of whether
2008 * delete access is explicitly allowed.
2009 * Limitations: User must have write access to parent directory.
2010 * Does not block signals or ASTs; if interrupted in midstream
2011 * may leave file with an altered ACL.
2012 * HANDLE WITH CARE!
2013 */
2014/*{{{int kill_file(char *name)*/
2015int
b8ffc8df 2016Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2017{
2f4077ca
JM		 2018 char rspec[NAM$C_MAXRSS+1];
2019 char *tspec;
e0e5e8d6
JM		 2020 Stat_t st;
2021 int rmsts;
a0d0e21e 2022
e0e5e8d6
JM		 2023 /* Remove() is allowed to delete directories, according to the X/Open
2024 * specifications.
4fdf8f88 2025 * This may need special handling to work with the ACL hacks.
a0d0e21e 2026 */
4fdf8f88 2027 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
dffb32cf 2028 rmsts = Perl_do_rmdir(aTHX_ name);
e0e5e8d6 2029 return rmsts;
a0d0e21e
LW		 2030 }
2031
e0e5e8d6 2032 rmsts = mp_do_kill_file(aTHX_ name, 0);
a0d0e21e
LW		 2033
2034 return rmsts;
2035
2036} /* end of kill_file() */
2037/*}}}*/
2038
8cc95fdb 2039
84902520 2040/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2041int
b8ffc8df 2042Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2043{
2044 STRLEN dirlen = strlen(dir);
2045
a2a90019
CB		 2046 /* zero length string sometimes gives ACCVIO */
2047 if (dirlen == 0) return -1;
2048
8cc95fdb 2049 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2050 * null file name/type. However, it's commonplace under Unix,
2051 * so we'll allow it for a gain in portability.
2052 */
2053 if (dir[dirlen-1] == '/') {
2054 char *newdir = savepvn(dir,dirlen-1);
2055 int ret = mkdir(newdir,mode);
2056 Safefree(newdir);
2057 return ret;
2058 }
2059 else return mkdir(dir,mode);
2060} /* end of my_mkdir */
2061/*}}}*/
2062
ee8c7f54
CB		 2063/*{{{int my_chdir(char *)*/
2064int
b8ffc8df 2065Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2066{
2067 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2068
2069 /* zero length string sometimes gives ACCVIO */
2070 if (dirlen == 0) return -1;
f7ddb74a
JM		 2071 const char *dir1;
2072
2073 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2074 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2075 * so that existing scripts do not need to be changed.
2076 */
2077 dir1 = dir;
2078 while ((dirlen > 0) && (*dir1 == ' ')) {
2079 dir1++;
2080 dirlen--;
2081 }
ee8c7f54
CB		 2082
2083 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2084 * that implies
2085 * null file name/type. However, it's commonplace under Unix,
2086 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 2087 *
2088 * - Preview- '/' will be valid soon on VMS
ee8c7f54 2089 */
f7ddb74a 2090 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
dca5a913 2091 char *newdir = savepvn(dir1,dirlen-1);
ee8c7f54
CB		 2092 int ret = chdir(newdir);
2093 Safefree(newdir);
2094 return ret;
2095 }
dca5a913 2096 else return chdir(dir1);
ee8c7f54
CB		 2097} /* end of my_chdir */
2098/*}}}*/
8cc95fdb 2099
674d6c38 2100
f1db9cda
JM		 2101/*{{{int my_chmod(char *, mode_t)*/
2102int
2103Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2104{
2105 STRLEN speclen = strlen(file_spec);
2106
2107 /* zero length string sometimes gives ACCVIO */
2108 if (speclen == 0) return -1;
2109
2110 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2111 * that implies null file name/type. However, it's commonplace under Unix,
2112 * so we'll allow it for a gain in portability.
2113 *
2114 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2115 * in VMS file.dir notation.
2116 */
2117 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2118 char *vms_src, *vms_dir, *rslt;
2119 int ret = -1;
2120 errno = EIO;
2121
2122 /* First convert this to a VMS format specification */
2123 vms_src = PerlMem_malloc(VMS_MAXRSS);
2124 if (vms_src == NULL)
2125 _ckvmssts(SS$_INSFMEM);
2126
2127 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2128 if (rslt == NULL) {
2129 /* If we fail, then not a file specification */
2130 PerlMem_free(vms_src);
2131 errno = EIO;
2132 return -1;
2133 }
2134
2135 /* Now make it a directory spec so chmod is happy */
2136 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2137 if (vms_dir == NULL)
2138 _ckvmssts(SS$_INSFMEM);
2139 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2140 PerlMem_free(vms_src);
2141
2142 /* Now do it */
2143 if (rslt != NULL) {
2144 ret = chmod(vms_dir, mode);
2145 } else {
2146 errno = EIO;
2147 }
2148 PerlMem_free(vms_dir);
2149 return ret;
2150 }
2151 else return chmod(file_spec, mode);
2152} /* end of my_chmod */
2153/*}}}*/
2154
2155
674d6c38
CB		 2156/*{{{FILE *my_tmpfile()*/
2157FILE *
2158my_tmpfile(void)
2159{
2160 FILE *fp;
2161 char *cp;
674d6c38
CB		 2162
2163 if ((fp = tmpfile())) return fp;
2164
c5375c28
JM		 2165 cp = PerlMem_malloc(L_tmpnam+24);
2166 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2167
2497a41f
JM		 2168 if (decc_filename_unix_only == 0)
2169 strcpy(cp,"Sys$Scratch:");
2170 else
2171 strcpy(cp,"/tmp/");
674d6c38
CB		 2172 tmpnam(cp+strlen(cp));
2173 strcat(cp,".Perltmp");
2174 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2175 PerlMem_free(cp);
674d6c38
CB		 2176 return fp;
2177}
2178/*}}}*/
2179
5c2d7af2
CB		 2180
2181#ifndef HOMEGROWN_POSIX_SIGNALS
2182/*
2183 * The C RTL's sigaction fails to check for invalid signal numbers so we
2184 * help it out a bit. The docs are correct, but the actual routine doesn't
2185 * do what the docs say it will.
2186 */
2187/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2188int
2189Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2190 struct sigaction* oact)
2191{
2192 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2193 SETERRNO(EINVAL, SS$_INVARG);
2194 return -1;
2195 }
2196 return sigaction(sig, act, oact);
2197}
2198/*}}}*/
2199#endif
2200
f2610a60
CL		 2201#ifdef KILL_BY_SIGPRC
2202#include <errnodef.h>
2203
05c058bc
CB		 2204/* We implement our own kill() using the undocumented system service
2205 sys$sigprc for one of two reasons:
2206
2207 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2208 target process to do a sys$exit, which usually can't be handled
2209 gracefully...certainly not by Perl and the %SIG{} mechanism.
2210
05c058bc
CB		 2211 2.) If the kill() in the CRTL can't be called from a signal
2212 handler without disappearing into the ether, i.e., the signal
2213 it purportedly sends is never trapped. Still true as of VMS 7.3.
2214
2215 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2216 in the target process rather than calling sys$exit.
2217
2218 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2219 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2220 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2221 with condition codes C$_SIG0+nsig*8, catching the exception on the
2222 target process and resignaling with appropriate arguments.
2223
2224 But we don't have that VMS 7.0+ exception handler, so if you
2225 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2226
2227 Also note that SIGTERM is listed in the docs as being "unimplemented",
2228 yet always seems to be signaled with a VMS condition code of 4 (and
2229 correctly handled for that code). So we hardwire it in.
2230
2231 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2232 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2233 than signalling with an unrecognized (and unhandled by CRTL) code.
2234*/
2235
fe1de8ce 2236#define _MY_SIG_MAX 28
f2610a60 2237
9c1171d1
JM		 2238static unsigned int
2239Perl_sig_to_vmscondition_int(int sig)
f2610a60 2240{
2e34cc90 2241 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2242 {
2243 0, /* 0 ZERO */
2244 SS$_HANGUP, /* 1 SIGHUP */
2245 SS$_CONTROLC, /* 2 SIGINT */
2246 SS$_CONTROLY, /* 3 SIGQUIT */
2247 SS$_RADRMOD, /* 4 SIGILL */
2248 SS$_BREAK, /* 5 SIGTRAP */
2249 SS$_OPCCUS, /* 6 SIGABRT */
2250 SS$_COMPAT, /* 7 SIGEMT */
2251#ifdef __VAX
2252 SS$_FLTOVF, /* 8 SIGFPE VAX */
2253#else
2254 SS$_HPARITH, /* 8 SIGFPE AXP */
2255#endif
2256 SS$_ABORT, /* 9 SIGKILL */
2257 SS$_ACCVIO, /* 10 SIGBUS */
2258 SS$_ACCVIO, /* 11 SIGSEGV */
2259 SS$_BADPARAM, /* 12 SIGSYS */
2260 SS$_NOMBX, /* 13 SIGPIPE */
2261 SS$_ASTFLT, /* 14 SIGALRM */
2262 4, /* 15 SIGTERM */
2263 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2264 0, /* 17 SIGUSR2 */
2265 0, /* 18 */
2266 0, /* 19 */
2267 0, /* 20 SIGCHLD */
2268 0, /* 21 SIGCONT */
2269 0, /* 22 SIGSTOP */
2270 0, /* 23 SIGTSTP */
2271 0, /* 24 SIGTTIN */
2272 0, /* 25 SIGTTOU */
2273 0, /* 26 */
2274 0, /* 27 */
2275 0 /* 28 SIGWINCH */
f2610a60
CL		 2276 };
2277
2278#if __VMS_VER >= 60200000
2279 static int initted = 0;
2280 if (!initted) {
2281 initted = 1;
2282 sig_code[16] = C$_SIGUSR1;
2283 sig_code[17] = C$_SIGUSR2;
fe1de8ce
CB		 2284#if __CRTL_VER >= 70000000
2285 sig_code[20] = C$_SIGCHLD;
2286#endif
2287#if __CRTL_VER >= 70300000
2288 sig_code[28] = C$_SIGWINCH;
2289#endif
f2610a60
CL		 2290 }
2291#endif
2292
2e34cc90
CL		 2293 if (sig < _SIG_MIN) return 0;
2294 if (sig > _MY_SIG_MAX) return 0;
2295 return sig_code[sig];
2296}
2297
9c1171d1
JM		 2298unsigned int
2299Perl_sig_to_vmscondition(int sig)
2300{
2301#ifdef SS$_DEBUG
2302 if (vms_debug_on_exception != 0)
2303 lib$signal(SS$_DEBUG);
2304#endif
2305 return Perl_sig_to_vmscondition_int(sig);
2306}
2307
2308
2e34cc90
CL		 2309int
2310Perl_my_kill(int pid, int sig)
2311{
218fdd94 2312 dTHX;
2e34cc90
CL		 2313 int iss;
2314 unsigned int code;
2315 int sys$sigprc(unsigned int *pidadr,
2316 struct dsc$descriptor_s *prcname,
2317 unsigned int code);
2318
7a7fd8e0
JM		 2319 /* sig 0 means validate the PID */
2320 /*------------------------------*/
2321 if (sig == 0) {
2322 const unsigned long int jpicode = JPI$_PID;
2323 pid_t ret_pid;
2324 int status;
2325 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2326 if ($VMS_STATUS_SUCCESS(status))
2327 return 0;
2328 switch (status) {
2329 case SS$_NOSUCHNODE:
2330 case SS$_UNREACHABLE:
2331 case SS$_NONEXPR:
2332 errno = ESRCH;
2333 break;
2334 case SS$_NOPRIV:
2335 errno = EPERM;
2336 break;
2337 default:
2338 errno = EVMSERR;
2339 }
2340 vaxc$errno=status;
2341 return -1;
2342 }
2343
9c1171d1 2344 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2345
7a7fd8e0
JM		 2346 if (!code) {
2347 SETERRNO(EINVAL, SS$_BADPARAM);
2348 return -1;
2349 }
2350
2351 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2352 * signals are to be sent to multiple processes.
2353 * pid = 0 - all processes in group except ones that the system exempts
2354 * pid = -1 - all processes except ones that the system exempts
2355 * pid = -n - all processes in group (abs(n)) except ...
2356 * For now, just report as not supported.
2357 */
2358
2359 if (pid <= 0) {
2360 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2361 return -1;
2362 }
2363
2e34cc90 2364 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2365 if (iss&1) return 0;
2366
2367 switch (iss) {
2368 case SS$_NOPRIV:
2369 set_errno(EPERM); break;
2370 case SS$_NONEXPR:
2371 case SS$_NOSUCHNODE:
2372 case SS$_UNREACHABLE:
2373 set_errno(ESRCH); break;
2374 case SS$_INSFMEM:
2375 set_errno(ENOMEM); break;
2376 default:
2377 _ckvmssts(iss);
2378 set_errno(EVMSERR);
2379 }
2380 set_vaxc_errno(iss);
2381
2382 return -1;
2383}
2384#endif
2385
2fbb330f
JM		 2386/* Routine to convert a VMS status code to a UNIX status code.
2387** More tricky than it appears because of conflicting conventions with
2388** existing code.
2389**
2390** VMS status codes are a bit mask, with the least significant bit set for
2391** success.
2392**
2393** Special UNIX status of EVMSERR indicates that no translation is currently
2394** available, and programs should check the VMS status code.
2395**
2396** Programs compiled with _POSIX_EXIT have a special encoding that requires
2397** decoding.
2398*/
2399
2400#ifndef C_FACILITY_NO
2401#define C_FACILITY_NO 0x350000
2402#endif
2403#ifndef DCL_IVVERB
2404#define DCL_IVVERB 0x38090
2405#endif
2406
7a7fd8e0 2407int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2408{
2409int facility;
2410int fac_sp;
2411int msg_no;
2412int msg_status;
2413int unix_status;
2414
2415 /* Assume the best or the worst */
2416 if (vms_status & STS$M_SUCCESS)
2417 unix_status = 0;
2418 else
2419 unix_status = EVMSERR;
2420
2421 msg_status = vms_status & ~STS$M_CONTROL;
2422
2423 facility = vms_status & STS$M_FAC_NO;
2424 fac_sp = vms_status & STS$M_FAC_SP;
2425 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2426
0968cdad 2427 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2428 switch(msg_no) {
2429 case SS$_NORMAL:
2430 unix_status = 0;
2431 break;
2432 case SS$_ACCVIO:
2433 unix_status = EFAULT;
2434 break;
7a7fd8e0
JM		 2435 case SS$_DEVOFFLINE:
2436 unix_status = EBUSY;
2437 break;
2438 case SS$_CLEARED:
2439 unix_status = ENOTCONN;
2440 break;
2441 case SS$_IVCHAN:
2fbb330f
JM		 2442 case SS$_IVLOGNAM:
2443 case SS$_BADPARAM:
2444 case SS$_IVLOGTAB:
2445 case SS$_NOLOGNAM:
2446 case SS$_NOLOGTAB:
2447 case SS$_INVFILFOROP:
2448 case SS$_INVARG:
2449 case SS$_NOSUCHID:
2450 case SS$_IVIDENT:
2451 unix_status = EINVAL;
2452 break;
7a7fd8e0
JM		 2453 case SS$_UNSUPPORTED:
2454 unix_status = ENOTSUP;
2455 break;
2fbb330f
JM		 2456 case SS$_FILACCERR:
2457 case SS$_NOGRPPRV:
2458 case SS$_NOSYSPRV:
2459 unix_status = EACCES;
2460 break;
2461 case SS$_DEVICEFULL:
2462 unix_status = ENOSPC;
2463 break;
2464 case SS$_NOSUCHDEV:
2465 unix_status = ENODEV;
2466 break;
2467 case SS$_NOSUCHFILE:
2468 case SS$_NOSUCHOBJECT:
2469 unix_status = ENOENT;
2470 break;
fb38d079
JM		 2471 case SS$_ABORT: /* Fatal case */
2472 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2473 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2474 unix_status = EINTR;
2475 break;
2476 case SS$_BUFFEROVF:
2477 unix_status = E2BIG;
2478 break;
2479 case SS$_INSFMEM:
2480 unix_status = ENOMEM;
2481 break;
2482 case SS$_NOPRIV:
2483 unix_status = EPERM;
2484 break;
2485 case SS$_NOSUCHNODE:
2486 case SS$_UNREACHABLE:
2487 unix_status = ESRCH;
2488 break;
2489 case SS$_NONEXPR:
2490 unix_status = ECHILD;
2491 break;
2492 default:
2493 if ((facility == 0) && (msg_no < 8)) {
2494 /* These are not real VMS status codes so assume that they are
2495 ** already UNIX status codes
2496 */
2497 unix_status = msg_no;
2498 break;
2499 }
2500 }
2501 }
2502 else {
2503 /* Translate a POSIX exit code to a UNIX exit code */
2504 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2505 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2506 }
2507 else {
7a7fd8e0
JM		 2508
2509 /* Documented traditional behavior for handling VMS child exits */
2510 /*--------------------------------------------------------------*/
2511 if (child_flag != 0) {
2512
2513 /* Success / Informational return 0 */
2514 /*----------------------------------*/
2515 if (msg_no & STS$K_SUCCESS)
2516 return 0;
2517
2518 /* Warning returns 1 */
2519 /*-------------------*/
2520 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2521 return 1;
2522
2523 /* Everything else pass through the severity bits */
2524 /*------------------------------------------------*/
2525 return (msg_no & STS$M_SEVERITY);
2526 }
2527
2528 /* Normal VMS status to ERRNO mapping attempt */
2529 /*--------------------------------------------*/
2fbb330f
JM		 2530 switch(msg_status) {
2531 /* case RMS$_EOF: */ /* End of File */
2532 case RMS$_FNF: /* File Not Found */
2533 case RMS$_DNF: /* Dir Not Found */
2534 unix_status = ENOENT;
2535 break;
2536 case RMS$_RNF: /* Record Not Found */
2537 unix_status = ESRCH;
2538 break;
2539 case RMS$_DIR:
2540 unix_status = ENOTDIR;
2541 break;
2542 case RMS$_DEV:
2543 unix_status = ENODEV;
2544 break;
7a7fd8e0
JM		 2545 case RMS$_IFI:
2546 case RMS$_FAC:
2547 case RMS$_ISI:
2548 unix_status = EBADF;
2549 break;
2550 case RMS$_FEX:
2551 unix_status = EEXIST;
2552 break;
2fbb330f
JM		 2553 case RMS$_SYN:
2554 case RMS$_FNM:
2555 case LIB$_INVSTRDES:
2556 case LIB$_INVARG:
2557 case LIB$_NOSUCHSYM:
2558 case LIB$_INVSYMNAM:
2559 case DCL_IVVERB:
2560 unix_status = EINVAL;
2561 break;
2562 case CLI$_BUFOVF:
2563 case RMS$_RTB:
2564 case CLI$_TKNOVF:
2565 case CLI$_RSLOVF:
2566 unix_status = E2BIG;
2567 break;
2568 case RMS$_PRV: /* No privilege */
2569 case RMS$_ACC: /* ACP file access failed */
2570 case RMS$_WLK: /* Device write locked */
2571 unix_status = EACCES;
2572 break;
ed1b9de0
JM		 2573 case RMS$_MKD: /* Failed to mark for delete */
2574 unix_status = EPERM;
2575 break;
2fbb330f
JM		 2576 /* case RMS$_NMF: */ /* No more files */
2577 }
2578 }
2579 }
2580
2581 return unix_status;
2582}
2583
7a7fd8e0
JM		 2584/* Try to guess at what VMS error status should go with a UNIX errno
2585 * value. This is hard to do as there could be many possible VMS
2586 * error statuses that caused the errno value to be set.
2587 */
2588
2589int Perl_unix_status_to_vms(int unix_status)
2590{
2591int test_unix_status;
2592
2593 /* Trivial cases first */
2594 /*---------------------*/
2595 if (unix_status == EVMSERR)
2596 return vaxc$errno;
2597
2598 /* Is vaxc$errno sane? */
2599 /*---------------------*/
2600 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2601 if (test_unix_status == unix_status)
2602 return vaxc$errno;
2603
2604 /* If way out of range, must be VMS code already */
2605 /*-----------------------------------------------*/
2606 if (unix_status > EVMSERR)
2607 return unix_status;
2608
2609 /* If out of range, punt */
2610 /*-----------------------*/
2611 if (unix_status > __ERRNO_MAX)
2612 return SS$_ABORT;
2613
2614
2615 /* Ok, now we have to do it the hard way. */
2616 /*----------------------------------------*/
2617 switch(unix_status) {
2618 case 0: return SS$_NORMAL;
2619 case EPERM: return SS$_NOPRIV;
2620 case ENOENT: return SS$_NOSUCHOBJECT;
2621 case ESRCH: return SS$_UNREACHABLE;
2622 case EINTR: return SS$_ABORT;
2623 /* case EIO: */
2624 /* case ENXIO: */
2625 case E2BIG: return SS$_BUFFEROVF;
2626 /* case ENOEXEC */
2627 case EBADF: return RMS$_IFI;
2628 case ECHILD: return SS$_NONEXPR;
2629 /* case EAGAIN */
2630 case ENOMEM: return SS$_INSFMEM;
2631 case EACCES: return SS$_FILACCERR;
2632 case EFAULT: return SS$_ACCVIO;
2633 /* case ENOTBLK */
0968cdad 2634 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2635 case EEXIST: return RMS$_FEX;
2636 /* case EXDEV */
2637 case ENODEV: return SS$_NOSUCHDEV;
2638 case ENOTDIR: return RMS$_DIR;
2639 /* case EISDIR */
2640 case EINVAL: return SS$_INVARG;
2641 /* case ENFILE */
2642 /* case EMFILE */
2643 /* case ENOTTY */
2644 /* case ETXTBSY */
2645 /* case EFBIG */
2646 case ENOSPC: return SS$_DEVICEFULL;
2647 case ESPIPE: return LIB$_INVARG;
2648 /* case EROFS: */
2649 /* case EMLINK: */
2650 /* case EPIPE: */
2651 /* case EDOM */
2652 case ERANGE: return LIB$_INVARG;
2653 /* case EWOULDBLOCK */
2654 /* case EINPROGRESS */
2655 /* case EALREADY */
2656 /* case ENOTSOCK */
2657 /* case EDESTADDRREQ */
2658 /* case EMSGSIZE */
2659 /* case EPROTOTYPE */
2660 /* case ENOPROTOOPT */
2661 /* case EPROTONOSUPPORT */
2662 /* case ESOCKTNOSUPPORT */
2663 /* case EOPNOTSUPP */
2664 /* case EPFNOSUPPORT */
2665 /* case EAFNOSUPPORT */
2666 /* case EADDRINUSE */
2667 /* case EADDRNOTAVAIL */
2668 /* case ENETDOWN */
2669 /* case ENETUNREACH */
2670 /* case ENETRESET */
2671 /* case ECONNABORTED */
2672 /* case ECONNRESET */
2673 /* case ENOBUFS */
2674 /* case EISCONN */
2675 case ENOTCONN: return SS$_CLEARED;
2676 /* case ESHUTDOWN */
2677 /* case ETOOMANYREFS */
2678 /* case ETIMEDOUT */
2679 /* case ECONNREFUSED */
2680 /* case ELOOP */
2681 /* case ENAMETOOLONG */
2682 /* case EHOSTDOWN */
2683 /* case EHOSTUNREACH */
2684 /* case ENOTEMPTY */
2685 /* case EPROCLIM */
2686 /* case EUSERS */
2687 /* case EDQUOT */
2688 /* case ENOMSG */
2689 /* case EIDRM */
2690 /* case EALIGN */
2691 /* case ESTALE */
2692 /* case EREMOTE */
2693 /* case ENOLCK */
2694 /* case ENOSYS */
2695 /* case EFTYPE */
2696 /* case ECANCELED */
2697 /* case EFAIL */
2698 /* case EINPROG */
2699 case ENOTSUP:
2700 return SS$_UNSUPPORTED;
2701 /* case EDEADLK */
2702 /* case ENWAIT */
2703 /* case EILSEQ */
2704 /* case EBADCAT */
2705 /* case EBADMSG */
2706 /* case EABANDONED */
2707 default:
2708 return SS$_ABORT; /* punt */
2709 }
2710
2711 return SS$_ABORT; /* Should not get here */
2712}
2fbb330f
JM		 2713
2714
22d4bb9c
CB		 2715/* default piping mailbox size */
2716#define PERL_BUFSIZ 512
2717
674d6c38 2718
a0d0e21e 2719static void
fd8cd3a3 2720create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2721{
22d4bb9c
CB		 2722 unsigned long int mbxbufsiz;
2723 static unsigned long int syssize = 0;
2724 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2725 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2726 int sts;
2727
22d4bb9c
CB		 2728 if (!syssize) {
2729 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2730 /*
22d4bb9c
CB		 2731 * Get the SYSGEN parameter MAXBUF
2732 *
2733 * If the logical 'PERL_MBX_SIZE' is defined
2734 * use the value of the logical instead of PERL_BUFSIZ, but
2735 * keep the size between 128 and MAXBUF.
2736 *
a0d0e21e 2737 */
22d4bb9c
CB		 2738 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2739 }
2740
2741 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2742 mbxbufsiz = atoi(csize);
2743 } else {
2744 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2745 }
22d4bb9c
CB		 2746 if (mbxbufsiz < 128) mbxbufsiz = 128;
2747 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2748
f7ddb74a 2749 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2750
f7ddb74a 2751 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 2752 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2753
2754} /* end of create_mbx() */
2755
22d4bb9c 2756
a0d0e21e 2757/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2758
2759typedef struct _iosb IOSB;
2760typedef struct _iosb* pIOSB;
2761typedef struct _pipe Pipe;
2762typedef struct _pipe* pPipe;
2763typedef struct pipe_details Info;
2764typedef struct pipe_details* pInfo;
2765typedef struct _srqp RQE;
2766typedef struct _srqp* pRQE;
2767typedef struct _tochildbuf CBuf;
2768typedef struct _tochildbuf* pCBuf;
2769
2770struct _iosb {
2771 unsigned short status;
2772 unsigned short count;
2773 unsigned long dvispec;
2774};
2775
2776#pragma member_alignment save
2777#pragma nomember_alignment quadword
2778struct _srqp { /* VMS self-relative queue entry */
2779 unsigned long qptr[2];
2780};
2781#pragma member_alignment restore
2782static RQE RQE_ZERO = {0,0};
2783
2784struct _tochildbuf {
2785 RQE q;
2786 int eof;
2787 unsigned short size;
2788 char *buf;
2789};
2790
2791struct _pipe {
2792 RQE free;
2793 RQE wait;
2794 int fd_out;
2795 unsigned short chan_in;
2796 unsigned short chan_out;
2797 char *buf;
2798 unsigned int bufsize;
2799 IOSB iosb;
2800 IOSB iosb2;
2801 int *pipe_done;
2802 int retry;
2803 int type;
2804 int shut_on_empty;
2805 int need_wake;
2806 pPipe *home;
2807 pInfo info;
2808 pCBuf curr;
2809 pCBuf curr2;
fd8cd3a3
DS		 2810#if defined(PERL_IMPLICIT_CONTEXT)
2811 void *thx; /* Either a thread or an interpreter */
2812 /* pointer, depending on how we're built */
2813#endif
22d4bb9c
CB		 2814};
2815
2816
a0d0e21e
LW		 2817struct pipe_details
2818{
22d4bb9c 2819 pInfo next;
ff7adb52
CL		 2820 PerlIO *fp; /* file pointer to pipe mailbox */
2821 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2822 int pid; /* PID of subprocess */
2823 int mode; /* == 'r' if pipe open for reading */
2824 int done; /* subprocess has completed */
ff7adb52 2825 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2826 int closing; /* my_pclose is closing this pipe */
2827 unsigned long completion; /* termination status of subprocess */
2828 pPipe in; /* pipe in to sub */
2829 pPipe out; /* pipe out of sub */
2830 pPipe err; /* pipe of sub's sys$error */
2831 int in_done; /* true when in pipe finished */
2832 int out_done;
2833 int err_done;
cd1191f1
CB		 2834 unsigned short xchan; /* channel to debug xterm */
2835 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2836};
2837
748a9306
LW		 2838struct exit_control_block
2839{
2840 struct exit_control_block *flink;
2841 unsigned long int (*exit_routine)();
2842 unsigned long int arg_count;
2843 unsigned long int *status_address;
2844 unsigned long int exit_status;
2845};
2846
d85f548a
JH		 2847typedef struct _closed_pipes Xpipe;
2848typedef struct _closed_pipes* pXpipe;
2849
2850struct _closed_pipes {
2851 int pid; /* PID of subprocess */
2852 unsigned long completion; /* termination status of subprocess */
2853};
2854#define NKEEPCLOSED 50
2855static Xpipe closed_list[NKEEPCLOSED];
2856static int closed_index = 0;
2857static int closed_num = 0;
2858
22d4bb9c
CB		 2859#define RETRY_DELAY "0 ::0.20"
2860#define MAX_RETRY 50
a0d0e21e 2861
22d4bb9c
CB		 2862static int pipe_ef = 0; /* first call to safe_popen inits these*/
2863static unsigned long mypid;
2864static unsigned long delaytime[2];
2865
2866static pInfo open_pipes = NULL;
2867static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2868
ff7adb52
CL		 2869#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2870
2871
3eeba6fb 2872
748a9306 2873static unsigned long int
fd8cd3a3 2874pipe_exit_routine(pTHX)
748a9306 2875{
22d4bb9c 2876 pInfo info;
1e422769 2877 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2878 int sts, did_stuff, need_eof, j;
2879
5ce486e0
CB		 2880 /*
2881 * Flush any pending i/o, but since we are in process run-down, be
2882 * careful about referencing PerlIO structures that may already have
2883 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2884 */
2885 info = open_pipes;
2886 while (info) {
2887 if (info->fp) {
5ce486e0
CB		 2888 if (!info->useFILE
2889#if defined(USE_ITHREADS)
2890 && my_perl
2891#endif
2892 && PL_perlio_fd_refcnt)
2893 PerlIO_flush(info->fp);
ff7adb52
CL		 2894 else
2895 fflush((FILE *)info->fp);
2896 }
2897 info = info->next;
2898 }
3eeba6fb
CB		 2899
2900 /*
ff7adb52 2901 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2902 don't hang
2903 */
2904 did_stuff = 0;
2905 info = open_pipes;
748a9306 2906
3eeba6fb 2907 while (info) {
b2b89246 2908 int need_eof;
d4c83939 2909 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2910 if (info->in && !info->in->shut_on_empty) {
d4c83939 2911 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
22d4bb9c 2912 0, 0, 0, 0, 0, 0));
ff7adb52 2913 info->waiting = 1;
22d4bb9c 2914 did_stuff = 1;
748a9306 2915 }
d4c83939 2916 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2917 info = info->next;
2918 }
ff7adb52
CL		 2919
2920 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2921
2922 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2923 int nwait = 0;
2924
2925 info = open_pipes;
2926 while (info) {
d4c83939 2927 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2928 if (info->waiting && info->done)
2929 info->waiting = 0;
2930 nwait += info->waiting;
d4c83939 2931 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2932 info = info->next;
2933 }
2934 if (!nwait) break;
2935 sleep(1);
2936 }
3eeba6fb
CB		 2937
2938 did_stuff = 0;
2939 info = open_pipes;
2940 while (info) {
d4c83939 2941 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2942 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2943 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2944 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2945 did_stuff = 1;
2946 }
d4c83939 2947 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2948 info = info->next;
2949 }
ff7adb52
CL		 2950
2951 /* again, wait for effect */
2952
2953 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2954 int nwait = 0;
2955
2956 info = open_pipes;
2957 while (info) {
d4c83939 2958 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2959 if (info->waiting && info->done)
2960 info->waiting = 0;
2961 nwait += info->waiting;
d4c83939 2962 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2963 info = info->next;
2964 }
2965 if (!nwait) break;
2966 sleep(1);
2967 }
3eeba6fb
CB		 2968
2969 info = open_pipes;
2970 while (info) {
d4c83939 2971 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2972 if (!info->done) { /* We tried to be nice . . . */
2973 sts = sys$delprc(&info->pid,0);
d4c83939 2974 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 2975 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 2976 }
d4c83939 2977 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2978 info = info->next;
2979 }
2980
2981 while(open_pipes) {
1e422769 2982 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2983 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 2984 }
2985 return retsts;
2986}
2987
2988static struct exit_control_block pipe_exitblock =
2989 {(struct exit_control_block *) 0,
2990 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2991
22d4bb9c
CB		 2992static void pipe_mbxtofd_ast(pPipe p);
2993static void pipe_tochild1_ast(pPipe p);
2994static void pipe_tochild2_ast(pPipe p);
748a9306 2995
a0d0e21e 2996static void
22d4bb9c 2997popen_completion_ast(pInfo info)
a0d0e21e 2998{
22d4bb9c
CB		 2999 pInfo i = open_pipes;
3000 int iss;
f7ddb74a 3001 int sts;
d85f548a
JH		 3002 pXpipe x;
3003
3004 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3005 closed_list[closed_index].pid = info->pid;
3006 closed_list[closed_index].completion = info->completion;
3007 closed_index++;
3008 if (closed_index == NKEEPCLOSED)
3009 closed_index = 0;
3010 closed_num++;
22d4bb9c
CB		 3011
3012 while (i) {
3013 if (i == info) break;
3014 i = i->next;
3015 }
3016 if (!i) return; /* unlinked, probably freed too */
3017
22d4bb9c
CB		 3018 info->done = TRUE;
3019
3020/*
3021 Writing to subprocess ...
3022 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3023
3024 chan_out may be waiting for "done" flag, or hung waiting
3025 for i/o completion to child...cancel the i/o. This will
3026 put it into "snarf mode" (done but no EOF yet) that discards
3027 input.
3028
3029 Output from subprocess (stdout, stderr) needs to be flushed and
3030 shut down. We try sending an EOF, but if the mbx is full the pipe
3031 routine should still catch the "shut_on_empty" flag, telling it to
3032 use immediate-style reads so that "mbx empty" -> EOF.
3033
3034
3035*/
3036 if (info->in && !info->in_done) { /* only for mode=w */
3037 if (info->in->shut_on_empty && info->in->need_wake) {
3038 info->in->need_wake = FALSE;
fd8cd3a3 3039 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3040 } else {
fd8cd3a3 3041 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3042 }
3043 }
3044
3045 if (info->out && !info->out_done) { /* were we also piping output? */
3046 info->out->shut_on_empty = TRUE;
3047 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3048 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3049 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3050 }
3051
3052 if (info->err && !info->err_done) { /* we were piping stderr */
3053 info->err->shut_on_empty = TRUE;
3054 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3055 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3056 _ckvmssts_noperl(iss);
a0d0e21e 3057 }
fd8cd3a3 3058 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3059
a0d0e21e
LW		 3060}
3061
2fbb330f 3062static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3063static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 3064
22d4bb9c
CB		 3065/*
3066 we actually differ from vmstrnenv since we use this to
3067 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3068 are pointing to the same thing
3069*/
3070
3071static unsigned short
fd8cd3a3 3072popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 3073{
3074 int iss;
3075 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3076 $DESCRIPTOR(d_log,"");
3077 struct _il3 {
3078 unsigned short length;
3079 unsigned short code;
3080 char * buffer_addr;
3081 unsigned short *retlenaddr;
3082 } itmlst[2];
3083 unsigned short l, ifi;
3084
3085 d_log.dsc$a_pointer = logical;
3086 d_log.dsc$w_length = strlen(logical);
3087
3088 itmlst[0].code = LNM$_STRING;
3089 itmlst[0].length = 255;
3090 itmlst[0].buffer_addr = result;
3091 itmlst[0].retlenaddr = &l;
3092
3093 itmlst[1].code = 0;
3094 itmlst[1].length = 0;
3095 itmlst[1].buffer_addr = 0;
3096 itmlst[1].retlenaddr = 0;
3097
3098 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3099 if (iss == SS$_NOLOGNAM) {
3100 iss = SS$_NORMAL;
3101 l = 0;
3102 }
3103 if (!(iss&1)) lib$signal(iss);
3104 result[l] = '\0';
3105/*
3106 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3107 strip it off and return the ifi, if any
3108*/
3109 ifi = 0;
3110 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 3111 memmove(&ifi,result+2,2);
22d4bb9c
CB		 3112 strcpy(result,result+4);
3113 }
3114 return ifi; /* this is the RMS internal file id */
3115}
3116
22d4bb9c
CB		 3117static void pipe_infromchild_ast(pPipe p);
3118
3119/*
3120 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3121 inside an AST routine without worrying about reentrancy and which Perl
3122 memory allocator is being used.
3123
3124 We read data and queue up the buffers, then spit them out one at a
3125 time to the output mailbox when the output mailbox is ready for one.
3126
3127*/
3128#define INITIAL_TOCHILDQUEUE 2
3129
3130static pPipe
fd8cd3a3 3131pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3132{
22d4bb9c
CB		 3133 pPipe p;
3134 pCBuf b;
3135 char mbx1[64], mbx2[64];
3136 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3137 DSC$K_CLASS_S, mbx1},
3138 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3139 DSC$K_CLASS_S, mbx2};
3140 unsigned int dviitm = DVI$_DEVBUFSIZ;
3141 int j, n;
3142
d4c83939
CB		 3143 n = sizeof(Pipe);
3144 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3145
fd8cd3a3
DS		 3146 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3147 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3148 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3149
3150 p->buf = 0;
3151 p->shut_on_empty = FALSE;
3152 p->need_wake = FALSE;
3153 p->type = 0;
3154 p->retry = 0;
3155 p->iosb.status = SS$_NORMAL;
3156 p->iosb2.status = SS$_NORMAL;
3157 p->free = RQE_ZERO;
3158 p->wait = RQE_ZERO;
3159 p->curr = 0;
3160 p->curr2 = 0;
3161 p->info = 0;
fd8cd3a3
DS		 3162#ifdef PERL_IMPLICIT_CONTEXT
3163 p->thx = aTHX;
3164#endif
22d4bb9c
CB		 3165
3166 n = sizeof(CBuf) + p->bufsize;
3167
3168 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3169 _ckvmssts(lib$get_vm(&n, &b));
3170 b->buf = (char *) b + sizeof(CBuf);
3171 _ckvmssts(lib$insqhi(b, &p->free));
3172 }
3173
3174 pipe_tochild2_ast(p);
3175 pipe_tochild1_ast(p);
3176 strcpy(wmbx, mbx1);
3177 strcpy(rmbx, mbx2);
3178 return p;
3179}
3180
3181/* reads the MBX Perl is writing, and queues */
3182
3183static void
3184pipe_tochild1_ast(pPipe p)
3185{
22d4bb9c
CB		 3186 pCBuf b = p->curr;
3187 int iss = p->iosb.status;
3188 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3189 int sts;
fd8cd3a3
DS		 3190#ifdef PERL_IMPLICIT_CONTEXT
3191 pTHX = p->thx;
3192#endif
22d4bb9c
CB		 3193
3194 if (p->retry) {
3195 if (eof) {
3196 p->shut_on_empty = TRUE;
3197 b->eof = TRUE;
3198 _ckvmssts(sys$dassgn(p->chan_in));
3199 } else {
3200 _ckvmssts(iss);
3201 }
3202
3203 b->eof = eof;
3204 b->size = p->iosb.count;
f7ddb74a 3205 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3206 if (p->need_wake) {
3207 p->need_wake = FALSE;
3208 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3209 }
3210 } else {
3211 p->retry = 1; /* initial call */
3212 }
3213
3214 if (eof) { /* flush the free queue, return when done */
3215 int n = sizeof(CBuf) + p->bufsize;
3216 while (1) {
3217 iss = lib$remqti(&p->free, &b);
3218 if (iss == LIB$_QUEWASEMP) return;
3219 _ckvmssts(iss);
3220 _ckvmssts(lib$free_vm(&n, &b));
3221 }
3222 }
3223
3224 iss = lib$remqti(&p->free, &b);
3225 if (iss == LIB$_QUEWASEMP) {
3226 int n = sizeof(CBuf) + p->bufsize;
3227 _ckvmssts(lib$get_vm(&n, &b));
3228 b->buf = (char *) b + sizeof(CBuf);
3229 } else {
3230 _ckvmssts(iss);
3231 }
3232
3233 p->curr = b;
3234 iss = sys$qio(0,p->chan_in,
3235 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3236 &p->iosb,
3237 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3238 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3239 _ckvmssts(iss);
3240}
3241
3242
3243/* writes queued buffers to output, waits for each to complete before
3244 doing the next */
3245
3246static void
3247pipe_tochild2_ast(pPipe p)
3248{
22d4bb9c
CB		 3249 pCBuf b = p->curr2;
3250 int iss = p->iosb2.status;
3251 int n = sizeof(CBuf) + p->bufsize;
3252 int done = (p->info && p->info->done) ||
3253 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3254#if defined(PERL_IMPLICIT_CONTEXT)
3255 pTHX = p->thx;
3256#endif
22d4bb9c
CB		 3257
3258 do {
3259 if (p->type) { /* type=1 has old buffer, dispose */
3260 if (p->shut_on_empty) {
3261 _ckvmssts(lib$free_vm(&n, &b));
3262 } else {
3263 _ckvmssts(lib$insqhi(b, &p->free));
3264 }
3265 p->type = 0;
3266 }
3267
3268 iss = lib$remqti(&p->wait, &b);
3269 if (iss == LIB$_QUEWASEMP) {
3270 if (p->shut_on_empty) {
3271 if (done) {
3272 _ckvmssts(sys$dassgn(p->chan_out));
3273 *p->pipe_done = TRUE;
3274 _ckvmssts(sys$setef(pipe_ef));
3275 } else {
3276 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3277 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3278 }
3279 return;
3280 }
3281 p->need_wake = TRUE;
3282 return;
3283 }
3284 _ckvmssts(iss);
3285 p->type = 1;
3286 } while (done);
3287
3288
3289 p->curr2 = b;
3290 if (b->eof) {
3291 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3292 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3293 } else {
3294 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3295 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3296 }
3297
3298 return;
3299
3300}
3301
3302
3303static pPipe
fd8cd3a3 3304pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3305{
22d4bb9c
CB		 3306 pPipe p;
3307 char mbx1[64], mbx2[64];
3308 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3309 DSC$K_CLASS_S, mbx1},
3310 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3311 DSC$K_CLASS_S, mbx2};
3312 unsigned int dviitm = DVI$_DEVBUFSIZ;
3313
d4c83939
CB		 3314 int n = sizeof(Pipe);
3315 _ckvmssts(lib$get_vm(&n, &p));
fd8cd3a3
DS		 3316 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3317 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3318
3319 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3320 n = p->bufsize * sizeof(char);
3321 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3322 p->shut_on_empty = FALSE;
3323 p->info = 0;
3324 p->type = 0;
3325 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3326#if defined(PERL_IMPLICIT_CONTEXT)
3327 p->thx = aTHX;
3328#endif
22d4bb9c
CB		 3329 pipe_infromchild_ast(p);
3330
3331 strcpy(wmbx, mbx1);
3332 strcpy(rmbx, mbx2);
3333 return p;
3334}
3335
3336static void
3337pipe_infromchild_ast(pPipe p)
3338{
22d4bb9c
CB		 3339 int iss = p->iosb.status;
3340 int eof = (iss == SS$_ENDOFFILE);
3341 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3342 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3343#if defined(PERL_IMPLICIT_CONTEXT)
3344 pTHX = p->thx;
3345#endif
22d4bb9c
CB		 3346
3347 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3348 _ckvmssts(sys$dassgn(p->chan_out));
3349 p->chan_out = 0;
3350 }
3351
3352 /* read completed:
3353 input shutdown if EOF from self (done or shut_on_empty)
3354 output shutdown if closing flag set (my_pclose)
3355 send data/eof from child or eof from self
3356 otherwise, re-read (snarf of data from child)
3357 */
3358
3359 if (p->type == 1) {
3360 p->type = 0;
3361 if (myeof && p->chan_in) { /* input shutdown */
3362 _ckvmssts(sys$dassgn(p->chan_in));
3363 p->chan_in = 0;
3364 }
3365
3366 if (p->chan_out) {
3367 if (myeof || kideof) { /* pass EOF to parent */
3368 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3369 pipe_infromchild_ast, p,
3370 0, 0, 0, 0, 0, 0));
3371 return;
3372 } else if (eof) { /* eat EOF --- fall through to read*/
3373
3374 } else { /* transmit data */
3375 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3376 pipe_infromchild_ast,p,
3377 p->buf, p->iosb.count, 0, 0, 0, 0));
3378 return;
3379 }
3380 }
3381 }
3382
3383 /* everything shut? flag as done */
3384
3385 if (!p->chan_in && !p->chan_out) {
3386 *p->pipe_done = TRUE;
3387 _ckvmssts(sys$setef(pipe_ef));
3388 return;
3389 }
3390
3391 /* write completed (or read, if snarfing from child)
3392 if still have input active,
3393 queue read...immediate mode if shut_on_empty so we get EOF if empty
3394 otherwise,
3395 check if Perl reading, generate EOFs as needed
3396 */
3397
3398 if (p->type == 0) {
3399 p->type = 1;
3400 if (p->chan_in) {
3401 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3402 pipe_infromchild_ast,p,
3403 p->buf, p->bufsize, 0, 0, 0, 0);
3404 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3405 _ckvmssts(iss);
3406 } else { /* send EOFs for extra reads */
3407 p->iosb.status = SS$_ENDOFFILE;
3408 p->iosb.dvispec = 0;
3409 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3410 0, 0, 0,
3411 pipe_infromchild_ast, p, 0, 0, 0, 0));
3412 }
3413 }
3414}
3415
3416static pPipe
fd8cd3a3 3417pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3418{
22d4bb9c
CB		 3419 pPipe p;
3420 char mbx[64];
3421 unsigned long dviitm = DVI$_DEVBUFSIZ;
3422 struct stat s;
3423 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3424 DSC$K_CLASS_S, mbx};
a480973c 3425 int n = sizeof(Pipe);
22d4bb9c
CB		 3426
3427 /* things like terminals and mbx's don't need this filter */
3428 if (fd && fstat(fd,&s) == 0) {
3429 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3430 char device[65];
3431 unsigned short dev_len;
3432 struct dsc$descriptor_s d_dev;
3433 char * cptr;
3434 struct item_list_3 items[3];
3435 int status;
3436 unsigned short dvi_iosb[4];
3437
3438 cptr = getname(fd, out, 1);
3439 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3440 d_dev.dsc$a_pointer = out;
3441 d_dev.dsc$w_length = strlen(out);
3442 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3443 d_dev.dsc$b_class = DSC$K_CLASS_S;
3444
3445 items[0].len = 4;
3446 items[0].code = DVI$_DEVCHAR;
3447 items[0].bufadr = &devchar;
3448 items[0].retadr = NULL;
3449 items[1].len = 64;
3450 items[1].code = DVI$_FULLDEVNAM;
3451 items[1].bufadr = device;
3452 items[1].retadr = &dev_len;
3453 items[2].len = 0;
3454 items[2].code = 0;
3455
3456 status = sys$getdviw
3457 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3458 _ckvmssts(status);
3459 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3460 device[dev_len] = 0;
3461
3462 if (!(devchar & DEV$M_DIR)) {
3463 strcpy(out, device);
3464 return 0;
3465 }
3466 }
22d4bb9c
CB		 3467 }
3468
d4c83939 3469 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3470 p->fd_out = dup(fd);
fd8cd3a3 3471 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 3472 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3473 n = (p->bufsize+1) * sizeof(char);
3474 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3475 p->shut_on_empty = FALSE;
3476 p->retry = 0;
3477 p->info = 0;
3478 strcpy(out, mbx);
3479
3480 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3481 pipe_mbxtofd_ast, p,
3482 p->buf, p->bufsize, 0, 0, 0, 0));
3483
3484 return p;
3485}
3486
3487static void
3488pipe_mbxtofd_ast(pPipe p)
3489{
22d4bb9c
CB		 3490 int iss = p->iosb.status;
3491 int done = p->info->done;
3492 int iss2;
3493 int eof = (iss == SS$_ENDOFFILE);
3494 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3495 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3496#if defined(PERL_IMPLICIT_CONTEXT)
3497 pTHX = p->thx;
3498#endif
22d4bb9c
CB		 3499
3500 if (done && myeof) { /* end piping */
3501 close(p->fd_out);
3502 sys$dassgn(p->chan_in);
3503 *p->pipe_done = TRUE;
3504 _ckvmssts(sys$setef(pipe_ef));
3505 return;
3506 }
3507
3508 if (!err && !eof) { /* good data to send to file */
3509 p->buf[p->iosb.count] = '\n';
3510 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3511 if (iss2 < 0) {
3512 p->retry++;
3513 if (p->retry < MAX_RETRY) {
3514 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3515 return;
3516 }
3517 }
3518 p->retry = 0;
3519 } else if (err) {
3520 _ckvmssts(iss);
3521 }
3522
3523
3524 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3525 pipe_mbxtofd_ast, p,
3526 p->buf, p->bufsize, 0, 0, 0, 0);
3527 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3528 _ckvmssts(iss);
3529}
3530
3531
3532typedef struct _pipeloc PLOC;
3533typedef struct _pipeloc* pPLOC;
3534
3535struct _pipeloc {
3536 pPLOC next;
3537 char dir[NAM$C_MAXRSS+1];
3538};
3539static pPLOC head_PLOC = 0;
3540
5c0ae288 3541void
fd8cd3a3 3542free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3543{
3544 pPLOC p, pnext;
ff7adb52 3545 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3546
ff7adb52 3547 p = *pHead;
5c0ae288
CL		 3548 while (p) {
3549 pnext = p->next;
e0ef6b43 3550 PerlMem_free(p);
5c0ae288
CL		 3551 p = pnext;
3552 }
ff7adb52 3553 *pHead = 0;
5c0ae288 3554}
22d4bb9c
CB		 3555
3556static void
fd8cd3a3 3557store_pipelocs(pTHX)
22d4bb9c
CB		 3558{
3559 int i;
3560 pPLOC p;
ff7adb52 3561 AV *av = 0;
22d4bb9c
CB		 3562 SV *dirsv;
3563 GV *gv;
3564 char *dir, *x;
3565 char *unixdir;
3566 char temp[NAM$C_MAXRSS+1];
3567 STRLEN n_a;
3568
ff7adb52 3569 if (head_PLOC)
218fdd94 3570 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3571
22d4bb9c
CB		 3572/* the . directory from @INC comes last */
3573
e0ef6b43 3574 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3575 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3576 p->next = head_PLOC;
3577 head_PLOC = p;
3578 strcpy(p->dir,"./");
3579
3580/* get the directory from $^X */
3581
c5375c28
JM		 3582 unixdir = PerlMem_malloc(VMS_MAXRSS);
3583 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3584
218fdd94
CL		 3585#ifdef PERL_IMPLICIT_CONTEXT
3586 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3587#else
22d4bb9c 3588 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3589#endif
22d4bb9c
CB		 3590 strcpy(temp, PL_origargv[0]);
3591 x = strrchr(temp,']');
2497a41f
JM		 3592 if (x == NULL) {
3593 x = strrchr(temp,'>');
3594 if (x == NULL) {
3595 /* It could be a UNIX path */
3596 x = strrchr(temp,'/');
3597 }
3598 }
3599 if (x)
3600 x[1] = '\0';
3601 else {
3602 /* Got a bare name, so use default directory */
3603 temp[0] = '.';
3604 temp[1] = '\0';
3605 }
22d4bb9c 3606
4e205ed6 3607 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3608 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3609 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3610 p->next = head_PLOC;
3611 head_PLOC = p;
3612 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3613 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3614 }
22d4bb9c
CB		 3615 }
3616
3617/* reverse order of @INC entries, skip "." since entered above */
3618
218fdd94
CL		 3619#ifdef PERL_IMPLICIT_CONTEXT
3620 if (aTHX)
3621#endif
ff7adb52
CL		 3622 if (PL_incgv) av = GvAVn(PL_incgv);
3623
3624 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3625 dirsv = *av_fetch(av,i,TRUE);
3626
3627 if (SvROK(dirsv)) continue;
3628 dir = SvPVx(dirsv,n_a);
3629 if (strcmp(dir,".") == 0) continue;
4e205ed6 3630 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3631 continue;
3632
e0ef6b43 3633 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3634 p->next = head_PLOC;
3635 head_PLOC = p;
3636 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3637 p->dir[NAM$C_MAXRSS] = '\0';
3638 }
3639
3640/* most likely spot (ARCHLIB) put first in the list */
3641
3642#ifdef ARCHLIB_EXP
4e205ed6 3643 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3644 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3645 if (p == NULL) _ckvmssts(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';
3650 }
3651#endif
c5375c28 3652 PerlMem_free(unixdir);
22d4bb9c
CB		 3653}
3654
a1887106
JM		 3655static I32
3656Perl_cando_by_name_int
3657 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3658#if !defined(PERL_IMPLICIT_CONTEXT)
3659#define cando_by_name_int Perl_cando_by_name_int
3660#else
3661#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3662#endif
22d4bb9c
CB		 3663
3664static char *
fd8cd3a3 3665find_vmspipe(pTHX)
22d4bb9c
CB		 3666{
3667 static int vmspipe_file_status = 0;
3668 static char vmspipe_file[NAM$C_MAXRSS+1];
3669
3670 /* already found? Check and use ... need read+execute permission */
3671
3672 if (vmspipe_file_status == 1) {
a1887106
JM		 3673 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3674 && cando_by_name_int
3675 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3676 return vmspipe_file;
3677 }
3678 vmspipe_file_status = 0;
3679 }
3680
3681 /* scan through stored @INC, $^X */
3682
3683 if (vmspipe_file_status == 0) {
3684 char file[NAM$C_MAXRSS+1];
3685 pPLOC p = head_PLOC;
3686
3687 while (p) {
2f4077ca 3688 char * exp_res;
4d743a9b 3689 int dirlen;
22d4bb9c 3690 strcpy(file, p->dir);
4d743a9b
JM		 3691 dirlen = strlen(file);
3692 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3693 file[NAM$C_MAXRSS] = '\0';
3694 p = p->next;
3695
2f4077ca 3696 exp_res = do_rmsexpand
360732b5 3697 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
2f4077ca 3698 if (!exp_res) continue;
22d4bb9c 3699
a1887106
JM		 3700 if (cando_by_name_int
3701 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3702 && cando_by_name_int
3703 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3704 vmspipe_file_status = 1;
3705 return vmspipe_file;
3706 }
3707 }
3708 vmspipe_file_status = -1; /* failed, use tempfiles */
3709 }
3710
3711 return 0;
3712}
3713
3714static FILE *
fd8cd3a3 3715vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3716{
3717 char file[NAM$C_MAXRSS+1];
3718 FILE *fp;
3719 static int index = 0;
2497a41f
JM		 3720 Stat_t s0, s1;
3721 int cmp_result;
22d4bb9c
CB		 3722
3723 /* create a tempfile */
3724
3725 /* we can't go from W, shr=get to R, shr=get without
3726 an intermediate vulnerable state, so don't bother trying...
3727
3728 and lib$spawn doesn't shr=put, so have to close the write
3729
3730 So... match up the creation date/time and the FID to
3731 make sure we're dealing with the same file
3732
3733 */
3734
3735 index++;
2497a41f
JM		 3736 if (!decc_filename_unix_only) {
3737 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3738 fp = fopen(file,"w");
3739 if (!fp) {
22d4bb9c
CB		 3740 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3741 fp = fopen(file,"w");
3742 if (!fp) {
3743 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3744 fp = fopen(file,"w");
2497a41f
JM		 3745 }
3746 }
3747 }
3748 else {
3749 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3750 fp = fopen(file,"w");
3751 if (!fp) {
3752 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3753 fp = fopen(file,"w");
3754 if (!fp) {
3755 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3756 fp = fopen(file,"w");
3757 }
3758 }
22d4bb9c
CB		 3759 }
3760 if (!fp) return 0; /* we're hosed */
3761
f9ecfa39 3762 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3763 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3764 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3765 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3766 fprintf(fp,"$ perl_on = \"set noon\"\n");
3767 fprintf(fp,"$ perl_exit = \"exit\"\n");
3768 fprintf(fp,"$ perl_del = \"delete\"\n");
3769 fprintf(fp,"$ pif = \"if\"\n");
3770 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3771 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3772 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3773 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3774 fprintf(fp,"$! --- build command line to get max possible length\n");
3775 fprintf(fp,"$c=perl_popen_cmd0\n");
3776 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3777 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3778 fprintf(fp,"$x=perl_popen_cmd3\n");
3779 fprintf(fp,"$c=c+x\n");
22d4bb9c 3780 fprintf(fp,"$ perl_on\n");
f9ecfa39 3781 fprintf(fp,"$ 'c'\n");
22d4bb9c 3782 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3783 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3784 fprintf(fp,"$ perl_exit 'perl_status'\n");
3785 fsync(fileno(fp));
3786
3787 fgetname(fp, file, 1);
2497a41f 3788 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3789 fclose(fp);
3790
2497a41f 3791 if (decc_filename_unix_only)
360732b5 3792 do_tounixspec(file, file, 0, NULL);
22d4bb9c
CB		 3793 fp = fopen(file,"r","shr=get");
3794 if (!fp) return 0;
2497a41f
JM		 3795 fstat(fileno(fp), (struct stat *)&s1);
3796
682e4b71 3797 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3798 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3799 fclose(fp);
3800 return 0;
3801 }
3802
3803 return fp;
3804}
3805
3806
cd1191f1
CB		 3807static int vms_is_syscommand_xterm(void)
3808{
3809 const static struct dsc$descriptor_s syscommand_dsc =
3810 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3811
3812 const static struct dsc$descriptor_s decwdisplay_dsc =
3813 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3814
3815 struct item_list_3 items[2];
3816 unsigned short dvi_iosb[4];
3817 unsigned long devchar;
3818 unsigned long devclass;
3819 int status;
3820
3821 /* Very simple check to guess if sys$command is a decterm? */
3822 /* First see if the DECW$DISPLAY: device exists */
3823 items[0].len = 4;
3824 items[0].code = DVI$_DEVCHAR;
3825 items[0].bufadr = &devchar;
3826 items[0].retadr = NULL;
3827 items[1].len = 0;
3828 items[1].code = 0;
3829
3830 status = sys$getdviw
3831 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3832
3833 if ($VMS_STATUS_SUCCESS(status)) {
3834 status = dvi_iosb[0];
3835 }
3836
3837 if (!$VMS_STATUS_SUCCESS(status)) {
3838 SETERRNO(EVMSERR, status);
3839 return -1;
3840 }
3841
3842 /* If it does, then for now assume that we are on a workstation */
3843 /* Now verify that SYS$COMMAND is a terminal */
3844 /* for creating the debugger DECTerm */
3845
3846 items[0].len = 4;
3847 items[0].code = DVI$_DEVCLASS;
3848 items[0].bufadr = &devclass;
3849 items[0].retadr = NULL;
3850 items[1].len = 0;
3851 items[1].code = 0;
3852
3853 status = sys$getdviw
3854 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3855
3856 if ($VMS_STATUS_SUCCESS(status)) {
3857 status = dvi_iosb[0];
3858 }
3859
3860 if (!$VMS_STATUS_SUCCESS(status)) {
3861 SETERRNO(EVMSERR, status);
3862 return -1;
3863 }
3864 else {
3865 if (devclass == DC$_TERM) {
3866 return 0;
3867 }
3868 }
3869 return -1;
3870}
3871
3872/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3873static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3874{
3875 int status;
3876 int ret_stat;
3877 char * ret_char;
3878 char device_name[65];
3879 unsigned short device_name_len;
3880 struct dsc$descriptor_s customization_dsc;
3881 struct dsc$descriptor_s device_name_dsc;
3882 const char * cptr;
3883 char * tptr;
3884 char customization[200];
3885 char title[40];
3886 pInfo info = NULL;
3887 char mbx1[64];
3888 unsigned short p_chan;
3889 int n;
3890 unsigned short iosb[4];
3891 struct item_list_3 items[2];
3892 const char * cust_str =
3893 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3894 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3895 DSC$K_CLASS_S, mbx1};
3896
8cb5d3d5
JM		 3897 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3898 /*---------------------------------------*/
d30c1055 3899 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3900
3901
3902 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3903 ret_char = strstr(cmd," xterm ");
3904 if (ret_char == NULL)
3905 return NULL;
3906 cptr = ret_char + 7;
3907 ret_char = strstr(cmd,"tty");
3908 if (ret_char == NULL)
3909 return NULL;
3910 ret_char = strstr(cmd,"sleep");
3911 if (ret_char == NULL)
3912 return NULL;
3913
8cb5d3d5
JM		 3914 if (decw_term_port == 0) {
3915 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3916 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3917 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3918
d30c1055 3919 status = lib$find_image_symbol
8cb5d3d5
JM		 3920 (&filename1_dsc,
3921 &decw_term_port_dsc,
3922 (void *)&decw_term_port,
3923 NULL,
3924 0);
3925
3926 /* Try again with the other image name */
3927 if (!$VMS_STATUS_SUCCESS(status)) {
3928
d30c1055 3929 status = lib$find_image_symbol
8cb5d3d5
JM		 3930 (&filename2_dsc,
3931 &decw_term_port_dsc,
3932 (void *)&decw_term_port,
3933 NULL,
3934 0);
3935
3936 }
3937
3938 }
3939
3940
3941 /* No decw$term_port, give it up */
3942 if (!$VMS_STATUS_SUCCESS(status))
3943 return NULL;
3944
cd1191f1
CB		 3945 /* Are we on a workstation? */
3946 /* to do: capture the rows / columns and pass their properties */
3947 ret_stat = vms_is_syscommand_xterm();
3948 if (ret_stat < 0)
3949 return NULL;
3950
3951 /* Make the title: */
3952 ret_char = strstr(cptr,"-title");
3953 if (ret_char != NULL) {
3954 while ((*cptr != 0) && (*cptr != '\"')) {
3955 cptr++;
3956 }
3957 if (*cptr == '\"')
3958 cptr++;
3959 n = 0;
3960 while ((*cptr != 0) && (*cptr != '\"')) {
3961 title[n] = *cptr;
3962 n++;
3963 if (n == 39) {
3964 title[39] == 0;
3965 break;
3966 }
3967 cptr++;
3968 }
3969 title[n] = 0;
3970 }
3971 else {
3972 /* Default title */
3973 strcpy(title,"Perl Debug DECTerm");
3974 }
3975 sprintf(customization, cust_str, title);
3976
3977 customization_dsc.dsc$a_pointer = customization;
3978 customization_dsc.dsc$w_length = strlen(customization);
3979 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3981
3982 device_name_dsc.dsc$a_pointer = device_name;
3983 device_name_dsc.dsc$w_length = sizeof device_name -1;
3984 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3985 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3986
3987 device_name_len = 0;
3988
3989 /* Try to create the window */
8cb5d3d5 3990 status = (*decw_term_port)
cd1191f1
CB		 3991 (NULL,
3992 NULL,
3993 &customization_dsc,
3994 &device_name_dsc,
3995 &device_name_len,
3996 NULL,
3997 NULL,
3998 NULL);
3999 if (!$VMS_STATUS_SUCCESS(status)) {
4000 SETERRNO(EVMSERR, status);
4001 return NULL;
4002 }
4003
4004 device_name[device_name_len] = '\0';
4005
4006 /* Need to set this up to look like a pipe for cleanup */
4007 n = sizeof(Info);
4008 status = lib$get_vm(&n, &info);
4009 if (!$VMS_STATUS_SUCCESS(status)) {
4010 SETERRNO(ENOMEM, status);
4011 return NULL;
4012 }
4013
4014 info->mode = *mode;
4015 info->done = FALSE;
4016 info->completion = 0;
4017 info->closing = FALSE;
4018 info->in = 0;
4019 info->out = 0;
4020 info->err = 0;
4e205ed6 4021 info->fp = NULL;
cd1191f1
CB		 4022 info->useFILE = 0;
4023 info->waiting = 0;
4024 info->in_done = TRUE;
4025 info->out_done = TRUE;
4026 info->err_done = TRUE;
4027
4028 /* Assign a channel on this so that it will persist, and not login */
4029 /* We stash this channel in the info structure for reference. */
4030 /* The created xterm self destructs when the last channel is removed */
4031 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4032 /* So leave this assigned. */
4033 device_name_dsc.dsc$w_length = device_name_len;
4034 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4035 if (!$VMS_STATUS_SUCCESS(status)) {
4036 SETERRNO(EVMSERR, status);
4037 return NULL;
4038 }
4039 info->xchan_valid = 1;
4040
4041 /* Now create a mailbox to be read by the application */
4042
4043 create_mbx(aTHX_ &p_chan, &d_mbx1);
4044
4045 /* write the name of the created terminal to the mailbox */
4046 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4047 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4048
4049 if (!$VMS_STATUS_SUCCESS(status)) {
4050 SETERRNO(EVMSERR, status);
4051 return NULL;
4052 }
4053
4054 info->fp = PerlIO_open(mbx1, mode);
4055
4056 /* Done with this channel */
4057 sys$dassgn(p_chan);
4058
4059 /* If any errors, then clean up */
4060 if (!info->fp) {
4061 n = sizeof(Info);
4062 _ckvmssts(lib$free_vm(&n, &info));
4063 return NULL;
4064 }
4065
4066 /* All done */
4067 return info->fp;
4068}
22d4bb9c 4069
8fde5078 4070static PerlIO *
2fbb330f 4071safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4072{
748a9306 4073 static int handler_set_up = FALSE;
55f2b99c 4074 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4075 /* The use of a GLOBAL table (as was done previously) rendered
4076 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4077 * environment. Hence we've switched to LOCAL symbol table.
4078 */