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