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