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