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