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