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