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