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