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