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