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