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
NetWare scripts tweak from Ananth Kesari.
[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 */
227#if defined(USE_THREADS)
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
HM		 232 }
233#if defined(USE_THREADS)
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
4b19af01 442#if defined(USE_THREADS) || 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
22d4bb9c
CB		 1067/* default piping mailbox size */
1068#define PERL_BUFSIZ 512
1069
674d6c38 1070
a0d0e21e 1071static void
fd8cd3a3 1072create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 1073{
22d4bb9c
CB		 1074 unsigned long int mbxbufsiz;
1075 static unsigned long int syssize = 0;
1076 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 1077 char csize[LNM$C_NAMLENGTH+1];
a0d0e21e 1078
22d4bb9c
CB		 1079 if (!syssize) {
1080 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 1081 /*
22d4bb9c
CB		 1082 * Get the SYSGEN parameter MAXBUF
1083 *
1084 * If the logical 'PERL_MBX_SIZE' is defined
1085 * use the value of the logical instead of PERL_BUFSIZ, but
1086 * keep the size between 128 and MAXBUF.
1087 *
a0d0e21e 1088 */
22d4bb9c
CB		 1089 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1090 }
1091
1092 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1093 mbxbufsiz = atoi(csize);
1094 } else {
1095 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 1096 }
22d4bb9c
CB		 1097 if (mbxbufsiz < 128) mbxbufsiz = 128;
1098 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1099
748a9306 1100 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 1101
748a9306 1102 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 1103 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1104
1105} /* end of create_mbx() */
1106
22d4bb9c 1107
a0d0e21e 1108/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 1109
1110typedef struct _iosb IOSB;
1111typedef struct _iosb* pIOSB;
1112typedef struct _pipe Pipe;
1113typedef struct _pipe* pPipe;
1114typedef struct pipe_details Info;
1115typedef struct pipe_details* pInfo;
1116typedef struct _srqp RQE;
1117typedef struct _srqp* pRQE;
1118typedef struct _tochildbuf CBuf;
1119typedef struct _tochildbuf* pCBuf;
1120
1121struct _iosb {
1122 unsigned short status;
1123 unsigned short count;
1124 unsigned long dvispec;
1125};
1126
1127#pragma member_alignment save
1128#pragma nomember_alignment quadword
1129struct _srqp { /* VMS self-relative queue entry */
1130 unsigned long qptr[2];
1131};
1132#pragma member_alignment restore
1133static RQE RQE_ZERO = {0,0};
1134
1135struct _tochildbuf {
1136 RQE q;
1137 int eof;
1138 unsigned short size;
1139 char *buf;
1140};
1141
1142struct _pipe {
1143 RQE free;
1144 RQE wait;
1145 int fd_out;
1146 unsigned short chan_in;
1147 unsigned short chan_out;
1148 char *buf;
1149 unsigned int bufsize;
1150 IOSB iosb;
1151 IOSB iosb2;
1152 int *pipe_done;
1153 int retry;
1154 int type;
1155 int shut_on_empty;
1156 int need_wake;
1157 pPipe *home;
1158 pInfo info;
1159 pCBuf curr;
1160 pCBuf curr2;
fd8cd3a3
DS		 1161#if defined(PERL_IMPLICIT_CONTEXT)
1162 void *thx; /* Either a thread or an interpreter */
1163 /* pointer, depending on how we're built */
1164#endif
22d4bb9c
CB		 1165};
1166
1167
a0d0e21e
LW		 1168struct pipe_details
1169{
22d4bb9c 1170 pInfo next;
740ce14c 1171 PerlIO *fp; /* stdio file pointer to pipe mailbox */
748a9306
LW		 1172 int pid; /* PID of subprocess */
1173 int mode; /* == 'r' if pipe open for reading */
1174 int done; /* subprocess has completed */
22d4bb9c
CB		 1175 int closing; /* my_pclose is closing this pipe */
1176 unsigned long completion; /* termination status of subprocess */
1177 pPipe in; /* pipe in to sub */
1178 pPipe out; /* pipe out of sub */
1179 pPipe err; /* pipe of sub's sys$error */
1180 int in_done; /* true when in pipe finished */
1181 int out_done;
1182 int err_done;
a0d0e21e
LW		 1183};
1184
748a9306
LW		 1185struct exit_control_block
1186{
1187 struct exit_control_block *flink;
1188 unsigned long int (*exit_routine)();
1189 unsigned long int arg_count;
1190 unsigned long int *status_address;
1191 unsigned long int exit_status;
1192};
1193
22d4bb9c
CB		 1194#define RETRY_DELAY "0 ::0.20"
1195#define MAX_RETRY 50
a0d0e21e 1196
22d4bb9c
CB		 1197static int pipe_ef = 0; /* first call to safe_popen inits these*/
1198static unsigned long mypid;
1199static unsigned long delaytime[2];
1200
1201static pInfo open_pipes = NULL;
1202static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 1203
3eeba6fb 1204
748a9306 1205static unsigned long int
fd8cd3a3 1206pipe_exit_routine(pTHX)
748a9306 1207{
22d4bb9c 1208 pInfo info;
1e422769 1209 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
22d4bb9c 1210 int sts, did_stuff, need_eof;
3eeba6fb
CB		 1211
1212 /*
1213 first we try sending an EOF...ignore if doesn't work, make sure we
1214 don't hang
1215 */
1216 did_stuff = 0;
1217 info = open_pipes;
748a9306 1218
3eeba6fb 1219 while (info) {
b2b89246 1220 int need_eof;
b08af3f0 1221 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 1222 if (info->in && !info->in->shut_on_empty) {
1223 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1224 0, 0, 0, 0, 0, 0));
1225 did_stuff = 1;
748a9306 1226 }
22d4bb9c 1227 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1228 info = info->next;
1229 }
1230 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1231
1232 did_stuff = 0;
1233 info = open_pipes;
1234 while (info) {
b08af3f0 1235 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1236 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1237 sts = sys$forcex(&info->pid,0,&abort);
1238 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1239 did_stuff = 1;
1240 }
b08af3f0 1241 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1242 info = info->next;
1243 }
1244 if (did_stuff) sleep(1); /* wait for them to respond */
1245
1246 info = open_pipes;
1247 while (info) {
b08af3f0 1248 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1249 if (!info->done) { /* We tried to be nice . . . */
1250 sts = sys$delprc(&info->pid,0);
1251 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
3eeba6fb 1252 }
b08af3f0 1253 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1254 info = info->next;
1255 }
1256
1257 while(open_pipes) {
1e422769
PP		 1258 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1259 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 1260 }
1261 return retsts;
1262}
1263
1264static struct exit_control_block pipe_exitblock =
1265 {(struct exit_control_block *) 0,
1266 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1267
22d4bb9c
CB		 1268static void pipe_mbxtofd_ast(pPipe p);
1269static void pipe_tochild1_ast(pPipe p);
1270static void pipe_tochild2_ast(pPipe p);
748a9306 1271
a0d0e21e 1272static void
22d4bb9c 1273popen_completion_ast(pInfo info)
a0d0e21e 1274{
22d4bb9c
CB		 1275 pInfo i = open_pipes;
1276 int iss;
1277
1278 while (i) {
1279 if (i == info) break;
1280 i = i->next;
1281 }
1282 if (!i) return; /* unlinked, probably freed too */
1283
1284 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1285 info->done = TRUE;
1286
1287/*
1288 Writing to subprocess ...
1289 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1290
1291 chan_out may be waiting for "done" flag, or hung waiting
1292 for i/o completion to child...cancel the i/o. This will
1293 put it into "snarf mode" (done but no EOF yet) that discards
1294 input.
1295
1296 Output from subprocess (stdout, stderr) needs to be flushed and
1297 shut down. We try sending an EOF, but if the mbx is full the pipe
1298 routine should still catch the "shut_on_empty" flag, telling it to
1299 use immediate-style reads so that "mbx empty" -> EOF.
1300
1301
1302*/
1303 if (info->in && !info->in_done) { /* only for mode=w */
1304 if (info->in->shut_on_empty && info->in->need_wake) {
1305 info->in->need_wake = FALSE;
fd8cd3a3 1306 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 1307 } else {
fd8cd3a3 1308 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 1309 }
1310 }
1311
1312 if (info->out && !info->out_done) { /* were we also piping output? */
1313 info->out->shut_on_empty = TRUE;
1314 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1315 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1316 _ckvmssts_noperl(iss);
22d4bb9c
CB		 1317 }
1318
1319 if (info->err && !info->err_done) { /* we were piping stderr */
1320 info->err->shut_on_empty = TRUE;
1321 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1322 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1323 _ckvmssts_noperl(iss);
a0d0e21e 1324 }
fd8cd3a3 1325 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 1326
a0d0e21e
LW		 1327}
1328
fd8cd3a3 1329static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
4b19af01 1330static void vms_execfree(pTHX);
aa779de1 1331
22d4bb9c
CB		 1332/*
1333 we actually differ from vmstrnenv since we use this to
1334 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1335 are pointing to the same thing
1336*/
1337
1338static unsigned short
fd8cd3a3 1339popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 1340{
1341 int iss;
1342 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1343 $DESCRIPTOR(d_log,"");
1344 struct _il3 {
1345 unsigned short length;
1346 unsigned short code;
1347 char * buffer_addr;
1348 unsigned short *retlenaddr;
1349 } itmlst[2];
1350 unsigned short l, ifi;
1351
1352 d_log.dsc$a_pointer = logical;
1353 d_log.dsc$w_length = strlen(logical);
1354
1355 itmlst[0].code = LNM$_STRING;
1356 itmlst[0].length = 255;
1357 itmlst[0].buffer_addr = result;
1358 itmlst[0].retlenaddr = &l;
1359
1360 itmlst[1].code = 0;
1361 itmlst[1].length = 0;
1362 itmlst[1].buffer_addr = 0;
1363 itmlst[1].retlenaddr = 0;
1364
1365 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1366 if (iss == SS$_NOLOGNAM) {
1367 iss = SS$_NORMAL;
1368 l = 0;
1369 }
1370 if (!(iss&1)) lib$signal(iss);
1371 result[l] = '\0';
1372/*
1373 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1374 strip it off and return the ifi, if any
1375*/
1376 ifi = 0;
1377 if (result[0] == 0x1b && result[1] == 0x00) {
1378 memcpy(&ifi,result+2,2);
1379 strcpy(result,result+4);
1380 }
1381 return ifi; /* this is the RMS internal file id */
1382}
1383
1384#define MAX_DCL_SYMBOL 255
1385static void pipe_infromchild_ast(pPipe p);
1386
1387/*
1388 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1389 inside an AST routine without worrying about reentrancy and which Perl
1390 memory allocator is being used.
1391
1392 We read data and queue up the buffers, then spit them out one at a
1393 time to the output mailbox when the output mailbox is ready for one.
1394
1395*/
1396#define INITIAL_TOCHILDQUEUE 2
1397
1398static pPipe
fd8cd3a3 1399pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 1400{
22d4bb9c
CB		 1401 pPipe p;
1402 pCBuf b;
1403 char mbx1[64], mbx2[64];
1404 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1405 DSC$K_CLASS_S, mbx1},
1406 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1407 DSC$K_CLASS_S, mbx2};
1408 unsigned int dviitm = DVI$_DEVBUFSIZ;
1409 int j, n;
1410
1411 New(1368, p, 1, Pipe);
1412
fd8cd3a3
DS		 1413 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1414 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 1415 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1416
1417 p->buf = 0;
1418 p->shut_on_empty = FALSE;
1419 p->need_wake = FALSE;
1420 p->type = 0;
1421 p->retry = 0;
1422 p->iosb.status = SS$_NORMAL;
1423 p->iosb2.status = SS$_NORMAL;
1424 p->free = RQE_ZERO;
1425 p->wait = RQE_ZERO;
1426 p->curr = 0;
1427 p->curr2 = 0;
1428 p->info = 0;
fd8cd3a3
DS		 1429#ifdef PERL_IMPLICIT_CONTEXT
1430 p->thx = aTHX;
1431#endif
22d4bb9c
CB		 1432
1433 n = sizeof(CBuf) + p->bufsize;
1434
1435 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1436 _ckvmssts(lib$get_vm(&n, &b));
1437 b->buf = (char *) b + sizeof(CBuf);
1438 _ckvmssts(lib$insqhi(b, &p->free));
1439 }
1440
1441 pipe_tochild2_ast(p);
1442 pipe_tochild1_ast(p);
1443 strcpy(wmbx, mbx1);
1444 strcpy(rmbx, mbx2);
1445 return p;
1446}
1447
1448/* reads the MBX Perl is writing, and queues */
1449
1450static void
1451pipe_tochild1_ast(pPipe p)
1452{
22d4bb9c
CB		 1453 pCBuf b = p->curr;
1454 int iss = p->iosb.status;
1455 int eof = (iss == SS$_ENDOFFILE);
fd8cd3a3
DS		 1456#ifdef PERL_IMPLICIT_CONTEXT
1457 pTHX = p->thx;
1458#endif
22d4bb9c
CB		 1459
1460 if (p->retry) {
1461 if (eof) {
1462 p->shut_on_empty = TRUE;
1463 b->eof = TRUE;
1464 _ckvmssts(sys$dassgn(p->chan_in));
1465 } else {
1466 _ckvmssts(iss);
1467 }
1468
1469 b->eof = eof;
1470 b->size = p->iosb.count;
1471 _ckvmssts(lib$insqhi(b, &p->wait));
1472 if (p->need_wake) {
1473 p->need_wake = FALSE;
1474 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1475 }
1476 } else {
1477 p->retry = 1; /* initial call */
1478 }
1479
1480 if (eof) { /* flush the free queue, return when done */
1481 int n = sizeof(CBuf) + p->bufsize;
1482 while (1) {
1483 iss = lib$remqti(&p->free, &b);
1484 if (iss == LIB$_QUEWASEMP) return;
1485 _ckvmssts(iss);
1486 _ckvmssts(lib$free_vm(&n, &b));
1487 }
1488 }
1489
1490 iss = lib$remqti(&p->free, &b);
1491 if (iss == LIB$_QUEWASEMP) {
1492 int n = sizeof(CBuf) + p->bufsize;
1493 _ckvmssts(lib$get_vm(&n, &b));
1494 b->buf = (char *) b + sizeof(CBuf);
1495 } else {
1496 _ckvmssts(iss);
1497 }
1498
1499 p->curr = b;
1500 iss = sys$qio(0,p->chan_in,
1501 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1502 &p->iosb,
1503 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1504 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1505 _ckvmssts(iss);
1506}
1507
1508
1509/* writes queued buffers to output, waits for each to complete before
1510 doing the next */
1511
1512static void
1513pipe_tochild2_ast(pPipe p)
1514{
22d4bb9c
CB		 1515 pCBuf b = p->curr2;
1516 int iss = p->iosb2.status;
1517 int n = sizeof(CBuf) + p->bufsize;
1518 int done = (p->info && p->info->done) ||
1519 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 1520#if defined(PERL_IMPLICIT_CONTEXT)
1521 pTHX = p->thx;
1522#endif
22d4bb9c
CB		 1523
1524 do {
1525 if (p->type) { /* type=1 has old buffer, dispose */
1526 if (p->shut_on_empty) {
1527 _ckvmssts(lib$free_vm(&n, &b));
1528 } else {
1529 _ckvmssts(lib$insqhi(b, &p->free));
1530 }
1531 p->type = 0;
1532 }
1533
1534 iss = lib$remqti(&p->wait, &b);
1535 if (iss == LIB$_QUEWASEMP) {
1536 if (p->shut_on_empty) {
1537 if (done) {
1538 _ckvmssts(sys$dassgn(p->chan_out));
1539 *p->pipe_done = TRUE;
1540 _ckvmssts(sys$setef(pipe_ef));
1541 } else {
1542 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1543 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1544 }
1545 return;
1546 }
1547 p->need_wake = TRUE;
1548 return;
1549 }
1550 _ckvmssts(iss);
1551 p->type = 1;
1552 } while (done);
1553
1554
1555 p->curr2 = b;
1556 if (b->eof) {
1557 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1558 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1559 } else {
1560 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1561 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1562 }
1563
1564 return;
1565
1566}
1567
1568
1569static pPipe
fd8cd3a3 1570pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 1571{
22d4bb9c
CB		 1572 pPipe p;
1573 char mbx1[64], mbx2[64];
1574 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1575 DSC$K_CLASS_S, mbx1},
1576 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1577 DSC$K_CLASS_S, mbx2};
1578 unsigned int dviitm = DVI$_DEVBUFSIZ;
1579
1580 New(1367, p, 1, Pipe);
fd8cd3a3
DS		 1581 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1582 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 1583
1584 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1585 New(1367, p->buf, p->bufsize, char);
1586 p->shut_on_empty = FALSE;
1587 p->info = 0;
1588 p->type = 0;
1589 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 1590#if defined(PERL_IMPLICIT_CONTEXT)
1591 p->thx = aTHX;
1592#endif
22d4bb9c
CB		 1593 pipe_infromchild_ast(p);
1594
1595 strcpy(wmbx, mbx1);
1596 strcpy(rmbx, mbx2);
1597 return p;
1598}
1599
1600static void
1601pipe_infromchild_ast(pPipe p)
1602{
22d4bb9c
CB		 1603 int iss = p->iosb.status;
1604 int eof = (iss == SS$_ENDOFFILE);
1605 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1606 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 1607#if defined(PERL_IMPLICIT_CONTEXT)
1608 pTHX = p->thx;
1609#endif
22d4bb9c
CB		 1610
1611 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1612 _ckvmssts(sys$dassgn(p->chan_out));
1613 p->chan_out = 0;
1614 }
1615
1616 /* read completed:
1617 input shutdown if EOF from self (done or shut_on_empty)
1618 output shutdown if closing flag set (my_pclose)
1619 send data/eof from child or eof from self
1620 otherwise, re-read (snarf of data from child)
1621 */
1622
1623 if (p->type == 1) {
1624 p->type = 0;
1625 if (myeof && p->chan_in) { /* input shutdown */
1626 _ckvmssts(sys$dassgn(p->chan_in));
1627 p->chan_in = 0;
1628 }
1629
1630 if (p->chan_out) {
1631 if (myeof || kideof) { /* pass EOF to parent */
1632 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1633 pipe_infromchild_ast, p,
1634 0, 0, 0, 0, 0, 0));
1635 return;
1636 } else if (eof) { /* eat EOF --- fall through to read*/
1637
1638 } else { /* transmit data */
1639 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1640 pipe_infromchild_ast,p,
1641 p->buf, p->iosb.count, 0, 0, 0, 0));
1642 return;
1643 }
1644 }
1645 }
1646
1647 /* everything shut? flag as done */
1648
1649 if (!p->chan_in && !p->chan_out) {
1650 *p->pipe_done = TRUE;
1651 _ckvmssts(sys$setef(pipe_ef));
1652 return;
1653 }
1654
1655 /* write completed (or read, if snarfing from child)
1656 if still have input active,
1657 queue read...immediate mode if shut_on_empty so we get EOF if empty
1658 otherwise,
1659 check if Perl reading, generate EOFs as needed
1660 */
1661
1662 if (p->type == 0) {
1663 p->type = 1;
1664 if (p->chan_in) {
1665 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1666 pipe_infromchild_ast,p,
1667 p->buf, p->bufsize, 0, 0, 0, 0);
1668 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1669 _ckvmssts(iss);
1670 } else { /* send EOFs for extra reads */
1671 p->iosb.status = SS$_ENDOFFILE;
1672 p->iosb.dvispec = 0;
1673 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1674 0, 0, 0,
1675 pipe_infromchild_ast, p, 0, 0, 0, 0));
1676 }
1677 }
1678}
1679
1680static pPipe
fd8cd3a3 1681pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 1682{
22d4bb9c
CB		 1683 pPipe p;
1684 char mbx[64];
1685 unsigned long dviitm = DVI$_DEVBUFSIZ;
1686 struct stat s;
1687 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1688 DSC$K_CLASS_S, mbx};
1689
1690 /* things like terminals and mbx's don't need this filter */
1691 if (fd && fstat(fd,&s) == 0) {
1692 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1693 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1694 DSC$K_CLASS_S, s.st_dev};
1695
1696 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1697 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1698 strcpy(out, s.st_dev);
1699 return 0;
1700 }
1701 }
1702
1703 New(1366, p, 1, Pipe);
1704 p->fd_out = dup(fd);
fd8cd3a3 1705 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c
CB		 1706 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1707 New(1366, p->buf, p->bufsize+1, char);
1708 p->shut_on_empty = FALSE;
1709 p->retry = 0;
1710 p->info = 0;
1711 strcpy(out, mbx);
1712
1713 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1714 pipe_mbxtofd_ast, p,
1715 p->buf, p->bufsize, 0, 0, 0, 0));
1716
1717 return p;
1718}
1719
1720static void
1721pipe_mbxtofd_ast(pPipe p)
1722{
22d4bb9c
CB		 1723 int iss = p->iosb.status;
1724 int done = p->info->done;
1725 int iss2;
1726 int eof = (iss == SS$_ENDOFFILE);
1727 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1728 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 1729#if defined(PERL_IMPLICIT_CONTEXT)
1730 pTHX = p->thx;
1731#endif
22d4bb9c
CB		 1732
1733 if (done && myeof) { /* end piping */
1734 close(p->fd_out);
1735 sys$dassgn(p->chan_in);
1736 *p->pipe_done = TRUE;
1737 _ckvmssts(sys$setef(pipe_ef));
1738 return;
1739 }
1740
1741 if (!err && !eof) { /* good data to send to file */
1742 p->buf[p->iosb.count] = '\n';
1743 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1744 if (iss2 < 0) {
1745 p->retry++;
1746 if (p->retry < MAX_RETRY) {
1747 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1748 return;
1749 }
1750 }
1751 p->retry = 0;
1752 } else if (err) {
1753 _ckvmssts(iss);
1754 }
1755
1756
1757 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1758 pipe_mbxtofd_ast, p,
1759 p->buf, p->bufsize, 0, 0, 0, 0);
1760 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1761 _ckvmssts(iss);
1762}
1763
1764
1765typedef struct _pipeloc PLOC;
1766typedef struct _pipeloc* pPLOC;
1767
1768struct _pipeloc {
1769 pPLOC next;
1770 char dir[NAM$C_MAXRSS+1];
1771};
1772static pPLOC head_PLOC = 0;
1773
5c0ae288 1774void
fd8cd3a3 1775free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 1776{
1777 pPLOC p, pnext;
1778
1779 p = (pPLOC) head;
1780 while (p) {
1781 pnext = p->next;
1782 Safefree(p);
1783 p = pnext;
1784 }
1785}
22d4bb9c
CB		 1786
1787static void
fd8cd3a3 1788store_pipelocs(pTHX)
22d4bb9c
CB		 1789{
1790 int i;
1791 pPLOC p;
1792 AV *av = GvAVn(PL_incgv);
1793 SV *dirsv;
1794 GV *gv;
1795 char *dir, *x;
1796 char *unixdir;
1797 char temp[NAM$C_MAXRSS+1];
1798 STRLEN n_a;
1799
1800/* the . directory from @INC comes last */
1801
1802 New(1370,p,1,PLOC);
1803 p->next = head_PLOC;
1804 head_PLOC = p;
1805 strcpy(p->dir,"./");
1806
1807/* get the directory from $^X */
1808
1809 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1810 strcpy(temp, PL_origargv[0]);
1811 x = strrchr(temp,']');
1812 if (x) x[1] = '\0';
1813
1814 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1815 New(1370,p,1,PLOC);
1816 p->next = head_PLOC;
1817 head_PLOC = p;
1818 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1819 p->dir[NAM$C_MAXRSS] = '\0';
1820 }
1821 }
1822
1823/* reverse order of @INC entries, skip "." since entered above */
1824
1825 for (i = 0; i <= AvFILL(av); i++) {
1826 dirsv = *av_fetch(av,i,TRUE);
1827
1828 if (SvROK(dirsv)) continue;
1829 dir = SvPVx(dirsv,n_a);
1830 if (strcmp(dir,".") == 0) continue;
1831 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1832 continue;
1833
1834 New(1370,p,1,PLOC);
1835 p->next = head_PLOC;
1836 head_PLOC = p;
1837 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1838 p->dir[NAM$C_MAXRSS] = '\0';
1839 }
1840
1841/* most likely spot (ARCHLIB) put first in the list */
1842
1843#ifdef ARCHLIB_EXP
1844 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1845 New(1370,p,1,PLOC);
1846 p->next = head_PLOC;
1847 head_PLOC = p;
1848 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1849 p->dir[NAM$C_MAXRSS] = '\0';
1850 }
1851#endif
fd8cd3a3 1852 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
22d4bb9c
CB		 1853}
1854
1855
1856static char *
fd8cd3a3 1857find_vmspipe(pTHX)
22d4bb9c
CB		 1858{
1859 static int vmspipe_file_status = 0;
1860 static char vmspipe_file[NAM$C_MAXRSS+1];
1861
1862 /* already found? Check and use ... need read+execute permission */
1863
1864 if (vmspipe_file_status == 1) {
1865 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1866 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1867 return vmspipe_file;
1868 }
1869 vmspipe_file_status = 0;
1870 }
1871
1872 /* scan through stored @INC, $^X */
1873
1874 if (vmspipe_file_status == 0) {
1875 char file[NAM$C_MAXRSS+1];
1876 pPLOC p = head_PLOC;
1877
1878 while (p) {
1879 strcpy(file, p->dir);
1880 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1881 file[NAM$C_MAXRSS] = '\0';
1882 p = p->next;
1883
1884 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1885
1886 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1887 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1888 vmspipe_file_status = 1;
1889 return vmspipe_file;
1890 }
1891 }
1892 vmspipe_file_status = -1; /* failed, use tempfiles */
1893 }
1894
1895 return 0;
1896}
1897
1898static FILE *
fd8cd3a3 1899vmspipe_tempfile(pTHX)
22d4bb9c
CB		 1900{
1901 char file[NAM$C_MAXRSS+1];
1902 FILE *fp;
1903 static int index = 0;
1904 stat_t s0, s1;
1905
1906 /* create a tempfile */
1907
1908 /* we can't go from W, shr=get to R, shr=get without
1909 an intermediate vulnerable state, so don't bother trying...
1910
1911 and lib$spawn doesn't shr=put, so have to close the write
1912
1913 So... match up the creation date/time and the FID to
1914 make sure we're dealing with the same file
1915
1916 */
1917
1918 index++;
1919 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1920 fp = fopen(file,"w");
1921 if (!fp) {
1922 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1923 fp = fopen(file,"w");
1924 if (!fp) {
1925 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1926 fp = fopen(file,"w");
1927 }
1928 }
1929 if (!fp) return 0; /* we're hosed */
1930
1931 fprintf(fp,"$! 'f$verify(0)\n");
1932 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1933 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1934 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1935 fprintf(fp,"$ perl_on = \"set noon\"\n");
1936 fprintf(fp,"$ perl_exit = \"exit\"\n");
1937 fprintf(fp,"$ perl_del = \"delete\"\n");
1938 fprintf(fp,"$ pif = \"if\"\n");
1939 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 1940 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1941 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 1942 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
22d4bb9c
CB		 1943 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1944 fprintf(fp,"$! --- get rid of global symbols\n");
1945 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1946 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
0e06870b 1947 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
22d4bb9c
CB		 1948 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1949 fprintf(fp,"$ perl_on\n");
1950 fprintf(fp,"$ 'cmd\n");
1951 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 1952 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 1953 fprintf(fp,"$ perl_exit 'perl_status'\n");
1954 fsync(fileno(fp));
1955
1956 fgetname(fp, file, 1);
1957 fstat(fileno(fp), &s0);
1958 fclose(fp);
1959
1960 fp = fopen(file,"r","shr=get");
1961 if (!fp) return 0;
1962 fstat(fileno(fp), &s1);
1963
1964 if (s0.st_ino[0] != s1.st_ino[0] ||
1965 s0.st_ino[1] != s1.st_ino[1] ||
1966 s0.st_ino[2] != s1.st_ino[2] ||
1967 s0.st_ctime != s1.st_ctime ) {
1968 fclose(fp);
1969 return 0;
1970 }
1971
1972 return fp;
1973}
1974
1975
1976
8fde5078 1977static PerlIO *
fd8cd3a3 1978safe_popen(pTHX_ char *cmd, char *mode)
a0d0e21e 1979{
748a9306 1980 static int handler_set_up = FALSE;
aa779de1 1981 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
22d4bb9c
CB		 1982 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1983 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1984 char in[512], out[512], err[512], mbx[512];
1985 FILE *tpipe = 0;
1986 char tfilebuf[NAM$C_MAXRSS+1];
1987 pInfo info;
1988 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1989 DSC$K_CLASS_S, symbol};
22d4bb9c 1990 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 1991 DSC$K_CLASS_S, 0};
0e06870b 1992
22d4bb9c
CB		 1993 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1994 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 1995 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 1996 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 1997
22d4bb9c
CB		 1998 /* once-per-program initialization...
1999 note that the SETAST calls and the dual test of pipe_ef
2000 makes sure that only the FIRST thread through here does
2001 the initialization...all other threads wait until it's
2002 done.
2003
2004 Yeah, uglier than a pthread call, it's got all the stuff inline
2005 rather than in a separate routine.
2006 */
2007
2008 if (!pipe_ef) {
2009 _ckvmssts(sys$setast(0));
2010 if (!pipe_ef) {
2011 unsigned long int pidcode = JPI$_PID;
2012 $DESCRIPTOR(d_delay, RETRY_DELAY);
2013 _ckvmssts(lib$get_ef(&pipe_ef));
2014 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2015 _ckvmssts(sys$bintim(&d_delay, delaytime));
2016 }
2017 if (!handler_set_up) {
2018 _ckvmssts(sys$dclexh(&pipe_exitblock));
2019 handler_set_up = TRUE;
2020 }
2021 _ckvmssts(sys$setast(1));
2022 }
2023
2024 /* see if we can find a VMSPIPE.COM */
2025
2026 tfilebuf[0] = '@';
fd8cd3a3 2027 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 2028 if (vmspipe) {
2029 strcpy(tfilebuf+1,vmspipe);
2030 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 2031 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 2032 if (!tpipe) { /* a fish popular in Boston */
2033 if (ckWARN(WARN_PIPE)) {
2034 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2035 }
2036 return Nullfp;
2037 }
2038 fgetname(tpipe,tfilebuf+1,1);
2039 }
2040 vmspipedsc.dsc$a_pointer = tfilebuf;
2041 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 2042
fd8cd3a3 2043 if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
22d4bb9c
CB		 2044 New(1301,info,1,Info);
2045
2046 info->mode = *mode;
2047 info->done = FALSE;
2048 info->completion = 0;
2049 info->closing = FALSE;
2050 info->in = 0;
2051 info->out = 0;
2052 info->err = 0;
2053 info->in_done = TRUE;
2054 info->out_done = TRUE;
2055 info->err_done = TRUE;
0e06870b 2056 in[0] = out[0] = err[0] = '\0';
22d4bb9c
CB		 2057
2058 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 2059
fd8cd3a3 2060 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 2061 if (info->out) {
2062 info->out->pipe_done = &info->out_done;
2063 info->out_done = FALSE;
2064 info->out->info = info;
2065 }
2066 info->fp = PerlIO_open(mbx, mode);
2067 if (!info->fp && info->out) {
2068 sys$cancel(info->out->chan_out);
2069
2070 while (!info->out_done) {
2071 int done;
2072 _ckvmssts(sys$setast(0));
2073 done = info->out_done;
2074 if (!done) _ckvmssts(sys$clref(pipe_ef));
2075 _ckvmssts(sys$setast(1));
2076 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 2077 }
22d4bb9c
CB		 2078
2079 if (info->out->buf) Safefree(info->out->buf);
2080 Safefree(info->out);
2081 Safefree(info);
2082 return Nullfp;
0e06870b 2083 }
22d4bb9c 2084
fd8cd3a3 2085 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 2086 if (info->err) {
2087 info->err->pipe_done = &info->err_done;
2088 info->err_done = FALSE;
2089 info->err->info = info;
2090 }
a0d0e21e 2091
22d4bb9c 2092 } else { /* piping to subroutine , mode=w*/
a0d0e21e 2093
fd8cd3a3 2094 info->in = pipe_tochild_setup(aTHX_ in,mbx);
22d4bb9c
CB		 2095 info->fp = PerlIO_open(mbx, mode);
2096 if (info->in) {
2097 info->in->pipe_done = &info->in_done;
2098 info->in_done = FALSE;
2099 info->in->info = info;
2100 }
a0d0e21e 2101
22d4bb9c
CB		 2102 /* error cleanup */
2103 if (!info->fp && info->in) {
2104 info->done = TRUE;
2105 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2106 0, 0, 0, 0, 0, 0, 0, 0));
2107
2108 while (!info->in_done) {
2109 int done;
2110 _ckvmssts(sys$setast(0));
2111 done = info->in_done;
2112 if (!done) _ckvmssts(sys$clref(pipe_ef));
2113 _ckvmssts(sys$setast(1));
2114 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2115 }
a0d0e21e 2116
22d4bb9c
CB		 2117 if (info->in->buf) Safefree(info->in->buf);
2118 Safefree(info->in);
2119 Safefree(info);
0e06870b 2120 return Nullfp;
22d4bb9c 2121 }
a0d0e21e 2122
22d4bb9c 2123
fd8cd3a3 2124 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 2125 if (info->out) {
2126 info->out->pipe_done = &info->out_done;
2127 info->out_done = FALSE;
2128 info->out->info = info;
2129 }
0e06870b 2130
fd8cd3a3 2131 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 2132 if (info->err) {
2133 info->err->pipe_done = &info->err_done;
2134 info->err_done = FALSE;
2135 info->err->info = info;
2136 }
748a9306 2137 }
22d4bb9c
CB		 2138
2139 symbol[MAX_DCL_SYMBOL] = '\0';
2140
2141 strncpy(symbol, in, MAX_DCL_SYMBOL);
2142 d_symbol.dsc$w_length = strlen(symbol);
2143 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2144
2145 strncpy(symbol, err, MAX_DCL_SYMBOL);
2146 d_symbol.dsc$w_length = strlen(symbol);
2147 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2148
0e06870b
CB		 2149 strncpy(symbol, out, MAX_DCL_SYMBOL);
2150 d_symbol.dsc$w_length = strlen(symbol);
2151 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c
CB		 2152
2153 p = VMScmd.dsc$a_pointer;
2154 while (*p && *p != '\n') p++;
2155 *p = '\0'; /* truncate on \n */
2156 p = VMScmd.dsc$a_pointer;
2157 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2158 if (*p == '$') p++; /* remove leading $ */
2159 while (*p == ' ' || *p == '\t') p++;
2160 strncpy(symbol, p, MAX_DCL_SYMBOL);
2161 d_symbol.dsc$w_length = strlen(symbol);
2162 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2163
2164 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 2165 info->next=open_pipes; /* prepend to list */
2166 open_pipes=info;
22d4bb9c 2167 _ckvmssts(sys$setast(1));
0e06870b 2168 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
22d4bb9c
CB		 2169 0, &info->pid, &info->completion,
2170 0, popen_completion_ast,info,0,0,0));
2171
2172 /* if we were using a tempfile, close it now */
2173
2174 if (tpipe) fclose(tpipe);
2175
2176 /* once the subprocess is spawned, its copied the symbols and
2177 we can get rid of ours */
2178
2179 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2180 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2181 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 2182 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
22d4bb9c 2183 vms_execfree(aTHX);
a0d0e21e 2184
6b88bc9c 2185 PL_forkprocess = info->pid;
a0d0e21e 2186 return info->fp;
1e422769
PP		 2187} /* end of safe_popen */
2188
2189
a15cef0c
CB		 2190/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2191PerlIO *
5c84aa53 2192Perl_my_popen(pTHX_ char *cmd, char *mode)
1e422769
PP		 2193{
2194 TAINT_ENV();
2195 TAINT_PROPER("popen");
45bc9206 2196 PERL_FLUSHALL_FOR_CHILD;
fd8cd3a3 2197 return safe_popen(aTHX_ cmd,mode);
a0d0e21e 2198}
1e422769 2199
a0d0e21e
LW		 2200/*}}}*/
2201
a15cef0c
CB		 2202/*{{{ I32 my_pclose(PerlIO *fp)*/
2203I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 2204{
22d4bb9c 2205 pInfo info, last = NULL;
748a9306 2206 unsigned long int retsts;
22d4bb9c 2207 int done, iss;
a0d0e21e
LW		 2208
2209 for (info = open_pipes; info != NULL; last = info, info = info->next)
2210 if (info->fp == fp) break;
2211
1e422769
PP		 2212 if (info == NULL) { /* no such pipe open */
2213 set_errno(ECHILD); /* quoth POSIX */
2214 set_vaxc_errno(SS$_NONEXPR);
2215 return -1;
2216 }
748a9306 2217
bbce6d69
PP		 2218 /* If we were writing to a subprocess, insure that someone reading from
2219 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 2220 * produce an EOF record in the mailbox.
2221 *
2222 * well, at least sometimes it *does*, so we have to watch out for
2223 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2224 */
2225
a15cef0c 2226 PerlIO_flush(info->fp); /* first, flush data */
22d4bb9c 2227
b08af3f0 2228 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 2229 info->closing = TRUE;
2230 done = info->done && info->in_done && info->out_done && info->err_done;
2231 /* hanging on write to Perl's input? cancel it */
2232 if (info->mode == 'r' && info->out && !info->out_done) {
2233 if (info->out->chan_out) {
2234 _ckvmssts(sys$cancel(info->out->chan_out));
2235 if (!info->out->chan_in) { /* EOF generation, need AST */
2236 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2237 }
2238 }
2239 }
2240 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2241 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2242 0, 0, 0, 0, 0, 0));
b08af3f0 2243 _ckvmssts(sys$setast(1));
740ce14c 2244 PerlIO_close(info->fp);
c07a80fd 2245
22d4bb9c
CB		 2246 /*
2247 we have to wait until subprocess completes, but ALSO wait until all
2248 the i/o completes...otherwise we'll be freeing the "info" structure
2249 that the i/o ASTs could still be using...
2250 */
2251
2252 while (!done) {
2253 _ckvmssts(sys$setast(0));
2254 done = info->done && info->in_done && info->out_done && info->err_done;
2255 if (!done) _ckvmssts(sys$clref(pipe_ef));
2256 _ckvmssts(sys$setast(1));
2257 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2258 }
2259 retsts = info->completion;
a0d0e21e 2260
a0d0e21e 2261 /* remove from list of open pipes */
b08af3f0 2262 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 2263 if (last) last->next = info->next;
2264 else open_pipes = info->next;
b08af3f0 2265 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 2266
2267 /* free buffers and structures */
2268
2269 if (info->in) {
2270 if (info->in->buf) Safefree(info->in->buf);
2271 Safefree(info->in);
2272 }
2273 if (info->out) {
2274 if (info->out->buf) Safefree(info->out->buf);
2275 Safefree(info->out);
2276 }
2277 if (info->err) {
2278 if (info->err->buf) Safefree(info->err->buf);
2279 Safefree(info->err);
2280 }
a0d0e21e
LW		 2281 Safefree(info);
2282
2283 return retsts;
748a9306 2284
a0d0e21e
LW		 2285} /* end of my_pclose() */
2286
a0d0e21e 2287/* sort-of waitpid; use only with popen() */
4fdae800
PP		 2288/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2289Pid_t
fd8cd3a3 2290Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 2291{
22d4bb9c
CB		 2292 pInfo info;
2293 int done;
a0d0e21e
LW		 2294
2295 for (info = open_pipes; info != NULL; info = info->next)
2296 if (info->pid == pid) break;
2297
2298 if (info != NULL) { /* we know about this child */
748a9306 2299 while (!info->done) {
22d4bb9c
CB		 2300 _ckvmssts(sys$setast(0));
2301 done = info->done;
2302 if (!done) _ckvmssts(sys$clref(pipe_ef));
2303 _ckvmssts(sys$setast(1));
2304 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 2305 }
2306
2307 *statusp = info->completion;
2308 return pid;
2309 }
2310 else { /* we haven't heard of this child */
2311 $DESCRIPTOR(intdsc,"0 00:00:01");
2312 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
748a9306 2313 unsigned long int interval[2],sts;
a0d0e21e 2314
3eeba6fb 2315 if (ckWARN(WARN_EXEC)) {
748a9306
LW		 2316 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2317 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2318 if (ownerpid != mypid)
5c84aa53 2319 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
748a9306 2320 }
a0d0e21e 2321
748a9306 2322 _ckvmssts(sys$bintim(&intdsc,interval));
a0d0e21e 2323 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
748a9306
LW		 2324 _ckvmssts(sys$schdwk(0,0,interval,0));
2325 _ckvmssts(sys$hiber());
a0d0e21e 2326 }
22d4bb9c 2327 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
748a9306 2328 _ckvmssts(sts);
a0d0e21e
LW		 2329
2330 /* There's no easy way to find the termination status a child we're
2331 * not aware of beforehand. If we're really interested in the future,
2332 * we can go looking for a termination mailbox, or chase after the
2333 * accounting record for the process.
2334 */
2335 *statusp = 0;
2336 return pid;
2337 }
2338
2339} /* end of waitpid() */
a0d0e21e
LW		 2340/*}}}*/
2341/*}}}*/
2342/*}}}*/
2343
2344/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2345char *
2346my_gconvert(double val, int ndig, int trail, char *buf)
2347{
2348 static char __gcvtbuf[DBL_DIG+1];
2349 char *loc;
2350
2351 loc = buf ? buf : __gcvtbuf;
71be2cbc
PP		 2352
2353#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2354 if (val < 1) {
2355 sprintf(loc,"%.*g",ndig,val);
2356 return loc;
2357 }
2358#endif
2359
a0d0e21e
LW		 2360 if (val) {
2361 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2362 return gcvt(val,ndig,loc);
2363 }
2364 else {
2365 loc[0] = '0'; loc[1] = '\0';
2366 return loc;
2367 }
2368
2369}
2370/*}}}*/
2371
bbce6d69
PP		 2372
2373/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2374/* Shortcut for common case of simple calls to $PARSE and $SEARCH
2375 * to expand file specification. Allows for a single default file
2376 * specification and a simple mask of options. If outbuf is non-NULL,
2377 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2378 * the resultant file specification is placed. If outbuf is NULL, the
2379 * resultant file specification is placed into a static buffer.
2380 * The third argument, if non-NULL, is taken to be a default file
2381 * specification string. The fourth argument is unused at present.
2382 * rmesexpand() returns the address of the resultant string if
2383 * successful, and NULL on error.
2384 */
4b19af01 2385static char *mp_do_tounixspec(pTHX_ char *, char *, int);
96e4d5b1 2386
bbce6d69 2387static char *
4b19af01 2388mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
bbce6d69
PP		 2389{
2390 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
96e4d5b1 2391 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
bbce6d69
PP		 2392 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2393 struct FAB myfab = cc$rms_fab;
2394 struct NAM mynam = cc$rms_nam;
2395 STRLEN speclen;
3eeba6fb 2396 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
bbce6d69
PP		 2397
2398 if (!filespec || !*filespec) {
2399 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2400 return NULL;
2401 }
2402 if (!outbuf) {
fc36a67e 2403 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
bbce6d69
PP		 2404 else outbuf = __rmsexpand_retbuf;
2405 }
96e4d5b1
PP		 2406 if ((isunix = (strchr(filespec,'/') != NULL))) {
2407 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2408 filespec = vmsfspec;
2409 }
bbce6d69
PP		 2410
2411 myfab.fab$l_fna = filespec;
2412 myfab.fab$b_fns = strlen(filespec);
2413 myfab.fab$l_nam = &mynam;
2414
2415 if (defspec && *defspec) {
96e4d5b1
PP		 2416 if (strchr(defspec,'/') != NULL) {
2417 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2418 defspec = tmpfspec;
2419 }
bbce6d69
PP		 2420 myfab.fab$l_dna = defspec;
2421 myfab.fab$b_dns = strlen(defspec);
2422 }
2423
2424 mynam.nam$l_esa = esa;
2425 mynam.nam$b_ess = sizeof esa;
2426 mynam.nam$l_rsa = outbuf;
2427 mynam.nam$b_rss = NAM$C_MAXRSS;
2428
2429 retsts = sys$parse(&myfab,0,0);
2430 if (!(retsts & 1)) {
17f28c40 2431 mynam.nam$b_nop |= NAM$M_SYNCHK;
f282b18d 2432 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
bbce6d69
PP		 2433 retsts = sys$parse(&myfab,0,0);
2434 if (retsts & 1) goto expanded;
2435 }
17f28c40
CB		 2436 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2437 (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 2438 if (out) Safefree(out);
2439 set_vaxc_errno(retsts);
2440 if (retsts == RMS$_PRV) set_errno(EACCES);
2441 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2442 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2443 else set_errno(EVMSERR);
2444 return NULL;
2445 }
2446 retsts = sys$search(&myfab,0,0);
2447 if (!(retsts & 1) && retsts != RMS$_FNF) {
17f28c40
CB		 2448 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2449 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 2450 if (out) Safefree(out);
2451 set_vaxc_errno(retsts);
2452 if (retsts == RMS$_PRV) set_errno(EACCES);
2453 else set_errno(EVMSERR);
2454 return NULL;
2455 }
2456
2457 /* If the input filespec contained any lowercase characters,
2458 * downcase the result for compatibility with Unix-minded code. */
2459 expanded:
2460 for (out = myfab.fab$l_fna; *out; out++)
2461 if (islower(*out)) { haslower = 1; break; }
2462 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2463 else { out = esa; speclen = mynam.nam$b_esl; }
3eeba6fb
CB		 2464 /* Trim off null fields added by $PARSE
2465 * If type > 1 char, must have been specified in original or default spec
2466 * (not true for version; $SEARCH may have added version of existing file).
2467 */
2468 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2469 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2470 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2471 if (trimver || trimtype) {
2472 if (defspec && *defspec) {
2473 char defesa[NAM$C_MAXRSS];
2474 struct FAB deffab = cc$rms_fab;
2475 struct NAM defnam = cc$rms_nam;
2476
2477 deffab.fab$l_nam = &defnam;
2478 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2479 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2480 defnam.nam$b_nop = NAM$M_SYNCHK;
2481 if (sys$parse(&deffab,0,0) & 1) {
2482 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2483 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2484 }
2485 }
2486 if (trimver) speclen = mynam.nam$l_ver - out;
2487 if (trimtype) {
2488 /* If we didn't already trim version, copy down */
2489 if (speclen > mynam.nam$l_ver - out)
2490 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2491 speclen - (mynam.nam$l_ver - out));
2492 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2493 }
2494 }
bbce6d69
PP		 2495 /* If we just had a directory spec on input, $PARSE "helpfully"
2496 * adds an empty name and type for us */
2497 if (mynam.nam$l_name == mynam.nam$l_type &&
2498 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2499 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2500 speclen = mynam.nam$l_name - out;
2501 out[speclen] = '\0';
2502 if (haslower) __mystrtolower(out);
2503
2504 /* Have we been working with an expanded, but not resultant, spec? */
96e4d5b1
PP		 2505 /* Also, convert back to Unix syntax if necessary. */
2506 if (!mynam.nam$b_rsl) {
2507 if (isunix) {
2508 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2509 }
2510 else strcpy(outbuf,esa);
2511 }
2512 else if (isunix) {
2513 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2514 strcpy(outbuf,tmpfspec);
2515 }
17f28c40
CB		 2516 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2517 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2518 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 2519 return outbuf;
2520}
2521/*}}}*/
2522/* External entry points */
4b19af01 2523char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
bbce6d69 2524{ return do_rmsexpand(spec,buf,0,def,opt); }
4b19af01 2525char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
bbce6d69
PP		 2526{ return do_rmsexpand(spec,buf,1,def,opt); }
2527
2528
a0d0e21e
LW		 2529/*
2530** The following routines are provided to make life easier when
2531** converting among VMS-style and Unix-style directory specifications.
2532** All will take input specifications in either VMS or Unix syntax. On
2533** failure, all return NULL. If successful, the routines listed below
748a9306 2534** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 2535** reformatted spec (and, therefore, subsequent calls to that routine
2536** will clobber the result), while the routines of the same names with
2537** a _ts suffix appended will return a pointer to a mallocd string
2538** containing the appropriately reformatted spec.
2539** In all cases, only explicit syntax is altered; no check is made that
2540** the resulting string is valid or that the directory in question
2541** actually exists.
2542**
2543** fileify_dirspec() - convert a directory spec into the name of the
2544** directory file (i.e. what you can stat() to see if it's a dir).
2545** The style (VMS or Unix) of the result is the same as the style
2546** of the parameter passed in.
2547** pathify_dirspec() - convert a directory spec into a path (i.e.
2548** what you prepend to a filename to indicate what directory it's in).
2549** The style (VMS or Unix) of the result is the same as the style
2550** of the parameter passed in.
2551** tounixpath() - convert a directory spec into a Unix-style path.
2552** tovmspath() - convert a directory spec into a VMS-style path.
2553** tounixspec() - convert any file spec into a Unix-style file spec.
2554** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 2555**
bd3fa61c 2556** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6
PP		 2557** Permission is given to distribute this code as part of the Perl
2558** standard distribution under the terms of the GNU General Public
2559** License or the Perl Artistic License. Copies of each may be
2560** found in the Perl standard distribution.
a0d0e21e
LW		 2561 */
2562
2563/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
4b19af01 2564static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
a0d0e21e
LW		 2565{
2566 static char __fileify_retbuf[NAM$C_MAXRSS+1];
b7ae7a0d 2567 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 2568 char *retspec, *cp1, *cp2, *lastdir;
61bb5906 2569 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
a0d0e21e 2570
c07a80fd
PP		 2571 if (!dir || !*dir) {
2572 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2573 }
a0d0e21e 2574 dirlen = strlen(dir);
a2a90019 2575 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906
CB		 2576 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2577 strcpy(trndir,"/sys$disk/000000");
2578 dir = trndir;
2579 dirlen = 16;
2580 }
2581 if (dirlen > NAM$C_MAXRSS) {
2582 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
c07a80fd 2583 }
e518068a
PP		 2584 if (!strpbrk(dir+1,"/]>:")) {
2585 strcpy(trndir,*dir == '/' ? dir + 1: dir);
c07a80fd 2586 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
e518068a
PP		 2587 dir = trndir;
2588 dirlen = strlen(dir);
2589 }
01b8edb6
PP		 2590 else {
2591 strncpy(trndir,dir,dirlen);
2592 trndir[dirlen] = '\0';
2593 dir = trndir;
2594 }
c07a80fd
PP		 2595 /* If we were handed a rooted logical name or spec, treat it like a
2596 * simple directory, so that
2597 * $ Define myroot dev:[dir.]
2598 * ... do_fileify_dirspec("myroot",buf,1) ...
2599 * does something useful.
2600 */
a2a90019 2601 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
c07a80fd
PP		 2602 dir[--dirlen] = '\0';
2603 dir[dirlen-1] = ']';
2604 }
e518068a 2605
b7ae7a0d
PP		 2606 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2607 /* If we've got an explicit filename, we can just shuffle the string. */
2608 if (*(cp1+1)) hasfilename = 1;
2609 /* Similarly, we can just back up a level if we've got multiple levels
2610 of explicit directories in a VMS spec which ends with directories. */
2611 else {
2612 for (cp2 = cp1; cp2 > dir; cp2--) {
2613 if (*cp2 == '.') {
2614 *cp2 = *cp1; *cp1 = '\0';
2615 hasfilename = 1;
2616 break;
2617 }
2618 if (*cp2 == '[' || *cp2 == '<') break;
2619 }
2620 }
2621 }
2622
2623 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
748a9306
LW		 2624 if (dir[0] == '.') {
2625 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2626 return do_fileify_dirspec("[]",buf,ts);
2627 else if (dir[1] == '.' &&
2628 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2629 return do_fileify_dirspec("[-]",buf,ts);
2630 }
a2a90019 2631 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e
LW		 2632 dirlen -= 1; /* to last element */
2633 lastdir = strrchr(dir,'/');
2634 }
01b8edb6
PP		 2635 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2636 /* If we have "/." or "/..", VMSify it and let the VMS code
2637 * below expand it, rather than repeating the code to handle
2638 * relative components of a filespec here */
4633a7c4
LW		 2639 do {
2640 if (*(cp1+2) == '.') cp1++;
2641 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
01b8edb6 2642 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
fc1ce8cc
CB		 2643 if (strchr(vmsdir,'/') != NULL) {
2644 /* If do_tovmsspec() returned it, it must have VMS syntax
2645 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2646 * the time to check this here only so we avoid a recursion
2647 * loop; otherwise, gigo.
2648 */
2649 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2650 }
01b8edb6
PP		 2651 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2652 return do_tounixspec(trndir,buf,ts);
4633a7c4
LW		 2653 }
2654 cp1++;
2655 } while ((cp1 = strstr(cp1,"/.")) != NULL);
17f28c40 2656 lastdir = strrchr(dir,'/');
748a9306 2657 }
a2a90019 2658 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
61bb5906
CB		 2659 /* Ditto for specs that end in an MFD -- let the VMS code
2660 * figure out whether it's a real device or a rooted logical. */
2661 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2662 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2663 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2664 return do_tounixspec(trndir,buf,ts);
2665 }
a0d0e21e 2666 else {
b7ae7a0d
PP		 2667 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2668 !(lastdir = cp1 = strrchr(dir,']')) &&
2669 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
a0d0e21e 2670 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d
PP		 2671 int ver; char *cp3;
2672 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2673 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2674 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2675 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2676 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2677 (ver || *cp3)))))) {
2678 set_errno(ENOTDIR);
748a9306 2679 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 2680 return NULL;
2681 }
b7ae7a0d 2682 dirlen = cp2 - dir;
a0d0e21e 2683 }
748a9306
LW		 2684 }
2685 /* If we lead off with a device or rooted logical, add the MFD
2686 if we're specifying a top-level directory. */
2687 if (lastdir && *dir == '/') {
2688 addmfd = 1;
2689 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2690 if (*cp1 == '/') {
2691 addmfd = 0;
2692 break;
a0d0e21e
LW		 2693 }
2694 }
748a9306 2695 }
4633a7c4 2696 retlen = dirlen + (addmfd ? 13 : 6);
748a9306 2697 if (buf) retspec = buf;
fc36a67e 2698 else if (ts) New(1309,retspec,retlen+1,char);
748a9306
LW		 2699 else retspec = __fileify_retbuf;
2700 if (addmfd) {
2701 dirlen = lastdir - dir;
2702 memcpy(retspec,dir,dirlen);
2703 strcpy(&retspec[dirlen],"/000000");
2704 strcpy(&retspec[dirlen+7],lastdir);
2705 }
2706 else {
2707 memcpy(retspec,dir,dirlen);
2708 retspec[dirlen] = '\0';
a0d0e21e
LW		 2709 }
2710 /* We've picked up everything up to the directory file name.
2711 Now just add the type and version, and we're set. */
2712 strcat(retspec,".dir;1");
2713 return retspec;
2714 }
2715 else { /* VMS-style directory spec */
01b8edb6
PP		 2716 char esa[NAM$C_MAXRSS+1], term, *cp;
2717 unsigned long int sts, cmplen, haslower = 0;
a0d0e21e
LW		 2718 struct FAB dirfab = cc$rms_fab;
2719 struct NAM savnam, dirnam = cc$rms_nam;
2720
2721 dirfab.fab$b_fns = strlen(dir);
2722 dirfab.fab$l_fna = dir;
2723 dirfab.fab$l_nam = &dirnam;
748a9306
LW		 2724 dirfab.fab$l_dna = ".DIR;1";
2725 dirfab.fab$b_dns = 6;
a0d0e21e
LW		 2726 dirnam.nam$b_ess = NAM$C_MAXRSS;
2727 dirnam.nam$l_esa = esa;
01b8edb6
PP		 2728
2729 for (cp = dir; *cp; cp++)
2730 if (islower(*cp)) { haslower = 1; break; }
e518068a
PP		 2731 if (!((sts = sys$parse(&dirfab))&1)) {
2732 if (dirfab.fab$l_sts == RMS$_DIR) {
2733 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2734 sts = sys$parse(&dirfab) & 1;
2735 }
2736 if (!sts) {
748a9306
LW		 2737 set_errno(EVMSERR);
2738 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 2739 return NULL;
2740 }
e518068a
PP		 2741 }
2742 else {
2743 savnam = dirnam;
2744 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2745 /* Yes; fake the fnb bits so we'll check type below */
2746 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2747 }
752635ea
CB		 2748 else { /* No; just work with potential name */
2749 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2750 else {
2751 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2752 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2753 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
e518068a
PP		 2754 return NULL;
2755 }
e518068a 2756 }
a0d0e21e 2757 }
748a9306
LW		 2758 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2759 cp1 = strchr(esa,']');
2760 if (!cp1) cp1 = strchr(esa,'>');
2761 if (cp1) { /* Should always be true */
2762 dirnam.nam$b_esl -= cp1 - esa - 1;
2763 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2764 }
2765 }
a0d0e21e
LW		 2766 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2767 /* Yep; check version while we're at it, if it's there. */
2768 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2769 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2770 /* Something other than .DIR[;1]. Bzzt. */
752635ea
CB		 2771 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2772 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 2773 set_errno(ENOTDIR);
2774 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 2775 return NULL;
2776 }
748a9306
LW		 2777 }
2778 esa[dirnam.nam$b_esl] = '\0';
2779 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2780 /* They provided at least the name; we added the type, if necessary, */
2781 if (buf) retspec = buf; /* in sys$parse() */
fc36a67e 2782 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
748a9306
LW		 2783 else retspec = __fileify_retbuf;
2784 strcpy(retspec,esa);
752635ea
CB		 2785 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2786 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 2787 return retspec;
2788 }
c07a80fd
PP		 2789 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2790 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2791 *cp1 = '\0';
2792 dirnam.nam$b_esl -= 9;
2793 }
748a9306 2794 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
752635ea
CB		 2795 if (cp1 == NULL) { /* should never happen */
2796 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2797 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2798 return NULL;
2799 }
748a9306
LW		 2800 term = *cp1;
2801 *cp1 = '\0';
2802 retlen = strlen(esa);
2803 if ((cp1 = strrchr(esa,'.')) != NULL) {
2804 /* There's more than one directory in the path. Just roll back. */
2805 *cp1 = term;
2806 if (buf) retspec = buf;
fc36a67e 2807 else if (ts) New(1311,retspec,retlen+7,char);
748a9306
LW		 2808 else retspec = __fileify_retbuf;
2809 strcpy(retspec,esa);
a0d0e21e
LW		 2810 }
2811 else {
748a9306
LW		 2812 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2813 /* Go back and expand rooted logical name */
2814 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2815 if (!(sys$parse(&dirfab) & 1)) {
752635ea
CB		 2816 dirnam.nam$l_rlf = NULL;
2817 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 2818 set_errno(EVMSERR);
2819 set_vaxc_errno(dirfab.fab$l_sts);
2820 return NULL;
2821 }
2822 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 2823 if (buf) retspec = buf;
fc36a67e 2824 else if (ts) New(1312,retspec,retlen+16,char);
a0d0e21e 2825 else retspec = __fileify_retbuf;
748a9306
LW		 2826 cp1 = strstr(esa,"][");
2827 dirlen = cp1 - esa;
2828 memcpy(retspec,esa,dirlen);
2829 if (!strncmp(cp1+2,"000000]",7)) {
2830 retspec[dirlen-1] = '\0';
4633a7c4
LW		 2831 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2832 if (*cp1 == '.') *cp1 = ']';
2833 else {
2834 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2835 memcpy(cp1+1,"000000]",7);
2836 }
748a9306
LW		 2837 }
2838 else {
2839 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2840 retspec[retlen] = '\0';
2841 /* Convert last '.' to ']' */
4633a7c4
LW		 2842 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2843 if (*cp1 == '.') *cp1 = ']';
2844 else {
2845 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2846 memcpy(cp1+1,"000000]",7);
2847 }
748a9306 2848 }
a0d0e21e 2849 }
748a9306 2850 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 2851 if (buf) retspec = buf;
fc36a67e 2852 else if (ts) New(1312,retspec,retlen+16,char);
a0d0e21e
LW		 2853 else retspec = __fileify_retbuf;
2854 cp1 = esa;
2855 cp2 = retspec;
2856 while (*cp1 != ':') *(cp2++) = *(cp1++);
2857 strcpy(cp2,":[000000]");
2858 cp1 += 2;
2859 strcpy(cp2+9,cp1);
2860 }
748a9306 2861 }
752635ea
CB		 2862 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2863 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306 2864 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 2865 type and version, and we're done. */
2866 strcat(retspec,".DIR;1");
01b8edb6
PP		 2867
2868 /* $PARSE may have upcased filespec, so convert output to lower
2869 * case if input contained any lowercase characters. */
2870 if (haslower) __mystrtolower(retspec);
a0d0e21e
LW		 2871 return retspec;
2872 }
2873} /* end of do_fileify_dirspec() */
2874/*}}}*/
2875/* External entry points */
4b19af01 2876char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
a0d0e21e 2877{ return do_fileify_dirspec(dir,buf,0); }
4b19af01 2878char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
a0d0e21e
LW		 2879{ return do_fileify_dirspec(dir,buf,1); }
2880
2881/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4b19af01 2882static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
a0d0e21e
LW		 2883{
2884 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2885 unsigned long int retlen;
748a9306 2886 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
a0d0e21e 2887
c07a80fd
PP		 2888 if (!dir || !*dir) {
2889 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2890 }
2891
2892 if (*dir) strcpy(trndir,dir);
2893 else getcwd(trndir,sizeof trndir - 1);
2894
93948341
CB		 2895 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2896 && my_trnlnm(trndir,trndir,0)) {
c07a80fd 2897 STRLEN trnlen = strlen(trndir);
a0d0e21e 2898
c07a80fd
PP		 2899 /* Trap simple rooted lnms, and return lnm:[000000] */
2900 if (!strcmp(trndir+trnlen-2,".]")) {
2901 if (buf) retpath = buf;
fc36a67e 2902 else if (ts) New(1318,retpath,strlen(dir)+10,char);
c07a80fd
PP		 2903 else retpath = __pathify_retbuf;
2904 strcpy(retpath,dir);
2905 strcat(retpath,":[000000]");
2906 return retpath;
2907 }
2908 }
748a9306
LW		 2909 dir = trndir;
2910
b7ae7a0d 2911 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
748a9306
LW		 2912 if (*dir == '.' && (*(dir+1) == '\0' ||
2913 (*(dir+1) == '.' && *(dir+2) == '\0')))
2914 retlen = 2 + (*(dir+1) != '\0');
2915 else {
b7ae7a0d
PP		 2916 if ( !(cp1 = strrchr(dir,'/')) &&
2917 !(cp1 = strrchr(dir,']')) &&
2918 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
f86702cc
PP		 2919 if ((cp2 = strchr(cp1,'.')) != NULL &&
2920 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2921 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2922 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2923 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d
PP		 2924 int ver; char *cp3;
2925 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2926 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2927 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2928 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2929 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2930 (ver || *cp3)))))) {
748a9306
LW		 2931 set_errno(ENOTDIR);
2932 set_vaxc_errno(RMS$_DIR);
2933 return NULL;
2934 }
b7ae7a0d 2935 retlen = cp2 - dir + 1;
a0d0e21e 2936 }
748a9306
LW		 2937 else { /* No file type present. Treat the filename as a directory. */
2938 retlen = strlen(dir) + 1;
a0d0e21e
LW		 2939 }
2940 }
a0d0e21e 2941 if (buf) retpath = buf;
fc36a67e 2942 else if (ts) New(1313,retpath,retlen+1,char);
a0d0e21e
LW		 2943 else retpath = __pathify_retbuf;
2944 strncpy(retpath,dir,retlen-1);
2945 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2946 retpath[retlen-1] = '/'; /* with '/', add it. */
2947 retpath[retlen] = '\0';
2948 }
2949 else retpath[retlen-1] = '\0';
2950 }
2951 else { /* VMS-style directory spec */
01b8edb6
PP		 2952 char esa[NAM$C_MAXRSS+1], *cp;
2953 unsigned long int sts, cmplen, haslower;
a0d0e21e
LW		 2954 struct FAB dirfab = cc$rms_fab;
2955 struct NAM savnam, dirnam = cc$rms_nam;
2956
b7ae7a0d
PP		 2957 /* If we've got an explicit filename, we can just shuffle the string. */
2958 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2959 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2960 if ((cp2 = strchr(cp1,'.')) != NULL) {
2961 int ver; char *cp3;
2962 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2963 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2964 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2965 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2966 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2967 (ver || *cp3)))))) {
2968 set_errno(ENOTDIR);
2969 set_vaxc_errno(RMS$_DIR);
2970 return NULL;
2971 }
2972 }
2973 else { /* No file type, so just draw name into directory part */
2974 for (cp2 = cp1; *cp2; cp2++) ;
2975 }
2976 *cp2 = *cp1;
2977 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2978 *cp1 = '.';
2979 /* We've now got a VMS 'path'; fall through */
2980 }
a0d0e21e
LW		 2981 dirfab.fab$b_fns = strlen(dir);
2982 dirfab.fab$l_fna = dir;
748a9306
LW		 2983 if (dir[dirfab.fab$b_fns-1] == ']' ||
2984 dir[dirfab.fab$b_fns-1] == '>' ||
2985 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2986 if (buf) retpath = buf;
fc36a67e 2987 else if (ts) New(1314,retpath,strlen(dir)+1,char);
748a9306
LW		 2988 else retpath = __pathify_retbuf;
2989 strcpy(retpath,dir);
2990 return retpath;
2991 }
2992 dirfab.fab$l_dna = ".DIR;1";
2993 dirfab.fab$b_dns = 6;
a0d0e21e 2994 dirfab.fab$l_nam = &dirnam;
e518068a 2995 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
a0d0e21e 2996 dirnam.nam$l_esa = esa;
01b8edb6
PP		 2997
2998 for (cp = dir; *cp; cp++)
2999 if (islower(*cp)) { haslower = 1; break; }
3000
3001 if (!(sts = (sys$parse(&dirfab)&1))) {
e518068a
PP		 3002 if (dirfab.fab$l_sts == RMS$_DIR) {
3003 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3004 sts = sys$parse(&dirfab) & 1;
3005 }
3006 if (!sts) {
748a9306
LW		 3007 set_errno(EVMSERR);
3008 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 3009 return NULL;
3010 }
a0d0e21e 3011 }
e518068a
PP		 3012 else {
3013 savnam = dirnam;
3014 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3015 if (dirfab.fab$l_sts != RMS$_FNF) {
752635ea
CB		 3016 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3017 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
e518068a
PP		 3018 set_errno(EVMSERR);
3019 set_vaxc_errno(dirfab.fab$l_sts);
3020 return NULL;
3021 }
3022 dirnam = savnam; /* No; just work with potential name */
3023 }
3024 }
a0d0e21e
LW		 3025 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3026 /* Yep; check version while we're at it, if it's there. */
3027 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3028 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3029 /* Something other than .DIR[;1]. Bzzt. */
752635ea
CB		 3030 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3031 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 3032 set_errno(ENOTDIR);
3033 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 3034 return NULL;
3035 }
a0d0e21e 3036 }
748a9306
LW		 3037 /* OK, the type was fine. Now pull any file name into the
3038 directory path. */
3039 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
a0d0e21e 3040 else {
748a9306
LW		 3041 cp1 = strrchr(esa,'>');
3042 *dirnam.nam$l_type = '>';
a0d0e21e 3043 }
748a9306
LW		 3044 *cp1 = '.';
3045 *(dirnam.nam$l_type + 1) = '\0';
3046 retlen = dirnam.nam$l_type - esa + 2;
a0d0e21e 3047 if (buf) retpath = buf;
fc36a67e 3048 else if (ts) New(1314,retpath,retlen,char);
a0d0e21e
LW		 3049 else retpath = __pathify_retbuf;
3050 strcpy(retpath,esa);
752635ea
CB		 3051 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3052 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
01b8edb6
PP		 3053 /* $PARSE may have upcased filespec, so convert output to lower
3054 * case if input contained any lowercase characters. */
3055 if (haslower) __mystrtolower(retpath);
a0d0e21e
LW		 3056 }
3057
3058 return retpath;
3059} /* end of do_pathify_dirspec() */
3060/*}}}*/
3061/* External entry points */
4b19af01 3062char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
a0d0e21e 3063{ return do_pathify_dirspec(dir,buf,0); }
4b19af01 3064char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
a0d0e21e
LW		 3065{ return do_pathify_dirspec(dir,buf,1); }
3066
3067/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
4b19af01 3068static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
a0d0e21e
LW		 3069{
3070 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3071 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
f86702cc 3072 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
a0d0e21e 3073
748a9306 3074 if (spec == NULL) return NULL;
e518068a 3075 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
a0d0e21e 3076 if (buf) rslt = buf;
e518068a
PP		 3077 else if (ts) {
3078 retlen = strlen(spec);
3079 cp1 = strchr(spec,'[');
3080 if (!cp1) cp1 = strchr(spec,'<');
3081 if (cp1) {
f86702cc
PP		 3082 for (cp1++; *cp1; cp1++) {
3083 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3084 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3085 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3086 }
e518068a 3087 }
fc36a67e 3088 New(1315,rslt,retlen+2+2*expand,char);
e518068a 3089 }
a0d0e21e
LW		 3090 else rslt = __tounixspec_retbuf;
3091 if (strchr(spec,'/') != NULL) {
3092 strcpy(rslt,spec);
3093 return rslt;
3094 }
3095
3096 cp1 = rslt;
3097 cp2 = spec;
3098 dirend = strrchr(spec,']');
3099 if (dirend == NULL) dirend = strrchr(spec,'>');
3100 if (dirend == NULL) dirend = strchr(spec,':');
3101 if (dirend == NULL) {
3102 strcpy(rslt,spec);
3103 return rslt;
3104 }
a5f75d66 3105 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 3106 *(cp1++) = '/';
3107 }
3108 else { /* the VMS spec begins with directories */
3109 cp2++;
a5f75d66 3110 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 3111 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
a5f75d66
AD		 3112 return rslt;
3113 }
f86702cc 3114 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
a0d0e21e
LW		 3115 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3116 if (ts) Safefree(rslt);
3117 return NULL;
3118 }
3119 do {
3120 cp3 = tmp;
3121 while (*cp3 != ':' && *cp3) cp3++;
3122 *(cp3++) = '\0';
3123 if (strchr(cp3,']') != NULL) break;
f675dbe5 3124 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 3125 if (ts && !buf &&
e518068a 3126 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 3127 retlen = devlen + dirlen;
f86702cc
PP		 3128 Renew(rslt,retlen+1+2*expand,char);
3129 cp1 = rslt;
3130 }
3131 cp3 = tmp;
3132 *(cp1++) = '/';
3133 while (*cp3) {
3134 *(cp1++) = *(cp3++);
3135 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
a0d0e21e 3136 }
f86702cc
PP		 3137 *(cp1++) = '/';
3138 }
3139 else if ( *cp2 == '.') {
3140 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3141 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3142 cp2 += 3;
3143 }
3144 else cp2++;
a0d0e21e 3145 }
a0d0e21e
LW		 3146 }
3147 for (; cp2 <= dirend; cp2++) {
3148 if (*cp2 == ':') {
3149 *(cp1++) = '/';
3150 if (*(cp2+1) == '[') cp2++;
3151 }
f86702cc
PP		 3152 else if (*cp2 == ']' || *cp2 == '>') {
3153 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3154 }
a0d0e21e
LW		 3155 else if (*cp2 == '.') {
3156 *(cp1++) = '/';
e518068a
PP		 3157 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3158 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3159 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3160 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3161 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3162 }
f86702cc
PP		 3163 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3164 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3165 cp2 += 2;
3166 }
a0d0e21e
LW		 3167 }
3168 else if (*cp2 == '-') {
3169 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3170 while (*cp2 == '-') {
3171 cp2++;
3172 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3173 }
3174 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3175 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 3176 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 3177 return NULL;
3178 }
a0d0e21e
LW		 3179 }
3180 else *(cp1++) = *cp2;
3181 }
3182 else *(cp1++) = *cp2;
3183 }
3184 while (*cp2) *(cp1++) = *(cp2++);
3185 *cp1 = '\0';
3186
3187 return rslt;
3188
3189} /* end of do_tounixspec() */
3190/*}}}*/
3191/* External entry points */
4b19af01
CB		 3192char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3193char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
a0d0e21e
LW		 3194
3195/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
4b19af01 3196static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
a0d0e21e 3197 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
e518068a
PP		 3198 char *rslt, *dirend;
3199 register char *cp1, *cp2;
3200 unsigned long int infront = 0, hasdir = 1;
a0d0e21e 3201
748a9306 3202 if (path == NULL) return NULL;
a0d0e21e 3203 if (buf) rslt = buf;
fc36a67e 3204 else if (ts) New(1316,rslt,strlen(path)+9,char);
a0d0e21e 3205 else rslt = __tovmsspec_retbuf;
748a9306 3206 if (strpbrk(path,"]:>") ||
a0d0e21e 3207 (dirend = strrchr(path,'/')) == NULL) {
748a9306
LW		 3208 if (path[0] == '.') {
3209 if (path[1] == '\0') strcpy(rslt,"[]");
3210 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3211 else strcpy(rslt,path); /* probably garbage */
3212 }
3213 else strcpy(rslt,path);
a0d0e21e
LW		 3214 return rslt;
3215 }
f86702cc 3216 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 3217 if (!*(dirend+2)) dirend +=2;
3218 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
f86702cc 3219 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 3220 }
a0d0e21e
LW		 3221 cp1 = rslt;
3222 cp2 = path;
3223 if (*cp2 == '/') {
e518068a
PP		 3224 char trndev[NAM$C_MAXRSS+1];
3225 int islnm, rooted;
3226 STRLEN trnend;
3227
b7ae7a0d 3228 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906
CB		 3229 if (!*(cp2+1)) {
3230 if (!buf & ts) Renew(rslt,18,char);
3231 strcpy(rslt,"sys$disk:[000000]");
3232 return rslt;
3233 }
a0d0e21e 3234 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 3235 *cp1 = '\0';
c07a80fd 3236 islnm = my_trnlnm(rslt,trndev,0);
e518068a
PP		 3237 trnend = islnm ? strlen(trndev) - 1 : 0;
3238 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3239 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3240 /* If the first element of the path is a logical name, determine
3241 * whether it has to be translated so we can add more directories. */
3242 if (!islnm || rooted) {
3243 *(cp1++) = ':';
3244 *(cp1++) = '[';
3245 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3246 else cp2++;
3247 }
3248 else {
3249 if (cp2 != dirend) {
3250 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3251 strcpy(rslt,trndev);
3252 cp1 = rslt + trnend;
3253 *(cp1++) = '.';
3254 cp2++;
3255 }
3256 else {
3257 *(cp1++) = ':';
3258 hasdir = 0;
3259 }
3260 }
748a9306 3261 }
a0d0e21e
LW		 3262 else {
3263 *(cp1++) = '[';
748a9306
LW		 3264 if (*cp2 == '.') {
3265 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3266 cp2 += 2; /* skip over "./" - it's redundant */
3267 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3268 }
3269 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3270 *(cp1++) = '-'; /* "../" --> "-" */
3271 cp2 += 3;
3272 }
f86702cc
PP		 3273 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3274 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3275 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3276 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3277 cp2 += 4;
3278 }
748a9306
LW		 3279 if (cp2 > dirend) cp2 = dirend;
3280 }
3281 else *(cp1++) = '.';
3282 }
3283 for (; cp2 < dirend; cp2++) {
3284 if (*cp2 == '/') {
01b8edb6 3285 if (*(cp2-1) == '/') continue;
748a9306
LW		 3286 if (*(cp1-1) != '.') *(cp1++) = '.';
3287 infront = 0;
3288 }
3289 else if (!infront && *cp2 == '.') {
01b8edb6
PP		 3290 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3291 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 3292 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3293 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 3294 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 3295 else { /* back up over previous directory name */
3296 cp1--;
3297 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3298 if (*(cp1-1) == '[') {
3299 memcpy(cp1,"000000.",7);
3300 cp1 += 7;
3301 }
748a9306
LW		 3302 }
3303 cp2 += 2;
01b8edb6 3304 if (cp2 == dirend) break;
748a9306 3305 }
f86702cc
PP		 3306 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3307 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3308 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3309 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3310 if (!*(cp2+3)) {
3311 *(cp1++) = '.'; /* Simulate trailing '/' */
3312 cp2 += 2; /* for loop will incr this to == dirend */
3313 }
3314 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3315 }
748a9306
LW		 3316 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3317 }
3318 else {
e518068a 3319 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
01b8edb6 3320 if (*cp2 == '.') *(cp1++) = '_';
748a9306
LW		 3321 else *(cp1++) = *cp2;
3322 infront = 1;
3323 }
a0d0e21e 3324 }
748a9306 3325 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 3326 if (hasdir) *(cp1++) = ']';
748a9306 3327 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
a0d0e21e
LW		 3328 while (*cp2) *(cp1++) = *(cp2++);
3329 *cp1 = '\0';
3330
3331 return rslt;
3332
3333} /* end of do_tovmsspec() */
3334/*}}}*/
3335/* External entry points */
4b19af01
CB		 3336char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3337char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
a0d0e21e
LW		 3338
3339/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
4b19af01 3340static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
a0d0e21e
LW		 3341 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3342 int vmslen;
3343 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3344
748a9306 3345 if (path == NULL) return NULL;
a0d0e21e
LW		 3346 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3347 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3348 if (buf) return buf;
3349 else if (ts) {
3350 vmslen = strlen(vmsified);
fc36a67e 3351 New(1317,cp,vmslen+1,char);
a0d0e21e
LW		 3352 memcpy(cp,vmsified,vmslen);
3353 cp[vmslen] = '\0';
3354 return cp;
3355 }
3356 else {
3357 strcpy(__tovmspath_retbuf,vmsified);
3358 return __tovmspath_retbuf;
3359 }
3360
3361} /* end of do_tovmspath() */
3362/*}}}*/
3363/* External entry points */
4b19af01
CB		 3364char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3365char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
a0d0e21e
LW		 3366
3367
3368/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
4b19af01 3369static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
a0d0e21e
LW		 3370 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3371 int unixlen;
3372 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3373
748a9306 3374 if (path == NULL) return NULL;
a0d0e21e
LW		 3375 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3376 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3377 if (buf) return buf;
3378 else if (ts) {
3379 unixlen = strlen(unixified);
fc36a67e 3380 New(1317,cp,unixlen+1,char);
a0d0e21e
LW		 3381 memcpy(cp,unixified,unixlen);
3382 cp[unixlen] = '\0';
3383 return cp;
3384 }
3385 else {
3386 strcpy(__tounixpath_retbuf,unixified);
3387 return __tounixpath_retbuf;
3388 }
3389
3390} /* end of do_tounixpath() */
3391/*}}}*/
3392/* External entry points */
4b19af01
CB		 3393char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3394char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
a0d0e21e
LW		 3395
3396/*
3397 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3398 *
3399 *****************************************************************************
3400 * *
3401 * Copyright (C) 1989-1994 by *
3402 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3403 * *
3404 * Permission is hereby granted for the reproduction of this software, *
3405 * on condition that this copyright notice is included in the reproduction, *
3406 * and that such reproduction is not for purposes of profit or material *
3407 * gain. *
3408 * *
3409 * 27-Aug-1994 Modified for inclusion in perl5 *
bd3fa61c 3410 * by Charles Bailey bailey@newman.upenn.edu *
a0d0e21e
LW		 3411 *****************************************************************************
3412 */
3413
3414/*
3415 * getredirection() is intended to aid in porting C programs
3416 * to VMS (Vax-11 C). The native VMS environment does not support
3417 * '>' and '<' I/O redirection, or command line wild card expansion,
3418 * or a command line pipe mechanism using the '|' AND background
3419 * command execution '&'. All of these capabilities are provided to any
3420 * C program which calls this procedure as the first thing in the
3421 * main program.
3422 * The piping mechanism will probably work with almost any 'filter' type
3423 * of program. With suitable modification, it may useful for other
3424 * portability problems as well.
3425 *
3426 * Author: Mark Pizzolato mark@infocomm.com
3427 */
3428struct list_item
3429 {
3430 struct list_item *next;
3431 char *value;
3432 };
3433
3434static void add_item(struct list_item **head,
3435 struct list_item **tail,
3436 char *value,
3437 int *count);
3438
4b19af01
CB		 3439static void mp_expand_wild_cards(pTHX_ char *item,
3440 struct list_item **head,
3441 struct list_item **tail,
3442 int *count);
a0d0e21e
LW		 3443
3444static int background_process(int argc, char **argv);
3445
fd8cd3a3 3446static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 3447
3448/*{{{ void getredirection(int *ac, char ***av)*/
84902520 3449static void
4b19af01 3450mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 3451/*
3452 * Process vms redirection arg's. Exit if any error is seen.
3453 * If getredirection() processes an argument, it is erased
3454 * from the vector. getredirection() returns a new argc and argv value.
3455 * In the event that a background command is requested (by a trailing "&"),
3456 * this routine creates a background subprocess, and simply exits the program.
3457 *
3458 * Warning: do not try to simplify the code for vms. The code
3459 * presupposes that getredirection() is called before any data is
3460 * read from stdin or written to stdout.
3461 *
3462 * Normal usage is as follows:
3463 *
3464 * main(argc, argv)
3465 * int argc;
3466 * char *argv[];
3467 * {
3468 * getredirection(&argc, &argv);
3469 * }
3470 */
3471{
3472 int argc = *ac; /* Argument Count */
3473 char **argv = *av; /* Argument Vector */
3474 char *ap; /* Argument pointer */
3475 int j; /* argv[] index */
3476 int item_count = 0; /* Count of Items in List */
3477 struct list_item *list_head = 0; /* First Item in List */
3478 struct list_item *list_tail; /* Last Item in List */
3479 char *in = NULL; /* Input File Name */
3480 char *out = NULL; /* Output File Name */
3481 char *outmode = "w"; /* Mode to Open Output File */
3482 char *err = NULL; /* Error File Name */
3483 char *errmode = "w"; /* Mode to Open Error File */
3484 int cmargc = 0; /* Piped Command Arg Count */
3485 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 3486
3487 /*
3488 * First handle the case where the last thing on the line ends with
3489 * a '&'. This indicates the desire for the command to be run in a
3490 * subprocess, so we satisfy that desire.
3491 */
3492 ap = argv[argc-1];
3493 if (0 == strcmp("&", ap))
3494 exit(background_process(--argc, argv));
e518068a 3495 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 3496 {
3497 ap[strlen(ap)-1] = '\0';
3498 exit(background_process(argc, argv));
3499 }
3500 /*
3501 * Now we handle the general redirection cases that involve '>', '>>',
3502 * '<', and pipes '|'.
3503 */
3504 for (j = 0; j < argc; ++j)
3505 {
3506 if (0 == strcmp("<", argv[j]))
3507 {
3508 if (j+1 >= argc)
3509 {
fd71b04b 3510 fprintf(stderr,"No input file after < on command line");
748a9306 3511 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3512 }
3513 in = argv[++j];
3514 continue;
3515 }
3516 if ('<' == *(ap = argv[j]))
3517 {
3518 in = 1 + ap;
3519 continue;
3520 }
3521 if (0 == strcmp(">", ap))
3522 {
3523 if (j+1 >= argc)
3524 {
fd71b04b 3525 fprintf(stderr,"No output file after > on command line");
748a9306 3526 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3527 }
3528 out = argv[++j];
3529 continue;
3530 }
3531 if ('>' == *ap)
3532 {
3533 if ('>' == ap[1])
3534 {
3535 outmode = "a";
3536 if ('\0' == ap[2])
3537 out = argv[++j];
3538 else
3539 out = 2 + ap;
3540 }
3541 else
3542 out = 1 + ap;
3543 if (j >= argc)
3544 {
fd71b04b 3545 fprintf(stderr,"No output file after > or >> on command line");
748a9306 3546 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3547 }
3548 continue;
3549 }
3550 if (('2' == *ap) && ('>' == ap[1]))
3551 {
3552 if ('>' == ap[2])
3553 {
3554 errmode = "a";
3555 if ('\0' == ap[3])
3556 err = argv[++j];
3557 else
3558 err = 3 + ap;
3559 }
3560 else
3561 if ('\0' == ap[2])
3562 err = argv[++j];
3563 else
748a9306 3564 err = 2 + ap;
a0d0e21e
LW		 3565 if (j >= argc)
3566 {
fd71b04b 3567 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 3568 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3569 }
3570 continue;
3571 }
3572 if (0 == strcmp("|", argv[j]))
3573 {
3574 if (j+1 >= argc)
3575 {
fd71b04b 3576 fprintf(stderr,"No command into which to pipe on command line");
748a9306 3577 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3578 }
3579 cmargc = argc-(j+1);
3580 cmargv = &argv[j+1];
3581 argc = j;
3582 continue;
3583 }
3584 if ('|' == *(ap = argv[j]))
3585 {
3586 ++argv[j];
3587 cmargc = argc-j;
3588 cmargv = &argv[j];
3589 argc = j;
3590 continue;
3591 }
3592 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3593 }
3594 /*
3595 * Allocate and fill in the new argument vector, Some Unix's terminate
3596 * the list with an extra null pointer.
3597 */
fc36a67e 3598 New(1302, argv, item_count+1, char *);
a0d0e21e
LW		 3599 *av = argv;
3600 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3601 argv[j] = list_head->value;
3602 *ac = item_count;
3603 if (cmargv != NULL)
3604 {
3605 if (out != NULL)
3606 {
fd71b04b 3607 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 3608 exit(LIB$_INVARGORD);
a0d0e21e 3609 }
fd8cd3a3 3610 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 3611 }
3612
3613 /* Check for input from a pipe (mailbox) */
3614
a5f75d66 3615 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 3616 {
3617 char mbxname[L_tmpnam];
3618 long int bufsize;
3619 long int dvi_item = DVI$_DEVBUFSIZ;
3620 $DESCRIPTOR(mbxnam, "");
3621 $DESCRIPTOR(mbxdevnam, "");
3622
3623 /* Input from a pipe, reopen it in binary mode to disable */
3624 /* carriage control processing. */
3625
fd71b04b 3626 fgetname(stdin, mbxname);
a0d0e21e
LW		 3627 mbxnam.dsc$a_pointer = mbxname;
3628 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3629 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3630 mbxdevnam.dsc$a_pointer = mbxname;
3631 mbxdevnam.dsc$w_length = sizeof(mbxname);
3632 dvi_item = DVI$_DEVNAM;
3633 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3634 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 3635 set_errno(0);
3636 set_vaxc_errno(1);
a0d0e21e
LW		 3637 freopen(mbxname, "rb", stdin);
3638 if (errno != 0)
3639 {
fd71b04b 3640 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 3641 exit(vaxc$errno);
a0d0e21e
LW		 3642 }
3643 }
3644 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3645 {
fd71b04b 3646 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 3647 exit(vaxc$errno);
a0d0e21e
LW		 3648 }
3649 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3650 {
fd71b04b 3651 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 3652 exit(vaxc$errno);
a0d0e21e 3653 }
fd8cd3a3 3654 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 3655
748a9306 3656 if (err != NULL) {
71d7ec5d 3657 if (strcmp(err,"&1") == 0) {
a15cef0c 3658 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 3659 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 3660 } else {
748a9306
LW		 3661 FILE *tmperr;
3662 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3663 {
fd71b04b 3664 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 3665 exit(vaxc$errno);
3666 }
3667 fclose(tmperr);
a15cef0c 3668 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 3669 {
3670 exit(vaxc$errno);
3671 }
fd8cd3a3 3672 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 3673 }
71d7ec5d 3674 }
a0d0e21e 3675#ifdef ARGPROC_DEBUG
740ce14c 3676 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 3677 for (j = 0; j < *ac; ++j)
740ce14c 3678 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 3679#endif
b7ae7a0d
PP		 3680 /* Clear errors we may have hit expanding wildcards, so they don't
3681 show up in Perl's $! later */
3682 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 3683} /* end of getredirection() */
3684/*}}}*/
3685
3686static void add_item(struct list_item **head,
3687 struct list_item **tail,
3688 char *value,
3689 int *count)
3690{
3691 if (*head == 0)
3692 {
fc36a67e 3693 New(1303,*head,1,struct list_item);
a0d0e21e
LW		 3694 *tail = *head;
3695 }
3696 else {
fc36a67e 3697 New(1304,(*tail)->next,1,struct list_item);
a0d0e21e
LW		 3698 *tail = (*tail)->next;
3699 }
3700 (*tail)->value = value;
3701 ++(*count);
3702}
3703
4b19af01 3704static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 3705 struct list_item **head,
3706 struct list_item **tail,
3707 int *count)
3708{
3709int expcount = 0;
748a9306 3710unsigned long int context = 0;
a0d0e21e 3711int isunix = 0;
a0d0e21e
LW		 3712char *had_version;
3713char *had_device;
3714int had_directory;
f675dbe5 3715char *devdir,*cp;
a0d0e21e
LW		 3716char vmsspec[NAM$C_MAXRSS+1];
3717$DESCRIPTOR(filespec, "");
748a9306 3718$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 3719$DESCRIPTOR(resultspec, "");
c07a80fd 3720unsigned long int zero = 0, sts;
a0d0e21e 3721
f675dbe5
CB		 3722 for (cp = item; *cp; cp++) {
3723 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3724 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3725 }
3726 if (!*cp || isspace(*cp))
a0d0e21e
LW		 3727 {
3728 add_item(head, tail, item, count);
3729 return;
3730 }
3731 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3732 resultspec.dsc$b_class = DSC$K_CLASS_D;
3733 resultspec.dsc$a_pointer = NULL;
748a9306 3734 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e
LW		 3735 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3736 if (!isunix || !filespec.dsc$a_pointer)
3737 filespec.dsc$a_pointer = item;
3738 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3739 /*
3740 * Only return version specs, if the caller specified a version
3741 */
3742 had_version = strchr(item, ';');
3743 /*
3744 * Only return device and directory specs, if the caller specifed either.
3745 */
3746 had_device = strchr(item, ':');
3747 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3748
c07a80fd
PP		 3749 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3750 &defaultspec, 0, 0, &zero))))
a0d0e21e
LW		 3751 {
3752 char *string;
3753 char *c;
3754
fc36a67e 3755 New(1305,string,resultspec.dsc$w_length+1,char);
a0d0e21e
LW		 3756 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3757 string[resultspec.dsc$w_length] = '\0';
3758 if (NULL == had_version)
3759 *((char *)strrchr(string, ';')) = '\0';
3760 if ((!had_directory) && (had_device == NULL))
3761 {
3762 if (NULL == (devdir = strrchr(string, ']')))
3763 devdir = strrchr(string, '>');
3764 strcpy(string, devdir + 1);
3765 }
3766 /*
3767 * Be consistent with what the C RTL has already done to the rest of
3768 * the argv items and lowercase all of these names.
3769 */
3770 for (c = string; *c; ++c)
3771 if (isupper(*c))
3772 *c = tolower(*c);
f86702cc 3773 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 3774 add_item(head, tail, string, count);
3775 ++expcount;
3776 }
c07a80fd
PP		 3777 if (sts != RMS$_NMF)
3778 {
3779 set_vaxc_errno(sts);
3780 switch (sts)
3781 {
f282b18d 3782 case RMS$_FNF: case RMS$_DNF:
c07a80fd 3783 set_errno(ENOENT); break;
f282b18d
CB		 3784 case RMS$_DIR:
3785 set_errno(ENOTDIR); break;
c07a80fd
PP		 3786 case RMS$_DEV:
3787 set_errno(ENODEV); break;
f282b18d 3788 case RMS$_FNM: case RMS$_SYN:
c07a80fd
PP		 3789 set_errno(EINVAL); break;
3790 case RMS$_PRV:
3791 set_errno(EACCES); break;
3792 default:
b7ae7a0d 3793 _ckvmssts_noperl(sts);
c07a80fd
PP		 3794 }
3795 }
a0d0e21e
LW		 3796 if (expcount == 0)
3797 add_item(head, tail, item, count);
b7ae7a0d
PP		 3798 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3799 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 3800}
3801
3802static int child_st[2];/* Event Flag set when child process completes */
3803
748a9306 3804static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 3805
748a9306 3806static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 3807{
3808short iosb[4];
3809
3810 if (0 == child_st[0])
3811 {
3812#ifdef ARGPROC_DEBUG
740ce14c 3813 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 3814#endif
3815 fflush(stdout); /* Have to flush pipe for binary data to */
3816 /* terminate properly -- <tp@mccall.com> */
3817 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3818 sys$dassgn(child_chan);
3819 fclose(stdout);
3820 sys$synch(0, child_st);
3821 }
3822 return(1);
3823}
3824
3825static void sig_child(int chan)
3826{
3827#ifdef ARGPROC_DEBUG
740ce14c 3828 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 3829#endif
3830 if (child_st[0] == 0)
3831 child_st[0] = 1;
3832}
3833
748a9306 3834static struct exit_control_block exit_block =
a0d0e21e
LW		 3835 {
3836 0,
3837 exit_handler,
3838 1,
3839 &exit_block.exit_status,
3840 0
3841 };
3842
fd8cd3a3 3843static void pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e
LW		 3844{
3845 char subcmd[2048];
3846 $DESCRIPTOR(cmddsc, "");
3847 static char mbxname[64];
3848 $DESCRIPTOR(mbxdsc, mbxname);
a0d0e21e 3849 int pid, j;
a0d0e21e
LW		 3850 unsigned long int zero = 0, one = 1;
3851
3852 strcpy(subcmd, cmargv[0]);
3853 for (j = 1; NULL != cmargv[j]; ++j)
3854 {
3855 strcat(subcmd, " \"");
3856 strcat(subcmd, cmargv[j]);
3857 strcat(subcmd, "\"");
3858 }
3859 cmddsc.dsc$a_pointer = subcmd;
3860 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3861