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