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