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