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