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