This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VMS exit handling still broken, need some help.
[perl5.git] / vms / vms.c
CommitLineData
748a9306 1/* vms.c
a0d0e21e 2 *
748a9306 3 * VMS-specific routines for perl5
22d4bb9c 4 * Version: 5.7.0
748a9306 5 *
2fbb330f 6 * August 2005 Convert VMS status code to UNIX status codes
22d4bb9c
CB
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW
11 */
12
13#include <acedef.h>
14#include <acldef.h>
15#include <armdef.h>
748a9306 16#include <atrdef.h>
a0d0e21e 17#include <chpdef.h>
8fde5078 18#include <clidef.h>
a3e9d8c9 19#include <climsgdef.h>
a0d0e21e 20#include <descrip.h>
22d4bb9c 21#include <devdef.h>
a0d0e21e 22#include <dvidef.h>
748a9306 23#include <fibdef.h>
a0d0e21e
LW
24#include <float.h>
25#include <fscndef.h>
26#include <iodef.h>
27#include <jpidef.h>
61bb5906 28#include <kgbdef.h>
f675dbe5 29#include <libclidef.h>
a0d0e21e
LW
30#include <libdef.h>
31#include <lib$routines.h>
32#include <lnmdef.h>
aeb5cf3c 33#include <msgdef.h>
f7ddb74a
JM
34#if __CRTL_VER >= 70301000 && !defined(__VAX)
35#include <ppropdef.h>
36#endif
748a9306 37#include <prvdef.h>
a0d0e21e
LW
38#include <psldef.h>
39#include <rms.h>
40#include <shrdef.h>
41#include <ssdef.h>
42#include <starlet.h>
f86702cc
PP
43#include <strdef.h>
44#include <str$routines.h>
a0d0e21e 45#include <syidef.h>
748a9306
LW
46#include <uaidef.h>
47#include <uicdef.h>
2fbb330f
JM
48#include <stsdef.h>
49#include <rmsdef.h>
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
2497a41f
JM
63#define VMS_MAXRSS NAML$C_MAXRSS+1
64#ifndef VMS_LONGNAME_SUPPORT
65#define VMS_LONGNAME_SUPPORT 1
66#endif /* VMS_LONGNAME_SUPPORT */
67#endif /* NAM$L_C_MAXRSS */
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
79#define VMS_MAXRSS NAM$C_MAXRSS
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
PP
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
PP
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
PP
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
PP
141/* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
143#ifdef __GNUC__
482b294c
PP
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
PP
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
PP
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
PP
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")) ) ) {
429 memcpy(eqv,eqv+4,eqvlen-4);
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
PP
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
PP
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
PP
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
PP
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
PP
1148 */
1149char *
fd8cd3a3 1150Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd
PP
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
PP
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
PP
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
PP
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
PP
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
PP
1470 case RMS$_DEV:
1471 set_errno(ENODEV); break;
f282b18d 1472 case RMS$_SYN: case SS$_INVFILFOROP:
740ce14c
PP
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
PP
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
PP
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
PP
1525{
1526 STRLEN dirlen = strlen(dir);
1527
a2a90019
CB
1528 /* zero length string sometimes gives ACCVIO */
1529 if (dirlen == 0) return -1;
1530
8cc95fdb
PP
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;
b08af3f0 2295 _ckvmssts(sys$setast(0));
22d4bb9c
CB
2296 if (info->in && !info->in->shut_on_empty) {
2297 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2298 0, 0, 0, 0, 0, 0));
ff7adb52 2299 info->waiting = 1;
22d4bb9c 2300 did_stuff = 1;
748a9306 2301 }
22d4bb9c 2302 _ckvmssts(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) {
2313 _ckvmssts(sys$setast(0));
2314 if (info->waiting && info->done)
2315 info->waiting = 0;
2316 nwait += info->waiting;
2317 _ckvmssts(sys$setast(1));
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) {
b08af3f0 2327 _ckvmssts(sys$setast(0));
3eeba6fb
CB
2328 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329 sts = sys$forcex(&info->pid,0,&abort);
2330 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
2331 did_stuff = 1;
2332 }
b08af3f0 2333 _ckvmssts(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) {
2344 _ckvmssts(sys$setast(0));
2345 if (info->waiting && info->done)
2346 info->waiting = 0;
2347 nwait += info->waiting;
2348 _ckvmssts(sys$setast(1));
2349 info = info->next;
2350 }
2351 if (!nwait) break;
2352 sleep(1);
2353 }
3eeba6fb
CB
2354
2355 info = open_pipes;
2356 while (info) {
b08af3f0 2357 _ckvmssts(sys$setast(0));
3eeba6fb
CB
2358 if (!info->done) { /* We tried to be nice . . . */
2359 sts = sys$delprc(&info->pid,0);
2360 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
3eeba6fb 2361 }
b08af3f0 2362 _ckvmssts(sys$setast(1));
3eeba6fb
CB
2363 info = info->next;
2364 }
2365
2366 while(open_pipes) {
1e422769
PP
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) {
2496 memcpy(&ifi,result+2,2);
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
a02a5408 2528 Newx(p, 1, Pipe);
22d4bb9c 2529
fd8cd3a3
DS
2530 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2531 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB
2532 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2533
2534 p->buf = 0;
2535 p->shut_on_empty = FALSE;
2536 p->need_wake = FALSE;
2537 p->type = 0;
2538 p->retry = 0;
2539 p->iosb.status = SS$_NORMAL;
2540 p->iosb2.status = SS$_NORMAL;
2541 p->free = RQE_ZERO;
2542 p->wait = RQE_ZERO;
2543 p->curr = 0;
2544 p->curr2 = 0;
2545 p->info = 0;
fd8cd3a3
DS
2546#ifdef PERL_IMPLICIT_CONTEXT
2547 p->thx = aTHX;
2548#endif
22d4bb9c
CB
2549
2550 n = sizeof(CBuf) + p->bufsize;
2551
2552 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2553 _ckvmssts(lib$get_vm(&n, &b));
2554 b->buf = (char *) b + sizeof(CBuf);
2555 _ckvmssts(lib$insqhi(b, &p->free));
2556 }
2557
2558 pipe_tochild2_ast(p);
2559 pipe_tochild1_ast(p);
2560 strcpy(wmbx, mbx1);
2561 strcpy(rmbx, mbx2);
2562 return p;
2563}
2564
2565/* reads the MBX Perl is writing, and queues */
2566
2567static void
2568pipe_tochild1_ast(pPipe p)
2569{
22d4bb9c
CB
2570 pCBuf b = p->curr;
2571 int iss = p->iosb.status;
2572 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 2573 int sts;
fd8cd3a3
DS
2574#ifdef PERL_IMPLICIT_CONTEXT
2575 pTHX = p->thx;
2576#endif
22d4bb9c
CB
2577
2578 if (p->retry) {
2579 if (eof) {
2580 p->shut_on_empty = TRUE;
2581 b->eof = TRUE;
2582 _ckvmssts(sys$dassgn(p->chan_in));
2583 } else {
2584 _ckvmssts(iss);
2585 }
2586
2587 b->eof = eof;
2588 b->size = p->iosb.count;
f7ddb74a 2589 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB
2590 if (p->need_wake) {
2591 p->need_wake = FALSE;
2592 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2593 }
2594 } else {
2595 p->retry = 1; /* initial call */
2596 }
2597
2598 if (eof) { /* flush the free queue, return when done */
2599 int n = sizeof(CBuf) + p->bufsize;
2600 while (1) {
2601 iss = lib$remqti(&p->free, &b);
2602 if (iss == LIB$_QUEWASEMP) return;
2603 _ckvmssts(iss);
2604 _ckvmssts(lib$free_vm(&n, &b));
2605 }
2606 }
2607
2608 iss = lib$remqti(&p->free, &b);
2609 if (iss == LIB$_QUEWASEMP) {
2610 int n = sizeof(CBuf) + p->bufsize;
2611 _ckvmssts(lib$get_vm(&n, &b));
2612 b->buf = (char *) b + sizeof(CBuf);
2613 } else {
2614 _ckvmssts(iss);
2615 }
2616
2617 p->curr = b;
2618 iss = sys$qio(0,p->chan_in,
2619 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2620 &p->iosb,
2621 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2622 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2623 _ckvmssts(iss);
2624}
2625
2626
2627/* writes queued buffers to output, waits for each to complete before
2628 doing the next */
2629
2630static void
2631pipe_tochild2_ast(pPipe p)
2632{
22d4bb9c
CB
2633 pCBuf b = p->curr2;
2634 int iss = p->iosb2.status;
2635 int n = sizeof(CBuf) + p->bufsize;
2636 int done = (p->info && p->info->done) ||
2637 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS
2638#if defined(PERL_IMPLICIT_CONTEXT)
2639 pTHX = p->thx;
2640#endif
22d4bb9c
CB
2641
2642 do {
2643 if (p->type) { /* type=1 has old buffer, dispose */
2644 if (p->shut_on_empty) {
2645 _ckvmssts(lib$free_vm(&n, &b));
2646 } else {
2647 _ckvmssts(lib$insqhi(b, &p->free));
2648 }
2649 p->type = 0;
2650 }
2651
2652 iss = lib$remqti(&p->wait, &b);
2653 if (iss == LIB$_QUEWASEMP) {
2654 if (p->shut_on_empty) {
2655 if (done) {
2656 _ckvmssts(sys$dassgn(p->chan_out));
2657 *p->pipe_done = TRUE;
2658 _ckvmssts(sys$setef(pipe_ef));
2659 } else {
2660 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2661 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2662 }
2663 return;
2664 }
2665 p->need_wake = TRUE;
2666 return;
2667 }
2668 _ckvmssts(iss);
2669 p->type = 1;
2670 } while (done);
2671
2672
2673 p->curr2 = b;
2674 if (b->eof) {
2675 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2676 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2677 } else {
2678 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2679 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2680 }
2681
2682 return;
2683
2684}
2685
2686
2687static pPipe
fd8cd3a3 2688pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2689{
22d4bb9c
CB
2690 pPipe p;
2691 char mbx1[64], mbx2[64];
2692 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2693 DSC$K_CLASS_S, mbx1},
2694 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2695 DSC$K_CLASS_S, mbx2};
2696 unsigned int dviitm = DVI$_DEVBUFSIZ;
2697
a02a5408 2698 Newx(p, 1, Pipe);
fd8cd3a3
DS
2699 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2700 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB
2701
2702 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
a02a5408 2703 Newx(p->buf, p->bufsize, char);
22d4bb9c
CB
2704 p->shut_on_empty = FALSE;
2705 p->info = 0;
2706 p->type = 0;
2707 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS
2708#if defined(PERL_IMPLICIT_CONTEXT)
2709 p->thx = aTHX;
2710#endif
22d4bb9c
CB
2711 pipe_infromchild_ast(p);
2712
2713 strcpy(wmbx, mbx1);
2714 strcpy(rmbx, mbx2);
2715 return p;
2716}
2717
2718static void
2719pipe_infromchild_ast(pPipe p)
2720{
22d4bb9c
CB
2721 int iss = p->iosb.status;
2722 int eof = (iss == SS$_ENDOFFILE);
2723 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2724 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS
2725#if defined(PERL_IMPLICIT_CONTEXT)
2726 pTHX = p->thx;
2727#endif
22d4bb9c
CB
2728
2729 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2730 _ckvmssts(sys$dassgn(p->chan_out));
2731 p->chan_out = 0;
2732 }
2733
2734 /* read completed:
2735 input shutdown if EOF from self (done or shut_on_empty)
2736 output shutdown if closing flag set (my_pclose)
2737 send data/eof from child or eof from self
2738 otherwise, re-read (snarf of data from child)
2739 */
2740
2741 if (p->type == 1) {
2742 p->type = 0;
2743 if (myeof && p->chan_in) { /* input shutdown */
2744 _ckvmssts(sys$dassgn(p->chan_in));
2745 p->chan_in = 0;
2746 }
2747
2748 if (p->chan_out) {
2749 if (myeof || kideof) { /* pass EOF to parent */
2750 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2751 pipe_infromchild_ast, p,
2752 0, 0, 0, 0, 0, 0));
2753 return;
2754 } else if (eof) { /* eat EOF --- fall through to read*/
2755
2756 } else { /* transmit data */
2757 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2758 pipe_infromchild_ast,p,
2759 p->buf, p->iosb.count, 0, 0, 0, 0));
2760 return;
2761 }
2762 }
2763 }
2764
2765 /* everything shut? flag as done */
2766
2767 if (!p->chan_in && !p->chan_out) {
2768 *p->pipe_done = TRUE;
2769 _ckvmssts(sys$setef(pipe_ef));
2770 return;
2771 }
2772
2773 /* write completed (or read, if snarfing from child)
2774 if still have input active,
2775 queue read...immediate mode if shut_on_empty so we get EOF if empty
2776 otherwise,
2777 check if Perl reading, generate EOFs as needed
2778 */
2779
2780 if (p->type == 0) {
2781 p->type = 1;
2782 if (p->chan_in) {
2783 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2784 pipe_infromchild_ast,p,
2785 p->buf, p->bufsize, 0, 0, 0, 0);
2786 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2787 _ckvmssts(iss);
2788 } else { /* send EOFs for extra reads */
2789 p->iosb.status = SS$_ENDOFFILE;
2790 p->iosb.dvispec = 0;
2791 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2792 0, 0, 0,
2793 pipe_infromchild_ast, p, 0, 0, 0, 0));
2794 }
2795 }
2796}
2797
2798static pPipe
fd8cd3a3 2799pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 2800{
22d4bb9c
CB
2801 pPipe p;
2802 char mbx[64];
2803 unsigned long dviitm = DVI$_DEVBUFSIZ;
2804 struct stat s;
2805 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2806 DSC$K_CLASS_S, mbx};
2807
2808 /* things like terminals and mbx's don't need this filter */
2809 if (fd && fstat(fd,&s) == 0) {
2810 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2811 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2812 DSC$K_CLASS_S, s.st_dev};
2813
2814 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2815 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2816 strcpy(out, s.st_dev);
2817 return 0;
2818 }
2819 }
2820
a02a5408 2821 Newx(p, 1, Pipe);
22d4bb9c 2822 p->fd_out = dup(fd);
fd8cd3a3 2823 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 2824 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
a02a5408 2825 Newx(p->buf, p->bufsize+1, char);
22d4bb9c
CB
2826 p->shut_on_empty = FALSE;
2827 p->retry = 0;
2828 p->info = 0;
2829 strcpy(out, mbx);
2830
2831 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2832 pipe_mbxtofd_ast, p,
2833 p->buf, p->bufsize, 0, 0, 0, 0));
2834
2835 return p;
2836}
2837
2838static void
2839pipe_mbxtofd_ast(pPipe p)
2840{
22d4bb9c
CB
2841 int iss = p->iosb.status;
2842 int done = p->info->done;
2843 int iss2;
2844 int eof = (iss == SS$_ENDOFFILE);
2845 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2846 int err = !(iss&1) && !eof;
fd8cd3a3
DS
2847#if defined(PERL_IMPLICIT_CONTEXT)
2848 pTHX = p->thx;
2849#endif
22d4bb9c
CB
2850
2851 if (done && myeof) { /* end piping */
2852 close(p->fd_out);
2853 sys$dassgn(p->chan_in);
2854 *p->pipe_done = TRUE;
2855 _ckvmssts(sys$setef(pipe_ef));
2856 return;
2857 }
2858
2859 if (!err && !eof) { /* good data to send to file */
2860 p->buf[p->iosb.count] = '\n';
2861 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2862 if (iss2 < 0) {
2863 p->retry++;
2864 if (p->retry < MAX_RETRY) {
2865 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2866 return;
2867 }
2868 }
2869 p->retry = 0;
2870 } else if (err) {
2871 _ckvmssts(iss);
2872 }
2873
2874
2875 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2876 pipe_mbxtofd_ast, p,
2877 p->buf, p->bufsize, 0, 0, 0, 0);
2878 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2879 _ckvmssts(iss);
2880}
2881
2882
2883typedef struct _pipeloc PLOC;
2884typedef struct _pipeloc* pPLOC;
2885
2886struct _pipeloc {
2887 pPLOC next;
2888 char dir[NAM$C_MAXRSS+1];
2889};
2890static pPLOC head_PLOC = 0;
2891
5c0ae288 2892void
fd8cd3a3 2893free_pipelocs(pTHX_ void *head)
5c0ae288
CL
2894{
2895 pPLOC p, pnext;
ff7adb52 2896 pPLOC *pHead = (pPLOC *)head;
5c0ae288 2897
ff7adb52 2898 p = *pHead;
5c0ae288
CL
2899 while (p) {
2900 pnext = p->next;
2901 Safefree(p);
2902 p = pnext;
2903 }
ff7adb52 2904 *pHead = 0;
5c0ae288 2905}
22d4bb9c
CB
2906
2907static void
fd8cd3a3 2908store_pipelocs(pTHX)
22d4bb9c
CB
2909{
2910 int i;
2911 pPLOC p;
ff7adb52 2912 AV *av = 0;
22d4bb9c
CB
2913 SV *dirsv;
2914 GV *gv;
2915 char *dir, *x;
2916 char *unixdir;
2917 char temp[NAM$C_MAXRSS+1];
2918 STRLEN n_a;
2919
ff7adb52 2920 if (head_PLOC)
218fdd94 2921 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 2922
22d4bb9c
CB
2923/* the . directory from @INC comes last */
2924
a02a5408 2925 Newx(p,1,PLOC);
22d4bb9c
CB
2926 p->next = head_PLOC;
2927 head_PLOC = p;
2928 strcpy(p->dir,"./");
2929
2930/* get the directory from $^X */
2931
218fdd94
CL
2932#ifdef PERL_IMPLICIT_CONTEXT
2933 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2934#else
22d4bb9c 2935 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 2936#endif
22d4bb9c
CB
2937 strcpy(temp, PL_origargv[0]);
2938 x = strrchr(temp,']');
2497a41f
JM
2939 if (x == NULL) {
2940 x = strrchr(temp,'>');
2941 if (x == NULL) {
2942 /* It could be a UNIX path */
2943 x = strrchr(temp,'/');
2944 }
2945 }
2946 if (x)
2947 x[1] = '\0';
2948 else {
2949 /* Got a bare name, so use default directory */
2950 temp[0] = '.';
2951 temp[1] = '\0';
2952 }
22d4bb9c
CB
2953
2954 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
a02a5408 2955 Newx(p,1,PLOC);
22d4bb9c
CB
2956 p->next = head_PLOC;
2957 head_PLOC = p;
2958 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2959 p->dir[NAM$C_MAXRSS] = '\0';
2960 }
2961 }
2962
2963/* reverse order of @INC entries, skip "." since entered above */
2964
218fdd94
CL
2965#ifdef PERL_IMPLICIT_CONTEXT
2966 if (aTHX)
2967#endif
ff7adb52
CL
2968 if (PL_incgv) av = GvAVn(PL_incgv);
2969
2970 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB
2971 dirsv = *av_fetch(av,i,TRUE);
2972
2973 if (SvROK(dirsv)) continue;
2974 dir = SvPVx(dirsv,n_a);
2975 if (strcmp(dir,".") == 0) continue;
2976 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2977 continue;
2978
a02a5408 2979 Newx(p,1,PLOC);
22d4bb9c
CB
2980 p->next = head_PLOC;
2981 head_PLOC = p;
2982 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2983 p->dir[NAM$C_MAXRSS] = '\0';
2984 }
2985
2986/* most likely spot (ARCHLIB) put first in the list */
2987
2988#ifdef ARCHLIB_EXP
2989 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
a02a5408 2990 Newx(p,1,PLOC);
22d4bb9c
CB
2991 p->next = head_PLOC;
2992 head_PLOC = p;
2993 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2994 p->dir[NAM$C_MAXRSS] = '\0';
2995 }
2996#endif
22d4bb9c
CB
2997}
2998
2999
3000static char *
fd8cd3a3 3001find_vmspipe(pTHX)
22d4bb9c
CB
3002{
3003 static int vmspipe_file_status = 0;
3004 static char vmspipe_file[NAM$C_MAXRSS+1];
3005
3006 /* already found? Check and use ... need read+execute permission */
3007
3008 if (vmspipe_file_status == 1) {
3009 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3010 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3011 return vmspipe_file;
3012 }
3013 vmspipe_file_status = 0;
3014 }
3015
3016 /* scan through stored @INC, $^X */
3017
3018 if (vmspipe_file_status == 0) {
3019 char file[NAM$C_MAXRSS+1];
3020 pPLOC p = head_PLOC;
3021
3022 while (p) {
3023 strcpy(file, p->dir);
3024 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3025 file[NAM$C_MAXRSS] = '\0';
3026 p = p->next;
3027
3028 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3029
3030 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3031 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3032 vmspipe_file_status = 1;
3033 return vmspipe_file;
3034 }
3035 }
3036 vmspipe_file_status = -1; /* failed, use tempfiles */
3037 }
3038
3039 return 0;
3040}
3041
3042static FILE *
fd8cd3a3 3043vmspipe_tempfile(pTHX)
22d4bb9c
CB
3044{
3045 char file[NAM$C_MAXRSS+1];
3046 FILE *fp;
3047 static int index = 0;
2497a41f
JM
3048 Stat_t s0, s1;
3049 int cmp_result;
22d4bb9c
CB
3050
3051 /* create a tempfile */
3052
3053 /* we can't go from W, shr=get to R, shr=get without
3054 an intermediate vulnerable state, so don't bother trying...
3055
3056 and lib$spawn doesn't shr=put, so have to close the write
3057
3058 So... match up the creation date/time and the FID to
3059 make sure we're dealing with the same file
3060
3061 */
3062
3063 index++;
2497a41f
JM
3064 if (!decc_filename_unix_only) {
3065 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3066 fp = fopen(file,"w");
3067 if (!fp) {
22d4bb9c
CB
3068 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3069 fp = fopen(file,"w");
3070 if (!fp) {
3071 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3072 fp = fopen(file,"w");
2497a41f
JM
3073 }
3074 }
3075 }
3076 else {
3077 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3078 fp = fopen(file,"w");
3079 if (!fp) {
3080 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3081 fp = fopen(file,"w");
3082 if (!fp) {
3083 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3084 fp = fopen(file,"w");
3085 }
3086 }
22d4bb9c
CB
3087 }
3088 if (!fp) return 0; /* we're hosed */
3089
f9ecfa39 3090 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB
3091 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3092 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3093 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3094 fprintf(fp,"$ perl_on = \"set noon\"\n");
3095 fprintf(fp,"$ perl_exit = \"exit\"\n");
3096 fprintf(fp,"$ perl_del = \"delete\"\n");
3097 fprintf(fp,"$ pif = \"if\"\n");
3098 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH
3099 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3100 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3101 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL
3102 fprintf(fp,"$! --- build command line to get max possible length\n");
3103 fprintf(fp,"$c=perl_popen_cmd0\n");
3104 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3105 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3106 fprintf(fp,"$x=perl_popen_cmd3\n");
3107 fprintf(fp,"$c=c+x\n");
22d4bb9c 3108 fprintf(fp,"$ perl_on\n");
f9ecfa39 3109 fprintf(fp,"$ 'c'\n");
22d4bb9c 3110 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3111 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB
3112 fprintf(fp,"$ perl_exit 'perl_status'\n");
3113 fsync(fileno(fp));
3114
3115 fgetname(fp, file, 1);
2497a41f 3116 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB
3117 fclose(fp);
3118
2497a41f
JM
3119 if (decc_filename_unix_only)
3120 do_tounixspec(file, file, 0);
22d4bb9c
CB
3121 fp = fopen(file,"r","shr=get");
3122 if (!fp) return 0;
2497a41f
JM
3123 fstat(fileno(fp), (struct stat *)&s1);
3124
3125 #if defined(_USE_STD_STAT)
f667e6d8 3126 cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
2497a41f 3127 #else
f667e6d8 3128 cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
2497a41f
JM
3129 #endif
3130 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB
3131 fclose(fp);
3132 return 0;
3133 }
3134
3135 return fp;
3136}
3137
3138
3139
8fde5078 3140static PerlIO *
2fbb330f 3141safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 3142{
748a9306 3143 static int handler_set_up = FALSE;
55f2b99c 3144 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP
3145 /* The use of a GLOBAL table (as was done previously) rendered
3146 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3147 * environment. Hence we've switched to LOCAL symbol table.
3148 */
3149 unsigned int table = LIB$K_CLI_LOCAL_SYM;
48b5a746 3150 int j, wait = 0;
ff7adb52 3151 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
22d4bb9c
CB
3152 char in[512], out[512], err[512], mbx[512];
3153 FILE *tpipe = 0;
3154 char tfilebuf[NAM$C_MAXRSS+1];
3155 pInfo info;
48b5a746 3156 char cmd_sym_name[20];
22d4bb9c
CB
3157 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3158 DSC$K_CLASS_S, symbol};
22d4bb9c 3159 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 3160 DSC$K_CLASS_S, 0};
48b5a746
CL
3161 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3162 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 3163 struct dsc$descriptor_s *vmscmd;
22d4bb9c 3164 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 3165 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 3166 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 3167
afd8f436
JH
3168 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3169
22d4bb9c
CB
3170 /* once-per-program initialization...
3171 note that the SETAST calls and the dual test of pipe_ef
3172 makes sure that only the FIRST thread through here does
3173 the initialization...all other threads wait until it's
3174 done.
3175
3176 Yeah, uglier than a pthread call, it's got all the stuff inline
3177 rather than in a separate routine.
3178 */
3179
3180 if (!pipe_ef) {
3181 _ckvmssts(sys$setast(0));
3182 if (!pipe_ef) {
3183 unsigned long int pidcode = JPI$_PID;
3184 $DESCRIPTOR(d_delay, RETRY_DELAY);
3185 _ckvmssts(lib$get_ef(&pipe_ef));
3186 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3187 _ckvmssts(sys$bintim(&d_delay, delaytime));
3188 }
3189 if (!handler_set_up) {
3190 _ckvmssts(sys$dclexh(&pipe_exitblock));
3191 handler_set_up = TRUE;
3192 }
3193 _ckvmssts(sys$setast(1));
3194 }
3195
3196 /* see if we can find a VMSPIPE.COM */
3197
3198 tfilebuf[0] = '@';
fd8cd3a3 3199 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB
3200 if (vmspipe) {
3201 strcpy(tfilebuf+1,vmspipe);
3202 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 3203 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB
3204 if (!tpipe) { /* a fish popular in Boston */
3205 if (ckWARN(WARN_PIPE)) {
f98bc0c6 3206 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB
3207 }
3208 return Nullfp;
3209 }
3210 fgetname(tpipe,tfilebuf+1,1);
3211 }
3212 vmspipedsc.dsc$a_pointer = tfilebuf;
3213 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 3214
218fdd94 3215 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH
3216 if (!(sts & 1)) {
3217 switch (sts) {
3218 case RMS$_FNF: case RMS$_DNF:
3219 set_errno(ENOENT); break;
3220 case RMS$_DIR:
3221 set_errno(ENOTDIR); break;
3222 case RMS$_DEV:
3223 set_errno(ENODEV); break;
3224 case RMS$_PRV:
3225 set_errno(EACCES); break;
3226 case RMS$_SYN:
3227 set_errno(EINVAL); break;
3228 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3229 set_errno(E2BIG); break;
3230 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3231 _ckvmssts(sts); /* fall through */
3232 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3233 set_errno(EVMSERR);
3234 }
3235 set_vaxc_errno(sts);
ff7adb52 3236 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 3237 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 3238 }
ff7adb52 3239 *psts = sts;
a2669cfc
JH
3240 return Nullfp;
3241 }
a02a5408 3242 Newx(info,1,Info);
22d4bb9c 3243
ff7adb52 3244 strcpy(mode,in_mode);
22d4bb9c
CB
3245 info->mode = *mode;
3246 info->done = FALSE;
3247 info->completion = 0;
3248 info->closing = FALSE;
3249 info->in = 0;
3250 info->out = 0;
3251 info->err = 0;
ff7adb52
CL
3252 info->fp = Nullfp;
3253 info->useFILE = 0;
3254 info->waiting = 0;
22d4bb9c
CB
3255 info->in_done = TRUE;
3256 info->out_done = TRUE;
3257 info->err_done = TRUE;
0e06870b 3258 in[0] = out[0] = err[0] = '\0';
22d4bb9c 3259
ff7adb52
CL
3260 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3261 info->useFILE = 1;
3262 strcpy(p,p+1);
3263 }
3264 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3265 wait = 1;
3266 strcpy(p,p+1);
3267 }
3268
22d4bb9c 3269 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 3270
fd8cd3a3 3271 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB
3272 if (info->out) {
3273 info->out->pipe_done = &info->out_done;
3274 info->out_done = FALSE;
3275 info->out->info = info;
3276 }
ff7adb52 3277 if (!info->useFILE) {
22d4bb9c 3278 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL
3279 } else {
3280 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3281 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3282 }
3283
22d4bb9c
CB
3284 if (!info->fp && info->out) {
3285 sys$cancel(info->out->chan_out);
3286
3287 while (!info->out_done) {
3288 int done;
3289 _ckvmssts(sys$setast(0));
3290 done = info->out_done;
3291 if (!done) _ckvmssts(sys$clref(pipe_ef));
3292 _ckvmssts(sys$setast(1));
3293 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 3294 }
22d4bb9c
CB
3295
3296 if (info->out->buf) Safefree(info->out->buf);
3297 Safefree(info->out);
3298 Safefree(info);
ff7adb52 3299 *psts = RMS$_FNF;
22d4bb9c 3300 return Nullfp;
0e06870b 3301 }
22d4bb9c 3302
fd8cd3a3 3303 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB
3304 if (info->err) {
3305 info->err->pipe_done = &info->err_done;
3306 info->err_done = FALSE;
3307 info->err->info = info;
3308 }
a0d0e21e 3309
ff7adb52
CL
3310 } else if (*mode == 'w') { /* piping to subroutine */
3311
3312 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3313 if (info->out) {
3314 info->out->pipe_done = &info->out_done;
3315 info->out_done = FALSE;
3316 info->out->info = info;
3317 }
3318
3319 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3320 if (info->err) {
3321 info->err->pipe_done = &info->err_done;
3322 info->err_done = FALSE;
3323 info->err->info = info;
3324 }
a0d0e21e 3325
fd8cd3a3 3326 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 3327 if (!info->useFILE) {
22d4bb9c 3328 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL
3329 } else {
3330 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3331 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3332 }
3333
22d4bb9c
CB
3334 if (info->in) {
3335 info->in->pipe_done = &info->in_done;
3336 info->in_done = FALSE;
3337 info->in->info = info;
3338 }
a0d0e21e 3339
22d4bb9c
CB
3340 /* error cleanup */
3341 if (!info->fp && info->in) {
3342 info->done = TRUE;
3343 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3344 0, 0, 0, 0, 0, 0, 0, 0));
3345
3346 while (!info->in_done) {
3347 int done;
3348 _ckvmssts(sys$setast(0));
3349 done = info->in_done;
3350 if (!done) _ckvmssts(sys$clref(pipe_ef));
3351 _ckvmssts(sys$setast(1));
3352 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3353 }
a0d0e21e 3354
22d4bb9c
CB
3355 if (info->in->buf) Safefree(info->in->buf);
3356 Safefree(info->in);
3357 Safefree(info);
ff7adb52 3358 *psts = RMS$_FNF;
0e06870b 3359 return Nullfp;
22d4bb9c 3360 }
a0d0e21e 3361
22d4bb9c 3362
ff7adb52 3363 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 3364 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB
3365 if (info->out) {
3366 info->out->pipe_done = &info->out_done;
3367 info->out_done = FALSE;
3368 info->out->info = info;
3369 }
0e06870b 3370
fd8cd3a3 3371 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB
3372 if (info->err) {
3373 info->err->pipe_done = &info->err_done;
3374 info->err_done = FALSE;
3375 info->err->info = info;
3376 }
748a9306 3377 }
22d4bb9c
CB
3378
3379 symbol[MAX_DCL_SYMBOL] = '\0';
3380
3381 strncpy(symbol, in, MAX_DCL_SYMBOL);
3382 d_symbol.dsc$w_length = strlen(symbol);
3383 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3384
3385 strncpy(symbol, err, MAX_DCL_SYMBOL);
3386 d_symbol.dsc$w_length = strlen(symbol);
3387 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3388
0e06870b
CB
3389 strncpy(symbol, out, MAX_DCL_SYMBOL);
3390 d_symbol.dsc$w_length = strlen(symbol);
3391 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 3392
218fdd94 3393 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB
3394 while (*p && *p != '\n') p++;
3395 *p = '\0'; /* truncate on \n */
218fdd94 3396 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB
3397 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3398 if (*p == '$') p++; /* remove leading $ */
3399 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL
3400
3401 for (j = 0; j < 4; j++) {
3402 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3403 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3404
22d4bb9c
CB
3405 strncpy(symbol, p, MAX_DCL_SYMBOL);
3406 d_symbol.dsc$w_length = strlen(symbol);
3407 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3408
48b5a746
CL
3409 if (strlen(p) > MAX_DCL_SYMBOL) {
3410 p += MAX_DCL_SYMBOL;
3411 } else {
3412 p += strlen(p);
3413 }
3414 }
22d4bb9c 3415 _ckvmssts(sys$setast(0));
a0d0e21e
LW
3416 info->next=open_pipes; /* prepend to list */
3417 open_pipes=info;
22d4bb9c 3418 _ckvmssts(sys$setast(1));
55f2b99c
CB
3419 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3420 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3421 * have SYS$COMMAND if we need it.
3422 */
3423 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB
3424 0, &info->pid, &info->completion,
3425 0, popen_completion_ast,info,0,0,0));
3426
3427 /* if we were using a tempfile, close it now */
3428
3429 if (tpipe) fclose(tpipe);
3430
ff7adb52 3431 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB
3432 we can get rid of ours */
3433
48b5a746
CL
3434 for (j = 0; j < 4; j++) {
3435 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3436 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 3437 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 3438 }
22d4bb9c
CB
3439 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3440 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 3441 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 3442 vms_execfree(vmscmd);
a0d0e21e 3443
218fdd94
CL
3444#ifdef PERL_IMPLICIT_CONTEXT
3445 if (aTHX)
3446#endif
6b88bc9c 3447 PL_forkprocess = info->pid;
218fdd94 3448
ff7adb52
CL
3449 if (wait) {
3450 int done = 0;
3451 while (!done) {
3452 _ckvmssts(sys$setast(0));
3453 done = info->done;
3454 if (!done) _ckvmssts(sys$clref(pipe_ef));
3455 _ckvmssts(sys$setast(1));
3456 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3457 }
3458 *psts = info->completion;
2fbb330f
JM
3459/* Caller thinks it is open and tries to close it. */
3460/* This causes some problems, as it changes the error status */
3461/* my_pclose(info->fp); */
ff7adb52
CL
3462 } else {
3463 *psts = SS$_NORMAL;
3464 }
a0d0e21e 3465 return info->fp;
1e422769
PP
3466} /* end of safe_popen */
3467
3468
a15cef0c
CB
3469/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3470PerlIO *
2fbb330f 3471Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 3472{
ff7adb52 3473 int sts;
1e422769
PP
3474 TAINT_ENV();
3475 TAINT_PROPER("popen");
45bc9206 3476 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 3477 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 3478}
1e422769 3479
a0d0e21e
LW
3480/*}}}*/
3481
a15cef0c
CB
3482/*{{{ I32 my_pclose(PerlIO *fp)*/
3483I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 3484{
22d4bb9c 3485 pInfo info, last = NULL;
748a9306 3486 unsigned long int retsts;
22d4bb9c 3487 int done, iss;
a0d0e21e
LW
3488
3489 for (info = open_pipes; info != NULL; last = info, info = info->next)
3490 if (info->fp == fp) break;
3491
1e422769
PP
3492 if (info == NULL) { /* no such pipe open */
3493 set_errno(ECHILD); /* quoth POSIX */
3494 set_vaxc_errno(SS$_NONEXPR);
3495 return -1;
3496 }
748a9306 3497
bbce6d69
PP
3498 /* If we were writing to a subprocess, insure that someone reading from
3499 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB
3500 * produce an EOF record in the mailbox.
3501 *
3502 * well, at least sometimes it *does*, so we have to watch out for
3503 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3504 */
ff7adb52
CL
3505 if (info->fp) {
3506 if (!info->useFILE)
a15cef0c 3507 PerlIO_flush(info->fp); /* first, flush data */
ff7adb52
CL
3508 else
3509 fflush((FILE *)info->fp);
3510 }
22d4bb9c 3511
b08af3f0 3512 _ckvmssts(sys$setast(0));
22d4bb9c
CB
3513 info->closing = TRUE;
3514 done = info->done && info->in_done && info->out_done && info->err_done;
3515 /* hanging on write to Perl's input? cancel it */
3516 if (info->mode == 'r' && info->out && !info->out_done) {
3517 if (info->out->chan_out) {
3518 _ckvmssts(sys$cancel(info->out->chan_out));
3519 if (!info->out->chan_in) { /* EOF generation, need AST */
3520 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3521 }
3522 }
3523 }
3524 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3525 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3526 0, 0, 0, 0, 0, 0));
b08af3f0 3527 _ckvmssts(sys$setast(1));
ff7adb52
CL
3528 if (info->fp) {
3529 if (!info->useFILE)
740ce14c 3530 PerlIO_close(info->fp);
ff7adb52
CL
3531 else
3532 fclose((FILE *)info->fp);
3533 }
22d4bb9c
CB
3534 /*
3535 we have to wait until subprocess completes, but ALSO wait until all
3536 the i/o completes...otherwise we'll be freeing the "info" structure
3537 that the i/o ASTs could still be using...
3538 */
3539
3540 while (!done) {
3541 _ckvmssts(sys$setast(0));
3542 done = info->done && info->in_done && info->out_done && info->err_done;
3543 if (!done) _ckvmssts(sys$clref(pipe_ef));
3544 _ckvmssts(sys$setast(1));
3545 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3546 }
3547 retsts = info->completion;
a0d0e21e 3548
a0d0e21e 3549 /* remove from list of open pipes */
b08af3f0 3550 _ckvmssts(sys$setast(0));
a0d0e21e
LW
3551 if (last) last->next = info->next;
3552 else open_pipes = info->next;
b08af3f0 3553 _ckvmssts(sys$setast(1));
22d4bb9c
CB
3554
3555 /* free buffers and structures */
3556
3557 if (info->in) {
3558 if (info->in->buf) Safefree(info->in->buf);
3559 Safefree(info->in);
3560 }
3561 if (info->out) {
3562 if (info->out->buf) Safefree(info->out->buf);
3563 Safefree(info->out);
3564 }
3565 if (info->err) {
3566 if (info->err->buf) Safefree(info->err->buf);
3567 Safefree(info->err);
3568 }
a0d0e21e
LW
3569 Safefree(info);
3570
3571 return retsts;
748a9306 3572
a0d0e21e
LW
3573} /* end of my_pclose() */
3574
119586db 3575#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB
3576 /* Roll our own prototype because we want this regardless of whether
3577 * _VMS_WAIT is defined.
3578 */
3579 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3580#endif
3581/* sort-of waitpid; special handling of pipe clean-up for subprocesses
3582 created with popen(); otherwise partially emulate waitpid() unless
3583 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3584 Also check processes not considered by the CRTL waitpid().
3585 */
4fdae800
PP
3586/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3587Pid_t
fd8cd3a3 3588Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 3589{
22d4bb9c
CB
3590 pInfo info;
3591 int done;
aeb5cf3c 3592 int sts;
d85f548a 3593 int j;
aeb5cf3c
CB
3594
3595 if (statusp) *statusp = 0;
a0d0e21e
LW
3596
3597 for (info = open_pipes; info != NULL; info = info->next)
3598 if (info->pid == pid) break;
3599
3600 if (info != NULL) { /* we know about this child */
748a9306 3601 while (!info->done) {
22d4bb9c
CB
3602 _ckvmssts(sys$setast(0));
3603 done = info->done;
3604 if (!done) _ckvmssts(sys$clref(pipe_ef));
3605 _ckvmssts(sys$setast(1));
3606 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW
3607 }
3608
aeb5cf3c 3609 if (statusp) *statusp = info->completion;
a0d0e21e 3610 return pid;
d85f548a
JH
3611 }
3612
3613 /* child that already terminated? */
aeb5cf3c 3614
d85f548a
JH
3615 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3616 if (closed_list[j].pid == pid) {
3617 if (statusp) *statusp = closed_list[j].completion;
3618 return pid;
3619 }
a0d0e21e 3620 }
d85f548a
JH
3621
3622 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 3623
119586db 3624#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB
3625
3626 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3627 * in 7.2 did we get a version that fills in the VMS completion
3628 * status as Perl has always tried to do.
3629 */
3630
3631 sts = __vms_waitpid( pid, statusp, flags );
3632
3633 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3634 return sts;
3635
3636 /* If the real waitpid tells us the child does not exist, we
3637 * fall through here to implement waiting for a child that
3638 * was created by some means other than exec() (say, spawned
3639 * from DCL) or to wait for a process that is not a subprocess
3640 * of the current process.
3641 */
3642
119586db 3643#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 3644
21bc9d50 3645 {
a0d0e21e 3646 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB
3647 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3648 unsigned long int pidcode = JPI$_PID, mypid;
3649 unsigned long int interval[2];
aeb5cf3c 3650 unsigned int jpi_iosb[2];
d85f548a 3651 struct itmlst_3 jpilist[2] = {
aeb5cf3c 3652 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB
3653 { 0, 0, 0, 0}
3654 };
aeb5cf3c
CB
3655
3656 if (pid <= 0) {
3657 /* Sorry folks, we don't presently implement rooting around for
3658 the first child we can find, and we definitely don't want to
3659 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3660 */
3661 set_errno(ENOTSUP);
3662 return -1;
3663 }
3664
d85f548a
JH
3665 /* Get the owner of the child so I can warn if it's not mine. If the
3666 * process doesn't exist or I don't have the privs to look at it,
3667 * I can go home early.
aeb5cf3c
CB
3668 */
3669 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3670 if (sts & 1) sts = jpi_iosb[0];
3671 if (!(sts & 1)) {
3672 switch (sts) {
3673 case SS$_NONEXPR:
3674 set_errno(ECHILD);
3675 break;
3676 case SS$_NOPRIV:
3677 set_errno(EACCES);
3678 break;
3679 default:
3680 _ckvmssts(sts);
3681 }
3682 set_vaxc_errno(sts);
3683 return -1;
3684 }
a0d0e21e 3685
3eeba6fb 3686 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB
3687 /* remind folks they are asking for non-standard waitpid behavior */
3688 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 3689 if (ownerpid != mypid)
f98bc0c6 3690 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB
3691 "waitpid: process %x is not a child of process %x",
3692 pid,mypid);
748a9306 3693 }
a0d0e21e 3694
d85f548a
JH
3695 /* simply check on it once a second until it's not there anymore. */
3696
3697 _ckvmssts(sys$bintim(&intdsc,interval));
3698 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB
3699 _ckvmssts(sys$schdwk(0,0,interval,0));
3700 _ckvmssts(sys$hiber());
d85f548a
JH
3701 }
3702 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB
3703
3704 _ckvmssts(sts);
a0d0e21e 3705 return pid;
21bc9d50 3706 }
a0d0e21e 3707} /* end of waitpid() */
a0d0e21e
LW
3708/*}}}*/
3709/*}}}*/
3710/*}}}*/
3711
3712/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3713char *
3714my_gconvert(double val, int ndig, int trail, char *buf)
3715{
3716 static char __gcvtbuf[DBL_DIG+1];
3717 char *loc;
3718
3719 loc = buf ? buf : __gcvtbuf;
71be2cbc
PP
3720
3721#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3722 if (val < 1) {
3723 sprintf(loc,"%.*g",ndig,val);
3724 return loc;
3725 }
3726#endif
3727
a0d0e21e
LW
3728 if (val) {
3729 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3730 return gcvt(val,ndig,loc);
3731 }
3732 else {
3733 loc[0] = '0'; loc[1] = '\0';
3734 return loc;
3735 }
3736
3737}
3738/*}}}*/
3739
bbce6d69
PP
3740
3741/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3742/* Shortcut for common case of simple calls to $PARSE and $SEARCH
3743 * to expand file specification. Allows for a single default file
3744 * specification and a simple mask of options. If outbuf is non-NULL,
3745 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3746 * the resultant file specification is placed. If outbuf is NULL, the
3747 * resultant file specification is placed into a static buffer.
3748 * The third argument, if non-NULL, is taken to be a default file
3749 * specification string. The fourth argument is unused at present.
3750 * rmesexpand() returns the address of the resultant string if
3751 * successful, and NULL on error.
e886094b
JM
3752 *
3753 * New functionality for previously unused opts value:
3754 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
bbce6d69 3755 */
b8ffc8df 3756static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
96e4d5b1 3757
bbce6d69 3758static char *
2fbb330f 3759mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
bbce6d69
PP
3760{
3761 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
96e4d5b1 3762 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
bbce6d69
PP
3763 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3764 struct FAB myfab = cc$rms_fab;
3765 struct NAM mynam = cc$rms_nam;
3766 STRLEN speclen;
3eeba6fb 3767 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
f7ddb74a 3768 int sts;
bbce6d69
PP
3769
3770 if (!filespec || !*filespec) {
3771 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3772 return NULL;
3773 }
3774 if (!outbuf) {
a02a5408 3775 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
bbce6d69
PP
3776 else outbuf = __rmsexpand_retbuf;
3777 }
2497a41f
JM
3778 isunix = is_unix_filespec(filespec);
3779 if (isunix) {
96e4d5b1
PP
3780 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3781 filespec = vmsfspec;
3782 }
bbce6d69 3783
2fbb330f 3784 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
bbce6d69
PP
3785 myfab.fab$b_fns = strlen(filespec);
3786 myfab.fab$l_nam = &mynam;
3787
3788 if (defspec && *defspec) {
96e4d5b1
PP
3789 if (strchr(defspec,'/') != NULL) {
3790 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3791 defspec = tmpfspec;
3792 }
2fbb330f 3793 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
bbce6d69
PP
3794 myfab.fab$b_dns = strlen(defspec);
3795 }
3796
3797 mynam.nam$l_esa = esa;
3798 mynam.nam$b_ess = sizeof esa;
3799 mynam.nam$l_rsa = outbuf;
3800 mynam.nam$b_rss = NAM$C_MAXRSS;
3801
3802 retsts = sys$parse(&myfab,0,0);
3803 if (!(retsts & 1)) {
17f28c40 3804 mynam.nam$b_nop |= NAM$M_SYNCHK;
f7ddb74a
JM
3805#ifdef NAM$M_NO_SHORT_UPCASE
3806 if (decc_efs_case_preserve)
3807 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3808#endif
f282b18d 3809 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
bbce6d69
PP
3810 retsts = sys$parse(&myfab,0,0);
3811 if (retsts & 1) goto expanded;
3812 }
17f28c40 3813 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
f7ddb74a 3814 sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP
3815 if (out) Safefree(out);
3816 set_vaxc_errno(retsts);
3817 if (retsts == RMS$_PRV) set_errno(EACCES);
3818 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3819 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3820 else set_errno(EVMSERR);
3821 return NULL;
3822 }
3823 retsts = sys$search(&myfab,0,0);
3824 if (!(retsts & 1) && retsts != RMS$_FNF) {
17f28c40 3825 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a
JM
3826#ifdef NAM$M_NO_SHORT_UPCASE
3827 if (decc_efs_case_preserve)
3828 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3829#endif
3830 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP
3831 if (out) Safefree(out);
3832 set_vaxc_errno(retsts);
3833 if (retsts == RMS$_PRV) set_errno(EACCES);
3834 else set_errno(EVMSERR);
3835 return NULL;
3836 }
3837
3838 /* If the input filespec contained any lowercase characters,
3839 * downcase the result for compatibility with Unix-minded code. */
3840 expanded:
f7ddb74a
JM
3841 if (!decc_efs_case_preserve) {
3842 for (out = myfab.fab$l_fna; *out; out++)
3843 if (islower(*out)) { haslower = 1; break; }
3844 }
bbce6d69
PP
3845 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3846 else { out = esa; speclen = mynam.nam$b_esl; }
3eeba6fb
CB
3847 /* Trim off null fields added by $PARSE
3848 * If type > 1 char, must have been specified in original or default spec
3849 * (not true for version; $SEARCH may have added version of existing file).
3850 */
3851 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3852 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3853 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3854 if (trimver || trimtype) {
3855 if (defspec && *defspec) {
3856 char defesa[NAM$C_MAXRSS];
3857 struct FAB deffab = cc$rms_fab;
3858 struct NAM defnam = cc$rms_nam;
3859
3860 deffab.fab$l_nam = &defnam;
f7ddb74a 3861 /* cast below ok for read only pointer */
2fbb330f 3862 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3eeba6fb
CB
3863 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3864 defnam.nam$b_nop = NAM$M_SYNCHK;
f7ddb74a
JM
3865#ifdef NAM$M_NO_SHORT_UPCASE
3866 if (decc_efs_case_preserve)
3867 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3868#endif
3eeba6fb
CB
3869 if (sys$parse(&deffab,0,0) & 1) {
3870 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3871 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3872 }
3873 }
2497a41f
JM
3874 if (trimver) {
3875 if (*mynam.nam$l_ver != '\"')
3876 speclen = mynam.nam$l_ver - out;
3877 }
3eeba6fb
CB
3878 if (trimtype) {
3879 /* If we didn't already trim version, copy down */
3880 if (speclen > mynam.nam$l_ver - out)
3881 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3882 speclen - (mynam.nam$l_ver - out));
3883 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3884 }
3885 }
bbce6d69
PP
3886 /* If we just had a directory spec on input, $PARSE "helpfully"
3887 * adds an empty name and type for us */
3888 if (mynam.nam$l_name == mynam.nam$l_type &&
3889 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3890 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3891 speclen = mynam.nam$l_name - out;
2497a41f
JM
3892
3893 /* Posix format specifications must have matching quotes */
3894 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
3895 if ((speclen > 1) && (out[speclen-1] != '\"')) {
3896 out[speclen] = '\"';
3897 speclen++;
3898 }
3899 }
3900
bbce6d69 3901 out[speclen] = '\0';
f7ddb74a 3902 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
bbce6d69
PP
3903
3904 /* Have we been working with an expanded, but not resultant, spec? */
96e4d5b1 3905 /* Also, convert back to Unix syntax if necessary. */
e886094b
JM
3906 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
3907 isunix = 0;
3908
96e4d5b1
PP
3909 if (!mynam.nam$b_rsl) {
3910 if (isunix) {
3911 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3912 }
3913 else strcpy(outbuf,esa);
3914 }
3915 else if (isunix) {
3916 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3917 strcpy(outbuf,tmpfspec);
3918 }
17f28c40 3919 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a
JM
3920#ifdef NAM$M_NO_SHORT_UPCASE
3921 if (decc_efs_case_preserve)
3922 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3923#endif
17f28c40 3924 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
f7ddb74a 3925 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP
3926 return outbuf;
3927}
3928/*}}}*/
3929/* External entry points */
2fbb330f 3930char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 3931{ return do_rmsexpand(spec,buf,0,def,opt); }
2fbb330f 3932char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69
PP
3933{ return do_rmsexpand(spec,buf,1,def,opt); }
3934
3935
a0d0e21e
LW
3936/*
3937** The following routines are provided to make life easier when
3938** converting among VMS-style and Unix-style directory specifications.
3939** All will take input specifications in either VMS or Unix syntax. On
3940** failure, all return NULL. If successful, the routines listed below
748a9306 3941** return a pointer to a buffer containing the appropriately
a0d0e21e
LW
3942** reformatted spec (and, therefore, subsequent calls to that routine
3943** will clobber the result), while the routines of the same names with
3944** a _ts suffix appended will return a pointer to a mallocd string
3945** containing the appropriately reformatted spec.
3946** In all cases, only explicit syntax is altered; no check is made that
3947** the resulting string is valid or that the directory in question
3948** actually exists.
3949**
3950** fileify_dirspec() - convert a directory spec into the name of the
3951** directory file (i.e. what you can stat() to see if it's a dir).
3952** The style (VMS or Unix) of the result is the same as the style
3953** of the parameter passed in.
3954