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