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