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