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