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