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