This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
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