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