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