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