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