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