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