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