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
More logical test ordering.
[perl5.git] / vms / vms.c
CommitLineData
748a9306 1/* vms.c
a0d0e21e 2 *
748a9306 3 * VMS-specific routines for perl5
22d4bb9c 4 * Version: 5.7.0
748a9306 5 *
22d4bb9c
CB		 6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 10 */
11
aeb5cf3c 12#include <accdef.h>
a0d0e21e
LW		 13#include <acedef.h>
14#include <acldef.h>
15#include <armdef.h>
748a9306 16#include <atrdef.h>
a0d0e21e 17#include <chpdef.h>
8fde5078 18#include <clidef.h>
a3e9d8c9 19#include <climsgdef.h>
a0d0e21e 20#include <descrip.h>
22d4bb9c 21#include <devdef.h>
a0d0e21e 22#include <dvidef.h>
748a9306 23#include <fibdef.h>
a0d0e21e
LW		 24#include <float.h>
25#include <fscndef.h>
26#include <iodef.h>
27#include <jpidef.h>
61bb5906 28#include <kgbdef.h>
f675dbe5 29#include <libclidef.h>
a0d0e21e
LW		 30#include <libdef.h>
31#include <lib$routines.h>
32#include <lnmdef.h>
aeb5cf3c 33#include <msgdef.h>
748a9306 34#include <prvdef.h>
a0d0e21e
LW		 35#include <psldef.h>
36#include <rms.h>
37#include <shrdef.h>
38#include <ssdef.h>
39#include <starlet.h>
f86702cc 40#include <strdef.h>
41#include <str$routines.h>
a0d0e21e 42#include <syidef.h>
748a9306
LW		 43#include <uaidef.h>
44#include <uicdef.h>
a0d0e21e 45
740ce14c 46/* Older versions of ssdef.h don't have these */
47#ifndef SS$_INVFILFOROP
48# define SS$_INVFILFOROP 3930
49#endif
50#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 51# define SS$_NOSUCHOBJECT 2696
52#endif
53
a15cef0c
CB		 54/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
55#define PERLIO_NOT_STDIO 0
56
aa689395 57/* Don't replace system definitions of vfork, getenv, and stat,
58 * code below needs to get to the underlying CRTL routines. */
59#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 60#include "EXTERN.h"
61#include "perl.h"
748a9306 62#include "XSUB.h"
3eeba6fb
CB		 63/* Anticipating future expansion in lexical warnings . . . */
64#ifndef WARN_INTERNAL
65# define WARN_INTERNAL WARN_MISC
66#endif
a0d0e21e 67
22d4bb9c
CB		 68#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
69# define RTL_USES_UTC 1
70#endif
71
72
c07a80fd 73/* gcc's header files don't #define direct access macros
74 * corresponding to VAXC's variant structs */
75#ifdef __GNUC__
482b294c 76# define uic$v_format uic$r_uic_form.uic$v_format
77# define uic$v_group uic$r_uic_form.uic$v_group
78# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 79# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
80# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
81# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
82# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
83#endif
84
c645ec3f
GS		 85#if defined(NEED_AN_H_ERRNO)
86dEXT int h_errno;
87#endif
c07a80fd 88
a0d0e21e
LW		 89struct itmlst_3 {
90 unsigned short int buflen;
91 unsigned short int itmcode;
92 void *bufadr;
748a9306 93 unsigned short int *retlen;
a0d0e21e
LW		 94};
95
4b19af01
CB		 96#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
97#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
98#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
99#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
100#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
101#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
102#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
103#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
104#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
105
0e06870b
CB		 106/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
107#define PERL_LNM_MAX_ALLOWED_INDEX 127
108
48b5a746
CL		 109#define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
110#define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
ff7adb52 111
01b8edb6 112static char *__mystrtolower(char *str)
113{
114 if (str) for (; *str; ++str) *str= tolower(*str);
115 return str;
116}
117
f675dbe5
CB		 118static struct dsc$descriptor_s fildevdsc =
119 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
120static struct dsc$descriptor_s crtlenvdsc =
121 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
122static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
123static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
124static struct dsc$descriptor_s **env_tables = defenv;
125static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
126
93948341
CB		 127/* True if we shouldn't treat barewords as logicals during directory */
128/* munching */
129static int no_translate_barewords;
130
22d4bb9c
CB		 131#ifndef RTL_USES_UTC
132static int tz_updated = 1;
133#endif
134
f675dbe5 135/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 136int
fd8cd3a3 137Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 138 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 139{
fd7385b9 140 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
f675dbe5 141 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 142 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
f675dbe5
CB		 143 unsigned char acmode;
144 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
146 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
147 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 148 {0, 0, 0, 0}};
f675dbe5 149 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 150#if defined(PERL_IMPLICIT_CONTEXT)
151 pTHX = NULL;
152# if defined(USE_5005THREADS)
cc077a9f
HM		 153 /* We jump through these hoops because we can be called at */
154 /* platform-specific initialization time, which is before anything is */
5c84aa53 155 /* set up--we can't even do a plain dTHX since that relies on the */
cc077a9f 156 /* interpreter structure to be initialized */
cc077a9f 157 if (PL_curinterp) {
fd8cd3a3
DS		 158 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
159 } else {
160 aTHX = NULL;
161 }
162# else
163 if (PL_curinterp) {
164 aTHX = PERL_GET_INTERP;
cc077a9f 165 } else {
fd8cd3a3 166 aTHX = NULL;
cc077a9f 167 }
fd8cd3a3
DS		 168
169# endif
cc077a9f 170#endif
748a9306 171
0e06870b 172 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
b7ae7a0d 173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
174 }
f675dbe5
CB		 175 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
176 *cp2 = _toupper(*cp1);
177 if (cp1 - lnm > LNM$C_NAMLENGTH) {
178 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
179 return 0;
180 }
181 }
182 lnmdsc.dsc$w_length = cp1 - lnm;
183 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 184 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 185 secure = flags & PERL__TRNENV_SECURE;
186 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
187 if (!tabvec || !*tabvec) tabvec = env_tables;
188
189 for (curtab = 0; tabvec[curtab]; curtab++) {
190 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
191 if (!ivenv && !secure) {
192 char *eq, *end;
193 int i;
194 if (!environ) {
195 ivenv = 1;
5c84aa53 196 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 197 continue;
198 }
199 retsts = SS$_NOLOGNAM;
200 for (i = 0; environ[i]; i++) {
201 if ((eq = strchr(environ[i],'=')) &&
202 !strncmp(environ[i],uplnm,eq - environ[i])) {
203 eq++;
204 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
205 if (!eqvlen) continue;
206 retsts = SS$_NORMAL;
207 break;
208 }
209 }
210 if (retsts != SS$_NOLOGNAM) break;
211 }
212 }
213 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
214 !str$case_blind_compare(&tmpdsc,&clisym)) {
215 if (!ivsym && !secure) {
216 unsigned short int deflen = LNM$C_NAMLENGTH;
217 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
218 /* dynamic dsc to accomodate possible long value */
219 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
220 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
221 if (retsts & 1) {
222 if (eqvlen > 1024) {
f675dbe5 223 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
3eeba6fb 224 eqvlen = 1024;
cc077a9f
HM		 225 /* Special hack--we might be called before the interpreter's */
226 /* fully initialized, in which case either thr or PL_curcop */
227 /* might be bogus. We have to check, since ckWARN needs them */
228 /* both to be valid if running threaded */
4d1ff10f 229#if defined(USE_5005THREADS)
cc077a9f
HM		 230 if (thr && PL_curcop) {
231#endif
232 if (ckWARN(WARN_MISC)) {
5c84aa53 233 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 234 }
4d1ff10f 235#if defined(USE_5005THREADS)
cc077a9f 236 } else {
5c84aa53 237 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f
HM		 238 }
239#endif
240
f675dbe5
CB		 241 }
242 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
243 }
244 _ckvmssts(lib$sfree1_dd(&eqvdsc));
245 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
246 if (retsts == LIB$_NOSUCHSYM) continue;
247 break;
248 }
249 }
250 else if (!ivlnm) {
251 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
252 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
253 if (retsts == SS$_NOLOGNAM) continue;
fd7385b9
CB		 254 /* PPFs have a prefix */
255 if (
256#if INTSIZE == 4
257 *((int *)uplnm) == *((int *)"SYS$") &&
258#endif
259 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
260 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
261 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
262 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
263 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
264 memcpy(eqv,eqv+4,eqvlen-4);
265 eqvlen -= 4;
266 }
f675dbe5
CB		 267 break;
268 }
c07a80fd 269 }
f675dbe5
CB		 270 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
271 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
272 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
273 retsts == SS$_NOLOGNAM) {
274 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 275 }
f675dbe5
CB		 276 else _ckvmssts(retsts);
277 return 0;
278} /* end of vmstrnenv */
279/*}}}*/
c07a80fd 280
f675dbe5
CB		 281/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
282/* Define as a function so we can access statics. */
4b19af01 283int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 284{
285 return vmstrnenv(lnm,eqv,idx,fildev,
286#ifdef SECURE_INTERNAL_GETENV
287 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
288#else
289 0
290#endif
291 );
292}
293/*}}}*/
a0d0e21e
LW		 294
295/* my_getenv
61bb5906
CB		 296 * Note: Uses Perl temp to store result so char * can be returned to
297 * caller; this pointer will be invalidated at next Perl statement
298 * transition.
a6c40364 299 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 300 * so that it'll work when PL_curinterp is undefined (and we therefore can't
301 * allocate SVs).
a0d0e21e 302 */
f675dbe5 303/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 304char *
5c84aa53 305Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e
LW		 306{
307 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
f675dbe5 308 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
c07a80fd 309 unsigned long int idx = 0;
bc10a425 310 int trnsuccess, success, secure, saverr, savvmserr;
61bb5906 311 SV *tmpsv;
a0d0e21e 312
6b88bc9c 313 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 314 /* Set up a temporary buffer for the return value; Perl will
315 * clean it up at the next statement transition */
316 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
317 if (!tmpsv) return NULL;
318 eqv = SvPVX(tmpsv);
319 }
320 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
f675dbe5
CB		 321 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
322 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
61bb5906
CB		 323 getcwd(eqv,LNM$C_NAMLENGTH);
324 return eqv;
748a9306 325 }
a0d0e21e 326 else {
f675dbe5
CB		 327 if ((cp2 = strchr(lnm,';')) != NULL) {
328 strcpy(uplnm,lnm);
329 uplnm[cp2-lnm] = '\0';
c07a80fd 330 idx = strtoul(cp2+1,NULL,0);
f675dbe5 331 lnm = uplnm;
c07a80fd 332 }
2512681b 333 /* Impose security constraints only if tainting */
bc10a425
CB		 334 if (sys) {
335 /* Impose security constraints only if tainting */
336 secure = PL_curinterp ? PL_tainting : will_taint;
337 saverr = errno; savvmserr = vaxc$errno;
338 }
339 else secure = 0;
340 success = vmstrnenv(lnm,eqv,idx,
341 secure ? fildev : NULL,
f675dbe5 342#ifdef SECURE_INTERNAL_GETENV
bc10a425 343 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 344#else
bc10a425 345 0
f675dbe5 346#endif
bc10a425
CB		 347 );
348 /* Discard NOLOGNAM on internal calls since we're often looking
349 * for an optional name, and this "error" often shows up as the
350 * (bogus) exit status for a die() call later on. */
351 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
352 return success ? eqv : Nullch;
a0d0e21e 353 }
a0d0e21e
LW		 354
355} /* end of my_getenv() */
356/*}}}*/
357
f675dbe5 358
a6c40364
GS		 359/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
360char *
fd8cd3a3 361Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 362{
cc077a9f 363 char *buf, *cp1, *cp2;
a6c40364 364 unsigned long idx = 0;
cc077a9f 365 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
bc10a425 366 int secure, saverr, savvmserr;
cc077a9f
HM		 367 SV *tmpsv;
368
369 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
370 /* Set up a temporary buffer for the return value; Perl will
371 * clean it up at the next statement transition */
372 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
373 if (!tmpsv) return NULL;
374 buf = SvPVX(tmpsv);
375 }
376 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
f675dbe5
CB		 377 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
378 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
379 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364
GS		 380 *len = strlen(buf);
381 return buf;
f675dbe5
CB		 382 }
383 else {
384 if ((cp2 = strchr(lnm,';')) != NULL) {
385 strcpy(buf,lnm);
386 buf[cp2-lnm] = '\0';
387 idx = strtoul(cp2+1,NULL,0);
388 lnm = buf;
389 }
bc10a425
CB		 390 if (sys) {
391 /* Impose security constraints only if tainting */
392 secure = PL_curinterp ? PL_tainting : will_taint;
393 saverr = errno; savvmserr = vaxc$errno;
394 }
395 else secure = 0;
396 *len = vmstrnenv(lnm,buf,idx,
397 secure ? fildev : NULL,
f675dbe5 398#ifdef SECURE_INTERNAL_GETENV
bc10a425 399 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 400#else
bc10a425 401 0
f675dbe5 402#endif
bc10a425
CB		 403 );
404 /* Discard NOLOGNAM on internal calls since we're often looking
405 * for an optional name, and this "error" often shows up as the
406 * (bogus) exit status for a die() call later on. */
407 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
408 return *len ? buf : Nullch;
f675dbe5
CB		 409 }
410
a6c40364 411} /* end of my_getenv_len() */
f675dbe5
CB		 412/*}}}*/
413
fd8cd3a3 414static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 415
416static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 417
740ce14c 418/*{{{ void prime_env_iter() */
419void
420prime_env_iter(void)
421/* Fill the %ENV associative array with all logical names we can
422 * find, in preparation for iterating over it.
423 */
424{
17f28c40 425 static int primed = 0;
3eeba6fb 426 HV *seenhv = NULL, *envhv;
22be8b3c 427 SV *sv = NULL;
f675dbe5 428 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 429 unsigned short int chan;
430#ifndef CLI$M_TRUSTED
431# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
432#endif
f675dbe5
CB		 433 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
434 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
435 long int i;
436 bool have_sym = FALSE, have_lnm = FALSE;
437 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
438 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
439 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
440 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
441 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 442#if defined(PERL_IMPLICIT_CONTEXT)
443 pTHX;
444#endif
4d1ff10f 445#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
b2b3adea
HM		 446 static perl_mutex primenv_mutex;
447 MUTEX_INIT(&primenv_mutex);
61bb5906 448#endif
740ce14c 449
fd8cd3a3
DS		 450#if defined(PERL_IMPLICIT_CONTEXT)
451 /* We jump through these hoops because we can be called at */
452 /* platform-specific initialization time, which is before anything is */
453 /* set up--we can't even do a plain dTHX since that relies on the */
454 /* interpreter structure to be initialized */
455#if defined(USE_5005THREADS)
456 if (PL_curinterp) {
457 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
458 } else {
459 aTHX = NULL;
460 }
461#else
462 if (PL_curinterp) {
463 aTHX = PERL_GET_INTERP;
464 } else {
465 aTHX = NULL;
466 }
467#endif
468#endif
469
3eeba6fb 470 if (primed || !PL_envgv) return;
61bb5906
CB		 471 MUTEX_LOCK(&primenv_mutex);
472 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 473 envhv = GvHVn(PL_envgv);
740ce14c 474 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 475 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 476 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 477
f675dbe5
CB		 478 for (i = 0; env_tables[i]; i++) {
479 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
480 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
481 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 482 }
f675dbe5
CB		 483 if (have_sym || have_lnm) {
484 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
485 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
486 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
487 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 488 }
f675dbe5
CB		 489
490 for (i--; i >= 0; i--) {
491 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
492 char *start;
493 int j;
494 for (j = 0; environ[j]; j++) {
495 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 496 if (ckWARN(WARN_INTERNAL))
5c84aa53 497 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 498 }
499 else {
500 start++;
22be8b3c
CB		 501 sv = newSVpv(start,0);
502 SvTAINTED_on(sv);
503 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 504 }
505 }
506 continue;
740ce14c 507 }
f675dbe5
CB		 508 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
509 !str$case_blind_compare(&tmpdsc,&clisym)) {
510 strcpy(cmd,"Show Symbol/Global *");
511 cmddsc.dsc$w_length = 20;
512 if (env_tables[i]->dsc$w_length == 12 &&
513 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
514 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
515 flags = defflags | CLI$M_NOLOGNAM;
516 }
517 else {
518 strcpy(cmd,"Show Logical *");
519 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
520 strcat(cmd," /Table=");
521 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
522 cmddsc.dsc$w_length = strlen(cmd);
523 }
524 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
525 flags = defflags | CLI$M_NOCLISYM;
526 }
527
528 /* Create a new subprocess to execute each command, to exclude the
529 * remote possibility that someone could subvert a mbx or file used
530 * to write multiple commands to a single subprocess.
531 */
532 do {
533 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
534 0,&riseandshine,0,0,&clidsc,&clitabdsc);
535 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
536 defflags &= ~CLI$M_TRUSTED;
537 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
538 _ckvmssts(retsts);
539 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
540 if (seenhv) SvREFCNT_dec(seenhv);
541 seenhv = newHV();
542 while (1) {
543 char *cp1, *cp2, *key;
544 unsigned long int sts, iosb[2], retlen, keylen;
545 register U32 hash;
546
547 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
548 if (sts & 1) sts = iosb[0] & 0xffff;
549 if (sts == SS$_ENDOFFILE) {
550 int wakect = 0;
551 while (substs == 0) { sys$hiber(); wakect++;}
552 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
553 _ckvmssts(substs);
554 break;
555 }
556 _ckvmssts(sts);
557 retlen = iosb[0] >> 16;
558 if (!retlen) continue; /* blank line */
559 buf[retlen] = '\0';
560 if (iosb[1] != subpid) {
561 if (iosb[1]) {
5c84aa53 562 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 563 }
564 continue;
565 }
3eeba6fb 566 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
5c84aa53 567 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 568
569 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
570 if (*cp1 == '(' || /* Logical name table name */
571 *cp1 == '=' /* Next eqv of searchlist */) continue;
572 if (*cp1 == '"') cp1++;
573 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
574 key = cp1; keylen = cp2 - cp1;
575 if (keylen && hv_exists(seenhv,key,keylen)) continue;
576 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 577 while (*cp2 && *cp2 == '=') cp2++;
578 while (*cp2 && *cp2 == ' ') cp2++;
579 if (*cp2 == '"') { /* String translation; may embed "" */
580 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
581 cp2++; cp1--; /* Skip "" surrounding translation */
582 }
583 else { /* Numeric translation */
584 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
585 cp1--; /* stop on last non-space char */
586 }
587 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
5c84aa53 588 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 589 continue;
590 }
f675dbe5 591 PERL_HASH(hash,key,keylen);
22be8b3c
CB		 592 sv = newSVpvn(cp2,cp1 - cp2 + 1);
593 SvTAINTED_on(sv);
594 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 595 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 596 }
f675dbe5
CB		 597 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
598 /* get the PPFs for this process, not the subprocess */
599 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
600 char eqv[LNM$C_NAMLENGTH+1];
601 int trnlen, i;
602 for (i = 0; ppfs[i]; i++) {
603 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 604 sv = newSVpv(eqv,trnlen);
605 SvTAINTED_on(sv);
606 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 607 }
740ce14c 608 }
609 }
f675dbe5
CB		 610 primed = 1;
611 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
612 if (buf) Safefree(buf);
613 if (seenhv) SvREFCNT_dec(seenhv);
614 MUTEX_UNLOCK(&primenv_mutex);
615 return;
616
740ce14c 617} /* end of prime_env_iter */
618/*}}}*/
740ce14c 619
f675dbe5
CB		 620
621/*{{{ int vmssetenv(char *lnm, char *eqv)*/
622/* Define or delete an element in the same "environment" as
623 * vmstrnenv(). If an element is to be deleted, it's removed from
624 * the first place it's found. If it's to be set, it's set in the
625 * place designated by the first element of the table vector.
3eeba6fb 626 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 627 */
f675dbe5 628int
fd8cd3a3 629Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e
LW		 630{
631 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
f675dbe5 632 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
a0d0e21e 633 unsigned long int retsts, usermode = PSL$C_USER;
a0d0e21e 634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
638 $DESCRIPTOR(local,"_LOCAL");
639
640 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
641 *cp2 = _toupper(*cp1);
642 if (cp1 - lnm > LNM$C_NAMLENGTH) {
643 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
644 return SS$_IVLOGNAM;
645 }
646 }
a0d0e21e 647 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 648 if (!tabvec || !*tabvec) tabvec = env_tables;
649
3eeba6fb 650 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 651 for (curtab = 0; tabvec[curtab]; curtab++) {
652 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
653 int i;
f675dbe5
CB		 654 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
655 if ((cp1 = strchr(environ[i],'=')) &&
656 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 657#ifdef HAS_SETENV
0e06870b 658 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 659 }
660 }
661 ivenv = 1; retsts = SS$_NOLOGNAM;
662#else
3eeba6fb 663 if (ckWARN(WARN_INTERNAL))
5c84aa53 664 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 665 ivenv = 1; retsts = SS$_NOSUCHPGM;
666 break;
667 }
668 }
f675dbe5
CB		 669#endif
670 }
671 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
672 !str$case_blind_compare(&tmpdsc,&clisym)) {
673 unsigned int symtype;
674 if (tabvec[curtab]->dsc$w_length == 12 &&
675 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
676 !str$case_blind_compare(&tmpdsc,&local))
677 symtype = LIB$K_CLI_LOCAL_SYM;
678 else symtype = LIB$K_CLI_GLOBAL_SYM;
679 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 680 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
681 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 682 break;
683 }
684 else if (!ivlnm) {
685 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
686 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
687 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
688 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
689 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
690 }
a0d0e21e
LW		 691 }
692 }
f675dbe5
CB		 693 else { /* we're defining a value */
694 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
695#ifdef HAS_SETENV
3eeba6fb 696 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 697#else
3eeba6fb 698 if (ckWARN(WARN_INTERNAL))
5c84aa53 699 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 700 retsts = SS$_NOSUCHPGM;
701#endif
702 }
703 else {
704 eqvdsc.dsc$a_pointer = eqv;
705 eqvdsc.dsc$w_length = strlen(eqv);
706 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
707 !str$case_blind_compare(&tmpdsc,&clisym)) {
708 unsigned int symtype;
709 if (tabvec[0]->dsc$w_length == 12 &&
710 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
711 !str$case_blind_compare(&tmpdsc,&local))
712 symtype = LIB$K_CLI_LOCAL_SYM;
713 else symtype = LIB$K_CLI_GLOBAL_SYM;
714 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
715 }
3eeba6fb
CB		 716 else {
717 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751
CB		 718 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
719 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
720 if (ckWARN(WARN_MISC)) {
721 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
722 }
723 }
3eeba6fb
CB		 724 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
725 }
f675dbe5
CB		 726 }
727 }
728 if (!(retsts & 1)) {
729 switch (retsts) {
730 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
731 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
732 set_errno(EVMSERR); break;
733 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
734 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
735 set_errno(EINVAL); break;
736 case SS$_NOPRIV:
737 set_errno(EACCES);
738 default:
739 _ckvmssts(retsts);
740 set_errno(EVMSERR);
741 }
742 set_vaxc_errno(retsts);
743 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 744 }
3eeba6fb
CB		 745 else {
746 /* We reset error values on success because Perl does an hv_fetch()
747 * before each hv_store(), and if the thing we're setting didn't
748 * previously exist, we've got a leftover error message. (Of course,
749 * this fails in the face of
750 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
751 * in that the error reported in $! isn't spurious,
752 * but it's right more often than not.)
753 */
f675dbe5
CB		 754 set_errno(0); set_vaxc_errno(retsts);
755 return 0;
756 }
757
758} /* end of vmssetenv() */
759/*}}}*/
a0d0e21e 760
f675dbe5
CB		 761/*{{{ void my_setenv(char *lnm, char *eqv)*/
762/* This has to be a function since there's a prototype for it in proto.h */
763void
5c84aa53 764Perl_my_setenv(pTHX_ char *lnm,char *eqv)
f675dbe5 765{
bc10a425
CB		 766 if (lnm && *lnm) {
767 int len = strlen(lnm);
768 if (len == 7) {
769 char uplnm[8];
22d4bb9c
CB		 770 int i;
771 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425
CB		 772 if (!strcmp(uplnm,"DEFAULT")) {
773 if (eqv && *eqv) chdir(eqv);
774 return;
775 }
776 }
777#ifndef RTL_USES_UTC
778 if (len == 6 || len == 2) {
779 char uplnm[7];
780 int i;
781 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
782 uplnm[len] = '\0';
783 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
784 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 785 }
786#endif
787 }
f675dbe5
CB		 788 (void) vmssetenv(lnm,eqv,NULL);
789}
a0d0e21e
LW		 790/*}}}*/
791
0e06870b
CB		 792/*{{{static void vmssetuserlnm(char *name, char *eqv);
793/* vmssetuserlnm
794 * sets a user-mode logical in the process logical name table
795 * used for redirection of sys$error
796 */
797void
fd8cd3a3 798Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
0e06870b
CB		 799{
800 $DESCRIPTOR(d_tab, "LNM$PROCESS");
801 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 802 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 803 unsigned char acmode = PSL$C_USER;
804 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
805 {0, 0, 0, 0}};
806 d_name.dsc$a_pointer = name;
807 d_name.dsc$w_length = strlen(name);
808
809 lnmlst[0].buflen = strlen(eqv);
810 lnmlst[0].bufadr = eqv;
811
812 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
813 if (!(iss&1)) lib$signal(iss);
814}
815/*}}}*/
c07a80fd 816
f675dbe5 817
c07a80fd 818/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
819/* my_crypt - VMS password hashing
820 * my_crypt() provides an interface compatible with the Unix crypt()
821 * C library function, and uses sys$hash_password() to perform VMS
822 * password hashing. The quadword hashed password value is returned
823 * as a NUL-terminated 8 character string. my_crypt() does not change
824 * the case of its string arguments; in order to match the behavior
825 * of LOGINOUT et al., alphabetic characters in both arguments must
826 * be upcased by the caller.
827 */
828char *
fd8cd3a3 829Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 830{
831# ifndef UAI$C_PREFERRED_ALGORITHM
832# define UAI$C_PREFERRED_ALGORITHM 127
833# endif
834 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
835 unsigned short int salt = 0;
836 unsigned long int sts;
837 struct const_dsc {
838 unsigned short int dsc$w_length;
839 unsigned char dsc$b_type;
840 unsigned char dsc$b_class;
841 const char * dsc$a_pointer;
842 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
843 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
844 struct itmlst_3 uailst[3] = {
845 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
846 { sizeof salt, UAI$_SALT, &salt, 0},
847 { 0, 0, NULL, NULL}};
848 static char hash[9];
849
850 usrdsc.dsc$w_length = strlen(usrname);
851 usrdsc.dsc$a_pointer = usrname;
852 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
853 switch (sts) {
f282b18d 854 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 855 set_errno(EACCES);
856 break;
857 case RMS$_RNF:
858 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
859 break;
860 default:
861 set_errno(EVMSERR);
862 }
863 set_vaxc_errno(sts);
864 if (sts != RMS$_RNF) return NULL;
865 }
866
867 txtdsc.dsc$w_length = strlen(textpasswd);
868 txtdsc.dsc$a_pointer = textpasswd;
869 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
870 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
871 }
872
873 return (char *) hash;
874
875} /* end of my_crypt() */
876/*}}}*/
877
878
4b19af01
CB		 879static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
880static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
881static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
a0d0e21e
LW		 882
883/*{{{int do_rmdir(char *name)*/
884int
4b19af01 885Perl_do_rmdir(pTHX_ char *name)
a0d0e21e
LW		 886{
887 char dirfile[NAM$C_MAXRSS+1];
888 int retval;
61bb5906 889 Stat_t st;
a0d0e21e
LW		 890
891 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
892 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
893 else retval = kill_file(dirfile);
894 return retval;
895
896} /* end of do_rmdir */
897/*}}}*/
898
899/* kill_file
900 * Delete any file to which user has control access, regardless of whether
901 * delete access is explicitly allowed.
902 * Limitations: User must have write access to parent directory.
903 * Does not block signals or ASTs; if interrupted in midstream
904 * may leave file with an altered ACL.
905 * HANDLE WITH CARE!
906 */
907/*{{{int kill_file(char *name)*/
908int
fd8cd3a3 909Perl_kill_file(pTHX_ char *name)
a0d0e21e 910{
bbce6d69 911 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
a0d0e21e 912 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 913 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e
LW		 914 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
915 struct myacedef {
748a9306
LW		 916 unsigned char myace$b_length;
917 unsigned char myace$b_type;
918 unsigned short int myace$w_flags;
919 unsigned long int myace$l_access;
920 unsigned long int myace$l_ident;
a0d0e21e
LW		 921 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
922 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
923 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
924 struct itmlst_3
748a9306
LW		 925 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
926 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
927 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
928 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
929 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
930 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 931
bbce6d69 932 /* Expand the input spec using RMS, since the CRTL remove() and
933 * system services won't do this by themselves, so we may miss
934 * a file "hiding" behind a logical name or search list. */
935 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
936 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
937 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
740ce14c 938 /* If not, can changing protections help? */
939 if (vaxc$errno != RMS$_PRV) return -1;
a0d0e21e
LW		 940
941 /* No, so we get our own UIC to use as a rights identifier,
942 * and the insert an ACE at the head of the ACL which allows us
943 * to delete the file.
944 */
748a9306 945 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
bbce6d69 946 fildsc.dsc$w_length = strlen(rspec);
947 fildsc.dsc$a_pointer = rspec;
a0d0e21e 948 cxt = 0;
748a9306 949 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
740ce14c 951 switch (aclsts) {
f282b18d 952 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
740ce14c 953 set_errno(ENOENT); break;
f282b18d
CB		 954 case RMS$_DIR:
955 set_errno(ENOTDIR); break;
740ce14c 956 case RMS$_DEV:
957 set_errno(ENODEV); break;
f282b18d 958 case RMS$_SYN: case SS$_INVFILFOROP:
740ce14c 959 set_errno(EINVAL); break;
960 case RMS$_PRV:
961 set_errno(EACCES); break;
962 default:
963 _ckvmssts(aclsts);
964 }
748a9306 965 set_vaxc_errno(aclsts);
a0d0e21e
LW		 966 return -1;
967 }
968 /* Grab any existing ACEs with this identifier in case we fail */
969 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a 970 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
971 || fndsts == SS$_NOMOREACE ) {
a0d0e21e
LW		 972 /* Add the new ACE . . . */
973 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
974 goto yourroom;
748a9306 975 if ((rmsts = remove(name))) {
a0d0e21e
LW		 976 /* We blew it - dir with files in it, no write priv for
977 * parent directory, etc. Put things back the way they were. */
978 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
979 goto yourroom;
980 if (fndsts & 1) {
981 addlst[0].bufadr = &oldace;
982 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
983 goto yourroom;
984 }
985 }
986 }
987
988 yourroom:
b7ae7a0d 989 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
990 /* We just deleted it, so of course it's not there. Some versions of
991 * VMS seem to return success on the unlock operation anyhow (after all
992 * the unlock is successful), but others don't.
993 */
760ac839 994 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
b7ae7a0d 995 if (aclsts & 1) aclsts = fndsts;
a0d0e21e 996 if (!(aclsts & 1)) {
748a9306
LW		 997 set_errno(EVMSERR);
998 set_vaxc_errno(aclsts);
a0d0e21e
LW		 999 return -1;
1000 }
1001
1002 return rmsts;
1003
1004} /* end of kill_file() */
1005/*}}}*/
1006
8cc95fdb 1007
84902520 1008/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 1009int
fd8cd3a3 1010Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
8cc95fdb 1011{
1012 STRLEN dirlen = strlen(dir);
1013
a2a90019
CB		 1014 /* zero length string sometimes gives ACCVIO */
1015 if (dirlen == 0) return -1;
1016
8cc95fdb 1017 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1018 * null file name/type. However, it's commonplace under Unix,
1019 * so we'll allow it for a gain in portability.
1020 */
1021 if (dir[dirlen-1] == '/') {
1022 char *newdir = savepvn(dir,dirlen-1);
1023 int ret = mkdir(newdir,mode);
1024 Safefree(newdir);
1025 return ret;
1026 }
1027 else return mkdir(dir,mode);
1028} /* end of my_mkdir */
1029/*}}}*/
1030
ee8c7f54
CB		 1031/*{{{int my_chdir(char *)*/
1032int
fd8cd3a3 1033Perl_my_chdir(pTHX_ char *dir)
ee8c7f54
CB		 1034{
1035 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 1036
1037 /* zero length string sometimes gives ACCVIO */
1038 if (dirlen == 0) return -1;
1039
1040 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1041 * that implies
1042 * null file name/type. However, it's commonplace under Unix,
1043 * so we'll allow it for a gain in portability.
1044 */
1045 if (dir[dirlen-1] == '/') {
1046 char *newdir = savepvn(dir,dirlen-1);
1047 int ret = chdir(newdir);
1048 Safefree(newdir);
1049 return ret;
1050 }
1051 else return chdir(dir);
1052} /* end of my_chdir */
1053/*}}}*/
8cc95fdb 1054
674d6c38
CB		 1055
1056/*{{{FILE *my_tmpfile()*/
1057FILE *
1058my_tmpfile(void)
1059{
1060 FILE *fp;
1061 char *cp;
674d6c38
CB		 1062
1063 if ((fp = tmpfile())) return fp;
1064
1065 New(1323,cp,L_tmpnam+24,char);
1066 strcpy(cp,"Sys$Scratch:");
1067 tmpnam(cp+strlen(cp));
1068 strcat(cp,".Perltmp");
1069 fp = fopen(cp,"w+","fop=dlt");
1070 Safefree(cp);
1071 return fp;
1072}
1073/*}}}*/
1074
5c2d7af2
CB		 1075
1076#ifndef HOMEGROWN_POSIX_SIGNALS
1077/*
1078 * The C RTL's sigaction fails to check for invalid signal numbers so we
1079 * help it out a bit. The docs are correct, but the actual routine doesn't
1080 * do what the docs say it will.
1081 */
1082/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1083int
1084Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1085 struct sigaction* oact)
1086{
1087 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1088 SETERRNO(EINVAL, SS$_INVARG);
1089 return -1;
1090 }
1091 return sigaction(sig, act, oact);
1092}
1093/*}}}*/
1094#endif
1095
f2610a60
CL		 1096#ifdef KILL_BY_SIGPRC
1097#include <errnodef.h>
1098
1099/* okay, this is some BLATENT hackery ...
1100 we use this if the kill() in the CRTL uses sys$forcex, causing the
1101 target process to do a sys$exit, which usually can't be handled
1102 gracefully...certainly not by Perl and the %SIG{} mechanism.
1103
1104 Instead we use the (undocumented) system service sys$sigprc.
1105 It has the same parameters as sys$forcex, but throws an exception
1106 in the target process rather than calling sys$exit.
1107
1108 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1109 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1110 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1111 with condition codes C$_SIG0+nsig*8, catching the exception on the
1112 target process and resignaling with appropriate arguments.
1113
1114 But we don't have that VMS 7.0+ exception handler, so if you
1115 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1116
1117 Also note that SIGTERM is listed in the docs as being "unimplemented",
1118 yet always seems to be signaled with a VMS condition code of 4 (and
1119 correctly handled for that code). So we hardwire it in.
1120
1121 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1122 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1123 than signalling with an unrecognized (and unhandled by CRTL) code.
1124*/
1125
1126#define _MY_SIG_MAX 17
1127
2e34cc90
CL		 1128unsigned int
1129Perl_sig_to_vmscondition(int sig)
f2610a60 1130{
2e34cc90 1131 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 1132 {
1133 0, /* 0 ZERO */
1134 SS$_HANGUP, /* 1 SIGHUP */
1135 SS$_CONTROLC, /* 2 SIGINT */
1136 SS$_CONTROLY, /* 3 SIGQUIT */
1137 SS$_RADRMOD, /* 4 SIGILL */
1138 SS$_BREAK, /* 5 SIGTRAP */
1139 SS$_OPCCUS, /* 6 SIGABRT */
1140 SS$_COMPAT, /* 7 SIGEMT */
1141#ifdef __VAX
1142 SS$_FLTOVF, /* 8 SIGFPE VAX */
1143#else
1144 SS$_HPARITH, /* 8 SIGFPE AXP */
1145#endif
1146 SS$_ABORT, /* 9 SIGKILL */
1147 SS$_ACCVIO, /* 10 SIGBUS */
1148 SS$_ACCVIO, /* 11 SIGSEGV */
1149 SS$_BADPARAM, /* 12 SIGSYS */
1150 SS$_NOMBX, /* 13 SIGPIPE */
1151 SS$_ASTFLT, /* 14 SIGALRM */
1152 4, /* 15 SIGTERM */
1153 0, /* 16 SIGUSR1 */
1154 0 /* 17 SIGUSR2 */
1155 };
1156
1157#if __VMS_VER >= 60200000
1158 static int initted = 0;
1159 if (!initted) {
1160 initted = 1;
1161 sig_code[16] = C$_SIGUSR1;
1162 sig_code[17] = C$_SIGUSR2;
1163 }
1164#endif
1165
2e34cc90
CL		 1166 if (sig < _SIG_MIN) return 0;
1167 if (sig > _MY_SIG_MAX) return 0;
1168 return sig_code[sig];
1169}
1170
1171
1172int
1173Perl_my_kill(int pid, int sig)
1174{
218fdd94 1175 dTHX;
2e34cc90
CL		 1176 int iss;
1177 unsigned int code;
1178 int sys$sigprc(unsigned int *pidadr,
1179 struct dsc$descriptor_s *prcname,
1180 unsigned int code);
1181
1182 code = Perl_sig_to_vmscondition(sig);
1183
1184 if (!pid || !code) {
f2610a60
CL		 1185 return -1;
1186 }
1187
2e34cc90 1188 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 1189 if (iss&1) return 0;
1190
1191 switch (iss) {
1192 case SS$_NOPRIV:
1193 set_errno(EPERM); break;
1194 case SS$_NONEXPR:
1195 case SS$_NOSUCHNODE:
1196 case SS$_UNREACHABLE:
1197 set_errno(ESRCH); break;
1198 case SS$_INSFMEM:
1199 set_errno(ENOMEM); break;
1200 default:
1201 _ckvmssts(iss);
1202 set_errno(EVMSERR);
1203 }
1204 set_vaxc_errno(iss);
1205
1206 return -1;
1207}
1208#endif
1209
22d4bb9c
CB		 1210/* default piping mailbox size */
1211#define PERL_BUFSIZ 512
1212
674d6c38 1213
a0d0e21e 1214static void
fd8cd3a3 1215create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 1216{
22d4bb9c
CB		 1217 unsigned long int mbxbufsiz;
1218 static unsigned long int syssize = 0;
1219 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 1220 char csize[LNM$C_NAMLENGTH+1];
a0d0e21e 1221
22d4bb9c
CB		 1222 if (!syssize) {
1223 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 1224 /*
22d4bb9c
CB		 1225 * Get the SYSGEN parameter MAXBUF
1226 *
1227 * If the logical 'PERL_MBX_SIZE' is defined
1228 * use the value of the logical instead of PERL_BUFSIZ, but
1229 * keep the size between 128 and MAXBUF.
1230 *
a0d0e21e 1231 */
22d4bb9c
CB		 1232 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1233 }
1234
1235 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1236 mbxbufsiz = atoi(csize);
1237 } else {
1238 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 1239 }
22d4bb9c
CB		 1240 if (mbxbufsiz < 128) mbxbufsiz = 128;
1241 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1242
748a9306 1243 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 1244
748a9306 1245 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 1246 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1247
1248} /* end of create_mbx() */
1249
22d4bb9c 1250
a0d0e21e 1251/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 1252
1253typedef struct _iosb IOSB;
1254typedef struct _iosb* pIOSB;
1255typedef struct _pipe Pipe;
1256typedef struct _pipe* pPipe;
1257typedef struct pipe_details Info;
1258typedef struct pipe_details* pInfo;
1259typedef struct _srqp RQE;
1260typedef struct _srqp* pRQE;
1261typedef struct _tochildbuf CBuf;
1262typedef struct _tochildbuf* pCBuf;
1263
1264struct _iosb {
1265 unsigned short status;
1266 unsigned short count;
1267 unsigned long dvispec;
1268};
1269
1270#pragma member_alignment save
1271#pragma nomember_alignment quadword
1272struct _srqp { /* VMS self-relative queue entry */
1273 unsigned long qptr[2];
1274};
1275#pragma member_alignment restore
1276static RQE RQE_ZERO = {0,0};
1277
1278struct _tochildbuf {
1279 RQE q;
1280 int eof;
1281 unsigned short size;
1282 char *buf;
1283};
1284
1285struct _pipe {
1286 RQE free;
1287 RQE wait;
1288 int fd_out;
1289 unsigned short chan_in;
1290 unsigned short chan_out;
1291 char *buf;
1292 unsigned int bufsize;
1293 IOSB iosb;
1294 IOSB iosb2;
1295 int *pipe_done;
1296 int retry;
1297 int type;
1298 int shut_on_empty;
1299 int need_wake;
1300 pPipe *home;
1301 pInfo info;
1302 pCBuf curr;
1303 pCBuf curr2;
fd8cd3a3
DS		 1304#if defined(PERL_IMPLICIT_CONTEXT)
1305 void *thx; /* Either a thread or an interpreter */
1306 /* pointer, depending on how we're built */
1307#endif
22d4bb9c
CB		 1308};
1309
1310
a0d0e21e
LW		 1311struct pipe_details
1312{
22d4bb9c 1313 pInfo next;
ff7adb52
CL		 1314 PerlIO *fp; /* file pointer to pipe mailbox */
1315 int useFILE; /* using stdio, not perlio */
748a9306
LW		 1316 int pid; /* PID of subprocess */
1317 int mode; /* == 'r' if pipe open for reading */
1318 int done; /* subprocess has completed */
ff7adb52 1319 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 1320 int closing; /* my_pclose is closing this pipe */
1321 unsigned long completion; /* termination status of subprocess */
1322 pPipe in; /* pipe in to sub */
1323 pPipe out; /* pipe out of sub */
1324 pPipe err; /* pipe of sub's sys$error */
1325 int in_done; /* true when in pipe finished */
1326 int out_done;
1327 int err_done;
a0d0e21e
LW		 1328};
1329
748a9306
LW		 1330struct exit_control_block
1331{
1332 struct exit_control_block *flink;
1333 unsigned long int (*exit_routine)();
1334 unsigned long int arg_count;
1335 unsigned long int *status_address;
1336 unsigned long int exit_status;
1337};
1338
22d4bb9c
CB		 1339#define RETRY_DELAY "0 ::0.20"
1340#define MAX_RETRY 50
a0d0e21e 1341
22d4bb9c
CB		 1342static int pipe_ef = 0; /* first call to safe_popen inits these*/
1343static unsigned long mypid;
1344static unsigned long delaytime[2];
1345
1346static pInfo open_pipes = NULL;
1347static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 1348
ff7adb52
CL		 1349#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1350
1351
3eeba6fb 1352
748a9306 1353static unsigned long int
fd8cd3a3 1354pipe_exit_routine(pTHX)
748a9306 1355{
22d4bb9c 1356 pInfo info;
1e422769 1357 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 1358 int sts, did_stuff, need_eof, j;
1359
1360 /*
1361 flush any pending i/o
1362 */
1363 info = open_pipes;
1364 while (info) {
1365 if (info->fp) {
1366 if (!info->useFILE)
1367 PerlIO_flush(info->fp); /* first, flush data */
1368 else
1369 fflush((FILE *)info->fp);
1370 }
1371 info = info->next;
1372 }
3eeba6fb
CB		 1373
1374 /*
ff7adb52 1375 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 1376 don't hang
1377 */
1378 did_stuff = 0;
1379 info = open_pipes;
748a9306 1380
3eeba6fb 1381 while (info) {
b2b89246 1382 int need_eof;
b08af3f0 1383 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 1384 if (info->in && !info->in->shut_on_empty) {
1385 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1386 0, 0, 0, 0, 0, 0));
ff7adb52 1387 info->waiting = 1;
22d4bb9c 1388 did_stuff = 1;
748a9306 1389 }
22d4bb9c 1390 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1391 info = info->next;
1392 }
ff7adb52
CL		 1393
1394 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1395
1396 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1397 int nwait = 0;
1398
1399 info = open_pipes;
1400 while (info) {
1401 _ckvmssts(sys$setast(0));
1402 if (info->waiting && info->done)
1403 info->waiting = 0;
1404 nwait += info->waiting;
1405 _ckvmssts(sys$setast(1));
1406 info = info->next;
1407 }
1408 if (!nwait) break;
1409 sleep(1);
1410 }
3eeba6fb
CB		 1411
1412 did_stuff = 0;
1413 info = open_pipes;
1414 while (info) {
b08af3f0 1415 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1416 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1417 sts = sys$forcex(&info->pid,0,&abort);
1418 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1419 did_stuff = 1;
1420 }
b08af3f0 1421 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1422 info = info->next;
1423 }
ff7adb52
CL		 1424
1425 /* again, wait for effect */
1426
1427 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1428 int nwait = 0;
1429
1430 info = open_pipes;
1431 while (info) {
1432 _ckvmssts(sys$setast(0));
1433 if (info->waiting && info->done)
1434 info->waiting = 0;
1435 nwait += info->waiting;
1436 _ckvmssts(sys$setast(1));
1437 info = info->next;
1438 }
1439 if (!nwait) break;
1440 sleep(1);
1441 }
3eeba6fb
CB		 1442
1443 info = open_pipes;
1444 while (info) {
b08af3f0 1445 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1446 if (!info->done) { /* We tried to be nice . . . */
1447 sts = sys$delprc(&info->pid,0);
1448 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
3eeba6fb 1449 }
b08af3f0 1450 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1451 info = info->next;
1452 }
1453
1454 while(open_pipes) {
1e422769 1455 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1456 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 1457 }
1458 return retsts;
1459}
1460
1461static struct exit_control_block pipe_exitblock =
1462 {(struct exit_control_block *) 0,
1463 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1464
22d4bb9c
CB		 1465static void pipe_mbxtofd_ast(pPipe p);
1466static void pipe_tochild1_ast(pPipe p);
1467static void pipe_tochild2_ast(pPipe p);
748a9306 1468
a0d0e21e 1469static void
22d4bb9c 1470popen_completion_ast(pInfo info)
a0d0e21e 1471{
22d4bb9c
CB		 1472 pInfo i = open_pipes;
1473 int iss;
1474
1475 while (i) {
1476 if (i == info) break;
1477 i = i->next;
1478 }
1479 if (!i) return; /* unlinked, probably freed too */
1480
1481 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1482 info->done = TRUE;
1483
1484/*
1485 Writing to subprocess ...
1486 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1487
1488 chan_out may be waiting for "done" flag, or hung waiting
1489 for i/o completion to child...cancel the i/o. This will
1490 put it into "snarf mode" (done but no EOF yet) that discards
1491 input.
1492
1493 Output from subprocess (stdout, stderr) needs to be flushed and
1494 shut down. We try sending an EOF, but if the mbx is full the pipe
1495 routine should still catch the "shut_on_empty" flag, telling it to
1496 use immediate-style reads so that "mbx empty" -> EOF.
1497
1498
1499*/
1500 if (info->in && !info->in_done) { /* only for mode=w */
1501 if (info->in->shut_on_empty && info->in->need_wake) {
1502 info->in->need_wake = FALSE;
fd8cd3a3 1503 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 1504 } else {
fd8cd3a3 1505 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 1506 }
1507 }
1508
1509 if (info->out && !info->out_done) { /* were we also piping output? */
1510 info->out->shut_on_empty = TRUE;
1511 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1512 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1513 _ckvmssts_noperl(iss);
22d4bb9c
CB		 1514 }
1515
1516 if (info->err && !info->err_done) { /* we were piping stderr */
1517 info->err->shut_on_empty = TRUE;
1518 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1519 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1520 _ckvmssts_noperl(iss);
a0d0e21e 1521 }
fd8cd3a3 1522 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 1523
a0d0e21e
LW		 1524}
1525
218fdd94
CL		 1526static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1527static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 1528
22d4bb9c
CB		 1529/*
1530 we actually differ from vmstrnenv since we use this to
1531 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1532 are pointing to the same thing
1533*/
1534
1535static unsigned short
fd8cd3a3 1536popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 1537{
1538 int iss;
1539 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1540 $DESCRIPTOR(d_log,"");
1541 struct _il3 {
1542 unsigned short length;
1543 unsigned short code;
1544 char * buffer_addr;
1545 unsigned short *retlenaddr;
1546 } itmlst[2];
1547 unsigned short l, ifi;
1548
1549 d_log.dsc$a_pointer = logical;
1550 d_log.dsc$w_length = strlen(logical);
1551
1552 itmlst[0].code = LNM$_STRING;
1553 itmlst[0].length = 255;
1554 itmlst[0].buffer_addr = result;
1555 itmlst[0].retlenaddr = &l;
1556
1557 itmlst[1].code = 0;
1558 itmlst[1].length = 0;
1559 itmlst[1].buffer_addr = 0;
1560 itmlst[1].retlenaddr = 0;
1561
1562 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1563 if (iss == SS$_NOLOGNAM) {
1564 iss = SS$_NORMAL;
1565 l = 0;
1566 }
1567 if (!(iss&1)) lib$signal(iss);
1568 result[l] = '\0';
1569/*
1570 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1571 strip it off and return the ifi, if any
1572*/
1573 ifi = 0;
1574 if (result[0] == 0x1b && result[1] == 0x00) {
1575 memcpy(&ifi,result+2,2);
1576 strcpy(result,result+4);
1577 }
1578 return ifi; /* this is the RMS internal file id */
1579}
1580
22d4bb9c
CB		 1581static void pipe_infromchild_ast(pPipe p);
1582
1583/*
1584 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1585 inside an AST routine without worrying about reentrancy and which Perl
1586 memory allocator is being used.
1587
1588 We read data and queue up the buffers, then spit them out one at a
1589 time to the output mailbox when the output mailbox is ready for one.
1590
1591*/
1592#define INITIAL_TOCHILDQUEUE 2
1593
1594static pPipe
fd8cd3a3 1595pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 1596{
22d4bb9c
CB		 1597 pPipe p;
1598 pCBuf b;
1599 char mbx1[64], mbx2[64];
1600 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1601 DSC$K_CLASS_S, mbx1},
1602 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1603 DSC$K_CLASS_S, mbx2};
1604 unsigned int dviitm = DVI$_DEVBUFSIZ;
1605 int j, n;
1606
1607 New(1368, p, 1, Pipe);
1608
fd8cd3a3
DS		 1609 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1610 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 1611 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1612
1613 p->buf = 0;
1614 p->shut_on_empty = FALSE;
1615 p->need_wake = FALSE;
1616 p->type = 0;
1617 p->retry = 0;
1618 p->iosb.status = SS$_NORMAL;
1619 p->iosb2.status = SS$_NORMAL;
1620 p->free = RQE_ZERO;
1621 p->wait = RQE_ZERO;
1622 p->curr = 0;
1623 p->curr2 = 0;
1624 p->info = 0;
fd8cd3a3
DS		 1625#ifdef PERL_IMPLICIT_CONTEXT
1626 p->thx = aTHX;
1627#endif
22d4bb9c
CB		 1628
1629 n = sizeof(CBuf) + p->bufsize;
1630
1631 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1632 _ckvmssts(lib$get_vm(&n, &b));
1633 b->buf = (char *) b + sizeof(CBuf);
1634 _ckvmssts(lib$insqhi(b, &p->free));
1635 }
1636
1637 pipe_tochild2_ast(p);
1638 pipe_tochild1_ast(p);
1639 strcpy(wmbx, mbx1);
1640 strcpy(rmbx, mbx2);
1641 return p;
1642}
1643
1644/* reads the MBX Perl is writing, and queues */
1645
1646static void
1647pipe_tochild1_ast(pPipe p)
1648{
22d4bb9c
CB		 1649 pCBuf b = p->curr;
1650 int iss = p->iosb.status;
1651 int eof = (iss == SS$_ENDOFFILE);
fd8cd3a3
DS		 1652#ifdef PERL_IMPLICIT_CONTEXT
1653 pTHX = p->thx;
1654#endif
22d4bb9c
CB		 1655
1656 if (p->retry) {
1657 if (eof) {
1658 p->shut_on_empty = TRUE;
1659 b->eof = TRUE;
1660 _ckvmssts(sys$dassgn(p->chan_in));
1661 } else {
1662 _ckvmssts(iss);
1663 }
1664
1665 b->eof = eof;
1666 b->size = p->iosb.count;
1667 _ckvmssts(lib$insqhi(b, &p->wait));
1668 if (p->need_wake) {
1669 p->need_wake = FALSE;
1670 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1671 }
1672 } else {
1673 p->retry = 1; /* initial call */
1674 }
1675
1676 if (eof) { /* flush the free queue, return when done */
1677 int n = sizeof(CBuf) + p->bufsize;
1678 while (1) {
1679 iss = lib$remqti(&p->free, &b);
1680 if (iss == LIB$_QUEWASEMP) return;
1681 _ckvmssts(iss);
1682 _ckvmssts(lib$free_vm(&n, &b));
1683 }
1684 }
1685
1686 iss = lib$remqti(&p->free, &b);
1687 if (iss == LIB$_QUEWASEMP) {
1688 int n = sizeof(CBuf) + p->bufsize;
1689 _ckvmssts(lib$get_vm(&n, &b));
1690 b->buf = (char *) b + sizeof(CBuf);
1691 } else {
1692 _ckvmssts(iss);
1693 }
1694
1695 p->curr = b;
1696 iss = sys$qio(0,p->chan_in,
1697 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1698 &p->iosb,
1699 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1700 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1701 _ckvmssts(iss);
1702}
1703
1704
1705/* writes queued buffers to output, waits for each to complete before
1706 doing the next */
1707
1708static void
1709pipe_tochild2_ast(pPipe p)
1710{
22d4bb9c
CB		 1711 pCBuf b = p->curr2;
1712 int iss = p->iosb2.status;
1713 int n = sizeof(CBuf) + p->bufsize;
1714 int done = (p->info && p->info->done) ||
1715 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 1716#if defined(PERL_IMPLICIT_CONTEXT)
1717 pTHX = p->thx;
1718#endif
22d4bb9c
CB		 1719
1720 do {
1721 if (p->type) { /* type=1 has old buffer, dispose */
1722 if (p->shut_on_empty) {
1723 _ckvmssts(lib$free_vm(&n, &b));
1724 } else {
1725 _ckvmssts(lib$insqhi(b, &p->free));
1726 }
1727 p->type = 0;
1728 }
1729
1730 iss = lib$remqti(&p->wait, &b);
1731 if (iss == LIB$_QUEWASEMP) {
1732 if (p->shut_on_empty) {
1733 if (done) {
1734 _ckvmssts(sys$dassgn(p->chan_out));
1735 *p->pipe_done = TRUE;
1736 _ckvmssts(sys$setef(pipe_ef));
1737 } else {
1738 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1739 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1740 }
1741 return;
1742 }
1743 p->need_wake = TRUE;
1744 return;
1745 }
1746 _ckvmssts(iss);
1747 p->type = 1;
1748 } while (done);
1749
1750
1751 p->curr2 = b;
1752 if (b->eof) {
1753 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1754 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1755 } else {
1756 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1757 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1758 }
1759
1760 return;
1761
1762}
1763
1764
1765static pPipe
fd8cd3a3 1766pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 1767{
22d4bb9c
CB		 1768 pPipe p;
1769 char mbx1[64], mbx2[64];
1770 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1771 DSC$K_CLASS_S, mbx1},
1772 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1773 DSC$K_CLASS_S, mbx2};
1774 unsigned int dviitm = DVI$_DEVBUFSIZ;
1775
1776 New(1367, p, 1, Pipe);
fd8cd3a3
DS		 1777 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1778 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 1779
1780 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1781 New(1367, p->buf, p->bufsize, char);
1782 p->shut_on_empty = FALSE;
1783 p->info = 0;
1784 p->type = 0;
1785 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 1786#if defined(PERL_IMPLICIT_CONTEXT)
1787 p->thx = aTHX;
1788#endif
22d4bb9c
CB		 1789 pipe_infromchild_ast(p);
1790
1791 strcpy(wmbx, mbx1);
1792 strcpy(rmbx, mbx2);
1793 return p;
1794}
1795
1796static void
1797pipe_infromchild_ast(pPipe p)
1798{
22d4bb9c
CB		 1799 int iss = p->iosb.status;
1800 int eof = (iss == SS$_ENDOFFILE);
1801 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1802 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 1803#if defined(PERL_IMPLICIT_CONTEXT)
1804 pTHX = p->thx;
1805#endif
22d4bb9c
CB		 1806
1807 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1808 _ckvmssts(sys$dassgn(p->chan_out));
1809 p->chan_out = 0;
1810 }
1811
1812 /* read completed:
1813 input shutdown if EOF from self (done or shut_on_empty)
1814 output shutdown if closing flag set (my_pclose)
1815 send data/eof from child or eof from self
1816 otherwise, re-read (snarf of data from child)
1817 */
1818
1819 if (p->type == 1) {
1820 p->type = 0;
1821 if (myeof && p->chan_in) { /* input shutdown */
1822 _ckvmssts(sys$dassgn(p->chan_in));
1823 p->chan_in = 0;
1824 }
1825
1826 if (p->chan_out) {
1827 if (myeof || kideof) { /* pass EOF to parent */
1828 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1829 pipe_infromchild_ast, p,
1830 0, 0, 0, 0, 0, 0));
1831 return;
1832 } else if (eof) { /* eat EOF --- fall through to read*/
1833
1834 } else { /* transmit data */
1835 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1836 pipe_infromchild_ast,p,
1837 p->buf, p->iosb.count, 0, 0, 0, 0));
1838 return;
1839 }
1840 }
1841 }
1842
1843 /* everything shut? flag as done */
1844
1845 if (!p->chan_in && !p->chan_out) {
1846 *p->pipe_done = TRUE;
1847 _ckvmssts(sys$setef(pipe_ef));
1848 return;
1849 }
1850
1851 /* write completed (or read, if snarfing from child)
1852 if still have input active,
1853 queue read...immediate mode if shut_on_empty so we get EOF if empty
1854 otherwise,
1855 check if Perl reading, generate EOFs as needed
1856 */
1857
1858 if (p->type == 0) {
1859 p->type = 1;
1860 if (p->chan_in) {
1861 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1862 pipe_infromchild_ast,p,
1863 p->buf, p->bufsize, 0, 0, 0, 0);
1864 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1865 _ckvmssts(iss);
1866 } else { /* send EOFs for extra reads */
1867 p->iosb.status = SS$_ENDOFFILE;
1868 p->iosb.dvispec = 0;
1869 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1870 0, 0, 0,
1871 pipe_infromchild_ast, p, 0, 0, 0, 0));
1872 }
1873 }
1874}
1875
1876static pPipe
fd8cd3a3 1877pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 1878{
22d4bb9c
CB		 1879 pPipe p;
1880 char mbx[64];
1881 unsigned long dviitm = DVI$_DEVBUFSIZ;
1882 struct stat s;
1883 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1884 DSC$K_CLASS_S, mbx};
1885
1886 /* things like terminals and mbx's don't need this filter */
1887 if (fd && fstat(fd,&s) == 0) {
1888 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1889 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1890 DSC$K_CLASS_S, s.st_dev};
1891
1892 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1893 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1894 strcpy(out, s.st_dev);
1895 return 0;
1896 }
1897 }
1898
1899 New(1366, p, 1, Pipe);
1900 p->fd_out = dup(fd);
fd8cd3a3 1901 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c
CB		 1902 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1903 New(1366, p->buf, p->bufsize+1, char);
1904 p->shut_on_empty = FALSE;
1905 p->retry = 0;
1906 p->info = 0;
1907 strcpy(out, mbx);
1908
1909 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1910 pipe_mbxtofd_ast, p,
1911 p->buf, p->bufsize, 0, 0, 0, 0));
1912
1913 return p;
1914}
1915
1916static void
1917pipe_mbxtofd_ast(pPipe p)
1918{
22d4bb9c
CB		 1919 int iss = p->iosb.status;
1920 int done = p->info->done;
1921 int iss2;
1922 int eof = (iss == SS$_ENDOFFILE);
1923 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1924 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 1925#if defined(PERL_IMPLICIT_CONTEXT)
1926 pTHX = p->thx;
1927#endif
22d4bb9c
CB		 1928
1929 if (done && myeof) { /* end piping */
1930 close(p->fd_out);
1931 sys$dassgn(p->chan_in);
1932 *p->pipe_done = TRUE;
1933 _ckvmssts(sys$setef(pipe_ef));
1934 return;
1935 }
1936
1937 if (!err && !eof) { /* good data to send to file */
1938 p->buf[p->iosb.count] = '\n';
1939 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1940 if (iss2 < 0) {
1941 p->retry++;
1942 if (p->retry < MAX_RETRY) {
1943 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1944 return;
1945 }
1946 }
1947 p->retry = 0;
1948 } else if (err) {
1949 _ckvmssts(iss);
1950 }
1951
1952
1953 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1954 pipe_mbxtofd_ast, p,
1955 p->buf, p->bufsize, 0, 0, 0, 0);
1956 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1957 _ckvmssts(iss);
1958}
1959
1960
1961typedef struct _pipeloc PLOC;
1962typedef struct _pipeloc* pPLOC;
1963
1964struct _pipeloc {
1965 pPLOC next;
1966 char dir[NAM$C_MAXRSS+1];
1967};
1968static pPLOC head_PLOC = 0;
1969
5c0ae288 1970void
fd8cd3a3 1971free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 1972{
1973 pPLOC p, pnext;
ff7adb52 1974 pPLOC *pHead = (pPLOC *)head;
5c0ae288 1975
ff7adb52 1976 p = *pHead;
5c0ae288
CL		 1977 while (p) {
1978 pnext = p->next;
1979 Safefree(p);
1980 p = pnext;
1981 }
ff7adb52 1982 *pHead = 0;
5c0ae288 1983}
22d4bb9c
CB		 1984
1985static void
fd8cd3a3 1986store_pipelocs(pTHX)
22d4bb9c
CB		 1987{
1988 int i;
1989 pPLOC p;
ff7adb52 1990 AV *av = 0;
22d4bb9c
CB		 1991 SV *dirsv;
1992 GV *gv;
1993 char *dir, *x;
1994 char *unixdir;
1995 char temp[NAM$C_MAXRSS+1];
1996 STRLEN n_a;
1997
ff7adb52 1998 if (head_PLOC)
218fdd94 1999 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 2000
22d4bb9c
CB		 2001/* the . directory from @INC comes last */
2002
2003 New(1370,p,1,PLOC);
2004 p->next = head_PLOC;
2005 head_PLOC = p;
2006 strcpy(p->dir,"./");
2007
2008/* get the directory from $^X */
2009
218fdd94
CL		 2010#ifdef PERL_IMPLICIT_CONTEXT
2011 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2012#else
22d4bb9c 2013 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 2014#endif
22d4bb9c
CB		 2015 strcpy(temp, PL_origargv[0]);
2016 x = strrchr(temp,']');
2017 if (x) x[1] = '\0';
2018
2019 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2020 New(1370,p,1,PLOC);
2021 p->next = head_PLOC;
2022 head_PLOC = p;
2023 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2024 p->dir[NAM$C_MAXRSS] = '\0';
2025 }
2026 }
2027
2028/* reverse order of @INC entries, skip "." since entered above */
2029
218fdd94
CL		 2030#ifdef PERL_IMPLICIT_CONTEXT
2031 if (aTHX)
2032#endif
ff7adb52
CL		 2033 if (PL_incgv) av = GvAVn(PL_incgv);
2034
2035 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 2036 dirsv = *av_fetch(av,i,TRUE);
2037
2038 if (SvROK(dirsv)) continue;
2039 dir = SvPVx(dirsv,n_a);
2040 if (strcmp(dir,".") == 0) continue;
2041 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2042 continue;
2043
2044 New(1370,p,1,PLOC);
2045 p->next = head_PLOC;
2046 head_PLOC = p;
2047 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2048 p->dir[NAM$C_MAXRSS] = '\0';
2049 }
2050
2051/* most likely spot (ARCHLIB) put first in the list */
2052
2053#ifdef ARCHLIB_EXP
2054 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2055 New(1370,p,1,PLOC);
2056 p->next = head_PLOC;
2057 head_PLOC = p;
2058 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2059 p->dir[NAM$C_MAXRSS] = '\0';
2060 }
2061#endif
22d4bb9c
CB		 2062}
2063
2064
2065static char *
fd8cd3a3 2066find_vmspipe(pTHX)
22d4bb9c
CB		 2067{
2068 static int vmspipe_file_status = 0;
2069 static char vmspipe_file[NAM$C_MAXRSS+1];
2070
2071 /* already found? Check and use ... need read+execute permission */
2072
2073 if (vmspipe_file_status == 1) {
2074 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2075 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2076 return vmspipe_file;
2077 }
2078 vmspipe_file_status = 0;
2079 }
2080
2081 /* scan through stored @INC, $^X */
2082
2083 if (vmspipe_file_status == 0) {
2084 char file[NAM$C_MAXRSS+1];
2085 pPLOC p = head_PLOC;
2086
2087 while (p) {
2088 strcpy(file, p->dir);
2089 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2090 file[NAM$C_MAXRSS] = '\0';
2091 p = p->next;
2092
2093 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2094
2095 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2096 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2097 vmspipe_file_status = 1;
2098 return vmspipe_file;
2099 }
2100 }
2101 vmspipe_file_status = -1; /* failed, use tempfiles */
2102 }
2103
2104 return 0;
2105}
2106
2107static FILE *
fd8cd3a3 2108vmspipe_tempfile(pTHX)
22d4bb9c
CB		 2109{
2110 char file[NAM$C_MAXRSS+1];
2111 FILE *fp;
2112 static int index = 0;
2113 stat_t s0, s1;
2114
2115 /* create a tempfile */
2116
2117 /* we can't go from W, shr=get to R, shr=get without
2118 an intermediate vulnerable state, so don't bother trying...
2119
2120 and lib$spawn doesn't shr=put, so have to close the write
2121
2122 So... match up the creation date/time and the FID to
2123 make sure we're dealing with the same file
2124
2125 */
2126
2127 index++;
2128 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2129 fp = fopen(file,"w");
2130 if (!fp) {
2131 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2132 fp = fopen(file,"w");
2133 if (!fp) {
2134 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2135 fp = fopen(file,"w");
2136 }
2137 }
2138 if (!fp) return 0; /* we're hosed */
2139
2140 fprintf(fp,"$! 'f$verify(0)\n");
2141 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2142 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2143 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2144 fprintf(fp,"$ perl_on = \"set noon\"\n");
2145 fprintf(fp,"$ perl_exit = \"exit\"\n");
2146 fprintf(fp,"$ perl_del = \"delete\"\n");
2147 fprintf(fp,"$ pif = \"if\"\n");
2148 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 2149 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2150 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 2151 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 2152 fprintf(fp,"$! --- build command line to get max possible length\n");
2153 fprintf(fp,"$c=perl_popen_cmd0\n");
2154 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2155 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2156 fprintf(fp,"$x=perl_popen_cmd3\n");
2157 fprintf(fp,"$c=c+x\n");
22d4bb9c
CB		 2158 fprintf(fp,"$! --- get rid of global symbols\n");
2159 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2160 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
0e06870b 2161 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
afd8f436
JH		 2162 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2163 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2164 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2165 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
22d4bb9c 2166 fprintf(fp,"$ perl_on\n");
48b5a746 2167 fprintf(fp,"$ 'c\n");
22d4bb9c 2168 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 2169 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 2170 fprintf(fp,"$ perl_exit 'perl_status'\n");
2171 fsync(fileno(fp));
2172
2173 fgetname(fp, file, 1);
2174 fstat(fileno(fp), &s0);
2175 fclose(fp);
2176
2177 fp = fopen(file,"r","shr=get");
2178 if (!fp) return 0;
2179 fstat(fileno(fp), &s1);
2180
2181 if (s0.st_ino[0] != s1.st_ino[0] ||
2182 s0.st_ino[1] != s1.st_ino[1] ||
2183 s0.st_ino[2] != s1.st_ino[2] ||
2184 s0.st_ctime != s1.st_ctime ) {
2185 fclose(fp);
2186 return 0;
2187 }
2188
2189 return fp;
2190}
2191
2192
2193
8fde5078 2194static PerlIO *
ff7adb52 2195safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
a0d0e21e 2196{
748a9306 2197 static int handler_set_up = FALSE;
aa779de1 2198 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
22d4bb9c 2199 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
48b5a746 2200 int j, wait = 0;
ff7adb52 2201 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
22d4bb9c
CB		 2202 char in[512], out[512], err[512], mbx[512];
2203 FILE *tpipe = 0;
2204 char tfilebuf[NAM$C_MAXRSS+1];
2205 pInfo info;
48b5a746 2206 char cmd_sym_name[20];
22d4bb9c
CB		 2207 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2208 DSC$K_CLASS_S, symbol};
22d4bb9c 2209 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 2210 DSC$K_CLASS_S, 0};
48b5a746
CL		 2211 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2212 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 2213 struct dsc$descriptor_s *vmscmd;
22d4bb9c 2214 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 2215 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 2216 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 2217
afd8f436
JH		 2218 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2219
22d4bb9c
CB		 2220 /* once-per-program initialization...
2221 note that the SETAST calls and the dual test of pipe_ef
2222 makes sure that only the FIRST thread through here does
2223 the initialization...all other threads wait until it's
2224 done.
2225
2226 Yeah, uglier than a pthread call, it's got all the stuff inline
2227 rather than in a separate routine.
2228 */
2229
2230 if (!pipe_ef) {
2231 _ckvmssts(sys$setast(0));
2232 if (!pipe_ef) {
2233 unsigned long int pidcode = JPI$_PID;
2234 $DESCRIPTOR(d_delay, RETRY_DELAY);
2235 _ckvmssts(lib$get_ef(&pipe_ef));
2236 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2237 _ckvmssts(sys$bintim(&d_delay, delaytime));
2238 }
2239 if (!handler_set_up) {
2240 _ckvmssts(sys$dclexh(&pipe_exitblock));
2241 handler_set_up = TRUE;
2242 }
2243 _ckvmssts(sys$setast(1));
2244 }
2245
2246 /* see if we can find a VMSPIPE.COM */
2247
2248 tfilebuf[0] = '@';
fd8cd3a3 2249 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 2250 if (vmspipe) {
2251 strcpy(tfilebuf+1,vmspipe);
2252 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 2253 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 2254 if (!tpipe) { /* a fish popular in Boston */
2255 if (ckWARN(WARN_PIPE)) {
2256 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2257 }
2258 return Nullfp;
2259 }
2260 fgetname(tpipe,tfilebuf+1,1);
2261 }
2262 vmspipedsc.dsc$a_pointer = tfilebuf;
2263 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 2264
218fdd94 2265 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 2266 if (!(sts & 1)) {
2267 switch (sts) {
2268 case RMS$_FNF: case RMS$_DNF:
2269 set_errno(ENOENT); break;
2270 case RMS$_DIR:
2271 set_errno(ENOTDIR); break;
2272 case RMS$_DEV:
2273 set_errno(ENODEV); break;
2274 case RMS$_PRV:
2275 set_errno(EACCES); break;
2276 case RMS$_SYN:
2277 set_errno(EINVAL); break;
2278 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2279 set_errno(E2BIG); break;
2280 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2281 _ckvmssts(sts); /* fall through */
2282 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2283 set_errno(EVMSERR);
2284 }
2285 set_vaxc_errno(sts);
ff7adb52 2286 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
a2669cfc
JH		 2287 Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2288 }
ff7adb52 2289 *psts = sts;
a2669cfc
JH		 2290 return Nullfp;
2291 }
22d4bb9c
CB		 2292 New(1301,info,1,Info);
2293
ff7adb52 2294 strcpy(mode,in_mode);
22d4bb9c
CB		 2295 info->mode = *mode;
2296 info->done = FALSE;
2297 info->completion = 0;
2298 info->closing = FALSE;
2299 info->in = 0;
2300 info->out = 0;
2301 info->err = 0;
ff7adb52
CL		 2302 info->fp = Nullfp;
2303 info->useFILE = 0;
2304 info->waiting = 0;
22d4bb9c
CB		 2305 info->in_done = TRUE;
2306 info->out_done = TRUE;
2307 info->err_done = TRUE;
0e06870b 2308 in[0] = out[0] = err[0] = '\0';
22d4bb9c 2309
ff7adb52
CL		 2310 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2311 info->useFILE = 1;
2312 strcpy(p,p+1);
2313 }
2314 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2315 wait = 1;
2316 strcpy(p,p+1);
2317 }
2318
22d4bb9c 2319 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 2320
fd8cd3a3 2321 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 2322 if (info->out) {
2323 info->out->pipe_done = &info->out_done;
2324 info->out_done = FALSE;
2325 info->out->info = info;
2326 }
ff7adb52 2327 if (!info->useFILE) {
22d4bb9c 2328 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 2329 } else {
2330 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2331 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2332 }
2333
22d4bb9c
CB		 2334 if (!info->fp && info->out) {
2335 sys$cancel(info->out->chan_out);
2336
2337 while (!info->out_done) {
2338 int done;
2339 _ckvmssts(sys$setast(0));
2340 done = info->out_done;
2341 if (!done) _ckvmssts(sys$clref(pipe_ef));
2342 _ckvmssts(sys$setast(1));
2343 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 2344 }
22d4bb9c
CB		 2345
2346 if (info->out->buf) Safefree(info->out->buf);
2347 Safefree(info->out);
2348 Safefree(info);
ff7adb52 2349 *psts = RMS$_FNF;
22d4bb9c 2350 return Nullfp;
0e06870b 2351 }
22d4bb9c 2352
fd8cd3a3 2353 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 2354 if (info->err) {
2355 info->err->pipe_done = &info->err_done;
2356 info->err_done = FALSE;
2357 info->err->info = info;
2358 }
a0d0e21e 2359
ff7adb52
CL		 2360 } else if (*mode == 'w') { /* piping to subroutine */
2361
2362 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2363 if (info->out) {
2364 info->out->pipe_done = &info->out_done;
2365 info->out_done = FALSE;
2366 info->out->info = info;
2367 }
2368
2369 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2370 if (info->err) {
2371 info->err->pipe_done = &info->err_done;
2372 info->err_done = FALSE;
2373 info->err->info = info;
2374 }
a0d0e21e 2375
fd8cd3a3 2376 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 2377 if (!info->useFILE) {
22d4bb9c 2378 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 2379 } else {
2380 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2381 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2382 }
2383
22d4bb9c
CB		 2384 if (info->in) {
2385 info->in->pipe_done = &info->in_done;
2386 info->in_done = FALSE;
2387 info->in->info = info;
2388 }
a0d0e21e 2389
22d4bb9c
CB		 2390 /* error cleanup */
2391 if (!info->fp && info->in) {
2392 info->done = TRUE;
2393 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2394 0, 0, 0, 0, 0, 0, 0, 0));
2395
2396 while (!info->in_done) {
2397 int done;
2398 _ckvmssts(sys$setast(0));
2399 done = info->in_done;
2400 if (!done) _ckvmssts(sys$clref(pipe_ef));
2401 _ckvmssts(sys$setast(1));
2402 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2403 }
a0d0e21e 2404
22d4bb9c
CB		 2405 if (info->in->buf) Safefree(info->in->buf);
2406 Safefree(info->in);
2407 Safefree(info);
ff7adb52 2408 *psts = RMS$_FNF;
0e06870b 2409 return Nullfp;
22d4bb9c 2410 }
a0d0e21e 2411
22d4bb9c 2412
ff7adb52 2413 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 2414 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 2415 if (info->out) {
2416 info->out->pipe_done = &info->out_done;
2417 info->out_done = FALSE;
2418 info->out->info = info;
2419 }
0e06870b 2420
fd8cd3a3 2421 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 2422 if (info->err) {
2423 info->err->pipe_done = &info->err_done;
2424 info->err_done = FALSE;
2425 info->err->info = info;
2426 }
748a9306 2427 }
22d4bb9c
CB		 2428
2429 symbol[MAX_DCL_SYMBOL] = '\0';
2430
2431 strncpy(symbol, in, MAX_DCL_SYMBOL);
2432 d_symbol.dsc$w_length = strlen(symbol);
2433 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2434
2435 strncpy(symbol, err, MAX_DCL_SYMBOL);
2436 d_symbol.dsc$w_length = strlen(symbol);
2437 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2438
0e06870b
CB		 2439 strncpy(symbol, out, MAX_DCL_SYMBOL);
2440 d_symbol.dsc$w_length = strlen(symbol);
2441 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 2442
218fdd94 2443 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 2444 while (*p && *p != '\n') p++;
2445 *p = '\0'; /* truncate on \n */
218fdd94 2446 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 2447 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2448 if (*p == '$') p++; /* remove leading $ */
2449 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 2450
2451 for (j = 0; j < 4; j++) {
2452 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2453 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2454
22d4bb9c
CB		 2455 strncpy(symbol, p, MAX_DCL_SYMBOL);
2456 d_symbol.dsc$w_length = strlen(symbol);
2457 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2458
48b5a746
CL		 2459 if (strlen(p) > MAX_DCL_SYMBOL) {
2460 p += MAX_DCL_SYMBOL;
2461 } else {
2462 p += strlen(p);
2463 }
2464 }
22d4bb9c 2465 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 2466 info->next=open_pipes; /* prepend to list */
2467 open_pipes=info;
22d4bb9c 2468 _ckvmssts(sys$setast(1));
0e06870b 2469 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
22d4bb9c
CB		 2470 0, &info->pid, &info->completion,
2471 0, popen_completion_ast,info,0,0,0));
2472
2473 /* if we were using a tempfile, close it now */
2474
2475 if (tpipe) fclose(tpipe);
2476
ff7adb52 2477 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 2478 we can get rid of ours */
2479
48b5a746
CL		 2480 for (j = 0; j < 4; j++) {
2481 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2482 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 2483 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 2484 }
22d4bb9c
CB		 2485 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2486 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 2487 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 2488 vms_execfree(vmscmd);
a0d0e21e 2489
218fdd94
CL		 2490#ifdef PERL_IMPLICIT_CONTEXT
2491 if (aTHX)
2492#endif
6b88bc9c 2493 PL_forkprocess = info->pid;
218fdd94 2494
ff7adb52
CL		 2495 if (wait) {
2496 int done = 0;
2497 while (!done) {
2498 _ckvmssts(sys$setast(0));
2499 done = info->done;
2500 if (!done) _ckvmssts(sys$clref(pipe_ef));
2501 _ckvmssts(sys$setast(1));
2502 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2503 }
2504 *psts = info->completion;
2505 my_pclose(info->fp);
2506 } else {
2507 *psts = SS$_NORMAL;
2508 }
a0d0e21e 2509 return info->fp;
1e422769 2510} /* end of safe_popen */
2511
2512
a15cef0c
CB		 2513/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2514PerlIO *
5c84aa53 2515Perl_my_popen(pTHX_ char *cmd, char *mode)
1e422769 2516{
ff7adb52 2517 int sts;
1e422769 2518 TAINT_ENV();
2519 TAINT_PROPER("popen");
45bc9206 2520 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 2521 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 2522}
1e422769 2523
a0d0e21e
LW		 2524/*}}}*/
2525
a15cef0c
CB		 2526/*{{{ I32 my_pclose(PerlIO *fp)*/
2527I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 2528{
22d4bb9c 2529 pInfo info, last = NULL;
748a9306 2530 unsigned long int retsts;
22d4bb9c 2531 int done, iss;
a0d0e21e
LW		 2532
2533 for (info = open_pipes; info != NULL; last = info, info = info->next)
2534 if (info->fp == fp) break;
2535
1e422769 2536 if (info == NULL) { /* no such pipe open */
2537 set_errno(ECHILD); /* quoth POSIX */
2538 set_vaxc_errno(SS$_NONEXPR);
2539 return -1;
2540 }
748a9306 2541
bbce6d69 2542 /* If we were writing to a subprocess, insure that someone reading from
2543 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 2544 * produce an EOF record in the mailbox.
2545 *
2546 * well, at least sometimes it *does*, so we have to watch out for
2547 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2548 */
ff7adb52
CL		 2549 if (info->fp) {
2550 if (!info->useFILE)
a15cef0c 2551 PerlIO_flush(info->fp); /* first, flush data */
ff7adb52
CL		 2552 else
2553 fflush((FILE *)info->fp);
2554 }
22d4bb9c 2555
b08af3f0 2556 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 2557 info->closing = TRUE;
2558 done = info->done && info->in_done && info->out_done && info->err_done;
2559 /* hanging on write to Perl's input? cancel it */
2560 if (info->mode == 'r' && info->out && !info->out_done) {
2561 if (info->out->chan_out) {
2562 _ckvmssts(sys$cancel(info->out->chan_out));
2563 if (!info->out->chan_in) { /* EOF generation, need AST */
2564 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2565 }
2566 }
2567 }
2568 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2569 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2570 0, 0, 0, 0, 0, 0));
b08af3f0 2571 _ckvmssts(sys$setast(1));
ff7adb52
CL		 2572 if (info->fp) {
2573 if (!info->useFILE)
740ce14c 2574 PerlIO_close(info->fp);
ff7adb52
CL		 2575 else
2576 fclose((FILE *)info->fp);
2577 }
22d4bb9c
CB		 2578 /*
2579 we have to wait until subprocess completes, but ALSO wait until all
2580 the i/o completes...otherwise we'll be freeing the "info" structure
2581 that the i/o ASTs could still be using...
2582 */
2583
2584 while (!done) {
2585 _ckvmssts(sys$setast(0));
2586 done = info->done && info->in_done && info->out_done && info->err_done;
2587 if (!done) _ckvmssts(sys$clref(pipe_ef));
2588 _ckvmssts(sys$setast(1));
2589 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2590 }
2591 retsts = info->completion;
a0d0e21e 2592
a0d0e21e 2593 /* remove from list of open pipes */
b08af3f0 2594 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 2595 if (last) last->next = info->next;
2596 else open_pipes = info->next;
b08af3f0 2597 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 2598
2599 /* free buffers and structures */
2600
2601 if (info->in) {
2602 if (info->in->buf) Safefree(info->in->buf);
2603 Safefree(info->in);
2604 }
2605 if (info->out) {
2606 if (info->out->buf) Safefree(info->out->buf);
2607 Safefree(info->out);
2608 }
2609 if (info->err) {
2610 if (info->err->buf) Safefree(info->err->buf);
2611 Safefree(info->err);
2612 }
a0d0e21e
LW		 2613 Safefree(info);
2614
2615 return retsts;
748a9306 2616
a0d0e21e
LW		 2617} /* end of my_pclose() */
2618
aeb5cf3c
CB		 2619#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2620 /* Roll our own prototype because we want this regardless of whether
2621 * _VMS_WAIT is defined.
2622 */
2623 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2624#endif
2625/* sort-of waitpid; special handling of pipe clean-up for subprocesses
2626 created with popen(); otherwise partially emulate waitpid() unless
2627 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2628 Also check processes not considered by the CRTL waitpid().
2629 */
4fdae800 2630/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2631Pid_t
fd8cd3a3 2632Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 2633{
22d4bb9c
CB		 2634 pInfo info;
2635 int done;
aeb5cf3c
CB		 2636 int sts;
2637
2638 if (statusp) *statusp = 0;
a0d0e21e
LW		 2639
2640 for (info = open_pipes; info != NULL; info = info->next)
2641 if (info->pid == pid) break;
2642
2643 if (info != NULL) { /* we know about this child */
748a9306 2644 while (!info->done) {
22d4bb9c
CB		 2645 _ckvmssts(sys$setast(0));
2646 done = info->done;
2647 if (!done) _ckvmssts(sys$clref(pipe_ef));
2648 _ckvmssts(sys$setast(1));
2649 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 2650 }
2651
aeb5cf3c 2652 if (statusp) *statusp = info->completion;
a0d0e21e 2653 return pid;
aeb5cf3c 2654
a0d0e21e 2655 }
aeb5cf3c
CB		 2656 else { /* this child is not one of our own pipe children */
2657
2658#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2659
2660 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2661 * in 7.2 did we get a version that fills in the VMS completion
2662 * status as Perl has always tried to do.
2663 */
2664
2665 sts = __vms_waitpid( pid, statusp, flags );
2666
2667 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2668 return sts;
2669
2670 /* If the real waitpid tells us the child does not exist, we
2671 * fall through here to implement waiting for a child that
2672 * was created by some means other than exec() (say, spawned
2673 * from DCL) or to wait for a process that is not a subprocess
2674 * of the current process.
2675 */
2676
2677#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2678
a0d0e21e 2679 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 2680 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2681 unsigned long int pidcode = JPI$_PID, mypid;
2682 unsigned long int interval[2];
2683 int termination_mbu = 0;
2684 unsigned short qio_iosb[4];
2685 unsigned int jpi_iosb[2];
2686 struct itmlst_3 jpilist[3] = {
2687 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2688 {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
2689 { 0, 0, 0, 0}
2690 };
2691 char trmmbx[NAM$C_DVI+1];
2692 $DESCRIPTOR(trmmbxdsc,trmmbx);
2693 struct accdef trmmsg;
2694 unsigned short int mbxchan;
2695
2696 if (pid <= 0) {
2697 /* Sorry folks, we don't presently implement rooting around for
2698 the first child we can find, and we definitely don't want to
2699 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2700 */
2701 set_errno(ENOTSUP);
2702 return -1;
2703 }
2704
2705 /* Get the owner of the child so I can warn if it's not mine, plus
2706 * get the termination mailbox. If the process doesn't exist or I
2707 * don't have the privs to look at it, I can go home early.
2708 */
2709 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2710 if (sts & 1) sts = jpi_iosb[0];
2711 if (!(sts & 1)) {
2712 switch (sts) {
2713 case SS$_NONEXPR:
2714 set_errno(ECHILD);
2715 break;
2716 case SS$_NOPRIV:
2717 set_errno(EACCES);
2718 break;
2719 default:
2720 _ckvmssts(sts);
2721 }
2722 set_vaxc_errno(sts);
2723 return -1;
2724 }
a0d0e21e 2725
3eeba6fb 2726 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 2727 /* remind folks they are asking for non-standard waitpid behavior */
2728 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 2729 if (ownerpid != mypid)
aeb5cf3c
CB		 2730 Perl_warner(aTHX_ WARN_EXEC,
2731 "waitpid: process %x is not a child of process %x",
2732 pid,mypid);
748a9306 2733 }
a0d0e21e 2734
aeb5cf3c
CB		 2735 /* It's possible to have a mailbox unit number but no actual mailbox; we
2736 * check for this by assigning a channel to it, which we need anyway.
2737 */
2738 if (termination_mbu != 0) {
2739 sprintf(trmmbx, "MBA%d:", termination_mbu);
2740 trmmbxdsc.dsc$w_length = strlen(trmmbx);
2741 sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
2742 if (sts == SS$_NOSUCHDEV) {
2743 termination_mbu = 0; /* set up to take "no mailbox" case */
2744 sts = SS$_NORMAL;
2745 }
2746 _ckvmssts(sts);
a0d0e21e 2747 }
aeb5cf3c
CB		 2748 /* If the process doesn't have a termination mailbox, then simply check
2749 * on it once a second until it's not there anymore.
a0d0e21e 2750 */
aeb5cf3c
CB		 2751 if (termination_mbu == 0) {
2752 _ckvmssts(sys$bintim(&intdsc,interval));
2753 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2754 _ckvmssts(sys$schdwk(0,0,interval,0));
2755 _ckvmssts(sys$hiber());
2756 }
2757 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2758 }
2759 else {
2760 /* If we do have a termination mailbox, post reads to it until we get a
2761 * termination message, discarding messages of the wrong type or for other
2762 * processes. If there is a place to put the final status, then do so.
2763 */
2764 sts = SS$_NORMAL;
2765 while (sts & 1) {
2766 memset((void *) &trmmsg, 0, sizeof(trmmsg));
2767 sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
2768 &trmmsg,ACC$K_TERMLEN,0,0,0,0);
2769 if (sts & 1) sts = qio_iosb[0];
2770
2771 if ( sts & 1
2772 && trmmsg.acc$w_msgtyp == MSG$_DELPROC
2773 && trmmsg.acc$l_pid == pid ) {
2774
2775 if (statusp) *statusp = trmmsg.acc$l_finalsts;
2776 sts = sys$dassgn(mbxchan);
2777 break;
2778 }
2779 }
2780 } /* termination_mbu ? */
2781
2782 _ckvmssts(sts);
a0d0e21e 2783 return pid;
aeb5cf3c
CB		 2784
2785 } /* else one of our own pipe children */
a0d0e21e
LW		 2786
2787} /* end of waitpid() */
a0d0e21e
LW		 2788/*}}}*/
2789/*}}}*/
2790/*}}}*/
2791
2792/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2793char *
2794my_gconvert(double val, int ndig, int trail, char *buf)
2795{
2796 static char __gcvtbuf[DBL_DIG+1];
2797 char *loc;
2798
2799 loc = buf ? buf : __gcvtbuf;
71be2cbc 2800
2801#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2802 if (val < 1) {
2803 sprintf(loc,"%.*g",ndig,val);
2804 return loc;
2805 }
2806#endif
2807
a0d0e21e
LW		 2808 if (val) {
2809 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2810 return gcvt(val,ndig,loc);
2811 }
2812 else {
2813 loc[0] = '0'; loc[1] = '\0';
2814 return loc;
2815 }
2816
2817}
2818/*}}}*/
2819
bbce6d69 2820
2821/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2822/* Shortcut for common case of simple calls to $PARSE and $SEARCH
2823 * to expand file specification. Allows for a single default file
2824 * specification and a simple mask of options. If outbuf is non-NULL,
2825 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2826 * the resultant file specification is placed. If outbuf is NULL, the
2827 * resultant file specification is placed into a static buffer.
2828 * The third argument, if non-NULL, is taken to be a default file
2829 * specification string. The fourth argument is unused at present.
2830 * rmesexpand() returns the address of the resultant string if
2831 * successful, and NULL on error.
2832 */
4b19af01 2833static char *mp_do_tounixspec(pTHX_ char *, char *, int);
96e4d5b1 2834
bbce6d69 2835static char *
4b19af01 2836mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
bbce6d69 2837{
2838 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
96e4d5b1 2839 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
bbce6d69 2840 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2841 struct FAB myfab = cc$rms_fab;
2842 struct NAM mynam = cc$rms_nam;
2843 STRLEN speclen;
3eeba6fb 2844 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
bbce6d69 2845
2846 if (!filespec || !*filespec) {
2847 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2848 return NULL;
2849 }
2850 if (!outbuf) {
fc36a67e 2851 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
bbce6d69 2852 else outbuf = __rmsexpand_retbuf;
2853 }
96e4d5b1 2854 if ((isunix = (strchr(filespec,'/') != NULL))) {
2855 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2856 filespec = vmsfspec;
2857 }
bbce6d69 2858
2859 myfab.fab$l_fna = filespec;
2860 myfab.fab$b_fns = strlen(filespec);
2861 myfab.fab$l_nam = &mynam;
2862
2863 if (defspec && *defspec) {
96e4d5b1 2864 if (strchr(defspec,'/') != NULL) {
2865 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2866 defspec = tmpfspec;
2867 }
bbce6d69 2868 myfab.fab$l_dna = defspec;
2869 myfab.fab$b_dns = strlen(defspec);
2870 }
2871
2872 mynam.nam$l_esa = esa;
2873 mynam.nam$b_ess = sizeof esa;
2874 mynam.nam$l_rsa = outbuf;
2875 mynam.nam$b_rss = NAM$C_MAXRSS;
2876
2877 retsts = sys$parse(&myfab,0,0);
2878 if (!(retsts & 1)) {
17f28c40 2879 mynam.nam$b_nop |= NAM$M_SYNCHK;
f282b18d 2880 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
bbce6d69 2881 retsts = sys$parse(&myfab,0,0);
2882 if (retsts & 1) goto expanded;
2883 }
17f28c40
CB		 2884 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2885 (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69 2886 if (out) Safefree(out);
2887 set_vaxc_errno(retsts);
2888 if (retsts == RMS$_PRV) set_errno(EACCES);
2889 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2890 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2891 else set_errno(EVMSERR);
2892 return NULL;
2893 }
2894 retsts = sys$search(&myfab,0,0);
2895 if (!(retsts & 1) && retsts != RMS$_FNF) {
17f28c40
CB		 2896 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2897 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69 2898 if (out) Safefree(out);
2899 set_vaxc_errno(retsts);
2900 if (retsts == RMS$_PRV) set_errno(EACCES);
2901 else set_errno(EVMSERR);
2902 return NULL;
2903 }
2904
2905 /* If the input filespec contained any lowercase characters,
2906 * downcase the result for compatibility with Unix-minded code. */
2907 expanded:
2908 for (out = myfab.fab$l_fna; *out; out++)
2909 if (islower(*out)) { haslower = 1; break; }
2910 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2911 else { out = esa; speclen = mynam.nam$b_esl; }
3eeba6fb
CB		 2912 /* Trim off null fields added by $PARSE
2913 * If type > 1 char, must have been specified in original or default spec
2914 * (not true for version; $SEARCH may have added version of existing file).
2915 */
2916 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2917 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2918 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2919 if (trimver || trimtype) {
2920 if (defspec && *defspec) {
2921 char defesa[NAM$C_MAXRSS];
2922 struct FAB deffab = cc$rms_fab;
2923 struct NAM defnam = cc$rms_nam;
2924
2925 deffab.fab$l_nam = &defnam;
2926 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2927 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2928 defnam.nam$b_nop = NAM$M_SYNCHK;
2929 if (sys$parse(&deffab,0,0) & 1) {
2930 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2931 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2932 }
2933 }
2934 if (trimver) speclen = mynam.nam$l_ver - out;
2935 if (trimtype) {
2936 /* If we didn't already trim version, copy down */
2937 if (speclen > mynam.nam$l_ver - out)
2938 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2939 speclen - (mynam.nam$l_ver - out));
2940 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2941 }
2942 }
bbce6d69 2943 /* If we just had a directory spec on input, $PARSE "helpfully"
2944 * adds an empty name and type for us */
2945 if (mynam.nam$l_name == mynam.nam$l_type &&
2946 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2947 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2948 speclen = mynam.nam$l_name - out;
2949 out[speclen] = '\0';
2950 if (haslower) __mystrtolower(out);
2951
2952 /* Have we been working with an expanded, but not resultant, spec? */
96e4d5b1 2953 /* Also, convert back to Unix syntax if necessary. */
2954 if (!mynam.nam$b_rsl) {
2955 if (isunix) {
2956 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2957 }
2958 else strcpy(outbuf,esa);
2959 }
2960 else if (isunix) {
2961 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2962 strcpy(outbuf,tmpfspec);
2963 }
17f28c40
CB		 2964 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2965 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2966 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
bbce6d69 2967 return outbuf;
2968}
2969/*}}}*/
2970/* External entry points */
4b19af01 2971char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
bbce6d69 2972{ return do_rmsexpand(spec,buf,0,def,opt); }
4b19af01 2973char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
bbce6d69 2974{ return do_rmsexpand(spec,buf,1,def,opt); }
2975
2976
a0d0e21e
LW		 2977/*
2978** The following routines are provided to make life easier when
2979** converting among VMS-style and Unix-style directory specifications.
2980** All will take input specifications in either VMS or Unix syntax. On
2981** failure, all return NULL. If successful, the routines listed below
748a9306 2982** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 2983** reformatted spec (and, therefore, subsequent calls to that routine
2984** will clobber the result), while the routines of the same names with
2985** a _ts suffix appended will return a pointer to a mallocd string
2986** containing the appropriately reformatted spec.
2987** In all cases, only explicit syntax is altered; no check is made that
2988** the resulting string is valid or that the directory in question
2989** actually exists.
2990**
2991** fileify_dirspec() - convert a directory spec into the name of the
2992** directory file (i.e. what you can stat() to see if it's a dir).
2993** The style (VMS or Unix) of the result is the same as the style
2994** of the parameter passed in.
2995** pathify_dirspec() - convert a directory spec into a path (i.e.
2996** what you prepend to a filename to indicate what directory it's in).
2997** The style (VMS or Unix) of the result is the same as the style
2998** of the parameter passed in.
2999** tounixpath() - convert a directory spec into a Unix-style path.
3000** tovmspath() - convert a directory spec into a VMS-style path.
3001** tounixspec() - convert any file spec into a Unix-style file spec.
3002** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 3003**
bd3fa61c 3004** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 3005** Permission is given to distribute this code as part of the Perl
3006** standard distribution under the terms of the GNU General Public
3007** License or the Perl Artistic License. Copies of each may be
3008** found in the Perl standard distribution.
a0d0e21e
LW		 3009 */
3010
3011/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
4b19af01 3012static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
a0d0e21e
LW		 3013{
3014 static char __fileify_retbuf[NAM$C_MAXRSS+1];
b7ae7a0d 3015 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 3016 char *retspec, *cp1, *cp2, *lastdir;
61bb5906 3017 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
a0d0e21e 3018
c07a80fd 3019 if (!dir || !*dir) {
3020 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3021 }
a0d0e21e 3022 dirlen = strlen(dir);
a2a90019 3023 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906
CB		 3024 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3025 strcpy(trndir,"/sys$disk/000000");
3026 dir = trndir;
3027 dirlen = 16;
3028 }
3029 if (dirlen > NAM$C_MAXRSS) {
3030 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
c07a80fd 3031 }
e518068a 3032 if (!strpbrk(dir+1,"/]>:")) {
3033 strcpy(trndir,*dir == '/' ? dir + 1: dir);
c07a80fd 3034 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
e518068a 3035 dir = trndir;
3036 dirlen = strlen(dir);
3037 }
01b8edb6 3038 else {
3039 strncpy(trndir,dir,dirlen);
3040 trndir[dirlen] = '\0';
3041 dir = trndir;
3042 }
c07a80fd 3043 /* If we were handed a rooted logical name or spec, treat it like a
3044 * simple directory, so that
3045 * $ Define myroot dev:[dir.]
3046 * ... do_fileify_dirspec("myroot",buf,1) ...
3047 * does something useful.
3048 */
a2a90019 3049 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
c07a80fd 3050 dir[--dirlen] = '\0';
3051 dir[dirlen-1] = ']';
3052 }
46112e17
CB		 3053 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3054 dir[--dirlen] = '\0';
3055 dir[dirlen-1] = '>';
3056 }
e518068a 3057
b7ae7a0d 3058 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3059 /* If we've got an explicit filename, we can just shuffle the string. */
3060 if (*(cp1+1)) hasfilename = 1;
3061 /* Similarly, we can just back up a level if we've got multiple levels
3062 of explicit directories in a VMS spec which ends with directories. */
3063 else {
3064 for (cp2 = cp1; cp2 > dir; cp2--) {
3065 if (*cp2 == '.') {
3066 *cp2 = *cp1; *cp1 = '\0';
3067 hasfilename = 1;
3068 break;
3069 }
3070 if (*cp2 == '[' || *cp2 == '<') break;
3071 }
3072 }
3073 }
3074
3075 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
748a9306
LW		 3076 if (dir[0] == '.') {
3077 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3078 return do_fileify_dirspec("[]",buf,ts);
3079 else if (dir[1] == '.' &&
3080 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3081 return do_fileify_dirspec("[-]",buf,ts);
3082 }
a2a90019 3083 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e
LW		 3084 dirlen -= 1; /* to last element */
3085 lastdir = strrchr(dir,'/');
3086 }
01b8edb6 3087 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3088 /* If we have "/." or "/..", VMSify it and let the VMS code
3089 * below expand it, rather than repeating the code to handle
3090 * relative components of a filespec here */
4633a7c4
LW		 3091 do {
3092 if (*(cp1+2) == '.') cp1++;
3093 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
01b8edb6 3094 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
fc1ce8cc
CB		 3095 if (strchr(vmsdir,'/') != NULL) {
3096 /* If do_tovmsspec() returned it, it must have VMS syntax
3097 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3098 * the time to check this here only so we avoid a recursion
3099 * loop; otherwise, gigo.
3100 */
3101 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3102 }
01b8edb6 3103 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3104 return do_tounixspec(trndir,buf,ts);
4633a7c4
LW		 3105 }
3106 cp1++;
3107 } while ((cp1 = strstr(cp1,"/.")) != NULL);
17f28c40 3108 lastdir = strrchr(dir,'/');
748a9306 3109 }
a2a90019 3110 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
61bb5906
CB		 3111 /* Ditto for specs that end in an MFD -- let the VMS code
3112 * figure out whether it's a real device or a rooted logical. */
3113 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3114 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3115 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3116 return do_tounixspec(trndir,buf,ts);
3117 }
a0d0e21e 3118 else {
b7ae7a0d 3119 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3120 !(lastdir = cp1 = strrchr(dir,']')) &&
3121 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
a0d0e21e 3122 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 3123 int ver; char *cp3;
3124 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3125 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3126 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3127 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3128 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3129 (ver || *cp3)))))) {
3130 set_errno(ENOTDIR);
748a9306 3131 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 3132 return NULL;
3133 }
b7ae7a0d 3134 dirlen = cp2 - dir;
a0d0e21e 3135 }
748a9306
LW		 3136 }
3137 /* If we lead off with a device or rooted logical, add the MFD
3138 if we're specifying a top-level directory. */
3139 if (lastdir && *dir == '/') {
3140 addmfd = 1;
3141 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3142 if (*cp1 == '/') {
3143 addmfd = 0;
3144 break;
a0d0e21e
LW		 3145 }
3146 }
748a9306 3147 }
4633a7c4 3148 retlen = dirlen + (addmfd ? 13 : 6);
748a9306 3149 if (buf) retspec = buf;
fc36a67e 3150 else if (ts) New(1309,retspec,retlen+1,char);
748a9306
LW		 3151 else retspec = __fileify_retbuf;
3152 if (addmfd) {
3153 dirlen = lastdir - dir;
3154 memcpy(retspec,dir,dirlen);
3155 strcpy(&retspec[dirlen],"/000000");
3156 strcpy(&retspec[dirlen+7],lastdir);
3157 }
3158 else {
3159 memcpy(retspec,dir,dirlen);
3160 retspec[dirlen] = '\0';
a0d0e21e
LW		 3161 }
3162 /* We've picked up everything up to the directory file name.
3163 Now just add the type and version, and we're set. */
3164 strcat(retspec,".dir;1");
3165 return retspec;
3166 }
3167 else { /* VMS-style directory spec */
01b8edb6 3168 char esa[NAM$C_MAXRSS+1], term, *cp;
3169 unsigned long int sts, cmplen, haslower = 0;
a0d0e21e
LW		 3170 struct FAB dirfab = cc$rms_fab;
3171 struct NAM savnam, dirnam = cc$rms_nam;
3172
3173 dirfab.fab$b_fns = strlen(dir);
3174 dirfab.fab$l_fna = dir;
3175 dirfab.fab$l_nam = &dirnam;
748a9306
LW		 3176 dirfab.fab$l_dna = ".DIR;1";
3177 dirfab.fab$b_dns = 6;
a0d0e21e
LW		 3178 dirnam.nam$b_ess = NAM$C_MAXRSS;
3179 dirnam.nam$l_esa = esa;
01b8edb6 3180
3181 for (cp = dir; *cp; cp++)
3182 if (islower(*cp)) { haslower = 1; break; }
e518068a 3183 if (!((sts = sys$parse(&dirfab))&1)) {
3184 if (dirfab.fab$l_sts == RMS$_DIR) {
3185 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3186 sts = sys$parse(&dirfab) & 1;
3187 }
3188 if (!sts) {
748a9306
LW		 3189 set_errno(EVMSERR);
3190 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 3191 return NULL;
3192 }
e518068a 3193 }
3194 else {
3195 savnam = dirnam;
3196 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3197 /* Yes; fake the fnb bits so we'll check type below */
3198 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3199 }
752635ea
CB		 3200 else { /* No; just work with potential name */
3201 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3202 else {
3203 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3204 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3205 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
e518068a 3206 return NULL;
3207 }
e518068a 3208 }
a0d0e21e 3209 }
748a9306
LW		 3210 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3211 cp1 = strchr(esa,']');
3212 if (!cp1) cp1 = strchr(esa,'>');
3213 if (cp1) { /* Should always be true */
3214 dirnam.nam$b_esl -= cp1 - esa - 1;
3215 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3216 }
3217 }
a0d0e21e
LW		 3218 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3219 /* Yep; check version while we're at it, if it's there. */
3220 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3221 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3222 /* Something other than .DIR[;1]. Bzzt. */
752635ea
CB		 3223 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3224 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 3225 set_errno(ENOTDIR);
3226 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 3227 return NULL;
3228 }
748a9306
LW		 3229 }
3230 esa[dirnam.nam$b_esl] = '\0';
3231 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3232 /* They provided at least the name; we added the type, if necessary, */
3233 if (buf) retspec = buf; /* in sys$parse() */
fc36a67e 3234 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
748a9306
LW		 3235 else retspec = __fileify_retbuf;
3236 strcpy(retspec,esa);
752635ea
CB		 3237 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3238 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 3239 return retspec;
3240 }
c07a80fd 3241 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3242 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3243 *cp1 = '\0';
3244 dirnam.nam$b_esl -= 9;
3245 }
748a9306 3246 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
752635ea
CB		 3247 if (cp1 == NULL) { /* should never happen */
3248 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3249 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3250 return NULL;
3251 }
748a9306
LW		 3252 term = *cp1;
3253 *cp1 = '\0';
3254 retlen = strlen(esa);
3255 if ((cp1 = strrchr(esa,'.')) != NULL) {
3256 /* There's more than one directory in the path. Just roll back. */
3257 *cp1 = term;
3258 if (buf) retspec = buf;
fc36a67e 3259 else if (ts) New(1311,retspec,retlen+7,char);
748a9306
LW		 3260 else retspec = __fileify_retbuf;
3261 strcpy(retspec,esa);
a0d0e21e
LW		 3262 }
3263 else {
748a9306
LW		 3264 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3265 /* Go back and expand rooted logical name */
3266 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3267 if (!(sys$parse(&dirfab) & 1)) {
752635ea
CB		 3268 dirnam.nam$l_rlf = NULL;
3269 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 3270 set_errno(EVMSERR);
3271 set_vaxc_errno(dirfab.fab$l_sts);
3272 return NULL;
3273 }
3274 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 3275 if (buf) retspec = buf;
fc36a67e 3276 else if (ts) New(1312,retspec,retlen+16,char);
a0d0e21e 3277 else retspec = __fileify_retbuf;
748a9306 3278 cp1 = strstr(esa,"][");
46112e17 3279 if (!cp1) cp1 = strstr(esa,"]<");
748a9306
LW		 3280 dirlen = cp1 - esa;
3281 memcpy(retspec,esa,dirlen);
3282 if (!strncmp(cp1+2,"000000]",7)) {
3283 retspec[dirlen-1] = '\0';
4633a7c4
LW		 3284 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3285 if (*cp1 == '.') *cp1 = ']';
3286 else {
3287 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3288 memcpy(cp1+1,"000000]",7);
3289 }
748a9306
LW		 3290 }
3291 else {
3292 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3293 retspec[retlen] = '\0';
3294 /* Convert last '.' to ']' */
4633a7c4
LW		 3295 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3296 if (*cp1 == '.') *cp1 = ']';
3297 else {
3298 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3299 memcpy(cp1+1,"000000]",7);
3300 }
748a9306 3301 }
a0d0e21e 3302 }
748a9306 3303 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 3304 if (buf) retspec = buf;
fc36a67e 3305 else if (ts) New(1312,retspec,retlen+16,char);
a0d0e21e
LW		 3306 else retspec = __fileify_retbuf;
3307 cp1 = esa;
3308 cp2 = retspec;
3309 while (*cp1 != ':') *(cp2++) = *(cp1++);
3310 strcpy(cp2,":[000000]");
3311 cp1 += 2;
3312 strcpy(cp2+9,cp1);
3313 }
748a9306 3314 }
752635ea
CB		 3315 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3316 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306 3317 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 3318 type and version, and we're done. */
3319 strcat(retspec,".DIR;1");
01b8edb6 3320
3321 /* $PARSE may have upcased filespec, so convert output to lower
3322 * case if input contained any lowercase characters. */
3323 if (haslower) __mystrtolower(retspec);
a0d0e21e
LW		 3324 return retspec;
3325 }
3326} /* end of do_fileify_dirspec() */
3327/*}}}*/
3328/* External entry points */
4b19af01 3329char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
a0d0e21e 3330{ return do_fileify_dirspec(dir,buf,0); }
4b19af01 3331char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
a0d0e21e
LW		 3332{ return do_fileify_dirspec(dir,buf,1); }
3333
3334/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4b19af01 3335static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
a0d0e21e
LW		 3336{
3337 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3338 unsigned long int retlen;
748a9306 3339 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
a0d0e21e 3340
c07a80fd 3341 if (!dir || !*dir) {
3342 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3343 }
3344
3345 if (*dir) strcpy(trndir,dir);
3346 else getcwd(trndir,sizeof trndir - 1);
3347
93948341
CB		 3348 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3349 && my_trnlnm(trndir,trndir,0)) {
c07a80fd 3350 STRLEN trnlen = strlen(trndir);
a0d0e21e 3351
c07a80fd 3352 /* Trap simple rooted lnms, and return lnm:[000000] */
3353 if (!strcmp(trndir+trnlen-2,".]")) {
3354 if (buf) retpath = buf;
fc36a67e 3355 else if (ts) New(1318,retpath,strlen(dir)+10,char);
c07a80fd 3356 else retpath = __pathify_retbuf;
3357 strcpy(retpath,dir);
3358 strcat(retpath,":[000000]");
3359 return retpath;
3360 }
3361 }
748a9306
LW		 3362 dir = trndir;
3363
b7ae7a0d 3364 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
748a9306
LW		 3365 if (*dir == '.' && (*(dir+1) == '\0' ||
3366 (*(dir+1) == '.' && *(dir+2) == '\0')))
3367 retlen = 2 + (*(dir+1) != '\0');
3368 else {
b7ae7a0d 3369 if ( !(cp1 = strrchr(dir,'/')) &&
3370 !(cp1 = strrchr(dir,']')) &&
3371 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
f86702cc 3372 if ((cp2 = strchr(cp1,'.')) != NULL &&
3373 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3374 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3375 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3376 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 3377 int ver; char *cp3;
3378 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3379 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3380 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3381 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3382 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3383 (ver || *cp3)))))) {
748a9306
LW		 3384 set_errno(ENOTDIR);
3385 set_vaxc_errno(RMS$_DIR);
3386 return NULL;
3387 }
b7ae7a0d 3388 retlen = cp2 - dir + 1;
a0d0e21e 3389 }
748a9306
LW		 3390 else { /* No file type present. Treat the filename as a directory. */
3391 retlen = strlen(dir) + 1;
a0d0e21e
LW		 3392 }
3393 }
a0d0e21e 3394 if (buf) retpath = buf;
fc36a67e 3395 else if (ts) New(1313,retpath,retlen+1,char);
a0d0e21e
LW		 3396 else retpath = __pathify_retbuf;
3397 strncpy(retpath,dir,retlen-1);
3398 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3399 retpath[retlen-1] = '/'; /* with '/', add it. */
3400 retpath[retlen] = '\0';
3401 }
3402 else retpath[retlen-1] = '\0';
3403 }
3404 else { /* VMS-style directory spec */
01b8edb6 3405 char esa[NAM$C_MAXRSS+1], *cp;
3406 unsigned long int sts, cmplen, haslower;
a0d0e21e
LW		 3407 struct FAB dirfab = cc$rms_fab;
3408 struct NAM savnam, dirnam = cc$rms_nam;
3409
b7ae7a0d 3410 /* If we've got an explicit filename, we can just shuffle the string. */
3411 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3412 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3413 if ((cp2 = strchr(cp1,'.')) != NULL) {
3414 int ver; char *cp3;
3415 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3416 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3417 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3418 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3419 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3420 (ver || *cp3)))))) {
3421 set_errno(ENOTDIR);
3422 set_vaxc_errno(RMS$_DIR);
3423 return NULL;
3424 }
3425 }
3426 else { /* No file type, so just draw name into directory part */
3427 for (cp2 = cp1; *cp2; cp2++) ;
3428 }
3429 *cp2 = *cp1;
3430 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3431 *cp1 = '.';
3432 /* We've now got a VMS 'path'; fall through */
3433 }
a0d0e21e
LW		 3434 dirfab.fab$b_fns = strlen(dir);
3435 dirfab.fab$l_fna = dir;
748a9306
LW		 3436 if (dir[dirfab.fab$b_fns-1] == ']' ||
3437 dir[dirfab.fab$b_fns-1] == '>' ||
3438 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3439 if (buf) retpath = buf;
fc36a67e 3440 else if (ts) New(1314,retpath,strlen(dir)+1,char);
748a9306
LW		 3441 else retpath = __pathify_retbuf;
3442 strcpy(retpath,dir);
3443 return retpath;
3444 }
3445 dirfab.fab$l_dna = ".DIR;1";
3446 dirfab.fab$b_dns = 6;
a0d0e21e 3447 dirfab.fab$l_nam = &dirnam;
e518068a 3448 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
a0d0e21e 3449 dirnam.nam$l_esa = esa;
01b8edb6 3450
3451 for (cp = dir; *cp; cp++)
3452 if (islower(*cp)) { haslower = 1; break; }
3453
3454 if (!(sts = (sys$parse(&dirfab)&1))) {
e518068a 3455 if (dirfab.fab$l_sts == RMS$_DIR) {
3456 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3457 sts = sys$parse(&dirfab) & 1;
3458 }
3459 if (!sts) {
748a9306
LW		 3460 set_errno(EVMSERR);
3461 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 3462 return NULL;
3463 }
a0d0e21e 3464 }
e518068a 3465 else {
3466 savnam = dirnam;
3467 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3468 if (dirfab.fab$l_sts != RMS$_FNF) {
752635ea
CB		 3469 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3470 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
e518068a 3471 set_errno(EVMSERR);
3472 set_vaxc_errno(dirfab.fab$l_sts);
3473 return NULL;
3474 }
3475 dirnam = savnam; /* No; just work with potential name */
3476 }
3477 }
a0d0e21e
LW		 3478 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3479 /* Yep; check version while we're at it, if it's there. */
3480 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3481 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3482 /* Something other than .DIR[;1]. Bzzt. */
752635ea
CB		 3483 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3484 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
748a9306
LW		 3485 set_errno(ENOTDIR);
3486 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 3487 return NULL;
3488 }
a0d0e21e 3489 }
748a9306
LW		 3490 /* OK, the type was fine. Now pull any file name into the
3491 directory path. */
3492 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
a0d0e21e 3493 else {
748a9306
LW		 3494 cp1 = strrchr(esa,'>');
3495 *dirnam.nam$l_type = '>';
a0d0e21e 3496 }
748a9306
LW		 3497 *cp1 = '.';
3498 *(dirnam.nam$l_type + 1) = '\0';
3499 retlen = dirnam.nam$l_type - esa + 2;
a0d0e21e 3500 if (buf) retpath = buf;
fc36a67e 3501 else if (ts) New(1314,retpath,retlen,char);
a0d0e21e
LW		 3502 else retpath = __pathify_retbuf;
3503 strcpy(retpath,esa);
752635ea
CB		 3504 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3505 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
01b8edb6 3506 /* $PARSE may have upcased filespec, so convert output to lower
3507 * case if input contained any lowercase characters. */
3508 if (haslower) __mystrtolower(retpath);
a0d0e21e
LW		 3509 }
3510
3511 return retpath;
3512} /* end of do_pathify_dirspec() */
3513/*}}}*/
3514/* External entry points */
4b19af01 3515char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
a0d0e21e 3516{ return do_pathify_dirspec(dir,buf,0); }
4b19af01 3517char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
a0d0e21e
LW		 3518{ return do_pathify_dirspec(dir,buf,1); }
3519
3520/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
4b19af01 3521static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
a0d0e21e
LW		 3522{
3523 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3524 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
f86702cc 3525 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
a0d0e21e 3526
748a9306 3527 if (spec == NULL) return NULL;
e518068a 3528 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
a0d0e21e 3529 if (buf) rslt = buf;
e518068a 3530 else if (ts) {
3531 retlen = strlen(spec);
3532 cp1 = strchr(spec,'[');
3533 if (!cp1) cp1 = strchr(spec,'<');
3534 if (cp1) {
f86702cc 3535 for (cp1++; *cp1; cp1++) {
3536 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3537 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3538 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3539 }
e518068a 3540 }
fc36a67e 3541 New(1315,rslt,retlen+2+2*expand,char);
e518068a 3542 }
a0d0e21e
LW		 3543 else rslt = __tounixspec_retbuf;
3544 if (strchr(spec,'/') != NULL) {
3545 strcpy(rslt,spec);
3546 return rslt;
3547 }
3548
3549 cp1 = rslt;
3550 cp2 = spec;
3551 dirend = strrchr(spec,']');
3552 if (dirend == NULL) dirend = strrchr(spec,'>');
3553 if (dirend == NULL) dirend = strchr(spec,':');
3554 if (dirend == NULL) {
3555 strcpy(rslt,spec);
3556 return rslt;
3557 }
a5f75d66 3558 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 3559 *(cp1++) = '/';
3560 }
3561 else { /* the VMS spec begins with directories */
3562 cp2++;
a5f75d66 3563 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 3564 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
a5f75d66
AD		 3565 return rslt;
3566 }
f86702cc 3567 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
a0d0e21e
LW		 3568 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3569 if (ts) Safefree(rslt);
3570 return NULL;
3571 }
3572 do {
3573 cp3 = tmp;
3574 while (*cp3 != ':' && *cp3) cp3++;
3575 *(cp3++) = '\0';
3576 if (strchr(cp3,']') != NULL) break;
f675dbe5 3577 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 3578 if (ts && !buf &&
e518068a 3579 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 3580 retlen = devlen + dirlen;
f86702cc 3581 Renew(rslt,retlen+1+2*expand,char);
3582 cp1 = rslt;
3583 }
3584 cp3 = tmp;
3585 *(cp1++) = '/';
3586 while (*cp3) {
3587 *(cp1++) = *(cp3++);
3588 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
a0d0e21e 3589 }
f86702cc 3590 *(cp1++) = '/';
3591 }
3592 else if ( *cp2 == '.') {
3593 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3594 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3595 cp2 += 3;
3596 }
3597 else cp2++;
a0d0e21e 3598 }
a0d0e21e
LW		 3599 }
3600 for (; cp2 <= dirend; cp2++) {
3601 if (*cp2 == ':') {
3602 *(cp1++) = '/';
3603 if (*(cp2+1) == '[') cp2++;
3604 }
f86702cc 3605 else if (*cp2 == ']' || *cp2 == '>') {
3606 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3607 }
a0d0e21e
LW		 3608 else if (*cp2 == '.') {
3609 *(cp1++) = '/';
e518068a 3610 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3611 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3612 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3613 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3614 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3615 }
f86702cc 3616 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3617 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3618 cp2 += 2;
3619 }
a0d0e21e
LW		 3620 }
3621 else if (*cp2 == '-') {
3622 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3623 while (*cp2 == '-') {
3624 cp2++;
3625 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3626 }
3627 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3628 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 3629 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 3630 return NULL;
3631 }
a0d0e21e
LW		 3632 }
3633 else *(cp1++) = *cp2;
3634 }
3635 else *(cp1++) = *cp2;
3636 }
3637 while (*cp2) *(cp1++) = *(cp2++);
3638 *cp1 = '\0';
3639
3640 return rslt;
3641
3642} /* end of do_tounixspec() */
3643/*}}}*/
3644/* External entry points */
4b19af01
CB		 3645char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3646char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
a0d0e21e
LW		 3647
3648/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
4b19af01 3649static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
a0d0e21e 3650 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
e518068a 3651 char *rslt, *dirend;
3652 register char *cp1, *cp2;
3653 unsigned long int infront = 0, hasdir = 1;
a0d0e21e 3654
748a9306 3655 if (path == NULL) return NULL;
a0d0e21e 3656 if (buf) rslt = buf;
fc36a67e 3657 else if (ts) New(1316,rslt,strlen(path)+9,char);
a0d0e21e 3658 else rslt = __tovmsspec_retbuf;
748a9306 3659 if (strpbrk(path,"]:>") ||
a0d0e21e 3660 (dirend = strrchr(path,'/')) == NULL) {
748a9306
LW		 3661 if (path[0] == '.') {
3662 if (path[1] == '\0') strcpy(rslt,"[]");
3663 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3664 else strcpy(rslt,path); /* probably garbage */
3665 }
3666 else strcpy(rslt,path);
a0d0e21e
LW		 3667 return rslt;
3668 }
f86702cc 3669 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 3670 if (!*(dirend+2)) dirend +=2;
3671 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
f86702cc 3672 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 3673 }
a0d0e21e
LW		 3674 cp1 = rslt;
3675 cp2 = path;
3676 if (*cp2 == '/') {
e518068a 3677 char trndev[NAM$C_MAXRSS+1];
3678 int islnm, rooted;
3679 STRLEN trnend;
3680
b7ae7a0d 3681 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906
CB		 3682 if (!*(cp2+1)) {
3683 if (!buf & ts) Renew(rslt,18,char);
3684 strcpy(rslt,"sys$disk:[000000]");
3685 return rslt;
3686 }
a0d0e21e 3687 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 3688 *cp1 = '\0';
c07a80fd 3689 islnm = my_trnlnm(rslt,trndev,0);
e518068a 3690 trnend = islnm ? strlen(trndev) - 1 : 0;
3691 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3692 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3693 /* If the first element of the path is a logical name, determine
3694 * whether it has to be translated so we can add more directories. */
3695 if (!islnm || rooted) {
3696 *(cp1++) = ':';
3697 *(cp1++) = '[';
3698 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3699 else cp2++;
3700 }
3701 else {
3702 if (cp2 != dirend) {
3703 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3704 strcpy(rslt,trndev);
3705 cp1 = rslt + trnend;
3706 *(cp1++) = '.';
3707 cp2++;
3708 }
3709 else {
3710 *(cp1++) = ':';
3711 hasdir = 0;
3712 }
3713 }
748a9306 3714 }
a0d0e21e
LW		 3715 else {
3716 *(cp1++) = '[';
748a9306
LW		 3717 if (*cp2 == '.') {
3718 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3719 cp2 += 2; /* skip over "./" - it's redundant */
3720 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3721 }
3722 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3723 *(cp1++) = '-'; /* "../" --> "-" */
3724 cp2 += 3;
3725 }
f86702cc 3726 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3727 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3728 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3729 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3730 cp2 += 4;
3731 }
748a9306
LW		 3732 if (cp2 > dirend) cp2 = dirend;
3733 }
3734 else *(cp1++) = '.';
3735 }
3736 for (; cp2 < dirend; cp2++) {
3737 if (*cp2 == '/') {
01b8edb6 3738 if (*(cp2-1) == '/') continue;
748a9306
LW		 3739 if (*(cp1-1) != '.') *(cp1++) = '.';
3740 infront = 0;
3741 }
3742 else if (!infront && *cp2 == '.') {
01b8edb6 3743 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3744 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 3745 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3746 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 3747 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 3748 else { /* back up over previous directory name */
3749 cp1--;
3750 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3751 if (*(cp1-1) == '[') {
3752 memcpy(cp1,"000000.",7);
3753 cp1 += 7;
3754 }
748a9306
LW		 3755 }
3756 cp2 += 2;
01b8edb6 3757 if (cp2 == dirend) break;
748a9306 3758 }
f86702cc 3759 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3760 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3761 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3762 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3763 if (!*(cp2+3)) {
3764 *(cp1++) = '.'; /* Simulate trailing '/' */
3765 cp2 += 2; /* for loop will incr this to == dirend */
3766 }
3767 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3768 }
748a9306
LW		 3769 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3770 }
3771 else {
e518068a 3772 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
01b8edb6 3773 if (*cp2 == '.') *(cp1++) = '_';
748a9306
LW		 3774 else *(cp1++) = *cp2;
3775 infront = 1;
3776 }
a0d0e21e 3777 }
748a9306 3778 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 3779 if (hasdir) *(cp1++) = ']';
748a9306 3780 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
a0d0e21e
LW		 3781 while (*cp2) *(cp1++) = *(cp2++);
3782 *cp1 = '\0';
3783
3784 return rslt;
3785
3786} /* end of do_tovmsspec() */
3787/*}}}*/
3788/* External entry points */
4b19af01
CB		 3789char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3790char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
a0d0e21e
LW		 3791
3792/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
4b19af01 3793static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
a0d0e21e
LW		 3794 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3795 int vmslen;
3796 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3797
748a9306 3798 if (path == NULL) return NULL;
a0d0e21e
LW		 3799 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3800 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3801 if (buf) return buf;
3802 else if (ts) {
3803 vmslen = strlen(vmsified);
fc36a67e 3804 New(1317,cp,vmslen+1,char);
a0d0e21e
LW		 3805 memcpy(cp,vmsified,vmslen);
3806 cp[vmslen] = '\0';
3807 return cp;
3808 }
3809 else {
3810 strcpy(__tovmspath_retbuf,vmsified);
3811 return __tovmspath_retbuf;
3812 }
3813
3814} /* end of do_tovmspath() */
3815/*}}}*/
3816/* External entry points */
4b19af01
CB		 3817char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3818char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
a0d0e21e
LW		 3819
3820
3821/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
4b19af01 3822static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
a0d0e21e
LW		 3823 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3824 int unixlen;
3825 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3826
748a9306 3827 if (path == NULL) return NULL;
a0d0e21e
LW		 3828 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3829 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3830 if (buf) return buf;
3831 else if (ts) {
3832 unixlen = strlen(unixified);
fc36a67e 3833 New(1317,cp,unixlen+1,char);
a0d0e21e
LW		 3834 memcpy(cp,unixified,unixlen);
3835 cp[unixlen] = '\0';
3836 return cp;
3837 }
3838 else {
3839 strcpy(__tounixpath_retbuf,unixified);
3840 return __tounixpath_retbuf;
3841 }
3842
3843} /* end of do_tounixpath() */
3844/*}}}*/
3845/* External entry points */
4b19af01
CB		 3846char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3847char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
a0d0e21e
LW		 3848
3849/*
3850 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3851 *
3852 *****************************************************************************
3853 * *
3854 * Copyright (C) 1989-1994 by *
3855 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3856 * *
3857 * Permission is hereby granted for the reproduction of this software, *
3858 * on condition that this copyright notice is included in the reproduction, *
3859 * and that such reproduction is not for purposes of profit or material *
3860 * gain. *
3861 * *
3862 * 27-Aug-1994 Modified for inclusion in perl5 *
bd3fa61c 3863 * by Charles Bailey bailey@newman.upenn.edu *
a0d0e21e
LW		 3864 *****************************************************************************
3865 */
3866
3867/*
3868 * getredirection() is intended to aid in porting C programs
3869 * to VMS (Vax-11 C). The native VMS environment does not support
3870 * '>' and '<' I/O redirection, or command line wild card expansion,
3871 * or a command line pipe mechanism using the '|' AND background
3872 * command execution '&'. All of these capabilities are provided to any
3873 * C program which calls this procedure as the first thing in the
3874 * main program.
3875 * The piping mechanism will probably work with almost any 'filter' type
3876 * of program. With suitable modification, it may useful for other
3877 * portability problems as well.
3878 *
3879 * Author: Mark Pizzolato mark@infocomm.com
3880 */
3881struct list_item
3882 {
3883 struct list_item *next;
3884 char *value;
3885 };
3886
3887static void add_item(struct list_item **head,
3888 struct list_item **tail,
3889 char *value,
3890 int *count);
3891
4b19af01
CB		 3892static void mp_expand_wild_cards(pTHX_ char *item,
3893 struct list_item **head,
3894 struct list_item **tail,
3895 int *count);
a0d0e21e
LW		 3896
3897static int background_process(int argc, char **argv);
3898
fd8cd3a3 3899static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 3900
3901/*{{{ void getredirection(int *ac, char ***av)*/
84902520 3902static void
4b19af01 3903mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 3904/*
3905 * Process vms redirection arg's. Exit if any error is seen.
3906 * If getredirection() processes an argument, it is erased
3907 * from the vector. getredirection() returns a new argc and argv value.
3908 * In the event that a background command is requested (by a trailing "&"),
3909 * this routine creates a background subprocess, and simply exits the program.
3910 *
3911 * Warning: do not try to simplify the code for vms. The code
3912 * presupposes that getredirection() is called before any data is
3913 * read from stdin or written to stdout.
3914 *
3915 * Normal usage is as follows:
3916 *
3917 * main(argc, argv)
3918 * int argc;
3919 * char *argv[];
3920 * {
3921 * getredirection(&argc, &argv);
3922 * }
3923 */
3924{
3925 int argc = *ac; /* Argument Count */
3926 char **argv = *av; /* Argument Vector */
3927 char *ap; /* Argument pointer */
3928 int j; /* argv[] index */
3929 int item_count = 0; /* Count of Items in List */
3930 struct list_item *list_head = 0; /* First Item in List */
3931 struct list_item *list_tail; /* Last Item in List */
3932 char *in = NULL; /* Input File Name */
3933 char *out = NULL; /* Output File Name */
3934 char *outmode = "w"; /* Mode to Open Output File */
3935 char *err = NULL; /* Error File Name */
3936 char *errmode = "w"; /* Mode to Open Error File */
3937 int cmargc = 0; /* Piped Command Arg Count */
3938 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 3939
3940 /*
3941 * First handle the case where the last thing on the line ends with
3942 * a '&'. This indicates the desire for the command to be run in a
3943 * subprocess, so we satisfy that desire.
3944 */
3945 ap = argv[argc-1];
3946 if (0 == strcmp("&", ap))
3947 exit(background_process(--argc, argv));
e518068a 3948 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 3949 {
3950 ap[strlen(ap)-1] = '\0';
3951 exit(background_process(argc, argv));
3952 }
3953 /*
3954 * Now we handle the general redirection cases that involve '>', '>>',
3955 * '<', and pipes '|'.
3956 */
3957 for (j = 0; j < argc; ++j)
3958 {
3959 if (0 == strcmp("<", argv[j]))
3960 {
3961 if (j+1 >= argc)
3962 {
fd71b04b 3963 fprintf(stderr,"No input file after < on command line");
748a9306 3964 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3965 }
3966 in = argv[++j];
3967 continue;
3968 }
3969 if ('<' == *(ap = argv[j]))
3970 {
3971 in = 1 + ap;
3972 continue;
3973 }
3974 if (0 == strcmp(">", ap))
3975 {
3976 if (j+1 >= argc)
3977 {
fd71b04b 3978 fprintf(stderr,"No output file after > on command line");
748a9306 3979 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 3980 }
3981 out = argv[++j];
3982 continue;
3983 }
3984 if ('>' == *ap)
3985 {
3986 if ('>' == ap[1])
3987 {
3988 outmode = "a";
3989 if ('\0' == ap[2])
3990 out = argv[++j];
3991 else
3992 out = 2 + ap;
3993 }
3994 else
3995 out = 1 + ap;
3996 if (j >= argc)
3997 {
fd71b04b 3998 fprintf(stderr,"No output file after > or >> on command line");
748a9306 3999 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 4000 }
4001 continue;
4002 }
4003 if (('2' == *ap) && ('>' == ap[1]))
4004 {
4005 if ('>' == ap[2])
4006 {
4007 errmode = "a";
4008 if ('\0' == ap[3])
4009 err = argv[++j];
4010 else
4011 err = 3 + ap;
4012 }
4013 else
4014 if ('\0' == ap[2])
4015 err = argv[++j];
4016 else
748a9306 4017 err = 2 + ap;
a0d0e21e
LW		 4018 if (j >= argc)
4019 {
fd71b04b 4020 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 4021 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 4022 }
4023 continue;
4024 }
4025 if (0 == strcmp("|", argv[j]))
4026 {
4027 if (j+1 >= argc)
4028 {
fd71b04b 4029 fprintf(stderr,"No command into which to pipe on command line");
748a9306 4030 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 4031 }
4032 cmargc = argc-(j+1);
4033 cmargv = &argv[j+1];
4034 argc = j;
4035 continue;
4036 }
4037 if ('|' == *(ap = argv[j]))
4038 {
4039 ++argv[j];
4040 cmargc = argc-j;
4041 cmargv = &argv[j];
4042 argc = j;
4043 continue;
4044 }
4045 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4046 }
4047 /*
4048 * Allocate and fill in the new argument vector, Some Unix's terminate
4049 * the list with an extra null pointer.
4050 */
fc36a67e 4051 New(1302, argv, item_count+1, char *);
a0d0e21e
LW		 4052 *av = argv;
4053 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4054 argv[j] = list_head->value;
4055 *ac = item_count;
4056 if (cmargv != NULL)
4057 {
4058 if (out != NULL)
4059 {
fd71b04b 4060 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 4061 exit(LIB$_INVARGORD);
a0d0e21e 4062 }
fd8cd3a3 4063 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 4064 }
4065
4066 /* Check for input from a pipe (mailbox) */
4067
a5f75d66 4068 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 4069 {
4070 char mbxname[L_tmpnam];
4071 long int bufsize;
4072 long int dvi_item = DVI$_DEVBUFSIZ;
4073 $DESCRIPTOR(mbxnam, "");
4074 $DESCRIPTOR(mbxdevnam, "");
4075
4076 /* Input from a pipe, reopen it in binary mode to disable */
4077 /* carriage control processing. */
4078
fd71b04b 4079 fgetname(stdin, mbxname);
a0d0e21e
LW		 4080 mbxnam.dsc$a_pointer = mbxname;
4081 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4082 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4083 mbxdevnam.dsc$a_pointer = mbxname;
4084 mbxdevnam.dsc$w_length = sizeof(mbxname);
4085 dvi_item = DVI$_DEVNAM;
4086 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4087 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 4088 set_errno(0);
4089 set_vaxc_errno(1);
a0d0e21e
LW		 4090 freopen(mbxname, "rb", stdin);
4091 if (errno != 0)
4092 {
fd71b04b 4093 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 4094 exit(vaxc$errno);
a0d0e21e
LW		 4095 }
4096 }
4097 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4098 {
fd71b04b 4099 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 4100 exit(vaxc$errno);
a0d0e21e
LW		 4101 }
4102 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4103 {
fd71b04b 4104 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 4105 exit(vaxc$errno);
a0d0e21e 4106 }
fd8cd3a3 4107 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 4108
748a9306 4109 if (err != NULL) {
71d7ec5d 4110 if (strcmp(err,"&1") == 0) {
a15cef0c 4111 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 4112 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 4113 } else {
748a9306
LW		 4114 FILE *tmperr;
4115 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4116 {
fd71b04b 4117 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 4118 exit(vaxc$errno);
4119 }
4120 fclose(tmperr);
a15cef0c 4121 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 4122 {
4123 exit(vaxc$errno);
4124 }
fd8cd3a3 4125 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 4126 }
71d7ec5d 4127 }
a0d0e21e 4128#ifdef ARGPROC_DEBUG
740ce14c 4129 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 4130 for (j = 0; j < *ac; ++j)
740ce14c 4131 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 4132#endif
b7ae7a0d 4133 /* Clear errors we may have hit expanding wildcards, so they don't
4134 show up in Perl's $! later */
4135 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 4136} /* end of getredirection() */
4137/*}}}*/
4138
4139static void add_item(struct list_item **head,
4140 struct list_item **tail,
4141 char *value,
4142 int *count)
4143{
4144 if (*head == 0)
4145 {
fc36a67e 4146 New(1303,*head,1,struct list_item);
a0d0e21e
LW		 4147 *tail = *head;
4148 }
4149 else {
fc36a67e 4150 New(1304,(*tail)->next,1,struct list_item);
a0d0e21e
LW		 4151 *tail = (*tail)->next;
4152 }
4153 (*tail)->value = value;
4154 ++(*count);
4155}
4156
4b19af01 4157static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 4158 struct list_item **head,
4159 struct list_item **tail,
4160 int *count)
4161{
4162int expcount = 0;
748a9306 4163unsigned long int context = 0;
a0d0e21e 4164int isunix = 0;
a0d0e21e
LW		 4165char *had_version;
4166char *had_device;
4167int had_directory;
f675dbe5 4168char *devdir,*cp;
a0d0e21e
LW		 4169char vmsspec[NAM$C_MAXRSS+1];
4170$DESCRIPTOR(filespec, "");
748a9306 4171$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 4172$DESCRIPTOR(resultspec, "");
c07a80fd 4173unsigned long int zero = 0, sts;
a0d0e21e 4174
f675dbe5
CB		 4175 for (cp = item; *cp; cp++) {
4176 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4177 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4178 }
4179 if (!*cp || isspace(*cp))
a0d0e21e
LW		 4180 {
4181 add_item(head, tail, item, count);
4182 return;
4183 }
4184 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4185 resultspec.dsc$b_class = DSC$K_CLASS_D;
4186 resultspec.dsc$a_pointer = NULL;
748a9306 4187 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e
LW		 4188 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4189 if (!isunix || !filespec.dsc$a_pointer)
4190 filespec.dsc$a_pointer = item;
4191 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4192 /*
4193 * Only return version specs, if the caller specified a version
4194 */
4195 had_version = strchr(item, ';');
4196 /*
4197 * Only return device and directory specs, if the caller specifed either.
4198 */
4199 had_device = strchr(item, ':');
4200 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4201
c07a80fd 4202 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4203 &defaultspec, 0, 0, &zero))))
a0d0e21e
LW		 4204 {
4205 char *string;
4206 char *c;
4207
fc36a67e 4208 New(1305,string,resultspec.dsc$w_length+1,char);
a0d0e21e
LW		 4209 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4210 string[resultspec.dsc$w_length] = '\0';
4211 if (NULL == had_version)
4212 *((char *)strrchr(string, ';')) = '\0';
4213 if ((!had_directory) && (had_device == NULL))
4214 {
4215 if (NULL == (devdir = strrchr(string, ']')))
4216 devdir = strrchr(string, '>');
4217 strcpy(string, devdir + 1);
4218 }
4219 /*
4220 * Be consistent with what the C RTL has already done to the rest of
4221 * the argv items and lowercase all of these names.
4222 */
4223 for (c = string; *c; ++c)
4224 if (isupper(*c))
4225 *c = tolower(*c);
f86702cc 4226 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 4227 add_item(head, tail, string, count);
4228 ++expcount;
4229 }
c07a80fd 4230 if (sts != RMS$_NMF)
4231 {
4232 set_vaxc_errno(sts);
4233 switch (sts)
4234 {
f282b18d 4235 case RMS$_FNF: case RMS$_DNF:
c07a80fd 4236 set_errno(ENOENT); break;
f282b18d
CB		 4237 case RMS$_DIR:
4238 set_errno(ENOTDIR); break;
c07a80fd 4239 case RMS$_DEV:
4240 set_errno(ENODEV); break;
f282b18d 4241 case RMS$_FNM: case RMS$_SYN:
c07a80fd 4242 set_errno(EINVAL); break;
4243 case RMS$_PRV:
4244 set_errno(EACCES); break;
4245 default:
b7ae7a0d 4246 _ckvmssts_noperl(sts);
c07a80fd 4247 }
4248 }
a0d0e21e
LW		 4249 if (expcount == 0)
4250 add_item(head, tail, item, count);
b7ae7a0d 4251 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4252 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 4253}
4254
4255static int child_st[2];/* Event Flag set when child process completes */
4256
748a9306 4257static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 4258
748a9306 4259static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 4260{
4261short iosb[4];
4262
4263 if (0 == child_st[0])
4264 {
4265#ifdef ARGPROC_DEBUG
740ce14c 4266 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 4267#endif
4268 fflush(stdout); /* Have to flush pipe for binary data to */
4269 /* terminate properly -- <tp@mccall.com> */
4270 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4271 sys$dassgn(child_chan);
4272 fclose(stdout);
4273 sys$synch(0, child_st);
4274 }
4275 return(1);
4276}
4277
4278static void sig_child(int chan)
4279{
4280#ifdef ARGPROC_DEBUG
740ce14c 4281 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 4282#endif
4283 if (child_st[0] == 0)
4284 child_st[0] = 1;
4285}
4286
748a9306 4287static struct exit_control_block exit_block =
a0d0e21e
LW		 4288 {
4289 0,
4290 exit_handler,
4291 1,
4292 &exit_block.exit_status,
4293 0
4294 };
4295
ff7adb52
CL		 4296static void
4297pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 4298{
ff7adb52 4299 PerlIO *fp;
218fdd94 4300 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 4301 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4302 int sts, j, l, ismcr, quote, tquote = 0;
4303
218fdd94
CL		 4304 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
4305 vms_execfree(vmscmd);
ff7adb52
CL		 4306
4307 j = l = 0;
4308 p = subcmd;
4309 q = cmargv[0];
4310 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4311 && toupper(*(q+2)) == 'R' && !*(q+3);
4312
4313 while (q && l < MAX_DCL_LINE_LENGTH) {
4314 if (!*q) {
4315 if (j > 0 && quote) {
4316 *p++ = '"';
4317 l++;
4318 }
4319 q = cmargv[++j];
4320 if (q) {
4321 if (ismcr && j > 1) quote = 1;
4322 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4323 *p++ = ' ';
4324 l++;
4325 if (quote || tquote) {
4326 *p++ = '"';
4327 l++;
4328 }
4329 }
4330 } else {
4331 if ((quote||tquote) && *q == '"') {
4332 *p++ = '"';
4333 l++;
a0d0e21e 4334 }
ff7adb52
CL		 4335 *p++ = *q++;
4336 l++;
4337 }
4338 }
4339 *p = '\0';
a0d0e21e 4340
218fdd94 4341 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
ff7adb52
CL		 4342 if (fp == Nullfp) {
4343 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
a0d0e21e
LW		 4344 }
4345}
4346
4347static int background_process(int argc, char **argv)
4348{
4349char command[2048] = "$";
4350$DESCRIPTOR(value, "");
4351static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4352static $DESCRIPTOR(null, "NLA0:");
4353static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4354char pidstring[80];
4355$DESCRIPTOR(pidstr, "");
4356int pid;
748a9306 4357unsigned long int flags = 17, one = 1, retsts;
a0d0e21e
LW		 4358
4359 strcat(command, argv[0]);
4360 while (--argc)
4361 {
4362 strcat(command, " \"");
4363 strcat(command, *(++argv));
4364 strcat(command, "\"");
4365 }
4366 value.dsc$a_pointer = command;
4367 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 4368 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 4369 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4370 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 4371 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 4372 }
4373 else {
b7ae7a0d 4374 _ckvmssts_noperl(retsts);
748a9306 4375 }
a0d0e21e 4376#ifdef ARGPROC_DEBUG
740ce14c 4377 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 4378#endif
4379 sprintf(pidstring, "%08X", pid);
740ce14c 4380 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 4381 pidstr.dsc$a_pointer = pidstring;
4382 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4383 lib$set_symbol(&pidsymbol, &pidstr);
4384 return(SS$_NORMAL);
4385}
4386/*}}}*/
4387/***** End of code taken from Mark Pizzolato's argproc.c package *****/
4388
84902520
TB		 4389
4390/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 4391/* Older VAXC header files lack these constants */
4392#ifndef JPI$_RIGHTS_SIZE
4393# define JPI$_RIGHTS_SIZE 817
4394#endif
4395#ifndef KGB$M_SUBSYSTEM
4396# define KGB$M_SUBSYSTEM 0x8
4397#endif
4398
84902520
TB		 4399/*{{{void vms_image_init(int *, char ***)*/
4400void
4401vms_image_init(int *argcp, char ***argvp)
4402{
f675dbe5
CB		 4403 char eqv[LNM$C_NAMLENGTH+1] = "";
4404 unsigned int len, tabct = 8, tabidx = 0;
4405 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 4406 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4407 unsigned short int dummy, rlen;
f675dbe5 4408 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 4409#if defined(PERL_IMPLICIT_CONTEXT)
4410 pTHX = NULL;
4411#endif
61bb5906
CB		 4412 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4413 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4414 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4415 { 0, 0, 0, 0} };
84902520 4416
2e34cc90
CL		 4417#ifdef KILL_BY_SIGPRC
4418 (void) Perl_csighandler_init();
4419#endif
4420
fd8cd3a3
DS		 4421 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4422 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 4423 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4424 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 4425 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 4426 will_taint = TRUE;
84902520
TB		 4427 break;
4428 }
4429 }
61bb5906 4430 /* Rights identifiers might trigger tainting as well. */
f675dbe5 4431 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 4432 while (rlen < rsz) {
4433 /* We didn't get all the identifiers on the first pass. Allocate a
4434 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4435 * were needed to hold all identifiers at time of last call; we'll
4436 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 4437 * If it gave us less than it wanted to despite ample buffer space,
4438 * something's broken. Is your system missing a system identifier?
61bb5906 4439 */
22d4bb9c
CB		 4440 if (rsz <= jpilist[1].buflen) {
4441 /* Perl_croak accvios when used this early in startup. */
4442 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4443 rsz, (unsigned long) jpilist[1].buflen,
4444 "Check your rights database for corruption.\n");
4445 exit(SS$_ABORT);
4446 }
61bb5906
CB		 4447 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4448 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4449 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 4450 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4451 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 4452 }
4453 mask = jpilist[1].bufadr;
4454 /* Check attribute flags for each identifier (2nd longword); protected
4455 * subsystem identifiers trigger tainting.
4456 */
4457 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4458 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 4459 will_taint = TRUE;
61bb5906
CB		 4460 break;
4461 }
4462 }
4463 if (mask != rlst) Safefree(mask);
4464 }
4465 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 4466 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 4467 * hasn't been allocated when vms_image_init() is called.
4468 */
f675dbe5 4469 if (will_taint) {
61bb5906
CB		 4470 char ***newap;
4471 New(1320,newap,*argcp+2,char **);
4472 newap[0] = argvp[0];
4473 *newap[1] = "-T";
4474 Copy(argvp[1],newap[2],*argcp-1,char **);
4475 /* We orphan the old argv, since we don't know where it's come from,
4476 * so we don't know how to free it.
4477 */
4478 *argcp++; argvp = newap;
4479 }
f675dbe5
CB		 4480 else { /* Did user explicitly request tainting? */
4481 int i;
4482 char *cp, **av = *argvp;
4483 for (i = 1; i < *argcp; i++) {
4484 if (*av[i] != '-') break;
4485 for (cp = av[i]+1; *cp; cp++) {
4486 if (*cp == 'T') { will_taint = 1; break; }
4487 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4488 strchr("DFIiMmx",*cp)) break;
4489 }
4490 if (will_taint) break;
4491 }
4492 }
4493
4494 for (tabidx = 0;
4495 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4496 tabidx++) {
4497 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4498 else if (tabidx >= tabct) {
4499 tabct += 8;
4500 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4501 }
4502 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4503 tabvec[tabidx]->dsc$w_length = 0;
4504 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4505 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4506 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 4507 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 4508 }
4509 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4510
84902520 4511 getredirection(argcp,argvp);
4d1ff10f 4512#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
09b7f37c
CB		 4513 {
4514# include <reentrancy.h>
4515 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4516 }
4517#endif
84902520
TB		 4518 return;
4519}
4520/*}}}*/
4521
4522
a0d0e21e
LW		 4523/* trim_unixpath()
4524 * Trim Unix-style prefix off filespec, so it looks like what a shell
4525 * glob expansion would return (i.e. from specified prefix on, not
4526 * full path). Note that returned filespec is Unix-style, regardless
4527 * of whether input filespec was VMS-style or Unix-style.
4528 *
a3e9d8c9 4529 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 4530 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4531 * vector of options; at present, only bit 0 is used, and if set tells
4532 * trim unixpath to try the current default directory as a prefix when
4533 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 4534 *
4535 * Returns !=0 on success, with trimmed filespec replacing contents of
4536 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 4537 */
f86702cc 4538/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 4539int
4b19af01 4540Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
a0d0e21e 4541{
a3e9d8c9 4542 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
f86702cc 4543 *template, *base, *end, *cp1, *cp2;
4544 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 4545
a3e9d8c9 4546 if (!wildspec || !fspec) return 0;
4547 if (strpbrk(wildspec,"]>:") != NULL) {
4548 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
f86702cc 4549 else template = unixwild;
a3e9d8c9 4550 }
4551 else template = wildspec;
a0d0e21e
LW		 4552 if (strpbrk(fspec,"]>:") != NULL) {
4553 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4554 else base = unixified;
a3e9d8c9 4555 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4556 * check to see that final result fits into (isn't longer than) fspec */
4557 reslen = strlen(fspec);
a0d0e21e
LW		 4558 }
4559 else base = fspec;
a3e9d8c9 4560
4561 /* No prefix or absolute path on wildcard, so nothing to remove */
4562 if (!*template || *template == '/') {
4563 if (base == fspec) return 1;
4564 tmplen = strlen(unixified);
4565 if (tmplen > reslen) return 0; /* not enough space */
4566 /* Copy unixified resultant, including trailing NUL */
4567 memmove(fspec,unixified,tmplen+1);
4568 return 1;
4569 }
a0d0e21e 4570
f86702cc 4571 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4572 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4573 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4574 for (cp1 = end ;cp1 >= base; cp1--)
4575 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4576 { cp1++; break; }
4577 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
a3e9d8c9 4578 return 1;
4579 }
f86702cc 4580 else {
4581 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4582 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4583 int ells = 1, totells, segdirs, match;
4584 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4585 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4586
4587 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4588 totells = ells;
4589 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4590 if (ellipsis == template && opts & 1) {
4591 /* Template begins with an ellipsis. Since we can't tell how many
4592 * directory names at the front of the resultant to keep for an
4593 * arbitrary starting point, we arbitrarily choose the current
4594 * default directory as a starting point. If it's there as a prefix,
4595 * clip it off. If not, fall through and act as if the leading
4596 * ellipsis weren't there (i.e. return shortest possible path that
4597 * could match template).
4598 */
4599 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4600 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4601 if (_tolower(*cp1) != _tolower(*cp2)) break;
4602 segdirs = dirs - totells; /* Min # of dirs we must have left */
4603 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4604 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4605 memcpy(fspec,cp2+1,end - cp2);
4606 return 1;
a3e9d8c9 4607 }
a3e9d8c9 4608 }
f86702cc 4609 /* First off, back up over constant elements at end of path */
4610 if (dirs) {
4611 for (front = end ; front >= base; front--)
4612 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 4613 }
17f28c40 4614 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
f86702cc 4615 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4616 if (cp1 != '\0') return 0; /* Path too long. */
4617 lcend = cp2;
4618 *cp2 = '\0'; /* Pick up with memcpy later */
4619 lcfront = lcres + (front - base);
4620 /* Now skip over each ellipsis and try to match the path in front of it. */
4621 while (ells--) {
4622 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4623 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4624 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4625 if (cp1 < template) break; /* template started with an ellipsis */
4626 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4627 ellipsis = cp1; continue;
4628 }
4629 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4630 nextell = cp1;
4631 for (segdirs = 0, cp2 = tpl;
4632 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4633 cp1++, cp2++) {
4634 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4635 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4636 if (*cp2 == '/') segdirs++;
4637 }
4638 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4639 /* Back up at least as many dirs as in template before matching */
4640 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4641 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4642 for (match = 0; cp1 > lcres;) {
4643 resdsc.dsc$a_pointer = cp1;
4644 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4645 match++;
4646 if (match == 1) lcfront = cp1;
4647 }
4648 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4649 }
4650 if (!match) return 0; /* Can't find prefix ??? */
4651 if (match > 1 && opts & 1) {
4652 /* This ... wildcard could cover more than one set of dirs (i.e.
4653 * a set of similar dir names is repeated). If the template
4654 * contains more than 1 ..., upstream elements could resolve the
4655 * ambiguity, but it's not worth a full backtracking setup here.
4656 * As a quick heuristic, clip off the current default directory
4657 * if it's present to find the trimmed spec, else use the
4658 * shortest string that this ... could cover.
4659 */
4660 char def[NAM$C_MAXRSS+1], *st;
4661
4662 if (getcwd(def, sizeof def,0) == NULL) return 0;
4663 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4664 if (_tolower(*cp1) != _tolower(*cp2)) break;
4665 segdirs = dirs - totells; /* Min # of dirs we must have left */
4666 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4667 if (*cp1 == '\0' && *cp2 == '/') {
4668 memcpy(fspec,cp2+1,end - cp2);
4669 return 1;
4670 }
4671 /* Nope -- stick with lcfront from above and keep going. */
4672 }
4673 }
4674 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
a3e9d8c9 4675 return 1;
f86702cc 4676 ellipsis = nextell;
a0d0e21e 4677 }
a0d0e21e
LW		 4678
4679} /* end of trim_unixpath() */
4680/*}}}*/
4681
a0d0e21e
LW		 4682
4683/*
4684 * VMS readdir() routines.
4685 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 4686 *
bd3fa61c 4687 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 4688 * Minor modifications to original routines.
4689 */
4690
4691 /* Number of elements in vms_versions array */
4692#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4693
4694/*
4695 * Open a directory, return a handle for later use.
4696 */
4697/*{{{ DIR *opendir(char*name) */
4698DIR *
4b19af01 4699Perl_opendir(pTHX_ char *name)
a0d0e21e
LW		 4700{
4701 DIR *dd;
4702 char dir[NAM$C_MAXRSS+1];
61bb5906
CB		 4703 Stat_t sb;
4704
a0d0e21e 4705 if (do_tovmspath(name,dir,0) == NULL) {
61bb5906 4706 return NULL;
a0d0e21e 4707 }
61bb5906
CB		 4708 if (flex_stat(dir,&sb) == -1) return NULL;
4709 if (!S_ISDIR(sb.st_mode)) {
4710 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4711 return NULL;
4712 }
4713 if (!cando_by_name(S_IRUSR,0,dir)) {
4714 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4715 return NULL;
4716 }
4717 /* Get memory for the handle, and the pattern. */
4718 New(1306,dd,1,DIR);
fc36a67e 4719 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 4720
4721 /* Fill in the fields; mainly playing with the descriptor. */
4722 (void)sprintf(dd->pattern, "%s*.*",dir);
4723 dd->context = 0;
4724 dd->count = 0;
4725 dd->vms_wantversions = 0;
4726 dd->pat.dsc$a_pointer = dd->pattern;
4727 dd->pat.dsc$w_length = strlen(dd->pattern);
4728 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4729 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4730
4731 return dd;
4732} /* end of opendir() */
4733/*}}}*/
4734
4735/*
4736 * Set the flag to indicate we want versions or not.
4737 */
4738/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4739void
4740vmsreaddirversions(DIR *dd, int flag)
4741{
4742 dd->vms_wantversions = flag;
4743}
4744/*}}}*/
4745
4746/*
4747 * Free up an opened directory.
4748 */
4749/*{{{ void closedir(DIR *dd)*/
4750void
4751closedir(DIR *dd)
4752{
4753 (void)lib$find_file_end(&dd->context);
4754 Safefree(dd->pattern);
4755 Safefree((char *)dd);
4756}
4757/*}}}*/
4758
4759/*
4760 * Collect all the version numbers for the current file.
4761 */
4762static void
fd8cd3a3 4763collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 4764{
4765 struct dsc$descriptor_s pat;
4766 struct dsc$descriptor_s res;
4767 struct dirent *e;
4768 char *p, *text, buff[sizeof dd->entry.d_name];
4769 int i;
4770 unsigned long context, tmpsts;
4771
4772 /* Convenient shorthand. */
4773 e = &dd->entry;
4774
4775 /* Add the version wildcard, ignoring the "*.*" put on before */
4776 i = strlen(dd->pattern);
fc36a67e 4777 New(1308,text,i + e->d_namlen + 3,char);
a0d0e21e
LW		 4778 (void)strcpy(text, dd->pattern);
4779 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4780
4781 /* Set up the pattern descriptor. */
4782 pat.dsc$a_pointer = text;
4783 pat.dsc$w_length = i + e->d_namlen - 1;
4784 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4785 pat.dsc$b_class = DSC$K_CLASS_S;
4786
4787 /* Set up result descriptor. */
4788 res.dsc$a_pointer = buff;
4789 res.dsc$w_length = sizeof buff - 2;
4790 res.dsc$b_dtype = DSC$K_DTYPE_T;
4791 res.dsc$b_class = DSC$K_CLASS_S;
4792
4793 /* Read files, collecting versions. */
4794 for (context = 0, e->vms_verscount = 0;
4795 e->vms_verscount < VERSIZE(e);
4796 e->vms_verscount++) {
4797 tmpsts = lib$find_file(&pat, &res, &context);
4798 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 4799 _ckvmssts(tmpsts);
a0d0e21e 4800 buff[sizeof buff - 1] = '\0';
748a9306 4801 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 4802 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4803 else
4804 e->vms_versions[e->vms_verscount] = -1;
4805 }
4806
748a9306 4807 _ckvmssts(lib$find_file_end(&context));
a0d0e21e
LW		 4808 Safefree(text);
4809
4810} /* end of collectversions() */
4811
4812/*
4813 * Read the next entry from the directory.
4814 */
4815/*{{{ struct dirent *readdir(DIR *dd)*/
4816struct dirent *
fd8cd3a3 4817Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 4818{
4819 struct dsc$descriptor_s res;
4820 char *p, buff[sizeof dd->entry.d_name];
a0d0e21e
LW		 4821 unsigned long int tmpsts;
4822
4823 /* Set up result descriptor, and get next file. */
4824 res.dsc$a_pointer = buff;
4825 res.dsc$w_length = sizeof buff - 2;
4826 res.dsc$b_dtype = DSC$K_DTYPE_T;
4827 res.dsc$b_class = DSC$K_CLASS_S;
a0d0e21e 4828 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4633a7c4
LW		 4829 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4830 if (!(tmpsts & 1)) {
4831 set_vaxc_errno(tmpsts);
4832 switch (tmpsts) {
4833 case RMS$_PRV:
c07a80fd 4834 set_errno(EACCES); break;
4633a7c4 4835 case RMS$_DEV:
c07a80fd 4836 set_errno(ENODEV); break;
4633a7c4 4837 case RMS$_DIR:
f282b18d
CB		 4838 set_errno(ENOTDIR); break;
4839 case RMS$_FNF: case RMS$_DNF:
c07a80fd 4840 set_errno(ENOENT); break;
4633a7c4
LW		 4841 default:
4842 set_errno(EVMSERR);
4843 }
4844 return NULL;
4845 }
4846 dd->count++;
a0d0e21e
LW		 4847 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4848 buff[sizeof buff - 1] = '\0';
f675dbe5
CB		 4849 for (p = buff; *p; p++) *p = _tolower(*p);
4850 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
a0d0e21e
LW		 4851 *p = '\0';
4852
4853 /* Skip any directory component and just copy the name. */
748a9306 4854 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
a0d0e21e
LW		 4855 else (void)strcpy(dd->entry.d_name, buff);
4856
4857 /* Clobber the version. */
748a9306 4858 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
a0d0e21e
LW		 4859
4860 dd->entry.d_namlen = strlen(dd->entry.d_name);
4861 dd->entry.vms_verscount = 0;
fd8cd3a3 4862 if (dd->vms_wantversions) collectversions(aTHX_ dd);
a0d0e21e
LW		 4863 return &dd->entry;
4864
4865} /* end of readdir() */
4866/*}}}*/
4867
4868/*
4869 * Return something that can be used in a seekdir later.
4870 */
4871/*{{{ long telldir(DIR *dd)*/
4872long
4873telldir(DIR *dd)
4874{
4875 return dd->count;
4876}
4877/*}}}*/
4878
4879/*
4880 * Return to a spot where we used to be. Brute force.
4881 */
4882/*{{{ void seekdir(DIR *dd,long count)*/
4883void
fd8cd3a3 4884Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e
LW		 4885{
4886 int vms_wantversions;
a0d0e21e
LW		 4887
4888 /* If we haven't done anything yet... */
4889 if (dd->count == 0)
4890 return;
4891
4892 /* Remember some state, and clear it. */
4893 vms_wantversions = dd->vms_wantversions;
4894 dd->vms_wantversions = 0;
748a9306 4895 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 4896 dd->context = 0;
4897
4898 /* The increment is in readdir(). */
4899 for (dd->count = 0; dd->count < count; )
4900 (void)readdir(dd);
4901
4902 dd->vms_wantversions = vms_wantversions;
4903
4904} /* end of seekdir() */
4905/*}}}*/
4906
4907/* VMS subprocess management
4908 *
4909 * my_vfork() - just a vfork(), after setting a flag to record that
4910 * the current script is trying a Unix-style fork/exec.
4911 *
4912 * vms_do_aexec() and vms_do_exec() are called in response to the
4913 * perl 'exec' function. If this follows a vfork call, then they
4914 * call out the the regular perl routines in doio.c which do an
4915 * execvp (for those who really want to try this under VMS).
4916 * Otherwise, they do exactly what the perl docs say exec should
4917 * do - terminate the current script and invoke a new command
4918 * (See below for notes on command syntax.)
4919 *
4920 * do_aspawn() and do_spawn() implement the VMS side of the perl
4921 * 'system' function.
4922 *
4923 * Note on command arguments to perl 'exec' and 'system': When handled
4924 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4925 * are concatenated to form a DCL command string. If the first arg
4926 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3eeba6fb 4927 * the the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 4928 * the first token of the command is taken as the filespec of an image
4929 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 4930 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 4931 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 4932 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 4933 * but I hope it will form a happy medium between what VMS folks expect
4934 * from lib$spawn and what Unix folks expect from exec.
4935 */
4936
4937static int vfork_called;
4938
4939/*{{{int my_vfork()*/
4940int
4941my_vfork()
4942{
748a9306 4943 vfork_called++;
a0d0e21e
LW		 4944 return vfork();
4945}
4946/*}}}*/
4947
4633a7c4 4948
a0d0e21e 4949static void
218fdd94
CL		 4950vms_execfree(struct dsc$descriptor_s *vmscmd)
4951{
4952 if (vmscmd) {
4953 if (vmscmd->dsc$a_pointer) {
4954 Safefree(vmscmd->dsc$a_pointer);
4955 }
4956 Safefree(vmscmd);
4633a7c4
LW		 4957 }
4958}
4959
4960static char *
fd8cd3a3 4961setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 4962{
4633a7c4 4963 char *junk, *tmps = Nullch;
a0d0e21e
LW		 4964 register size_t cmdlen = 0;
4965 size_t rlen;
4966 register SV **idx;
2d8e6c8d 4967 STRLEN n_a;
a0d0e21e
LW		 4968
4969 idx = mark;
4633a7c4
LW		 4970 if (really) {
4971 tmps = SvPV(really,rlen);
4972 if (*tmps) {
4973 cmdlen += rlen + 1;
4974 idx++;
4975 }
a0d0e21e
LW		 4976 }
4977
4978 for (idx++; idx <= sp; idx++) {
4979 if (*idx) {
4980 junk = SvPVx(*idx,rlen);
4981 cmdlen += rlen ? rlen + 1 : 0;
4982 }
4983 }
6b88bc9c 4984 New(401,PL_Cmd,cmdlen+1,char);
a0d0e21e 4985
4633a7c4 4986 if (tmps && *tmps) {
6b88bc9c 4987 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 4988 mark++;
4989 }
6b88bc9c 4990 else *PL_Cmd = '\0';
a0d0e21e
LW		 4991 while (++mark <= sp) {
4992 if (*mark) {
3eeba6fb
CB		 4993 char *s = SvPVx(*mark,n_a);
4994 if (!*s) continue;
4995 if (*PL_Cmd) strcat(PL_Cmd," ");
4996 strcat(PL_Cmd,s);
a0d0e21e
LW		 4997 }
4998 }
6b88bc9c 4999 return PL_Cmd;
a0d0e21e
LW		 5000
5001} /* end of setup_argstr() */
5002
4633a7c4 5003
a0d0e21e 5004static unsigned long int
218fdd94
CL		 5005setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5006 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 5007{
aa779de1 5008 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
a0d0e21e 5009 $DESCRIPTOR(defdsc,".EXE");
8012a33e 5010 $DESCRIPTOR(defdsc2,".");
a0d0e21e 5011 $DESCRIPTOR(resdsc,resspec);
218fdd94 5012 struct dsc$descriptor_s *vmscmd;
a0d0e21e 5013 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 5014 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1
CB		 5015 register char *s, *rest, *cp, *wordbreak;
5016 register int isdcl;
a0d0e21e 5017
218fdd94
CL		 5018 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5019 vmscmd->dsc$a_pointer = NULL;
5020 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5021 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5022 vmscmd->dsc$w_length = 0;
5023 if (pvmscmd) *pvmscmd = vmscmd;
5024
ff7adb52
CL		 5025 if (suggest_quote) *suggest_quote = 0;
5026
a2669cfc
JH		 5027 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5028 return CLI$_BUFOVF; /* continuation lines currently unsupported */
a0d0e21e
LW		 5029 s = cmd;
5030 while (*s && isspace(*s)) s++;
aa779de1
CB		 5031
5032 if (*s == '@' || *s == '$') {
5033 vmsspec[0] = *s; rest = s + 1;
5034 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5035 }
5036 else { cp = vmsspec; rest = s; }
5037 if (*rest == '.' || *rest == '/') {
5038 char *cp2;
5039 for (cp2 = resspec;
5040 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5041 rest++, cp2++) *cp2 = *rest;
5042 *cp2 = '\0';
5043 if (do_tovmsspec(resspec,cp,0)) {
5044 s = vmsspec;
5045 if (*rest) {
5046 for (cp2 = vmsspec + strlen(vmsspec);
5047 *rest && cp2 - vmsspec < sizeof vmsspec;
5048 rest++, cp2++) *cp2 = *rest;
5049 *cp2 = '\0';
a0d0e21e
LW		 5050 }
5051 }
5052 }
aa779de1
CB		 5053 /* Intuit whether verb (first word of cmd) is a DCL command:
5054 * - if first nonspace char is '@', it's a DCL indirection
5055 * otherwise
5056 * - if verb contains a filespec separator, it's not a DCL command
5057 * - if it doesn't, caller tells us whether to default to a DCL
5058 * command, or to a local image unless told it's DCL (by leading '$')
5059 */
ff7adb52
CL		 5060 if (*s == '@') {
5061 isdcl = 1;
5062 if (suggest_quote) *suggest_quote = 1;
5063 } else {
aa779de1
CB		 5064 register char *filespec = strpbrk(s,":<[.;");
5065 rest = wordbreak = strpbrk(s," \"\t/");
5066 if (!wordbreak) wordbreak = s + strlen(s);
5067 if (*s == '$') check_img = 0;
5068 if (filespec && (filespec < wordbreak)) isdcl = 0;
5069 else isdcl = !check_img;
5070 }
5071
3eeba6fb 5072 if (!isdcl) {
aa779de1
CB		 5073 imgdsc.dsc$a_pointer = s;
5074 imgdsc.dsc$w_length = wordbreak - s;
a0d0e21e 5075 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8012a33e
CB		 5076 if (!(retsts&1)) {
5077 _ckvmssts(lib$find_file_end(&cxt));
5078 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
aa779de1 5079 if (!(retsts & 1) && *s == '$') {
8012a33e 5080 _ckvmssts(lib$find_file_end(&cxt));
aa779de1
CB		 5081 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5082 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8012a33e 5083 if (!(retsts&1)) {
748a9306 5084 _ckvmssts(lib$find_file_end(&cxt));
8012a33e
CB		 5085 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5086 }
5087 }
aa779de1 5088 }
8012a33e
CB		 5089 _ckvmssts(lib$find_file_end(&cxt));
5090
aa779de1 5091 if (retsts & 1) {
8012a33e 5092 FILE *fp;
a0d0e21e
LW		 5093 s = resspec;
5094 while (*s && !isspace(*s)) s++;
5095 *s = '\0';
8012a33e
CB		 5096
5097 /* check that it's really not DCL with no file extension */
5098 fp = fopen(resspec,"r","ctx=bin,shr=get");
5099 if (fp) {
5100 char b[4] = {0,0,0,0};
5101 read(fileno(fp),b,4);
5102 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5103 fclose(fp);
5104 }
5105 if (check_img && isdcl) return RMS$_FNF;
5106
3eeba6fb 5107 if (cando_by_name(S_IXUSR,0,resspec)) {
218fdd94 5108 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
8012a33e 5109 if (!isdcl) {
218fdd94 5110 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
ff7adb52 5111 if (suggest_quote) *suggest_quote = 1;
8012a33e 5112 } else {
218fdd94 5113 strcpy(vmscmd->dsc$a_pointer,"@");
ff7adb52 5114 if (suggest_quote) *suggest_quote = 1;
8012a33e 5115 }
218fdd94
CL		 5116 strcat(vmscmd->dsc$a_pointer,resspec);
5117 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5118 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5119 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb
CB		 5120 }
5121 else retsts = RMS$_PRV;
a0d0e21e
LW		 5122 }
5123 }
3eeba6fb 5124 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94
CL		 5125 vmscmd->dsc$w_length = strlen(cmd);
5126/* if (cmd == PL_Cmd) {
5127 vmscmd->dsc$a_pointer = PL_Cmd;
ff7adb52
CL		 5128 if (suggest_quote) *suggest_quote = 1;
5129 }
218fdd94
CL		 5130 else */
5131 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
ff7adb52
CL		 5132
5133 /* check if it's a symbol (for quoting purposes) */
5134 if (suggest_quote && !*suggest_quote) {
5135 int iss;
5136 char equiv[LNM$C_NAMLENGTH];
5137 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5138 eqvdsc.dsc$a_pointer = equiv;
5139
218fdd94 5140 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 5141 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5142 }
3eeba6fb
CB		 5143 if (!(retsts & 1)) {
5144 /* just hand off status values likely to be due to user error */
5145 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5146 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5147 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5148 else { _ckvmssts(retsts); }
5149 }
a0d0e21e 5150
218fdd94 5151 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 5152
a0d0e21e
LW		 5153} /* end of setup_cmddsc() */
5154
a3e9d8c9 5155
a0d0e21e
LW		 5156/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5157bool
fd8cd3a3 5158Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 5159{
a0d0e21e
LW		 5160 if (sp > mark) {
5161 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 5162 vfork_called--;
5163 if (vfork_called < 0) {
5c84aa53 5164 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 5165 vfork_called = 0;
5166 }
5167 else return do_aexec(really,mark,sp);
a0d0e21e 5168 }
4633a7c4 5169 /* no vfork - act VMSish */
fd8cd3a3 5170 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
748a9306 5171
a0d0e21e
LW		 5172 }
5173
5174 return FALSE;
5175} /* end of vms_do_aexec() */
5176/*}}}*/
5177
5178/* {{{bool vms_do_exec(char *cmd) */
5179bool
fd8cd3a3 5180Perl_vms_do_exec(pTHX_ char *cmd)
a0d0e21e 5181{
218fdd94 5182 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 5183
5184 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 5185 vfork_called--;
5186 if (vfork_called < 0) {
5c84aa53 5187 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 5188 vfork_called = 0;
5189 }
5190 else return do_exec(cmd);
a0d0e21e 5191 }
748a9306
LW		 5192
5193 { /* no vfork - act VMSish */
748a9306 5194 unsigned long int retsts;
a0d0e21e 5195
1e422769 5196 TAINT_ENV();
5197 TAINT_PROPER("exec");
218fdd94
CL		 5198 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5199 retsts = lib$do_command(vmscmd);
a0d0e21e 5200
09b7f37c 5201 switch (retsts) {
f282b18d 5202 case RMS$_FNF: case RMS$_DNF:
09b7f37c 5203 set_errno(ENOENT); break;
f282b18d 5204 case RMS$_DIR:
09b7f37c 5205 set_errno(ENOTDIR); break;
f282b18d
CB		 5206 case RMS$_DEV:
5207 set_errno(ENODEV); break;
09b7f37c
CB		 5208 case RMS$_PRV:
5209 set_errno(EACCES); break;
5210 case RMS$_SYN:
5211 set_errno(EINVAL); break;
a2669cfc 5212 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 5213 set_errno(E2BIG); break;
5214 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5215 _ckvmssts(retsts); /* fall through */
5216 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5217 set_errno(EVMSERR);
5218 }
748a9306 5219 set_vaxc_errno(retsts);
3eeba6fb 5220 if (ckWARN(WARN_EXEC)) {
5c84aa53 5221 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
218fdd94 5222 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 5223 }
218fdd94 5224 vms_execfree(vmscmd);
a0d0e21e
LW		 5225 }
5226
5227 return FALSE;
5228
5229} /* end of vms_do_exec() */
5230/*}}}*/
5231
fd8cd3a3 5232unsigned long int Perl_do_spawn(pTHX_ char *);
a0d0e21e 5233
61bb5906 5234/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
a0d0e21e 5235unsigned long int
fd8cd3a3 5236Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
a0d0e21e 5237{
fd8cd3a3 5238 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
a0d0e21e
LW		 5239
5240 return SS$_ABORT;
5241} /* end of do_aspawn() */
5242/*}}}*/
5243
5244/* {{{unsigned long int do_spawn(char *cmd) */
5245unsigned long int
fd8cd3a3 5246Perl_do_spawn(pTHX_ char *cmd)
a0d0e21e 5247{
209030df 5248 unsigned long int sts, substs;
a0d0e21e 5249
1e422769 5250 TAINT_ENV();
5251 TAINT_PROPER("spawn");
748a9306 5252 if (!cmd || !*cmd) {
09b7f37c 5253 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 5254 if (!(sts & 1)) {
5255 switch (sts) {
209030df
JH		 5256 case RMS$_FNF: case RMS$_DNF:
5257 set_errno(ENOENT); break;
5258 case RMS$_DIR:
5259 set_errno(ENOTDIR); break;
5260 case RMS$_DEV:
5261 set_errno(ENODEV); break;
5262 case RMS$_PRV:
5263 set_errno(EACCES); break;
5264 case RMS$_SYN:
5265 set_errno(EINVAL); break;
5266 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5267 set_errno(E2BIG); break;
5268 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5269 _ckvmssts(sts); /* fall through */
5270 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5271 set_errno(EVMSERR);
c8795d8b
JH		 5272 }
5273 set_vaxc_errno(sts);
5274 if (ckWARN(WARN_EXEC)) {
209030df 5275 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
c8795d8b
JH		 5276 Strerror(errno));
5277 }
09b7f37c 5278 }
c8795d8b 5279 sts = substs;
48023aa8
CL		 5280 }
5281 else {
218fdd94 5282 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
48023aa8 5283 }
48023aa8 5284 return sts;
a0d0e21e
LW		 5285} /* end of do_spawn() */
5286/*}}}*/
5287
bc10a425
CB		 5288
5289static unsigned int *sockflags, sockflagsize;
5290
5291/*
5292 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5293 * routines found in some versions of the CRTL can't deal with sockets.
5294 * We don't shim the other file open routines since a socket isn't
5295 * likely to be opened by a name.
5296 */
275feba9
CB		 5297/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5298FILE *my_fdopen(int fd, const char *mode)
bc10a425 5299{
275feba9 5300 FILE *fp = fdopen(fd, (char *) mode);
bc10a425
CB		 5301
5302 if (fp) {
5303 unsigned int fdoff = fd / sizeof(unsigned int);
5304 struct stat sbuf; /* native stat; we don't need flex_stat */
5305 if (!sockflagsize || fdoff > sockflagsize) {
5306 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5307 else New (1324,sockflags,fdoff+2,unsigned int);
5308 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5309 sockflagsize = fdoff + 2;
5310 }
5311 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5312 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5313 }
5314 return fp;
5315
5316}
5317/*}}}*/
5318
5319
5320/*
5321 * Clear the corresponding bit when the (possibly) socket stream is closed.
5322 * There still a small hole: we miss an implicit close which might occur
5323 * via freopen(). >> Todo
5324 */
5325/*{{{ int my_fclose(FILE *fp)*/
5326int my_fclose(FILE *fp) {
5327 if (fp) {
5328 unsigned int fd = fileno(fp);
5329 unsigned int fdoff = fd / sizeof(unsigned int);
5330
5331 if (sockflagsize && fdoff <= sockflagsize)
5332 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5333 }
5334 return fclose(fp);
5335}
5336/*}}}*/
5337
5338
a0d0e21e
LW		 5339/*
5340 * A simple fwrite replacement which outputs itmsz*nitm chars without
5341 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 5342 * We are using fputs, which depends on a terminating null. We may
5343 * well be writing binary data, so we need to accommodate not only
5344 * data with nulls sprinkled in the middle but also data with no null
5345 * byte at the end.
a0d0e21e 5346 */
a15cef0c 5347/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 5348int
a15cef0c 5349my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 5350{
22d4bb9c 5351 register char *cp, *end, *cpd, *data;
bc10a425
CB		 5352 register unsigned int fd = fileno(dest);
5353 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 5354 int retval;
bc10a425
CB		 5355 int bufsize = itmsz * nitm + 1;
5356
5357 if (fdoff < sockflagsize &&
5358 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5359 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5360 return nitm;
5361 }
22d4bb9c 5362
bc10a425 5363 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 5364 memcpy( data, src, itmsz*nitm );
5365 data[itmsz*nitm] = '\0';
a0d0e21e 5366
22d4bb9c
CB		 5367 end = data + itmsz * nitm;
5368 retval = (int) nitm; /* on success return # items written */
a0d0e21e 5369
22d4bb9c
CB		 5370 cpd = data;
5371 while (cpd <= end) {
5372 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5373 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 5374 if (cp < end)
22d4bb9c
CB		 5375 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5376 cpd = cp + 1;
a0d0e21e
LW		 5377 }
5378
bc10a425 5379 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 5380 return retval;
a0d0e21e
LW		 5381
5382} /* end of my_fwrite() */
5383/*}}}*/
5384
d27fe803
JH		 5385/*{{{ int my_flush(FILE *fp)*/
5386int
fd8cd3a3 5387Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 5388{
5389 int res;
93948341 5390 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 5391#ifdef VMS_DO_SOCKETS
61bb5906 5392 Stat_t s;
d27fe803
JH		 5393 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5394#endif
5395 res = fsync(fileno(fp));
5396 }
22d4bb9c
CB		 5397/*
5398 * If the flush succeeded but set end-of-file, we need to clear
5399 * the error because our caller may check ferror(). BTW, this
5400 * probably means we just flushed an empty file.
5401 */
5402 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5403
d27fe803
JH		 5404 return res;
5405}
5406/*}}}*/
5407
748a9306
LW		 5408/*
5409 * Here are replacements for the following Unix routines in the VMS environment:
5410 * getpwuid Get information for a particular UIC or UID
5411 * getpwnam Get information for a named user
5412 * getpwent Get information for each user in the rights database
5413 * setpwent Reset search to the start of the rights database
5414 * endpwent Finish searching for users in the rights database
5415 *
5416 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5417 * (defined in pwd.h), which contains the following fields:-
5418 * struct passwd {
5419 * char *pw_name; Username (in lower case)
5420 * char *pw_passwd; Hashed password
5421 * unsigned int pw_uid; UIC
5422 * unsigned int pw_gid; UIC group number
5423 * char *pw_unixdir; Default device/directory (VMS-style)
5424 * char *pw_gecos; Owner name
5425 * char *pw_dir; Default device/directory (Unix-style)
5426 * char *pw_shell; Default CLI name (eg. DCL)
5427 * };
5428 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5429 *
5430 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5431 * not the UIC member number (eg. what's returned by getuid()),
5432 * getpwuid() can accept either as input (if uid is specified, the caller's
5433 * UIC group is used), though it won't recognise gid=0.
5434 *
5435 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5436 * information about other users in your group or in other groups, respectively.
5437 * If the required privilege is not available, then these routines fill only
5438 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5439 * string).
5440 *
5441 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5442 */
5443
5444/* sizes of various UAF record fields */
5445#define UAI$S_USERNAME 12
5446#define UAI$S_IDENT 31
5447#define UAI$S_OWNER 31
5448#define UAI$S_DEFDEV 31
5449#define UAI$S_DEFDIR 63
5450#define UAI$S_DEFCLI 31
5451#define UAI$S_PWD 8
5452
5453#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5454 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5455 (uic).uic$v_group != UIC$K_WILD_GROUP)
5456
4633a7c4
LW		 5457static char __empty[]= "";
5458static struct passwd __passwd_empty=
748a9306
LW		 5459 {(char *) __empty, (char *) __empty, 0, 0,
5460 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5461static int contxt= 0;
5462static struct passwd __pwdcache;
5463static char __pw_namecache[UAI$S_IDENT+1];
5464
748a9306
LW		 5465/*
5466 * This routine does most of the work extracting the user information.
5467 */
fd8cd3a3 5468static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 5469{
748a9306
LW		 5470 static struct {
5471 unsigned char length;
5472 char pw_gecos[UAI$S_OWNER+1];
5473 } owner;
5474 static union uicdef uic;
5475 static struct {
5476 unsigned char length;
5477 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5478 } defdev;
5479 static struct {
5480 unsigned char length;
5481 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5482 } defdir;
5483 static struct {
5484 unsigned char length;
5485 char pw_shell[UAI$S_DEFCLI+1];
5486 } defcli;
5487 static char pw_passwd[UAI$S_PWD+1];
5488
5489 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5490 struct dsc$descriptor_s name_desc;
c07a80fd 5491 unsigned long int sts;
748a9306 5492
4633a7c4 5493 static struct itmlst_3 itmlst[]= {
748a9306
LW		 5494 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5495 {sizeof(uic), UAI$_UIC, &uic, &luic},
5496 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5497 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5498 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5499 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5500 {0, 0, NULL, NULL}};
5501
5502 name_desc.dsc$w_length= strlen(name);
5503 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5504 name_desc.dsc$b_class= DSC$K_CLASS_S;
5505 name_desc.dsc$a_pointer= (char *) name;
5506
5507/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 5508 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5509 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5510 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5511 }
5512 else { _ckvmssts(sts); }
5513 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 5514
5515 if ((int) owner.length < lowner) lowner= (int) owner.length;
5516 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5517 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5518 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5519 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5520 owner.pw_gecos[lowner]= '\0';
5521 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5522 defcli.pw_shell[ldefcli]= '\0';
5523 if (valid_uic(uic)) {
5524 pwd->pw_uid= uic.uic$l_uic;
5525 pwd->pw_gid= uic.uic$v_group;
5526 }
5527 else
5c84aa53 5528 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 5529 pwd->pw_passwd= pw_passwd;
5530 pwd->pw_gecos= owner.pw_gecos;
5531 pwd->pw_dir= defdev.pw_dir;
5532 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5533 pwd->pw_shell= defcli.pw_shell;
5534 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5535 int ldir;
5536 ldir= strlen(pwd->pw_unixdir) - 1;
5537 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5538 }
5539 else
5540 strcpy(pwd->pw_unixdir, pwd->pw_dir);
01b8edb6 5541 __mystrtolower(pwd->pw_unixdir);
c07a80fd 5542 return 1;
a0d0e21e 5543}
748a9306
LW		 5544
5545/*
5546 * Get information for a named user.
5547*/
5548/*{{{struct passwd *getpwnam(char *name)*/
fd8cd3a3 5549struct passwd *Perl_my_getpwnam(pTHX_ char *name)
748a9306
LW		 5550{
5551 struct dsc$descriptor_s name_desc;
5552 union uicdef uic;
aa689395 5553 unsigned long int status, sts;
748a9306
LW		 5554
5555 __pwdcache = __passwd_empty;
fd8cd3a3 5556 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 5557 /* We still may be able to determine pw_uid and pw_gid */
5558 name_desc.dsc$w_length= strlen(name);
5559 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5560 name_desc.dsc$b_class= DSC$K_CLASS_S;
5561 name_desc.dsc$a_pointer= (char *) name;
aa689395 5562 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 5563 __pwdcache.pw_uid= uic.uic$l_uic;
5564 __pwdcache.pw_gid= uic.uic$v_group;
5565 }
c07a80fd 5566 else {
aa689395 5567 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5568 set_vaxc_errno(sts);
5569 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 5570 return NULL;
5571 }
aa689395 5572 else { _ckvmssts(sts); }
c07a80fd 5573 }
748a9306 5574 }
748a9306
LW		 5575 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5576 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5577 __pwdcache.pw_name= __pw_namecache;
5578 return &__pwdcache;
5579} /* end of my_getpwnam() */
a0d0e21e
LW		 5580/*}}}*/
5581
748a9306
LW		 5582/*
5583 * Get information for a particular UIC or UID.
5584 * Called by my_getpwent with uid=-1 to list all users.
5585*/
5586/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 5587struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 5588{
748a9306
LW		 5589 const $DESCRIPTOR(name_desc,__pw_namecache);
5590 unsigned short lname;
5591 union uicdef uic;
5592 unsigned long int status;
5593
5594 if (uid == (unsigned int) -1) {
5595 do {
5596 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5597 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 5598 set_vaxc_errno(status);
5599 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 5600 my_endpwent();
5601 return NULL;
5602 }
5603 else { _ckvmssts(status); }
5604 } while (!valid_uic (uic));
5605 }
5606 else {
5607 uic.uic$l_uic= uid;
c07a80fd 5608 if (!uic.uic$v_group)
76e3520e 5609 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 5610 if (valid_uic(uic))
5611 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5612 else status = SS$_IVIDENT;
c07a80fd 5613 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5614 status == RMS$_PRV) {
5615 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5616 return NULL;
5617 }
5618 else { _ckvmssts(status); }
748a9306
LW		 5619 }
5620 __pw_namecache[lname]= '\0';
01b8edb6 5621 __mystrtolower(__pw_namecache);
748a9306
LW		 5622
5623 __pwdcache = __passwd_empty;
5624 __pwdcache.pw_name = __pw_namecache;
5625
5626/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5627 The identifier's value is usually the UIC, but it doesn't have to be,
5628 so if we can, we let fillpasswd update this. */
5629 __pwdcache.pw_uid = uic.uic$l_uic;
5630 __pwdcache.pw_gid = uic.uic$v_group;
5631
fd8cd3a3 5632 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 5633 return &__pwdcache;
a0d0e21e 5634
748a9306
LW		 5635} /* end of my_getpwuid() */
5636/*}}}*/
5637
5638/*
5639 * Get information for next user.
5640*/
5641/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 5642struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 5643{
5644 return (my_getpwuid((unsigned int) -1));
5645}
5646/*}}}*/
a0d0e21e 5647
748a9306
LW		 5648/*
5649 * Finish searching rights database for users.
5650*/
5651/*{{{void my_endpwent()*/
fd8cd3a3 5652void Perl_my_endpwent(pTHX)
748a9306
LW		 5653{
5654 if (contxt) {
5655 _ckvmssts(sys$finish_rdb(&contxt));
5656 contxt= 0;
5657 }
a0d0e21e
LW		 5658}
5659/*}}}*/
748a9306 5660
61bb5906
CB		 5661#ifdef HOMEGROWN_POSIX_SIGNALS
5662 /* Signal handling routines, pulled into the core from POSIX.xs.
5663 *
5664 * We need these for threads, so they've been rolled into the core,
5665 * rather than left in POSIX.xs.
5666 *
5667 * (DRS, Oct 23, 1997)
5668 */
5b411029 5669
61bb5906
CB		 5670 /* sigset_t is atomic under VMS, so these routines are easy */
5671/*{{{int my_sigemptyset(sigset_t *) */
5b411029 5672int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 5673 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5674 *set = 0; return 0;
5b411029 5675}
61bb5906
CB		 5676/*}}}*/
5677
5678
5679/*{{{int my_sigfillset(sigset_t *)*/
5b411029 5680int my_sigfillset(sigset_t *set) {
61bb5906
CB		 5681 int i;
5682 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5683 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5684 return 0;
5b411029 5685}
61bb5906
CB		 5686/*}}}*/
5687
5688
5689/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 5690int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 5691 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5692 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5693 *set |= (1 << (sig - 1));
5694 return 0;
5b411029 5695}
61bb5906
CB		 5696/*}}}*/
5697
5698
5699/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 5700int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 5701 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5702 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5703 *set &= ~(1 << (sig - 1));
5704 return 0;
5b411029 5705}
61bb5906
CB		 5706/*}}}*/
5707
5708
5709/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 5710int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 5711 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5712 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 5713 return *set & (1 << (sig - 1));
5b411029 5714}
61bb5906 5715/*}}}*/
5b411029 5716
5b411029 5717
61bb5906
CB		 5718/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5719int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5720 sigset_t tempmask;
5721
5722 /* If set and oset are both null, then things are badly wrong. Bail out. */
5723 if ((oset == NULL) && (set == NULL)) {
5724 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 5725 return -1;
5726 }
5b411029 5727
61bb5906
CB		 5728 /* If set's null, then we're just handling a fetch. */
5729 if (set == NULL) {
5730 tempmask = sigblock(0);
5731 }
5732 else {
5733 switch (how) {
5734 case SIG_SETMASK:
5735 tempmask = sigsetmask(*set);
5736 break;
5737 case SIG_BLOCK:
5738 tempmask = sigblock(*set);
5739 break;
5740 case SIG_UNBLOCK:
5741 tempmask = sigblock(0);
5742 sigsetmask(*oset & ~tempmask);
5743 break;
5744 default:
5745 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5746 return -1;
5747 }
5748 }
5749
5750 /* Did they pass us an oset? If so, stick our holding mask into it */
5751 if (oset)
5752 *oset = tempmask;
5b411029 5753
61bb5906 5754 return 0;
5b411029 5755}
61bb5906
CB		 5756/*}}}*/
5757#endif /* HOMEGROWN_POSIX_SIGNALS */
5758
5b411029 5759
ff0cee69 5760/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5761 * my_utime(), and flex_stat(), all of which operate on UTC unless
5762 * VMSISH_TIMES is true.
5763 */
5764/* method used to handle UTC conversions:
5765 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 5766 */
ff0cee69 5767static int gmtime_emulation_type;
5768/* number of secs to add to UTC POSIX-style time to get local time */
5769static long int utc_offset_secs;
e518068a 5770
ff0cee69 5771/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5772 * in vmsish.h. #undef them here so we can call the CRTL routines
5773 * directly.
e518068a 5774 */
5775#undef gmtime
ff0cee69 5776#undef localtime
5777#undef time
5778
61bb5906 5779
a44ceb8e
CB		 5780/*
5781 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5782 * qualifier with the extern prefix pragma. This provisional
5783 * hack circumvents this prefix pragma problem in previous
5784 * precompilers.
5785 */
5786#if defined(__VMS_VER) && __VMS_VER >= 70000000
5787# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5788# pragma __extern_prefix save
5789# pragma __extern_prefix "" /* set to empty to prevent prefixing */
5790# define gmtime decc$__utctz_gmtime
5791# define localtime decc$__utctz_localtime
5792# define time decc$__utc_time
5793# pragma __extern_prefix restore
5794
5795 struct tm *gmtime(), *localtime();
5796
5797# endif
5798#endif
5799
5800
61bb5906
CB		 5801static time_t toutc_dst(time_t loc) {
5802 struct tm *rsltmp;
5803
5804 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5805 loc -= utc_offset_secs;
5806 if (rsltmp->tm_isdst) loc -= 3600;
5807 return loc;
5808}
32da55ab 5809#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 5810 ((gmtime_emulation_type || my_time(NULL)), \
5811 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5812 ((secs) - utc_offset_secs))))
5813
5814static time_t toloc_dst(time_t utc) {
5815 struct tm *rsltmp;
5816
5817 utc += utc_offset_secs;
5818 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5819 if (rsltmp->tm_isdst) utc += 3600;
5820 return utc;
5821}
32da55ab 5822#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 5823 ((gmtime_emulation_type || my_time(NULL)), \
5824 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5825 ((secs) + utc_offset_secs))))
5826
22d4bb9c
CB		 5827#ifndef RTL_USES_UTC
5828/*
5829
5830 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5831 DST starts on 1st sun of april at 02:00 std time
5832 ends on last sun of october at 02:00 dst time
5833 see the UCX management command reference, SET CONFIG TIMEZONE
5834 for formatting info.
5835
5836 No, it's not as general as it should be, but then again, NOTHING
5837 will handle UK times in a sensible way.
5838*/
5839
5840
5841/*
5842 parse the DST start/end info:
5843 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5844*/
5845
5846static char *
5847tz_parse_startend(char *s, struct tm *w, int *past)
5848{
5849 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5850 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5851 time_t g;
5852
5853 if (!s) return 0;
5854 if (!w) return 0;
5855 if (!past) return 0;
5856
5857 ly = 0;
5858 if (w->tm_year % 4 == 0) ly = 1;
5859 if (w->tm_year % 100 == 0) ly = 0;
5860 if (w->tm_year+1900 % 400 == 0) ly = 1;
5861 if (ly) dinm[1]++;
5862
5863 dozjd = isdigit(*s);
5864 if (*s == 'J' || *s == 'j' || dozjd) {
5865 if (!dozjd && !isdigit(*++s)) return 0;
5866 d = *s++ - '0';
5867 if (isdigit(*s)) {
5868 d = d*10 + *s++ - '0';
5869 if (isdigit(*s)) {
5870 d = d*10 + *s++ - '0';
5871 }
5872 }
5873 if (d == 0) return 0;
5874 if (d > 366) return 0;
5875 d--;
5876 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5877 g = d * 86400;
5878 dozjd = 1;
5879 } else if (*s == 'M' || *s == 'm') {
5880 if (!isdigit(*++s)) return 0;
5881 m = *s++ - '0';
5882 if (isdigit(*s)) m = 10*m + *s++ - '0';
5883 if (*s != '.') return 0;
5884 if (!isdigit(*++s)) return 0;
5885 n = *s++ - '0';
5886 if (n < 1 || n > 5) return 0;
5887 if (*s != '.') return 0;
5888 if (!isdigit(*++s)) return 0;
5889 d = *s++ - '0';
5890 if (d > 6) return 0;
5891 }
5892
5893 if (*s == '/') {
5894 if (!isdigit(*++s)) return 0;
5895 hour = *s++ - '0';
5896 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5897 if (*s == ':') {
5898 if (!isdigit(*++s)) return 0;
5899 min = *s++ - '0';
5900 if (isdigit(*s)) min = 10*min + *s++ - '0';
5901 if (*s == ':') {
5902 if (!isdigit(*++s)) return 0;
5903 sec = *s++ - '0';
5904 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5905 }
5906 }
5907 } else {
5908 hour = 2;
5909 min = 0;
5910 sec = 0;
5911 }
5912
5913 if (dozjd) {
5914 if (w->tm_yday < d) goto before;
5915 if (w->tm_yday > d) goto after;
5916 } else {
5917 if (w->tm_mon+1 < m) goto before;
5918 if (w->tm_mon+1 > m) goto after;
5919
5920 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5921 k = d - j; /* mday of first d */
5922 if (k <= 0) k += 7;
5923 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5924 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5925 if (w->tm_mday < k) goto before;
5926 if (w->tm_mday > k) goto after;
5927 }
5928
5929 if (w->tm_hour < hour) goto before;
5930 if (w->tm_hour > hour) goto after;
5931 if (w->tm_min < min) goto before;
5932 if (w->tm_min > min) goto after;
5933 if (w->tm_sec < sec) goto before;
5934 goto after;
5935
5936before:
5937 *past = 0;
5938 return s;
5939after:
5940 *past = 1;
5941 return s;
5942}
5943
5944
5945
5946
5947/* parse the offset: (+|-)hh[:mm[:ss]] */
5948
5949static char *
5950tz_parse_offset(char *s, int *offset)
5951{
5952 int hour = 0, min = 0, sec = 0;
5953 int neg = 0;
5954 if (!s) return 0;
5955 if (!offset) return 0;
5956
5957 if (*s == '-') {neg++; s++;}
5958 if (*s == '+') s++;
5959 if (!isdigit(*s)) return 0;
5960 hour = *s++ - '0';
5961 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5962 if (hour > 24) return 0;
5963 if (*s == ':') {
5964 if (!isdigit(*++s)) return 0;
5965 min = *s++ - '0';
5966 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5967 if (min > 59) return 0;
5968 if (*s == ':') {
5969 if (!isdigit(*++s)) return 0;
5970 sec = *s++ - '0';
5971 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5972 if (sec > 59) return 0;
5973 }
5974 }
5975
5976 *offset = (hour*60+min)*60 + sec;
5977 if (neg) *offset = -*offset;
5978 return s;
5979}
5980
5981/*
5982 input time is w, whatever type of time the CRTL localtime() uses.
5983 sets dst, the zone, and the gmtoff (seconds)
5984
5985 caches the value of TZ and UCX$TZ env variables; note that
5986 my_setenv looks for these and sets a flag if they're changed
5987 for efficiency.
5988
5989 We have to watch out for the "australian" case (dst starts in
5990 october, ends in april)...flagged by "reverse" and checked by
5991 scanning through the months of the previous year.
5992
5993*/
5994
5995static int
fd8cd3a3 5996tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 5997{
5998 time_t when;
5999 struct tm *w2;
6000 char *s,*s2;
6001 char *dstzone, *tz, *s_start, *s_end;
6002 int std_off, dst_off, isdst;
6003 int y, dststart, dstend;
6004 static char envtz[1025]; /* longer than any logical, symbol, ... */
6005 static char ucxtz[1025];
6006 static char reversed = 0;
6007
6008 if (!w) return 0;
6009
6010 if (tz_updated) {
6011 tz_updated = 0;
6012 reversed = -1; /* flag need to check */
6013 envtz[0] = ucxtz[0] = '\0';
6014 tz = my_getenv("TZ",0);
6015 if (tz) strcpy(envtz, tz);
6016 tz = my_getenv("UCX$TZ",0);
6017 if (tz) strcpy(ucxtz, tz);
6018 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6019 }
6020 tz = envtz;
6021 if (!*tz) tz = ucxtz;
6022
6023 s = tz;
6024 while (isalpha(*s)) s++;
6025 s = tz_parse_offset(s, &std_off);
6026 if (!s) return 0;
6027 if (!*s) { /* no DST, hurray we're done! */
6028 isdst = 0;
6029 goto done;
6030 }
6031
6032 dstzone = s;
6033 while (isalpha(*s)) s++;
6034 s2 = tz_parse_offset(s, &dst_off);
6035 if (s2) {
6036 s = s2;
6037 } else {
6038 dst_off = std_off - 3600;
6039 }
6040
6041 if (!*s) { /* default dst start/end?? */
6042 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6043 s = strchr(ucxtz,',');
6044 }
6045 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6046 }
6047 if (*s != ',') return 0;
6048
6049 when = *w;
6050 when = _toutc(when); /* convert to utc */
6051 when = when - std_off; /* convert to pseudolocal time*/
6052
6053 w2 = localtime(&when);
6054 y = w2->tm_year;
6055 s_start = s+1;
6056 s = tz_parse_startend(s_start,w2,&dststart);
6057 if (!s) return 0;
6058 if (*s != ',') return 0;
6059
6060 when = *w;
6061 when = _toutc(when); /* convert to utc */
6062 when = when - dst_off; /* convert to pseudolocal time*/
6063 w2 = localtime(&when);
6064 if (w2->tm_year != y) { /* spans a year, just check one time */
6065 when += dst_off - std_off;
6066 w2 = localtime(&when);
6067 }
6068 s_end = s+1;
6069 s = tz_parse_startend(s_end,w2,&dstend);
6070 if (!s) return 0;
6071
6072 if (reversed == -1) { /* need to check if start later than end */
6073 int j, ds, de;
6074
6075 when = *w;
6076 if (when < 2*365*86400) {
6077 when += 2*365*86400;
6078 } else {
6079 when -= 365*86400;
6080 }
6081 w2 =localtime(&when);
6082 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6083
6084 for (j = 0; j < 12; j++) {
6085 w2 =localtime(&when);
6086 (void) tz_parse_startend(s_start,w2,&ds);
6087 (void) tz_parse_startend(s_end,w2,&de);
6088 if (ds != de) break;
6089 when += 30*86400;
6090 }
6091 reversed = 0;
6092 if (de && !ds) reversed = 1;
6093 }
6094
6095 isdst = dststart && !dstend;
6096 if (reversed) isdst = dststart || !dstend;
6097
6098done:
6099 if (dst) *dst = isdst;
6100 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6101 if (isdst) tz = dstzone;
6102 if (zone) {
6103 while(isalpha(*tz)) *zone++ = *tz++;
6104 *zone = '\0';
6105 }
6106 return 1;
6107}
6108
6109#endif /* !RTL_USES_UTC */
61bb5906 6110
ff0cee69 6111/* my_time(), my_localtime(), my_gmtime()
61bb5906 6112 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 6113 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 6114 * Note: We need to use these functions even when the CRTL has working
6115 * UTC support, since they also handle C<use vmsish qw(times);>
6116 *
ff0cee69 6117 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 6118 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 6119 */
6120
6121/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 6122time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 6123{
e518068a 6124 time_t when;
61bb5906 6125 struct tm *tm_p;
e518068a 6126
6127 if (gmtime_emulation_type == 0) {
61bb5906
CB		 6128 int dstnow;
6129 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6130 /* results of calls to gmtime() and localtime() */
6131 /* for same &base */
ff0cee69 6132
e518068a 6133 gmtime_emulation_type++;
ff0cee69 6134 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 6135 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 6136
e518068a 6137 gmtime_emulation_type++;
f675dbe5 6138 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 6139 gmtime_emulation_type++;
22d4bb9c 6140 utc_offset_secs = 0;
5c84aa53 6141 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 6142 }
6143 else { utc_offset_secs = atol(off); }
e518068a 6144 }
ff0cee69 6145 else { /* We've got a working gmtime() */
6146 struct tm gmt, local;
e518068a 6147
ff0cee69 6148 gmt = *tm_p;
6149 tm_p = localtime(&base);
6150 local = *tm_p;
6151 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6152 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6153 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6154 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6155 }
e518068a 6156 }
ff0cee69 6157
6158 when = time(NULL);
61bb5906
CB		 6159# ifdef VMSISH_TIME
6160# ifdef RTL_USES_UTC
6161 if (VMSISH_TIME) when = _toloc(when);
6162# else
6163 if (!VMSISH_TIME) when = _toutc(when);
6164# endif
6165# endif
ff0cee69 6166 if (timep != NULL) *timep = when;
6167 return when;
6168
6169} /* end of my_time() */
6170/*}}}*/
6171
6172
6173/*{{{struct tm *my_gmtime(const time_t *timep)*/
6174struct tm *
fd8cd3a3 6175Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 6176{
6177 char *p;
6178 time_t when;
61bb5906 6179 struct tm *rsltmp;
ff0cee69 6180
68dc0745 6181 if (timep == NULL) {
6182 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6183 return NULL;
6184 }
6185 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 6186
6187 when = *timep;
6188# ifdef VMSISH_TIME
61bb5906
CB		 6189 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6190# endif
6191# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6192 return gmtime(&when);
6193# else
ff0cee69 6194 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 6195 rsltmp = localtime(&when);
6196 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6197 return rsltmp;
6198#endif
e518068a 6199} /* end of my_gmtime() */
e518068a 6200/*}}}*/
6201
6202
ff0cee69 6203/*{{{struct tm *my_localtime(const time_t *timep)*/
6204struct tm *
fd8cd3a3 6205Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 6206{
22d4bb9c 6207 time_t when, whenutc;
61bb5906 6208 struct tm *rsltmp;
22d4bb9c 6209 int dst, offset;
ff0cee69 6210
68dc0745 6211 if (timep == NULL) {
6212 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6213 return NULL;
6214 }
6215 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 6216 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6217
6218 when = *timep;
61bb5906 6219# ifdef RTL_USES_UTC
ff0cee69 6220# ifdef VMSISH_TIME
61bb5906 6221 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 6222# endif
61bb5906 6223 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 6224 return localtime(&when);
22d4bb9c
CB		 6225
6226# else /* !RTL_USES_UTC */
6227 whenutc = when;
61bb5906 6228# ifdef VMSISH_TIME
22d4bb9c
CB		 6229 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6230 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 6231# endif
22d4bb9c
CB		 6232 dst = -1;
6233#ifndef RTL_USES_UTC
32af7c23 6234 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 6235 when = whenutc - offset; /* pseudolocal time*/
6236 }
61bb5906
CB		 6237# endif
6238 /* CRTL localtime() wants local time as input, so does no tz correction */
6239 rsltmp = localtime(&when);
22d4bb9c 6240 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 6241 return rsltmp;
22d4bb9c 6242# endif
ff0cee69 6243
6244} /* end of my_localtime() */
6245/*}}}*/
6246
6247/* Reset definitions for later calls */
6248#define gmtime(t) my_gmtime(t)
6249#define localtime(t) my_localtime(t)
6250#define time(t) my_time(t)
6251
6252
6253/* my_utime - update modification time of a file
6254 * calling sequence is identical to POSIX utime(), but under
6255 * VMS only the modification time is changed; ODS-2 does not
6256 * maintain access times. Restrictions differ from the POSIX
6257 * definition in that the time can be changed as long as the
6258 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6259 * no separate checks are made to insure that the caller is the
6260 * owner of the file or has special privs enabled.
6261 * Code here is based on Joe Meadows' FILE utility.
6262 */
6263
6264/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6265 * to VMS epoch (01-JAN-1858 00:00:00.00)
6266 * in 100 ns intervals.
6267 */
6268static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6269
6270/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
fd8cd3a3 6271int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
ff0cee69 6272{
6273 register int i;
6274 long int bintime[2], len = 2, lowbit, unixtime,
6275 secscale = 10000000; /* seconds --> 100 ns intervals */
6276 unsigned long int chan, iosb[2], retsts;
6277 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6278 struct FAB myfab = cc$rms_fab;
6279 struct NAM mynam = cc$rms_nam;
6280#if defined (__DECC) && defined (__VAX)
6281 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6282 * at least through VMS V6.1, which causes a type-conversion warning.
6283 */
6284# pragma message save
6285# pragma message disable cvtdiftypes
6286#endif
6287 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6288 struct fibdef myfib;
6289#if defined (__DECC) && defined (__VAX)
6290 /* This should be right after the declaration of myatr, but due
6291 * to a bug in VAX DEC C, this takes effect a statement early.
6292 */
6293# pragma message restore
6294#endif
6295 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6296 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6297 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6298
6299 if (file == NULL || *file == '\0') {
6300 set_errno(ENOENT);
6301 set_vaxc_errno(LIB$_INVARG);
6302 return -1;
6303 }
6304 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6305
6306 if (utimes != NULL) {
6307 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6308 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6309 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6310 * as input, we force the sign bit to be clear by shifting unixtime right
6311 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6312 */
6313 lowbit = (utimes->modtime & 1) ? secscale : 0;
6314 unixtime = (long int) utimes->modtime;
61bb5906
CB		 6315# ifdef VMSISH_TIME
6316 /* If input was UTC; convert to local for sys svc */
6317 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 6318# endif
1a6334fb 6319 unixtime >>= 1; secscale <<= 1;
ff0cee69 6320 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6321 if (!(retsts & 1)) {
6322 set_errno(EVMSERR);
6323 set_vaxc_errno(retsts);
6324 return -1;
6325 }
6326 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6327 if (!(retsts & 1)) {
6328 set_errno(EVMSERR);
6329 set_vaxc_errno(retsts);
6330 return -1;
6331 }
6332 }
6333 else {
6334 /* Just get the current time in VMS format directly */
6335 retsts = sys$gettim(bintime);
6336 if (!(retsts & 1)) {
6337 set_errno(EVMSERR);
6338 set_vaxc_errno(retsts);
6339 return -1;
6340 }
6341 }
6342
6343 myfab.fab$l_fna = vmsspec;
6344 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6345 myfab.fab$l_nam = &mynam;
6346 mynam.nam$l_esa = esa;
6347 mynam.nam$b_ess = (unsigned char) sizeof esa;
6348 mynam.nam$l_rsa = rsa;
6349 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6350
6351 /* Look for the file to be affected, letting RMS parse the file
6352 * specification for us as well. I have set errno using only
6353 * values documented in the utime() man page for VMS POSIX.
6354 */
6355 retsts = sys$parse(&myfab,0,0);
6356 if (!(retsts & 1)) {
6357 set_vaxc_errno(retsts);
6358 if (retsts == RMS$_PRV) set_errno(EACCES);
6359 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6360 else set_errno(EVMSERR);
6361 return -1;
6362 }
6363 retsts = sys$search(&myfab,0,0);
6364 if (!(retsts & 1)) {
752635ea
CB		 6365 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6366 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
ff0cee69 6367 set_vaxc_errno(retsts);
6368 if (retsts == RMS$_PRV) set_errno(EACCES);
6369 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6370 else set_errno(EVMSERR);
6371 return -1;
6372 }
6373
6374 devdsc.dsc$w_length = mynam.nam$b_dev;
6375 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6376
6377 retsts = sys$assign(&devdsc,&chan,0,0);
6378 if (!(retsts & 1)) {
752635ea
CB		 6379 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6380 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
ff0cee69 6381 set_vaxc_errno(retsts);
6382 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6383 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6384 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6385 else set_errno(EVMSERR);
6386 return -1;
6387 }
6388
6389 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6390 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6391
6392 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 6393#if defined(__DECC) || defined(__DECCXX)
ff0cee69 6394 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6395 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6396 /* This prevents the revision time of the file being reset to the current
6397 * time as a result of our IO$_MODIFY $QIO. */
6398 myfib.fib$l_acctl = FIB$M_NORECORD;
6399#else
6400 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6401 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6402 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6403#endif
6404 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea
CB		 6405 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6406 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
ff0cee69 6407 _ckvmssts(sys$dassgn(chan));
6408 if (retsts & 1) retsts = iosb[0];
6409 if (!(retsts & 1)) {
6410 set_vaxc_errno(retsts);
6411 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6412 else set_errno(EVMSERR);
6413 return -1;
6414 }
6415
6416 return 0;
6417} /* end of my_utime() */
6418/*}}}*/
6419
748a9306
LW		 6420/*
6421 * flex_stat, flex_fstat
6422 * basic stat, but gets it right when asked to stat
6423 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6424 */
6425
6426/* encode_dev packs a VMS device name string into an integer to allow
6427 * simple comparisons. This can be used, for example, to check whether two
6428 * files are located on the same device, by comparing their encoded device
6429 * names. Even a string comparison would not do, because stat() reuses the
6430 * device name buffer for each call; so without encode_dev, it would be
6431 * necessary to save the buffer and use strcmp (this would mean a number of
6432 * changes to the standard Perl code, to say nothing of what a Perl script
6433 * would have to do.
6434 *
6435 * The device lock id, if it exists, should be unique (unless perhaps compared
6436 * with lock ids transferred from other nodes). We have a lock id if the disk is
6437 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6438 * device names. Thus we use the lock id in preference, and only if that isn't
6439 * available, do we try to pack the device name into an integer (flagged by
6440 * the sign bit (LOCKID_MASK) being set).
6441 *
e518068a 6442 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 6443 * name and its encoded form, but it seems very unlikely that we will find
6444 * two files on different disks that share the same encoded device names,
6445 * and even more remote that they will share the same file id (if the test
6446 * is to check for the same file).
6447 *
6448 * A better method might be to use sys$device_scan on the first call, and to
6449 * search for the device, returning an index into the cached array.
6450 * The number returned would be more intelligable.
6451 * This is probably not worth it, and anyway would take quite a bit longer
6452 * on the first call.
6453 */
6454#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 6455static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 6456{
6457 int i;
6458 unsigned long int f;
aa689395 6459 mydev_t enc;
748a9306
LW		 6460 char c;
6461 const char *q;
6462
6463 if (!dev || !dev[0]) return 0;
6464
6465#if LOCKID_MASK
6466 {
6467 struct dsc$descriptor_s dev_desc;
6468 unsigned long int status, lockid, item = DVI$_LOCKID;
6469
6470 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6471 can try that first. */
6472 dev_desc.dsc$w_length = strlen (dev);
6473 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6474 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6475 dev_desc.dsc$a_pointer = (char *) dev;
6476 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6477 if (lockid) return (lockid & ~LOCKID_MASK);
6478 }
a0d0e21e 6479#endif
748a9306
LW		 6480
6481 /* Otherwise we try to encode the device name */
6482 enc = 0;
6483 f = 1;
6484 i = 0;
6485 for (q = dev + strlen(dev); q--; q >= dev) {
6486 if (isdigit (*q))
6487 c= (*q) - '0';
6488 else if (isalpha (toupper (*q)))
6489 c= toupper (*q) - 'A' + (char)10;
6490 else
6491 continue; /* Skip '$'s */
6492 i++;
6493 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6494 if (i>1) f *= 36;
6495 enc += f * (unsigned long int) c;
6496 }
6497 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6498
6499} /* end of encode_dev() */
6500
6501static char namecache[NAM$C_MAXRSS+1];
6502
6503static int
6504is_null_device(name)
6505 const char *name;
6506{
6507 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6508 The underscore prefix, controller letter, and unit number are
6509 independently optional; for our purposes, the colon punctuation
6510 is not. The colon can be trailed by optional directory and/or
6511 filename, but two consecutive colons indicates a nodename rather
6512 than a device. [pr] */
6513 if (*name == '_') ++name;
6514 if (tolower(*name++) != 'n') return 0;
6515 if (tolower(*name++) != 'l') return 0;
6516 if (tolower(*name) == 'a') ++name;
6517 if (*name == '0') ++name;
6518 return (*name++ == ':') && (*name != ':');
6519}
6520
6b88bc9c 6521/* Do the permissions allow some operation? Assumes PL_statcache already set. */
748a9306 6522/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
61bb5906 6523 * subset of the applicable information.
748a9306 6524 */
146174a9
CB		 6525bool
6526Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
748a9306 6527{
22d4bb9c 6528 char fname_phdev[NAM$C_MAXRSS+1];
6b88bc9c 6529 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
748a9306
LW		 6530 else {
6531 char fname[NAM$C_MAXRSS+1];
6532 unsigned long int retsts;
6533 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6534 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6535
6536 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6537 device name on successive calls */
61bb5906
CB		 6538 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6539 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
748a9306
LW		 6540 namdsc.dsc$a_pointer = fname;
6541 namdsc.dsc$w_length = sizeof fname - 1;
6542
61bb5906 6543 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
aa689395 6544 &namdsc,&namdsc.dsc$w_length,0,0);
748a9306
LW		 6545 if (retsts & 1) {
6546 fname[namdsc.dsc$w_length] = '\0';
22d4bb9c
CB		 6547/*
6548 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6549 * but if someone has redefined that logical, Perl gets very lost. Since
6550 * we have the physical device name from the stat buffer, just paste it on.
6551 */
6552 strcpy( fname_phdev, statbufp->st_devnam );
6553 strcat( fname_phdev, strrchr(fname, ':') );
6554
6555 return cando_by_name(bit,effective,fname_phdev);
748a9306
LW		 6556 }
6557 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5c84aa53 6558 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
748a9306
LW		 6559 return FALSE;
6560 }
6561 _ckvmssts(retsts);
6562 return FALSE; /* Should never get to here */
6563 }
e518068a 6564} /* end of cando() */
748a9306
LW		 6565/*}}}*/
6566
c07a80fd 6567
146174a9 6568/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
748a9306 6569I32
fd8cd3a3 6570Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
748a9306
LW		 6571{
6572 static char usrname[L_cuserid];
6573 static struct dsc$descriptor_s usrdsc =
6574 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
a5f75d66 6575 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
748a9306
LW		 6576 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6577 unsigned short int retlen;
6578 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6579 union prvdef curprv;
6580 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6581 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6582 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6583 {0,0,0,0}};
6584
6585 if (!fname || !*fname) return FALSE;
01b8edb6 6586 /* Make sure we expand logical names, since sys$check_access doesn't */
6587 if (!strpbrk(fname,"/]>:")) {
6588 strcpy(fileified,fname);
6589 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6590 fname = fileified;
6591 }
a5f75d66
AD		 6592 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6593 retlen = namdsc.dsc$w_length = strlen(vmsname);
6594 namdsc.dsc$a_pointer = vmsname;
6595 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6596 vmsname[retlen-1] == ':') {
6597 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6598 namdsc.dsc$w_length = strlen(fileified);
6599 namdsc.dsc$a_pointer = fileified;
6600 }
6601
748a9306
LW		 6602 if (!usrdsc.dsc$w_length) {
6603 cuserid(usrname);
6604 usrdsc.dsc$w_length = strlen(usrname);
6605 }
a5f75d66 6606
748a9306 6607 switch (bit) {
f282b18d
CB		 6608 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6609 access = ARM$M_EXECUTE; break;
6610 case S_IRUSR: case S_IRGRP: case S_IROTH:
6611 access = ARM$M_READ; break;
6612 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6613 access = ARM$M_WRITE; break;
6614 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6615 access = ARM$M_DELETE; break;
748a9306
LW		 6616 default:
6617 return FALSE;
6618 }
6619
6620 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
bbce6d69 6621 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 6622 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 6623 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 6624 set_vaxc_errno(retsts);
6625 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6626 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6627 else set_errno(ENOENT);
a3e9d8c9 6628 return FALSE;
6629 }
748a9306
LW		 6630 if (retsts == SS$_NORMAL) {
6631 if (!privused) return TRUE;
6632 /* We can get access, but only by using privs. Do we have the
6633 necessary privs currently enabled? */
6634 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6635 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
c07a80fd 6636 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6637 !curprv.prv$v_bypass) return FALSE;
6638 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6639 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
748a9306
LW		 6640 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6641 return TRUE;
6642 }
3a385817
GS		 6643 if (retsts == SS$_ACCONFLICT) {
6644 return TRUE;
6645 }
748a9306
LW		 6646 _ckvmssts(retsts);
6647
6648 return FALSE; /* Should never get here */
6649
6650} /* end of cando_by_name() */
6651/*}}}*/
6652
6653
61bb5906 6654/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 6655int
fd8cd3a3 6656Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 6657{
b7ae7a0d 6658 if (!fstat(fd,(stat_t *) statbufp)) {
6b88bc9c 6659 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
fd8cd3a3 6660 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
61bb5906
CB		 6661# ifdef RTL_USES_UTC
6662# ifdef VMSISH_TIME
6663 if (VMSISH_TIME) {
6664 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6665 statbufp->st_atime = _toloc(statbufp->st_atime);
6666 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6667 }
6668# endif
6669# else
ff0cee69 6670# ifdef VMSISH_TIME
6671 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6672# else
6673 if (1) {
6674# endif
61bb5906
CB		 6675 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6676 statbufp->st_atime = _toutc(statbufp->st_atime);
6677 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 6678 }
61bb5906 6679#endif
b7ae7a0d 6680 return 0;
6681 }
6682 return -1;
748a9306
LW		 6683
6684} /* end of flex_fstat() */
6685/*}}}*/
6686
cc077a9f 6687/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
748a9306 6688int
fd8cd3a3 6689Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
748a9306
LW		 6690{
6691 char fileified[NAM$C_MAXRSS+1];
cc077a9f 6692 char temp_fspec[NAM$C_MAXRSS+300];
bbce6d69 6693 int retval = -1;
748a9306 6694
e956e27a 6695 if (!fspec) return retval;
cc077a9f 6696 strcpy(temp_fspec, fspec);
6b88bc9c 6697 if (statbufp == (Stat_t *) &PL_statcache)
cc077a9f
HM		 6698 do_tovmsspec(temp_fspec,namecache,0);
6699 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
748a9306 6700 memset(statbufp,0,sizeof *statbufp);
fd8cd3a3 6701 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
748a9306
LW		 6702 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6703 statbufp->st_uid = 0x00010001;
6704 statbufp->st_gid = 0x0001;
6705 time((time_t *)&statbufp->st_mtime);
6706 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6707 return 0;
6708 }
6709
bbce6d69 6710 /* Try for a directory name first. If fspec contains a filename without
61bb5906 6711 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 6712 * and sea:[wine.dark]water. exist, we prefer the directory here.
6713 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6714 * not sea:[wine.dark]., if the latter exists. If the intended target is
6715 * the file with null type, specify this by calling flex_stat() with
6716 * a '.' at the end of fspec.
6717 */
cc077a9f 6718 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
bbce6d69 6719 retval = stat(fileified,(stat_t *) statbufp);
6b88bc9c 6720 if (!retval && statbufp == (Stat_t *) &PL_statcache)
aa689395 6721 strcpy(namecache,fileified);
748a9306 6722 }
cc077a9f 6723 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
ff0cee69 6724 if (!retval) {
fd8cd3a3 6725 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
61bb5906
CB		 6726# ifdef RTL_USES_UTC
6727# ifdef VMSISH_TIME
6728 if (VMSISH_TIME) {
6729 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6730 statbufp->st_atime = _toloc(statbufp->st_atime);
6731 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6732 }
6733# endif
6734# else
ff0cee69 6735# ifdef VMSISH_TIME
6736 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6737# else
6738 if (1) {
6739# endif
61bb5906
CB		 6740 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6741 statbufp->st_atime = _toutc(statbufp->st_atime);
6742 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 6743 }
61bb5906 6744# endif
ff0cee69 6745 }
748a9306
LW		 6746 return retval;
6747
6748} /* end of flex_stat() */
6749/*}}}*/
6750
b7ae7a0d 6751
c07a80fd 6752/*{{{char *my_getlogin()*/
6753/* VMS cuserid == Unix getlogin, except calling sequence */
6754char *
6755my_getlogin()
6756{
6757 static char user[L_cuserid];
6758 return cuserid(user);
6759}
6760/*}}}*/
6761
6762
a5f75d66
AD		 6763/* rmscopy - copy a file using VMS RMS routines
6764 *
6765 * Copies contents and attributes of spec_in to spec_out, except owner
6766 * and protection information. Name and type of spec_in are used as
a3e9d8c9 6767 * defaults for spec_out. The third parameter specifies whether rmscopy()
6768 * should try to propagate timestamps from the input file to the output file.
6769 * If it is less than 0, no timestamps are preserved. If it is 0, then
6770 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6771 * propagated to the output file at creation iff the output file specification
6772 * did not contain an explicit name or type, and the revision date is always
6773 * updated at the end of the copy operation. If it is greater than 0, then
6774 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6775 * other than the revision date should be propagated, and bit 1 indicates
6776 * that the revision date should be propagated.
6777 *
6778 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 6779 *
bd3fa61c 6780 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 6781 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 6782 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6783 * as part of the Perl standard distribution under the terms of the
6784 * GNU General Public License or the Perl Artistic License. Copies
6785 * of each may be found in the Perl standard distribution.
a5f75d66 6786 */
a3e9d8c9 6787/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a5f75d66 6788int
4b19af01 6789Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
a5f75d66
AD		 6790{
6791 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6792 rsa[NAM$C_MAXRSS], ubf[32256];
6793 unsigned long int i, sts, sts2;
6794 struct FAB fab_in, fab_out;
6795 struct RAB rab_in, rab_out;
6796 struct NAM nam;
6797 struct XABDAT xabdat;
6798 struct XABFHC xabfhc;
6799 struct XABRDT xabrdt;
6800 struct XABSUM xabsum;
6801
6802 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6803 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6804 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6805 return 0;
6806 }
6807
6808 fab_in = cc$rms_fab;
6809 fab_in.fab$l_fna = vmsin;
6810 fab_in.fab$b_fns = strlen(vmsin);
6811 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6812 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6813 fab_in.fab$l_fop = FAB$M_SQO;
6814 fab_in.fab$l_nam = &nam;
a3e9d8c9 6815 fab_in.fab$l_xab = (void *) &xabdat;
a5f75d66
AD		 6816
6817 nam = cc$rms_nam;
6818 nam.nam$l_rsa = rsa;
6819 nam.nam$b_rss = sizeof(rsa);
6820 nam.nam$l_esa = esa;
6821 nam.nam$b_ess = sizeof (esa);
6822 nam.nam$b_esl = nam.nam$b_rsl = 0;
6823
6824 xabdat = cc$rms_xabdat; /* To get creation date */
a3e9d8c9 6825 xabdat.xab$l_nxt = (void *) &xabfhc;
a5f75d66
AD		 6826
6827 xabfhc = cc$rms_xabfhc; /* To get record length */
a3e9d8c9 6828 xabfhc.xab$l_nxt = (void *) &xabsum;
a5f75d66
AD		 6829
6830 xabsum = cc$rms_xabsum; /* To get key and area information */
6831
6832 if (!((sts = sys$open(&fab_in)) & 1)) {
6833 set_vaxc_errno(sts);
6834 switch (sts) {
f282b18d 6835 case RMS$_FNF: case RMS$_DNF:
a5f75d66 6836 set_errno(ENOENT); break;
f282b18d
CB		 6837 case RMS$_DIR:
6838 set_errno(ENOTDIR); break;
a5f75d66
AD		 6839 case RMS$_DEV:
6840 set_errno(ENODEV); break;
6841 case RMS$_SYN:
6842 set_errno(EINVAL); break;
6843 case RMS$_PRV:
6844 set_errno(EACCES); break;
6845 default:
6846 set_errno(EVMSERR);
6847 }
6848 return 0;
6849 }
6850
6851 fab_out = fab_in;
6852 fab_out.fab$w_ifi = 0;
6853 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6854 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6855 fab_out.fab$l_fop = FAB$M_SQO;
6856 fab_out.fab$l_fna = vmsout;
6857 fab_out.fab$b_fns = strlen(vmsout);
6858 fab_out.fab$l_dna = nam.nam$l_name;
6859 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
a3e9d8c9 6860
6861 if (preserve_dates == 0) { /* Act like DCL COPY */
6862 nam.nam$b_nop = NAM$M_SYNCHK;
6863 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6864 if (!((sts = sys$parse(&fab_out)) & 1)) {
6865 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6866 set_vaxc_errno(sts);
6867 return 0;
6868 }
6869 fab_out.fab$l_xab = (void *) &xabdat;
6870 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6871 }
6872 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6873 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6874 preserve_dates =0; /* bitmask from this point forward */
6875
6876 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a5f75d66
AD		 6877 if (!((sts = sys$create(&fab_out)) & 1)) {
6878 set_vaxc_errno(sts);
6879 switch (sts) {
f282b18d 6880 case RMS$_DNF:
a5f75d66 6881 set_errno(ENOENT); break;
f282b18d
CB		 6882 case RMS$_DIR:
6883 set_errno(ENOTDIR); break;
a5f75d66
AD		 6884 case RMS$_DEV:
6885 set_errno(ENODEV); break;
6886 case RMS$_SYN:
6887 set_errno(EINVAL); break;
6888 case RMS$_PRV:
6889 set_errno(EACCES); break;
6890 default:
6891 set_errno(EVMSERR);
6892 }
6893 return 0;
6894 }
6895 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
a3e9d8c9 6896 if (preserve_dates & 2) {
6897 /* sys$close() will process xabrdt, not xabdat */
6898 xabrdt = cc$rms_xabrdt;
b7ae7a0d 6899#ifndef __GNUC__
a3e9d8c9 6900 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
b7ae7a0d 6901#else
6902 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6903 * is unsigned long[2], while DECC & VAXC use a struct */
6904 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6905#endif
a3e9d8c9 6906 fab_out.fab$l_xab = (void *) &xabrdt;
6907 }
a5f75d66
AD		 6908
6909 rab_in = cc$rms_rab;
6910 rab_in.rab$l_fab = &fab_in;
6911 rab_in.rab$l_rop = RAB$M_BIO;
6912 rab_in.rab$l_ubf = ubf;
6913 rab_in.rab$w_usz = sizeof ubf;
6914 if (!((sts = sys$connect(&rab_in)) & 1)) {
6915 sys$close(&fab_in); sys$close(&fab_out);
6916 set_errno(EVMSERR); set_vaxc_errno(sts);
6917 return 0;
6918 }
6919
6920 rab_out = cc$rms_rab;
6921 rab_out.rab$l_fab = &fab_out;
6922 rab_out.rab$l_rbf = ubf;
6923 if (!((sts = sys$connect(&rab_out)) & 1)) {
6924 sys$close(&fab_in); sys$close(&fab_out);
6925 set_errno(EVMSERR); set_vaxc_errno(sts);
6926 return 0;
6927 }
6928
6929 while ((sts = sys$read(&rab_in))) { /* always true */
6930 if (sts == RMS$_EOF) break;
6931 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6932 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6933 sys$close(&fab_in); sys$close(&fab_out);
6934 set_errno(EVMSERR); set_vaxc_errno(sts);
6935 return 0;
6936 }
6937 }
6938
6939 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6940 sys$close(&fab_in); sys$close(&fab_out);
6941 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6942 if (!(sts & 1)) {
6943 set_errno(EVMSERR); set_vaxc_errno(sts);
6944 return 0;
6945 }
6946
6947 return 1;
6948
6949} /* end of rmscopy() */
6950/*}}}*/
6951
6952
748a9306
LW		 6953/*** The following glue provides 'hooks' to make some of the routines
6954 * from this file available from Perl. These routines are sufficiently
6955 * basic, and are required sufficiently early in the build process,
6956 * that's it's nice to have them available to miniperl as well as the
6957 * full Perl, so they're set up here instead of in an extension. The
6958 * Perl code which handles importation of these names into a given
6959 * package lives in [.VMS]Filespec.pm in @INC.
6960 */
6961
6962void
5c84aa53 6963rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 6964{
6965 dXSARGS;
bbce6d69 6966 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 6967 STRLEN n_a;
01b8edb6 6968
bbce6d69 6969 if (!items || items > 2)
5c84aa53 6970 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 6971 fspec = SvPV(ST(0),n_a);
bbce6d69 6972 if (!fspec || !*fspec) XSRETURN_UNDEF;
2d8e6c8d 6973 if (items == 2) defspec = SvPV(ST(1),n_a);
b7ae7a0d 6974
bbce6d69 6975 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6976 ST(0) = sv_newmortal();
6977 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
740ce14c 6978 XSRETURN(1);
01b8edb6 6979}
6980
6981void
5c84aa53 6982vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 6983{
6984 dXSARGS;
6985 char *vmsified;
2d8e6c8d 6986 STRLEN n_a;
748a9306 6987
5c84aa53 6988 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
2d8e6c8d 6989 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 6990 ST(0) = sv_newmortal();
6991 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6992 XSRETURN(1);
6993}
6994
6995void
5c84aa53 6996unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 6997{
6998 dXSARGS;
6999 char *unixified;
2d8e6c8d 7000 STRLEN n_a;
748a9306 7001
5c84aa53 7002 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
2d8e6c8d 7003 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 7004 ST(0) = sv_newmortal();
7005 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7006 XSRETURN(1);
7007}
7008
7009void
5c84aa53 7010fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 7011{
7012 dXSARGS;
7013 char *fileified;
2d8e6c8d 7014 STRLEN n_a;
748a9306 7015
5c84aa53 7016 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
2d8e6c8d 7017 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 7018 ST(0) = sv_newmortal();
7019 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7020 XSRETURN(1);
7021}
7022
7023void
5c84aa53 7024pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 7025{
7026 dXSARGS;
7027 char *pathified;
2d8e6c8d 7028 STRLEN n_a;
748a9306 7029
5c84aa53 7030 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
2d8e6c8d 7031 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 7032 ST(0) = sv_newmortal();
7033 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7034 XSRETURN(1);
7035}
7036
7037void
5c84aa53 7038vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 7039{
7040 dXSARGS;
7041 char *vmspath;
2d8e6c8d 7042 STRLEN n_a;
748a9306 7043
5c84aa53 7044 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
2d8e6c8d 7045 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 7046 ST(0) = sv_newmortal();
7047 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7048 XSRETURN(1);
7049}
7050
7051void
5c84aa53 7052unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 7053{
7054 dXSARGS;
7055 char *unixpath;
2d8e6c8d 7056 STRLEN n_a;
748a9306 7057
5c84aa53 7058 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
2d8e6c8d 7059 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 7060 ST(0) = sv_newmortal();
7061 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7062 XSRETURN(1);
7063}
7064
7065void
5c84aa53 7066candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 7067{
7068 dXSARGS;
a5f75d66
AD		 7069 char fspec[NAM$C_MAXRSS+1], *fsp;
7070 SV *mysv;
7071 IO *io;
2d8e6c8d 7072 STRLEN n_a;
748a9306 7073
5c84aa53 7074 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 7075
7076 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7077 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 7078 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 7079 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7080 ST(0) = &PL_sv_no;
a5f75d66
AD		 7081 XSRETURN(1);
7082 }
7083 fsp = fspec;
7084 }
7085 else {
2d8e6c8d 7086 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 7087 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7088 ST(0) = &PL_sv_no;
a5f75d66
AD		 7089 XSRETURN(1);
7090 }
7091 }
7092
54310121 7093 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
a5f75d66
AD		 7094 XSRETURN(1);
7095}
7096
7097void
5c84aa53 7098rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 7099{
7100 dXSARGS;
7101 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
a3e9d8c9 7102 int date_flag;
a5f75d66
AD		 7103 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7104 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7105 unsigned long int sts;
7106 SV *mysv;
7107 IO *io;
2d8e6c8d 7108 STRLEN n_a;
a5f75d66 7109
a3e9d8c9 7110 if (items < 2 || items > 3)
5c84aa53 7111 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 7112
7113 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7114 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 7115 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 7116 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7117 ST(0) = &PL_sv_no;
a5f75d66
AD		 7118 XSRETURN(1);
7119 }
7120 inp = inspec;
7121 }
7122 else {
2d8e6c8d 7123 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 7124 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7125 ST(0) = &PL_sv_no;
a5f75d66
AD		 7126 XSRETURN(1);
7127 }
7128 }
7129 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7130 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 7131 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 7132 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7133 ST(0) = &PL_sv_no;
a5f75d66
AD		 7134 XSRETURN(1);
7135 }
7136 outp = outspec;
7137 }
7138 else {
2d8e6c8d 7139 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 7140 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 7141 ST(0) = &PL_sv_no;
a5f75d66
AD		 7142 XSRETURN(1);
7143 }
7144 }
a3e9d8c9 7145 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 7146
54310121 7147 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
748a9306
LW		 7148 XSRETURN(1);
7149}
7150
4b19af01
CB		 7151
7152void
fd8cd3a3 7153mod2fname(pTHX_ CV *cv)
4b19af01
CB		 7154{
7155 dXSARGS;
7156 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7157 workbuff[NAM$C_MAXRSS*1 + 1];
7158 int total_namelen = 3, counter, num_entries;
7159 /* ODS-5 ups this, but we want to be consistent, so... */
7160 int max_name_len = 39;
7161 AV *in_array = (AV *)SvRV(ST(0));
7162
7163 num_entries = av_len(in_array);
7164
7165 /* All the names start with PL_. */
7166 strcpy(ultimate_name, "PL_");
7167
7168 /* Clean up our working buffer */
7169 Zero(work_name, sizeof(work_name), char);
7170
7171 /* Run through the entries and build up a working name */
7172 for(counter = 0; counter <= num_entries; counter++) {
7173 /* If it's not the first name then tack on a __ */
7174 if (counter) {
7175 strcat(work_name, "__");
7176 }
7177 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7178 PL_na));
7179 }
7180
7181 /* Check to see if we actually have to bother...*/
7182 if (strlen(work_name) + 3 <= max_name_len) {
7183 strcat(ultimate_name, work_name);
7184 } else {
7185 /* It's too darned big, so we need to go strip. We use the same */
7186 /* algorithm as xsubpp does. First, strip out doubled __ */
7187 char *source, *dest, last;
7188 dest = workbuff;
7189 last = 0;
7190 for (source = work_name; *source; source++) {
7191 if (last == *source && last == '_') {
7192 continue;
7193 }
7194 *dest++ = *source;
7195 last = *source;
7196 }
7197 /* Go put it back */
7198 strcpy(work_name, workbuff);
7199 /* Is it still too big? */
7200 if (strlen(work_name) + 3 > max_name_len) {
7201 /* Strip duplicate letters */
7202 last = 0;
7203 dest = workbuff;
7204 for (source = work_name; *source; source++) {
7205 if (last == toupper(*source)) {
7206 continue;
7207 }
7208 *dest++ = *source;
7209 last = toupper(*source);
7210 }
7211 strcpy(work_name, workbuff);
7212 }
7213
7214 /* Is it *still* too big? */
7215 if (strlen(work_name) + 3 > max_name_len) {
7216 /* Too bad, we truncate */
7217 work_name[max_name_len - 2] = 0;
7218 }
7219 strcat(ultimate_name, work_name);
7220 }
7221
7222 /* Okay, return it */
7223 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7224 XSRETURN(1);
7225}
7226
748a9306 7227void
96e176bf
CL		 7228hushexit_fromperl(pTHX_ CV *cv)
7229{
7230 dXSARGS;
7231
7232 if (items > 0) {
7233 VMSISH_HUSHED = SvTRUE(ST(0));
7234 }
7235 ST(0) = boolSV(VMSISH_HUSHED);
7236 XSRETURN(1);
7237}
7238
7239void
7240Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7241 struct interp_intern *dst)
7242{
7243 memcpy(dst,src,sizeof(struct interp_intern));
7244}
7245
7246void
7247Perl_sys_intern_clear(pTHX)
7248{
7249}
7250
7251void
7252Perl_sys_intern_init(pTHX)
7253{
3ff49832
CL		 7254 unsigned int ix = RAND_MAX;
7255 double x;
96e176bf
CL		 7256
7257 VMSISH_HUSHED = 0;
7258
7259 x = (float)ix;
7260 MY_INV_RAND_MAX = 1./x;
ff7adb52 7261}
96e176bf
CL		 7262
7263void
a69a6dba 7264init_os_extras()
748a9306 7265{
a69a6dba 7266 dTHX;
748a9306 7267 char* file = __FILE__;
93948341
CB		 7268 char temp_buff[512];
7269 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7270 no_translate_barewords = TRUE;
7271 } else {
7272 no_translate_barewords = FALSE;
7273 }
748a9306 7274
740ce14c 7275 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 7276 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7277 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7278 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7279 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7280 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7281 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7282 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 7283 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 7284 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 7285 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
17f28c40 7286
afd8f436 7287 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 7288
748a9306
LW		 7289 return;
7290}
7291
7292/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.