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
an assert in av_undef was leaking memory
[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 *
2fbb330f 6 * August 2005 Convert VMS status code to UNIX status codes
22d4bb9c
CB		 7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 11 */
12
13#include <acedef.h>
14#include <acldef.h>
15#include <armdef.h>
748a9306 16#include <atrdef.h>
a0d0e21e 17#include <chpdef.h>
8fde5078 18#include <clidef.h>
a3e9d8c9 19#include <climsgdef.h>
a0d0e21e 20#include <descrip.h>
22d4bb9c 21#include <devdef.h>
a0d0e21e 22#include <dvidef.h>
748a9306 23#include <fibdef.h>
a0d0e21e
LW		 24#include <float.h>
25#include <fscndef.h>
26#include <iodef.h>
27#include <jpidef.h>
61bb5906 28#include <kgbdef.h>
f675dbe5 29#include <libclidef.h>
a0d0e21e
LW		 30#include <libdef.h>
31#include <lib$routines.h>
32#include <lnmdef.h>
aeb5cf3c 33#include <msgdef.h>
f7ddb74a
JM		 34#if __CRTL_VER >= 70301000 && !defined(__VAX)
35#include <ppropdef.h>
36#endif
748a9306 37#include <prvdef.h>
a0d0e21e
LW		 38#include <psldef.h>
39#include <rms.h>
40#include <shrdef.h>
41#include <ssdef.h>
42#include <starlet.h>
f86702cc
PP		 43#include <strdef.h>
44#include <str$routines.h>
a0d0e21e 45#include <syidef.h>
748a9306
LW		 46#include <uaidef.h>
47#include <uicdef.h>
2fbb330f
JM		 48#include <stsdef.h>
49#include <rmsdef.h>
a0d0e21e 50
f7ddb74a
JM		 51/* Set the maximum filespec size here as it is larger for EFS file
52 * specifications.
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
59 */
60#define VMS_MAXRSS NAM$C_MAXRSS
61#ifndef __VAX
62#if 0
63#ifdef NAML$C_MAXRSS
64#undef VMS_MAXRSS
65#define VMS_MAXRSS NAML$C_MAXRSS
66#endif
67#endif
68#endif
69
70#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
71int decc$feature_get_index(const char *name);
72char* decc$feature_get_name(int index);
73int decc$feature_get_value(int index, int mode);
74int decc$feature_set_value(int index, int mode, int value);
75#else
76#include <unixlib.h>
77#endif
78
79#ifndef __VAX
80#if __CRTL_VER >= 70300000
81
82static int set_feature_default(const char *name, int value)
83{
84 int status;
85 int index;
86
87 index = decc$feature_get_index(name);
88
89 status = decc$feature_set_value(index, 1, value);
90 if (index == -1 || (status == -1)) {
91 return -1;
92 }
93
94 status = decc$feature_get_value(index, 1);
95 if (status != value) {
96 return -1;
97 }
98
99return 0;
100}
101#endif
102#endif
103
740ce14c
PP		 104/* Older versions of ssdef.h don't have these */
105#ifndef SS$_INVFILFOROP
106# define SS$_INVFILFOROP 3930
107#endif
108#ifndef SS$_NOSUCHOBJECT
b7ae7a0d
PP		 109# define SS$_NOSUCHOBJECT 2696
110#endif
111
a15cef0c
CB		 112/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
113#define PERLIO_NOT_STDIO 0
114
aa689395
PP		 115/* Don't replace system definitions of vfork, getenv, and stat,
116 * code below needs to get to the underlying CRTL routines. */
117#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 118#include "EXTERN.h"
119#include "perl.h"
748a9306 120#include "XSUB.h"
3eeba6fb
CB		 121/* Anticipating future expansion in lexical warnings . . . */
122#ifndef WARN_INTERNAL
123# define WARN_INTERNAL WARN_MISC
124#endif
a0d0e21e 125
22d4bb9c
CB		 126#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
127# define RTL_USES_UTC 1
128#endif
129
130
c07a80fd
PP		 131/* gcc's header files don't #define direct access macros
132 * corresponding to VAXC's variant structs */
133#ifdef __GNUC__
482b294c
PP		 134# define uic$v_format uic$r_uic_form.uic$v_format
135# define uic$v_group uic$r_uic_form.uic$v_group
136# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd
PP		 137# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
138# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
139# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
140# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
141#endif
142
c645ec3f
GS		 143#if defined(NEED_AN_H_ERRNO)
144dEXT int h_errno;
145#endif
c07a80fd 146
f7ddb74a
JM		 147#ifdef __DECC
148#pragma message disable pragma
149#pragma member_alignment save
150#pragma nomember_alignment longword
151#pragma message save
152#pragma message disable misalgndmem
153#endif
a0d0e21e
LW		 154struct itmlst_3 {
155 unsigned short int buflen;
156 unsigned short int itmcode;
157 void *bufadr;
748a9306 158 unsigned short int *retlen;
a0d0e21e 159};
f7ddb74a
JM		 160#ifdef __DECC
161#pragma message restore
162#pragma member_alignment restore
163#endif
a0d0e21e 164
4b19af01
CB		 165#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
166#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
167#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
168#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
169#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
f7ddb74a 170#define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
4b19af01
CB		 171#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
172#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
f7ddb74a 173#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 174#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
175#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
176
f7ddb74a
JM		 177static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
178static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
179static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
180static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
181
0e06870b
CB		 182/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
183#define PERL_LNM_MAX_ALLOWED_INDEX 127
184
2d9f3838
CB		 185/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
186 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
187 * the Perl facility.
188 */
189#define PERL_LNM_MAX_ITER 10
190
48b5a746
CL		 191#define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
192#define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
ff7adb52 193
01b8edb6
PP		 194static char *__mystrtolower(char *str)
195{
196 if (str) for (; *str; ++str) *str= tolower(*str);
197 return str;
198}
199
f675dbe5
CB		 200static struct dsc$descriptor_s fildevdsc =
201 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
202static struct dsc$descriptor_s crtlenvdsc =
203 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
204static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
205static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
206static struct dsc$descriptor_s **env_tables = defenv;
207static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
208
93948341
CB		 209/* True if we shouldn't treat barewords as logicals during directory */
210/* munching */
211static int no_translate_barewords;
212
22d4bb9c
CB		 213#ifndef RTL_USES_UTC
214static int tz_updated = 1;
215#endif
216
f7ddb74a
JM		 217/* DECC Features that may need to affect how Perl interprets
218 * displays filename information
219 */
220static int decc_disable_to_vms_logname_translation = 1;
221static int decc_disable_posix_root = 1;
222int decc_efs_case_preserve = 0;
223static int decc_efs_charset = 0;
224static int decc_filename_unix_no_version = 0;
225static int decc_filename_unix_only = 0;
226int decc_filename_unix_report = 0;
227int decc_posix_compliant_pathnames = 0;
228int decc_readdir_dropdotnotype = 0;
229static int vms_process_case_tolerant = 1;
230
231/* Is this a UNIX file specification?
232 * No longer a simple check with EFS file specs
233 * For now, not a full check, but need to
234 * handle POSIX ^UP^ specifications
235 * Fixing to handle ^/ cases would require
236 * changes to many other conversion routines.
237 */
238
239static is_unix_filespec(const char *path)
240{
241int ret_val;
242const char * pch1;
243
244 ret_val = 0;
245 if (strncmp(path,"\"^UP^",5) != 0) {
246 pch1 = strchr(path, '/');
247 if (pch1 != NULL)
248 ret_val = 1;
249 else {
250
251 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
252 if (decc_filename_unix_report || decc_filename_unix_only) {
253 if (strcmp(path,".") == 0)
254 ret_val = 1;
255 }
256 }
257 }
258 return ret_val;
259}
260
261
fa537f88
CB		 262/* my_maxidx
263 * Routine to retrieve the maximum equivalence index for an input
264 * logical name. Some calls to this routine have no knowledge if
265 * the variable is a logical or not. So on error we return a max
266 * index of zero.
267 */
f7ddb74a 268/*{{{int my_maxidx(const char *lnm) */
fa537f88 269static int
f7ddb74a 270my_maxidx(const char *lnm)
fa537f88
CB		 271{
272 int status;
273 int midx;
274 int attr = LNM$M_CASE_BLIND;
275 struct dsc$descriptor lnmdsc;
276 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
277 {0, 0, 0, 0}};
278
279 lnmdsc.dsc$w_length = strlen(lnm);
280 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
281 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 282 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 283
284 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
285 if ((status & 1) == 0)
286 midx = 0;
287
288 return (midx);
289}
290/*}}}*/
291
f675dbe5 292/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 293int
fd8cd3a3 294Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 295 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 296{
f7ddb74a
JM		 297 const char *cp1;
298 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 299 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 300 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 301 int midx;
f675dbe5
CB		 302 unsigned char acmode;
303 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
304 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
305 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
306 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 307 {0, 0, 0, 0}};
f675dbe5 308 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 309#if defined(PERL_IMPLICIT_CONTEXT)
310 pTHX = NULL;
fd8cd3a3
DS		 311 if (PL_curinterp) {
312 aTHX = PERL_GET_INTERP;
cc077a9f 313 } else {
fd8cd3a3 314 aTHX = NULL;
cc077a9f
HM		 315 }
316#endif
748a9306 317
fa537f88 318 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d
PP		 319 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
320 }
f7ddb74a 321 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 322 *cp2 = _toupper(*cp1);
323 if (cp1 - lnm > LNM$C_NAMLENGTH) {
324 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
325 return 0;
326 }
327 }
328 lnmdsc.dsc$w_length = cp1 - lnm;
329 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 330 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 331 secure = flags & PERL__TRNENV_SECURE;
332 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
333 if (!tabvec || !*tabvec) tabvec = env_tables;
334
335 for (curtab = 0; tabvec[curtab]; curtab++) {
336 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
337 if (!ivenv && !secure) {
338 char *eq, *end;
339 int i;
340 if (!environ) {
341 ivenv = 1;
5c84aa53 342 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 343 continue;
344 }
345 retsts = SS$_NOLOGNAM;
346 for (i = 0; environ[i]; i++) {
347 if ((eq = strchr(environ[i],'=')) &&
299d126a 348 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 349 !strncmp(environ[i],uplnm,eq - environ[i])) {
350 eq++;
351 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
352 if (!eqvlen) continue;
353 retsts = SS$_NORMAL;
354 break;
355 }
356 }
357 if (retsts != SS$_NOLOGNAM) break;
358 }
359 }
360 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
361 !str$case_blind_compare(&tmpdsc,&clisym)) {
362 if (!ivsym && !secure) {
363 unsigned short int deflen = LNM$C_NAMLENGTH;
364 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
365 /* dynamic dsc to accomodate possible long value */
366 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
367 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
368 if (retsts & 1) {
369 if (eqvlen > 1024) {
f675dbe5 370 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
3eeba6fb 371 eqvlen = 1024;
cc077a9f
HM		 372 /* Special hack--we might be called before the interpreter's */
373 /* fully initialized, in which case either thr or PL_curcop */
374 /* might be bogus. We have to check, since ckWARN needs them */
375 /* both to be valid if running threaded */
cc077a9f 376 if (ckWARN(WARN_MISC)) {
f98bc0c6 377 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 378 }
f675dbe5
CB		 379 }
380 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
381 }
382 _ckvmssts(lib$sfree1_dd(&eqvdsc));
383 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
384 if (retsts == LIB$_NOSUCHSYM) continue;
385 break;
386 }
387 }
388 else if (!ivlnm) {
843027b0 389 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 390 midx = my_maxidx(lnm);
391 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
392 lnmlst[1].bufadr = cp2;
fa537f88
CB		 393 eqvlen = 0;
394 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
395 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
396 if (retsts == SS$_NOLOGNAM) break;
397 /* PPFs have a prefix */
398 if (
fd7385b9 399#if INTSIZE == 4
fa537f88 400 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 401#endif
fa537f88
CB		 402 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
403 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
404 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
405 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
406 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
407 memcpy(eqv,eqv+4,eqvlen-4);
408 eqvlen -= 4;
409 }
f7ddb74a
JM		 410 cp2 += eqvlen;
411 *cp2 = '\0';
fa537f88
CB		 412 }
413 if ((retsts == SS$_IVLOGNAM) ||
414 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 415 }
fa537f88 416 else {
fa537f88
CB		 417 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
418 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
419 if (retsts == SS$_NOLOGNAM) continue;
420 eqv[eqvlen] = '\0';
421 }
422 eqvlen = strlen(eqv);
f675dbe5
CB		 423 break;
424 }
c07a80fd 425 }
f675dbe5
CB		 426 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
427 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
428 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
429 retsts == SS$_NOLOGNAM) {
430 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 431 }
f675dbe5
CB		 432 else _ckvmssts(retsts);
433 return 0;
434} /* end of vmstrnenv */
435/*}}}*/
c07a80fd 436
f675dbe5
CB		 437/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
438/* Define as a function so we can access statics. */
4b19af01 439int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 440{
441 return vmstrnenv(lnm,eqv,idx,fildev,
442#ifdef SECURE_INTERNAL_GETENV
443 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
444#else
445 0
446#endif
447 );
448}
449/*}}}*/
a0d0e21e
LW		 450
451/* my_getenv
61bb5906
CB		 452 * Note: Uses Perl temp to store result so char * can be returned to
453 * caller; this pointer will be invalidated at next Perl statement
454 * transition.
a6c40364 455 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 456 * so that it'll work when PL_curinterp is undefined (and we therefore can't
457 * allocate SVs).
a0d0e21e 458 */
f675dbe5 459/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 460char *
5c84aa53 461Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 462{
f7ddb74a 463 const char *cp1;
fa537f88 464 static char *__my_getenv_eqv = NULL;
f7ddb74a 465 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 466 unsigned long int idx = 0;
bc10a425 467 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 468 int midx, flags;
61bb5906 469 SV *tmpsv;
a0d0e21e 470
f7ddb74a 471 midx = my_maxidx(lnm) + 1;
fa537f88 472
6b88bc9c 473 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 474 /* Set up a temporary buffer for the return value; Perl will
475 * clean it up at the next statement transition */
fa537f88 476 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 477 if (!tmpsv) return NULL;
478 eqv = SvPVX(tmpsv);
479 }
fa537f88
CB		 480 else {
481 /* Assume no interpreter ==> single thread */
482 if (__my_getenv_eqv != NULL) {
483 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
484 }
485 else {
a02a5408 486 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 487 }
488 eqv = __my_getenv_eqv;
489 }
490
f7ddb74a 491 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 492 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
61bb5906
CB		 493 getcwd(eqv,LNM$C_NAMLENGTH);
494 return eqv;
748a9306 495 }
a0d0e21e 496 else {
2512681b 497 /* Impose security constraints only if tainting */
bc10a425
CB		 498 if (sys) {
499 /* Impose security constraints only if tainting */
500 secure = PL_curinterp ? PL_tainting : will_taint;
501 saverr = errno; savvmserr = vaxc$errno;
502 }
843027b0
CB		 503 else {
504 secure = 0;
505 }
506
507 flags =
f675dbe5 508#ifdef SECURE_INTERNAL_GETENV
843027b0 509 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 510#else
843027b0 511 0
f675dbe5 512#endif
843027b0
CB		 513 ;
514
515 /* For the getenv interface we combine all the equivalence names
516 * of a search list logical into one value to acquire a maximum
517 * value length of 255*128 (assuming %ENV is using logicals).
518 */
519 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
520
521 /* If the name contains a semicolon-delimited index, parse it
522 * off and make sure we only retrieve the equivalence name for
523 * that index. */
524 if ((cp2 = strchr(lnm,';')) != NULL) {
525 strcpy(uplnm,lnm);
526 uplnm[cp2-lnm] = '\0';
527 idx = strtoul(cp2+1,NULL,0);
528 lnm = uplnm;
529 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
530 }
531
532 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
533
bc10a425
CB		 534 /* Discard NOLOGNAM on internal calls since we're often looking
535 * for an optional name, and this "error" often shows up as the
536 * (bogus) exit status for a die() call later on. */
537 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
538 return success ? eqv : Nullch;
a0d0e21e 539 }
a0d0e21e
LW		 540
541} /* end of my_getenv() */
542/*}}}*/
543
f675dbe5 544
a6c40364
GS		 545/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
546char *
fd8cd3a3 547Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 548{
f7ddb74a
JM		 549 const char *cp1;
550 char *buf, *cp2;
a6c40364 551 unsigned long idx = 0;
843027b0 552 int midx, flags;
fa537f88 553 static char *__my_getenv_len_eqv = NULL;
bc10a425 554 int secure, saverr, savvmserr;
cc077a9f
HM		 555 SV *tmpsv;
556
f7ddb74a 557 midx = my_maxidx(lnm) + 1;
fa537f88 558
cc077a9f
HM		 559 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
560 /* Set up a temporary buffer for the return value; Perl will
561 * clean it up at the next statement transition */
fa537f88 562 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 563 if (!tmpsv) return NULL;
564 buf = SvPVX(tmpsv);
565 }
fa537f88
CB		 566 else {
567 /* Assume no interpreter ==> single thread */
568 if (__my_getenv_len_eqv != NULL) {
569 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
570 }
571 else {
a02a5408 572 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 573 }
574 buf = __my_getenv_len_eqv;
575 }
576
f7ddb74a 577 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 578 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 579 char * zeros;
580
f675dbe5 581 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 582 *len = strlen(buf);
f7ddb74a
JM		 583
584 /* Get rid of "000000/ in rooted filespecs */
585 if (*len > 7) {
586 zeros = strstr(buf, "/000000/");
587 if (zeros != NULL) {
588 int mlen;
589 mlen = *len - (zeros - buf) - 7;
590 memmove(zeros, &zeros[7], mlen);
591 *len = *len - 7;
592 buf[*len] = '\0';
593 }
594 }
a6c40364 595 return buf;
f675dbe5
CB		 596 }
597 else {
bc10a425
CB		 598 if (sys) {
599 /* Impose security constraints only if tainting */
600 secure = PL_curinterp ? PL_tainting : will_taint;
601 saverr = errno; savvmserr = vaxc$errno;
602 }
843027b0
CB		 603 else {
604 secure = 0;
605 }
606
607 flags =
f675dbe5 608#ifdef SECURE_INTERNAL_GETENV
843027b0 609 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 610#else
843027b0 611 0
f675dbe5 612#endif
843027b0
CB		 613 ;
614
615 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
616
617 if ((cp2 = strchr(lnm,';')) != NULL) {
618 strcpy(buf,lnm);
619 buf[cp2-lnm] = '\0';
620 idx = strtoul(cp2+1,NULL,0);
621 lnm = buf;
622 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
623 }
624
625 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
626
f7ddb74a
JM		 627 /* Get rid of "000000/ in rooted filespecs */
628 if (*len > 7) {
629 char * zeros;
630 zeros = strstr(buf, "/000000/");
631 if (zeros != NULL) {
632 int mlen;
633 mlen = *len - (zeros - buf) - 7;
634 memmove(zeros, &zeros[7], mlen);
635 *len = *len - 7;
636 buf[*len] = '\0';
637 }
638 }
639
bc10a425
CB		 640 /* Discard NOLOGNAM on internal calls since we're often looking
641 * for an optional name, and this "error" often shows up as the
642 * (bogus) exit status for a die() call later on. */
643 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
644 return *len ? buf : Nullch;
f675dbe5
CB		 645 }
646
a6c40364 647} /* end of my_getenv_len() */
f675dbe5
CB		 648/*}}}*/
649
fd8cd3a3 650static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 651
652static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 653
740ce14c
PP		 654/*{{{ void prime_env_iter() */
655void
656prime_env_iter(void)
657/* Fill the %ENV associative array with all logical names we can
658 * find, in preparation for iterating over it.
659 */
660{
17f28c40 661 static int primed = 0;
3eeba6fb 662 HV *seenhv = NULL, *envhv;
22be8b3c 663 SV *sv = NULL;
f675dbe5 664 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 665 unsigned short int chan;
666#ifndef CLI$M_TRUSTED
667# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
668#endif
f675dbe5
CB		 669 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
670 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
671 long int i;
672 bool have_sym = FALSE, have_lnm = FALSE;
673 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
674 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
675 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
676 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
677 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 678#if defined(PERL_IMPLICIT_CONTEXT)
679 pTHX;
680#endif
3db8f154 681#if defined(USE_ITHREADS)
b2b3adea
HM		 682 static perl_mutex primenv_mutex;
683 MUTEX_INIT(&primenv_mutex);
61bb5906 684#endif
740ce14c 685
fd8cd3a3
DS		 686#if defined(PERL_IMPLICIT_CONTEXT)
687 /* We jump through these hoops because we can be called at */
688 /* platform-specific initialization time, which is before anything is */
689 /* set up--we can't even do a plain dTHX since that relies on the */
690 /* interpreter structure to be initialized */
fd8cd3a3
DS		 691 if (PL_curinterp) {
692 aTHX = PERL_GET_INTERP;
693 } else {
694 aTHX = NULL;
695 }
696#endif
fd8cd3a3 697
3eeba6fb 698 if (primed || !PL_envgv) return;
61bb5906
CB		 699 MUTEX_LOCK(&primenv_mutex);
700 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 701 envhv = GvHVn(PL_envgv);
740ce14c 702 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 703 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 704 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 705
f675dbe5
CB		 706 for (i = 0; env_tables[i]; i++) {
707 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
708 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
709 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 710 }
f675dbe5
CB		 711 if (have_sym || have_lnm) {
712 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
713 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
714 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
715 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 716 }
f675dbe5
CB		 717
718 for (i--; i >= 0; i--) {
719 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
720 char *start;
721 int j;
722 for (j = 0; environ[j]; j++) {
723 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 724 if (ckWARN(WARN_INTERNAL))
f98bc0c6 725 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 726 }
727 else {
728 start++;
22be8b3c
CB		 729 sv = newSVpv(start,0);
730 SvTAINTED_on(sv);
731 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 732 }
733 }
734 continue;
740ce14c 735 }
f675dbe5
CB		 736 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
737 !str$case_blind_compare(&tmpdsc,&clisym)) {
738 strcpy(cmd,"Show Symbol/Global *");
739 cmddsc.dsc$w_length = 20;
740 if (env_tables[i]->dsc$w_length == 12 &&
741 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
742 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
743 flags = defflags | CLI$M_NOLOGNAM;
744 }
745 else {
746 strcpy(cmd,"Show Logical *");
747 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
748 strcat(cmd," /Table=");
749 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
750 cmddsc.dsc$w_length = strlen(cmd);
751 }
752 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
753 flags = defflags | CLI$M_NOCLISYM;
754 }
755
756 /* Create a new subprocess to execute each command, to exclude the
757 * remote possibility that someone could subvert a mbx or file used
758 * to write multiple commands to a single subprocess.
759 */
760 do {
761 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
762 0,&riseandshine,0,0,&clidsc,&clitabdsc);
763 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
764 defflags &= ~CLI$M_TRUSTED;
765 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
766 _ckvmssts(retsts);
a02a5408 767 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 768 if (seenhv) SvREFCNT_dec(seenhv);
769 seenhv = newHV();
770 while (1) {
771 char *cp1, *cp2, *key;
772 unsigned long int sts, iosb[2], retlen, keylen;
773 register U32 hash;
774
775 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
776 if (sts & 1) sts = iosb[0] & 0xffff;
777 if (sts == SS$_ENDOFFILE) {
778 int wakect = 0;
779 while (substs == 0) { sys$hiber(); wakect++;}
780 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
781 _ckvmssts(substs);
782 break;
783 }
784 _ckvmssts(sts);
785 retlen = iosb[0] >> 16;
786 if (!retlen) continue; /* blank line */
787 buf[retlen] = '\0';
788 if (iosb[1] != subpid) {
789 if (iosb[1]) {
5c84aa53 790 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 791 }
792 continue;
793 }
3eeba6fb 794 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 795 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 796
797 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
798 if (*cp1 == '(' || /* Logical name table name */
799 *cp1 == '=' /* Next eqv of searchlist */) continue;
800 if (*cp1 == '"') cp1++;
801 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
802 key = cp1; keylen = cp2 - cp1;
803 if (keylen && hv_exists(seenhv,key,keylen)) continue;
804 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 805 while (*cp2 && *cp2 == '=') cp2++;
806 while (*cp2 && *cp2 == ' ') cp2++;
807 if (*cp2 == '"') { /* String translation; may embed "" */
808 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
809 cp2++; cp1--; /* Skip "" surrounding translation */
810 }
811 else { /* Numeric translation */
812 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
813 cp1--; /* stop on last non-space char */
814 }
815 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 816 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 817 continue;
818 }
5afd6d42 819 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 820
821 if (cp1 == cp2 && *cp2 == '.') {
822 /* A single dot usually means an unprintable character, such as a null
823 * to indicate a zero-length value. Get the actual value to make sure.
824 */
825 char lnm[LNM$C_NAMLENGTH+1];
826 char eqv[LNM$C_NAMLENGTH+1];
827 strncpy(lnm, key, keylen);
828 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
829 sv = newSVpvn(eqv, strlen(eqv));
830 }
831 else {
832 sv = newSVpvn(cp2,cp1 - cp2 + 1);
833 }
834
22be8b3c
CB		 835 SvTAINTED_on(sv);
836 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 837 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 838 }
f675dbe5
CB		 839 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
840 /* get the PPFs for this process, not the subprocess */
f7ddb74a 841 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 842 char eqv[LNM$C_NAMLENGTH+1];
843 int trnlen, i;
844 for (i = 0; ppfs[i]; i++) {
845 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 846 sv = newSVpv(eqv,trnlen);
847 SvTAINTED_on(sv);
848 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 849 }
740ce14c
PP		 850 }
851 }
f675dbe5
CB		 852 primed = 1;
853 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
854 if (buf) Safefree(buf);
855 if (seenhv) SvREFCNT_dec(seenhv);
856 MUTEX_UNLOCK(&primenv_mutex);
857 return;
858
740ce14c
PP		 859} /* end of prime_env_iter */
860/*}}}*/
740ce14c 861
f675dbe5 862
2c590a56 863/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 864/* Define or delete an element in the same "environment" as
865 * vmstrnenv(). If an element is to be deleted, it's removed from
866 * the first place it's found. If it's to be set, it's set in the
867 * place designated by the first element of the table vector.
3eeba6fb 868 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 869 */
f675dbe5 870int
2c590a56 871Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 872{
f7ddb74a
JM		 873 const char *cp1;
874 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 875 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 876 int nseg = 0, j;
a0d0e21e 877 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 878 struct itmlst_3 *ile, *ilist;
a0d0e21e 879 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 880 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
881 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
882 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
883 $DESCRIPTOR(local,"_LOCAL");
884
ed253963
CB		 885 if (!lnm) {
886 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
887 return SS$_IVLOGNAM;
888 }
889
f7ddb74a 890 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 891 *cp2 = _toupper(*cp1);
892 if (cp1 - lnm > LNM$C_NAMLENGTH) {
893 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
894 return SS$_IVLOGNAM;
895 }
896 }
a0d0e21e 897 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 898 if (!tabvec || !*tabvec) tabvec = env_tables;
899
3eeba6fb 900 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 901 for (curtab = 0; tabvec[curtab]; curtab++) {
902 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
903 int i;
299d126a 904 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 905 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 906 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 907 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 908#ifdef HAS_SETENV
0e06870b 909 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 910 }
911 }
912 ivenv = 1; retsts = SS$_NOLOGNAM;
913#else
3eeba6fb 914 if (ckWARN(WARN_INTERNAL))
f98bc0c6 915 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 916 ivenv = 1; retsts = SS$_NOSUCHPGM;
917 break;
918 }
919 }
f675dbe5
CB		 920#endif
921 }
922 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
923 !str$case_blind_compare(&tmpdsc,&clisym)) {
924 unsigned int symtype;
925 if (tabvec[curtab]->dsc$w_length == 12 &&
926 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
927 !str$case_blind_compare(&tmpdsc,&local))
928 symtype = LIB$K_CLI_LOCAL_SYM;
929 else symtype = LIB$K_CLI_GLOBAL_SYM;
930 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 931 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
932 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 933 break;
934 }
935 else if (!ivlnm) {
936 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
937 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
938 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
939 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
940 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
941 }
a0d0e21e
LW		 942 }
943 }
f675dbe5
CB		 944 else { /* we're defining a value */
945 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
946#ifdef HAS_SETENV
3eeba6fb 947 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 948#else
3eeba6fb 949 if (ckWARN(WARN_INTERNAL))
f98bc0c6 950 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 951 retsts = SS$_NOSUCHPGM;
952#endif
953 }
954 else {
f7ddb74a 955 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 956 eqvdsc.dsc$w_length = strlen(eqv);
957 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
958 !str$case_blind_compare(&tmpdsc,&clisym)) {
959 unsigned int symtype;
960 if (tabvec[0]->dsc$w_length == 12 &&
961 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
962 !str$case_blind_compare(&tmpdsc,&local))
963 symtype = LIB$K_CLI_LOCAL_SYM;
964 else symtype = LIB$K_CLI_GLOBAL_SYM;
965 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
966 }
3eeba6fb
CB		 967 else {
968 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 969 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 970
971 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
972 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
973 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
974 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
975 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
976 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
977 }
978
a02a5408 979 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 980 ile = ilist;
981 if (!ile) {
982 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
983 return SS$_INSFMEM;
a1dfe751 984 }
fa537f88
CB		 985 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
986
987 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
988 ile->itmcode = LNM$_STRING;
989 ile->bufadr = c;
990 if ((j+1) == nseg) {
991 ile->buflen = strlen(c);
992 /* in case we are truncating one that's too long */
993 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
994 }
995 else {
996 ile->buflen = LNM$C_NAMLENGTH;
997 }
998 }
999
1000 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1001 Safefree (ilist);
1002 }
1003 else {
1004 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1005 }
3eeba6fb 1006 }
f675dbe5
CB		 1007 }
1008 }
1009 if (!(retsts & 1)) {
1010 switch (retsts) {
1011 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1012 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1013 set_errno(EVMSERR); break;
1014 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1015 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1016 set_errno(EINVAL); break;
1017 case SS$_NOPRIV:
1018 set_errno(EACCES);
1019 default:
1020 _ckvmssts(retsts);
1021 set_errno(EVMSERR);
1022 }
1023 set_vaxc_errno(retsts);
1024 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1025 }
3eeba6fb
CB		 1026 else {
1027 /* We reset error values on success because Perl does an hv_fetch()
1028 * before each hv_store(), and if the thing we're setting didn't
1029 * previously exist, we've got a leftover error message. (Of course,
1030 * this fails in the face of
1031 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1032 * in that the error reported in $! isn't spurious,
1033 * but it's right more often than not.)
1034 */
f675dbe5
CB		 1035 set_errno(0); set_vaxc_errno(retsts);
1036 return 0;
1037 }
1038
1039} /* end of vmssetenv() */
1040/*}}}*/
a0d0e21e 1041
2c590a56 1042/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1043/* This has to be a function since there's a prototype for it in proto.h */
1044void
2c590a56 1045Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1046{
bc10a425
CB		 1047 if (lnm && *lnm) {
1048 int len = strlen(lnm);
1049 if (len == 7) {
1050 char uplnm[8];
22d4bb9c
CB		 1051 int i;
1052 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425
CB		 1053 if (!strcmp(uplnm,"DEFAULT")) {
1054 if (eqv && *eqv) chdir(eqv);
1055 return;
1056 }
1057 }
1058#ifndef RTL_USES_UTC
1059 if (len == 6 || len == 2) {
1060 char uplnm[7];
1061 int i;
1062 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1063 uplnm[len] = '\0';
1064 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1065 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1066 }
1067#endif
1068 }
f675dbe5
CB		 1069 (void) vmssetenv(lnm,eqv,NULL);
1070}
a0d0e21e
LW		 1071/*}}}*/
1072
27c67b75 1073/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1074/* vmssetuserlnm
1075 * sets a user-mode logical in the process logical name table
1076 * used for redirection of sys$error
1077 */
1078void
2fbb330f 1079Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1080{
1081 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1082 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1083 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1084 unsigned char acmode = PSL$C_USER;
1085 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1086 {0, 0, 0, 0}};
2fbb330f 1087 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1088 d_name.dsc$w_length = strlen(name);
1089
1090 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1091 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1092
1093 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1094 if (!(iss&1)) lib$signal(iss);
1095}
1096/*}}}*/
c07a80fd 1097
f675dbe5 1098
c07a80fd
PP		 1099/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1100/* my_crypt - VMS password hashing
1101 * my_crypt() provides an interface compatible with the Unix crypt()
1102 * C library function, and uses sys$hash_password() to perform VMS
1103 * password hashing. The quadword hashed password value is returned
1104 * as a NUL-terminated 8 character string. my_crypt() does not change
1105 * the case of its string arguments; in order to match the behavior
1106 * of LOGINOUT et al., alphabetic characters in both arguments must
1107 * be upcased by the caller.
1108 */
1109char *
fd8cd3a3 1110Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd
PP		 1111{
1112# ifndef UAI$C_PREFERRED_ALGORITHM
1113# define UAI$C_PREFERRED_ALGORITHM 127
1114# endif
1115 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1116 unsigned short int salt = 0;
1117 unsigned long int sts;
1118 struct const_dsc {
1119 unsigned short int dsc$w_length;
1120 unsigned char dsc$b_type;
1121 unsigned char dsc$b_class;
1122 const char * dsc$a_pointer;
1123 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1124 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1125 struct itmlst_3 uailst[3] = {
1126 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1127 { sizeof salt, UAI$_SALT, &salt, 0},
1128 { 0, 0, NULL, NULL}};
1129 static char hash[9];
1130
1131 usrdsc.dsc$w_length = strlen(usrname);
1132 usrdsc.dsc$a_pointer = usrname;
1133 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1134 switch (sts) {
f282b18d 1135 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd
PP		 1136 set_errno(EACCES);
1137 break;
1138 case RMS$_RNF:
1139 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1140 break;
1141 default:
1142 set_errno(EVMSERR);
1143 }
1144 set_vaxc_errno(sts);
1145 if (sts != RMS$_RNF) return NULL;
1146 }
1147
1148 txtdsc.dsc$w_length = strlen(textpasswd);
1149 txtdsc.dsc$a_pointer = textpasswd;
1150 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1151 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1152 }
1153
1154 return (char *) hash;
1155
1156} /* end of my_crypt() */
1157/*}}}*/
1158
1159
2fbb330f 1160static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
b8ffc8df
RGS		 1161static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1162static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
a0d0e21e
LW		 1163
1164/*{{{int do_rmdir(char *name)*/
1165int
b8ffc8df 1166Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e
LW		 1167{
1168 char dirfile[NAM$C_MAXRSS+1];
1169 int retval;
61bb5906 1170 Stat_t st;
a0d0e21e
LW		 1171
1172 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1173 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1174 else retval = kill_file(dirfile);
1175 return retval;
1176
1177} /* end of do_rmdir */
1178/*}}}*/
1179
1180/* kill_file
1181 * Delete any file to which user has control access, regardless of whether
1182 * delete access is explicitly allowed.
1183 * Limitations: User must have write access to parent directory.
1184 * Does not block signals or ASTs; if interrupted in midstream
1185 * may leave file with an altered ACL.
1186 * HANDLE WITH CARE!
1187 */
1188/*{{{int kill_file(char *name)*/
1189int
b8ffc8df 1190Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1191{
bbce6d69 1192 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
a0d0e21e 1193 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 1194 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e
LW		 1195 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1196 struct myacedef {
748a9306
LW		 1197 unsigned char myace$b_length;
1198 unsigned char myace$b_type;
1199 unsigned short int myace$w_flags;
1200 unsigned long int myace$l_access;
1201 unsigned long int myace$l_ident;
a0d0e21e
LW		 1202 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1203 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1204 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1205 struct itmlst_3
748a9306
LW		 1206 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1207 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1208 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1209 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1210 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1211 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 1212
bbce6d69
PP		 1213 /* Expand the input spec using RMS, since the CRTL remove() and
1214 * system services won't do this by themselves, so we may miss
1215 * a file "hiding" behind a logical name or search list. */
1216 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1217 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1218 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
740ce14c
PP		 1219 /* If not, can changing protections help? */
1220 if (vaxc$errno != RMS$_PRV) return -1;
a0d0e21e
LW		 1221
1222 /* No, so we get our own UIC to use as a rights identifier,
1223 * and the insert an ACE at the head of the ACL which allows us
1224 * to delete the file.
1225 */
748a9306 1226 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
bbce6d69
PP		 1227 fildsc.dsc$w_length = strlen(rspec);
1228 fildsc.dsc$a_pointer = rspec;
a0d0e21e 1229 cxt = 0;
748a9306 1230 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 1231 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
740ce14c 1232 switch (aclsts) {
f282b18d 1233 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
740ce14c 1234 set_errno(ENOENT); break;
f282b18d
CB		 1235 case RMS$_DIR:
1236 set_errno(ENOTDIR); break;
740ce14c
PP		 1237 case RMS$_DEV:
1238 set_errno(ENODEV); break;
f282b18d 1239 case RMS$_SYN: case SS$_INVFILFOROP:
740ce14c
PP		 1240 set_errno(EINVAL); break;
1241 case RMS$_PRV:
1242 set_errno(EACCES); break;
1243 default:
1244 _ckvmssts(aclsts);
1245 }
748a9306 1246 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1247 return -1;
1248 }
1249 /* Grab any existing ACEs with this identifier in case we fail */
1250 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a
PP		 1251 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1252 || fndsts == SS$_NOMOREACE ) {
a0d0e21e
LW		 1253 /* Add the new ACE . . . */
1254 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1255 goto yourroom;
748a9306 1256 if ((rmsts = remove(name))) {
a0d0e21e
LW		 1257 /* We blew it - dir with files in it, no write priv for
1258 * parent directory, etc. Put things back the way they were. */
1259 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1260 goto yourroom;
1261 if (fndsts & 1) {
1262 addlst[0].bufadr = &oldace;
1263 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1264 goto yourroom;
1265 }
1266 }
1267 }
1268
1269 yourroom:
b7ae7a0d
PP		 1270 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1271 /* We just deleted it, so of course it's not there. Some versions of
1272 * VMS seem to return success on the unlock operation anyhow (after all
1273 * the unlock is successful), but others don't.
1274 */
760ac839 1275 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
b7ae7a0d 1276 if (aclsts & 1) aclsts = fndsts;
a0d0e21e 1277 if (!(aclsts & 1)) {
748a9306
LW		 1278 set_errno(EVMSERR);
1279 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1280 return -1;
1281 }
1282
1283 return rmsts;
1284
1285} /* end of kill_file() */
1286/*}}}*/
1287
8cc95fdb 1288
84902520 1289/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 1290int
b8ffc8df 1291Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb
PP		 1292{
1293 STRLEN dirlen = strlen(dir);
1294
a2a90019
CB		 1295 /* zero length string sometimes gives ACCVIO */
1296 if (dirlen == 0) return -1;
1297
8cc95fdb
PP		 1298 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1299 * null file name/type. However, it's commonplace under Unix,
1300 * so we'll allow it for a gain in portability.
1301 */
1302 if (dir[dirlen-1] == '/') {
1303 char *newdir = savepvn(dir,dirlen-1);
1304 int ret = mkdir(newdir,mode);
1305 Safefree(newdir);
1306 return ret;
1307 }
1308 else return mkdir(dir,mode);
1309} /* end of my_mkdir */
1310/*}}}*/
1311
ee8c7f54
CB		 1312/*{{{int my_chdir(char *)*/
1313int
b8ffc8df 1314Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 1315{
1316 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 1317
1318 /* zero length string sometimes gives ACCVIO */
1319 if (dirlen == 0) return -1;
f7ddb74a
JM		 1320 const char *dir1;
1321
1322 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1323 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1324 * so that existing scripts do not need to be changed.
1325 */
1326 dir1 = dir;
1327 while ((dirlen > 0) && (*dir1 == ' ')) {
1328 dir1++;
1329 dirlen--;
1330 }
ee8c7f54
CB		 1331
1332 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1333 * that implies
1334 * null file name/type. However, it's commonplace under Unix,
1335 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 1336 *
1337 * - Preview- '/' will be valid soon on VMS
ee8c7f54 1338 */
f7ddb74a 1339 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
ee8c7f54
CB		 1340 char *newdir = savepvn(dir,dirlen-1);
1341 int ret = chdir(newdir);
1342 Safefree(newdir);
1343 return ret;
1344 }
1345 else return chdir(dir);
1346} /* end of my_chdir */
1347/*}}}*/
8cc95fdb 1348
674d6c38
CB		 1349
1350/*{{{FILE *my_tmpfile()*/
1351FILE *
1352my_tmpfile(void)
1353{
1354 FILE *fp;
1355 char *cp;
674d6c38
CB		 1356
1357 if ((fp = tmpfile())) return fp;
1358
a02a5408 1359 Newx(cp,L_tmpnam+24,char);
674d6c38
CB		 1360 strcpy(cp,"Sys$Scratch:");
1361 tmpnam(cp+strlen(cp));
1362 strcat(cp,".Perltmp");
1363 fp = fopen(cp,"w+","fop=dlt");
1364 Safefree(cp);
1365 return fp;
1366}
1367/*}}}*/
1368
5c2d7af2
CB		 1369
1370#ifndef HOMEGROWN_POSIX_SIGNALS
1371/*
1372 * The C RTL's sigaction fails to check for invalid signal numbers so we
1373 * help it out a bit. The docs are correct, but the actual routine doesn't
1374 * do what the docs say it will.
1375 */
1376/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1377int
1378Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1379 struct sigaction* oact)
1380{
1381 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1382 SETERRNO(EINVAL, SS$_INVARG);
1383 return -1;
1384 }
1385 return sigaction(sig, act, oact);
1386}
1387/*}}}*/
1388#endif
1389
f2610a60
CL		 1390#ifdef KILL_BY_SIGPRC
1391#include <errnodef.h>
1392
05c058bc
CB		 1393/* We implement our own kill() using the undocumented system service
1394 sys$sigprc for one of two reasons:
1395
1396 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 1397 target process to do a sys$exit, which usually can't be handled
1398 gracefully...certainly not by Perl and the %SIG{} mechanism.
1399
05c058bc
CB		 1400 2.) If the kill() in the CRTL can't be called from a signal
1401 handler without disappearing into the ether, i.e., the signal
1402 it purportedly sends is never trapped. Still true as of VMS 7.3.
1403
1404 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 1405 in the target process rather than calling sys$exit.
1406
1407 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1408 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1409 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1410 with condition codes C$_SIG0+nsig*8, catching the exception on the
1411 target process and resignaling with appropriate arguments.
1412
1413 But we don't have that VMS 7.0+ exception handler, so if you
1414 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1415
1416 Also note that SIGTERM is listed in the docs as being "unimplemented",
1417 yet always seems to be signaled with a VMS condition code of 4 (and
1418 correctly handled for that code). So we hardwire it in.
1419
1420 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1421 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1422 than signalling with an unrecognized (and unhandled by CRTL) code.
1423*/
1424
1425#define _MY_SIG_MAX 17
1426
2e34cc90
CL		 1427unsigned int
1428Perl_sig_to_vmscondition(int sig)
f2610a60 1429{
2e34cc90 1430 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 1431 {
1432 0, /* 0 ZERO */
1433 SS$_HANGUP, /* 1 SIGHUP */
1434 SS$_CONTROLC, /* 2 SIGINT */
1435 SS$_CONTROLY, /* 3 SIGQUIT */
1436 SS$_RADRMOD, /* 4 SIGILL */
1437 SS$_BREAK, /* 5 SIGTRAP */
1438 SS$_OPCCUS, /* 6 SIGABRT */
1439 SS$_COMPAT, /* 7 SIGEMT */
1440#ifdef __VAX
1441 SS$_FLTOVF, /* 8 SIGFPE VAX */
1442#else
1443 SS$_HPARITH, /* 8 SIGFPE AXP */
1444#endif
1445 SS$_ABORT, /* 9 SIGKILL */
1446 SS$_ACCVIO, /* 10 SIGBUS */
1447 SS$_ACCVIO, /* 11 SIGSEGV */
1448 SS$_BADPARAM, /* 12 SIGSYS */
1449 SS$_NOMBX, /* 13 SIGPIPE */
1450 SS$_ASTFLT, /* 14 SIGALRM */
1451 4, /* 15 SIGTERM */
1452 0, /* 16 SIGUSR1 */
1453 0 /* 17 SIGUSR2 */
1454 };
1455
1456#if __VMS_VER >= 60200000
1457 static int initted = 0;
1458 if (!initted) {
1459 initted = 1;
1460 sig_code[16] = C$_SIGUSR1;
1461 sig_code[17] = C$_SIGUSR2;
1462 }
1463#endif
1464
2e34cc90
CL		 1465 if (sig < _SIG_MIN) return 0;
1466 if (sig > _MY_SIG_MAX) return 0;
1467 return sig_code[sig];
1468}
1469
2e34cc90
CL		 1470int
1471Perl_my_kill(int pid, int sig)
1472{
218fdd94 1473 dTHX;
2e34cc90
CL		 1474 int iss;
1475 unsigned int code;
1476 int sys$sigprc(unsigned int *pidadr,
1477 struct dsc$descriptor_s *prcname,
1478 unsigned int code);
1479
1480 code = Perl_sig_to_vmscondition(sig);
1481
1482 if (!pid || !code) {
f2610a60
CL		 1483 return -1;
1484 }
1485
2e34cc90 1486 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 1487 if (iss&1) return 0;
1488
1489 switch (iss) {
1490 case SS$_NOPRIV:
1491 set_errno(EPERM); break;
1492 case SS$_NONEXPR:
1493 case SS$_NOSUCHNODE:
1494 case SS$_UNREACHABLE:
1495 set_errno(ESRCH); break;
1496 case SS$_INSFMEM:
1497 set_errno(ENOMEM); break;
1498 default:
1499 _ckvmssts(iss);
1500 set_errno(EVMSERR);
1501 }
1502 set_vaxc_errno(iss);
1503
1504 return -1;
1505}
1506#endif
1507
2fbb330f
JM		 1508/* Routine to convert a VMS status code to a UNIX status code.
1509** More tricky than it appears because of conflicting conventions with
1510** existing code.
1511**
1512** VMS status codes are a bit mask, with the least significant bit set for
1513** success.
1514**
1515** Special UNIX status of EVMSERR indicates that no translation is currently
1516** available, and programs should check the VMS status code.
1517**
1518** Programs compiled with _POSIX_EXIT have a special encoding that requires
1519** decoding.
1520*/
1521
1522#ifndef C_FACILITY_NO
1523#define C_FACILITY_NO 0x350000
1524#endif
1525#ifndef DCL_IVVERB
1526#define DCL_IVVERB 0x38090
1527#endif
1528
1529int vms_status_to_unix(int vms_status)
1530{
1531int facility;
1532int fac_sp;
1533int msg_no;
1534int msg_status;
1535int unix_status;
1536
1537 /* Assume the best or the worst */
1538 if (vms_status & STS$M_SUCCESS)
1539 unix_status = 0;
1540 else
1541 unix_status = EVMSERR;
1542
1543 msg_status = vms_status & ~STS$M_CONTROL;
1544
1545 facility = vms_status & STS$M_FAC_NO;
1546 fac_sp = vms_status & STS$M_FAC_SP;
1547 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1548
1549 if ((facility == 0) || (fac_sp == 0)) {
1550 switch(msg_no) {
1551 case SS$_NORMAL:
1552 unix_status = 0;
1553 break;
1554 case SS$_ACCVIO:
1555 unix_status = EFAULT;
1556 break;
1557 case SS$_IVLOGNAM:
1558 case SS$_BADPARAM:
1559 case SS$_IVLOGTAB:
1560 case SS$_NOLOGNAM:
1561 case SS$_NOLOGTAB:
1562 case SS$_INVFILFOROP:
1563 case SS$_INVARG:
1564 case SS$_NOSUCHID:
1565 case SS$_IVIDENT:
1566 unix_status = EINVAL;
1567 break;
1568 case SS$_FILACCERR:
1569 case SS$_NOGRPPRV:
1570 case SS$_NOSYSPRV:
1571 unix_status = EACCES;
1572 break;
1573 case SS$_DEVICEFULL:
1574 unix_status = ENOSPC;
1575 break;
1576 case SS$_NOSUCHDEV:
1577 unix_status = ENODEV;
1578 break;
1579 case SS$_NOSUCHFILE:
1580 case SS$_NOSUCHOBJECT:
1581 unix_status = ENOENT;
1582 break;
1583 case SS$_ABORT:
1584 unix_status = EINTR;
1585 break;
1586 case SS$_BUFFEROVF:
1587 unix_status = E2BIG;
1588 break;
1589 case SS$_INSFMEM:
1590 unix_status = ENOMEM;
1591 break;
1592 case SS$_NOPRIV:
1593 unix_status = EPERM;
1594 break;
1595 case SS$_NOSUCHNODE:
1596 case SS$_UNREACHABLE:
1597 unix_status = ESRCH;
1598 break;
1599 case SS$_NONEXPR:
1600 unix_status = ECHILD;
1601 break;
1602 default:
1603 if ((facility == 0) && (msg_no < 8)) {
1604 /* These are not real VMS status codes so assume that they are
1605 ** already UNIX status codes
1606 */
1607 unix_status = msg_no;
1608 break;
1609 }
1610 }
1611 }
1612 else {
1613 /* Translate a POSIX exit code to a UNIX exit code */
1614 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
1615 unix_status = (msg_no & 0x0FF0) >> 3;
1616 }
1617 else {
1618 switch(msg_status) {
1619 /* case RMS$_EOF: */ /* End of File */
1620 case RMS$_FNF: /* File Not Found */
1621 case RMS$_DNF: /* Dir Not Found */
1622 unix_status = ENOENT;
1623 break;
1624 case RMS$_RNF: /* Record Not Found */
1625 unix_status = ESRCH;
1626 break;
1627 case RMS$_DIR:
1628 unix_status = ENOTDIR;
1629 break;
1630 case RMS$_DEV:
1631 unix_status = ENODEV;
1632 break;
1633 case RMS$_SYN:
1634 case RMS$_FNM:
1635 case LIB$_INVSTRDES:
1636 case LIB$_INVARG:
1637 case LIB$_NOSUCHSYM:
1638 case LIB$_INVSYMNAM:
1639 case DCL_IVVERB:
1640 unix_status = EINVAL;
1641 break;
1642 case CLI$_BUFOVF:
1643 case RMS$_RTB:
1644 case CLI$_TKNOVF:
1645 case CLI$_RSLOVF:
1646 unix_status = E2BIG;
1647 break;
1648 case RMS$_PRV: /* No privilege */
1649 case RMS$_ACC: /* ACP file access failed */
1650 case RMS$_WLK: /* Device write locked */
1651 unix_status = EACCES;
1652 break;
1653 /* case RMS$_NMF: */ /* No more files */
1654 }
1655 }
1656 }
1657
1658 return unix_status;
1659}
1660
1661
1662
22d4bb9c
CB		 1663/* default piping mailbox size */
1664#define PERL_BUFSIZ 512
1665
674d6c38 1666
a0d0e21e 1667static void
fd8cd3a3 1668create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 1669{
22d4bb9c
CB		 1670 unsigned long int mbxbufsiz;
1671 static unsigned long int syssize = 0;
1672 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 1673 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 1674 int sts;
1675
22d4bb9c
CB		 1676 if (!syssize) {
1677 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 1678 /*
22d4bb9c
CB		 1679 * Get the SYSGEN parameter MAXBUF
1680 *
1681 * If the logical 'PERL_MBX_SIZE' is defined
1682 * use the value of the logical instead of PERL_BUFSIZ, but
1683 * keep the size between 128 and MAXBUF.
1684 *
a0d0e21e 1685 */
22d4bb9c
CB		 1686 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1687 }
1688
1689 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1690 mbxbufsiz = atoi(csize);
1691 } else {
1692 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 1693 }
22d4bb9c
CB		 1694 if (mbxbufsiz < 128) mbxbufsiz = 128;
1695 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1696
f7ddb74a 1697 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 1698
f7ddb74a 1699 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 1700 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1701
1702} /* end of create_mbx() */
1703
22d4bb9c 1704
a0d0e21e 1705/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 1706
1707typedef struct _iosb IOSB;
1708typedef struct _iosb* pIOSB;
1709typedef struct _pipe Pipe;
1710typedef struct _pipe* pPipe;
1711typedef struct pipe_details Info;
1712typedef struct pipe_details* pInfo;
1713typedef struct _srqp RQE;
1714typedef struct _srqp* pRQE;
1715typedef struct _tochildbuf CBuf;
1716typedef struct _tochildbuf* pCBuf;
1717
1718struct _iosb {
1719 unsigned short status;
1720 unsigned short count;
1721 unsigned long dvispec;
1722};
1723
1724#pragma member_alignment save
1725#pragma nomember_alignment quadword
1726struct _srqp { /* VMS self-relative queue entry */
1727 unsigned long qptr[2];
1728};
1729#pragma member_alignment restore
1730static RQE RQE_ZERO = {0,0};
1731
1732struct _tochildbuf {
1733 RQE q;
1734 int eof;
1735 unsigned short size;
1736 char *buf;
1737};
1738
1739struct _pipe {
1740 RQE free;
1741 RQE wait;
1742 int fd_out;
1743 unsigned short chan_in;
1744 unsigned short chan_out;
1745 char *buf;
1746 unsigned int bufsize;
1747 IOSB iosb;
1748 IOSB iosb2;
1749 int *pipe_done;
1750 int retry;
1751 int type;
1752 int shut_on_empty;
1753 int need_wake;
1754 pPipe *home;
1755 pInfo info;
1756 pCBuf curr;
1757 pCBuf curr2;
fd8cd3a3
DS		 1758#if defined(PERL_IMPLICIT_CONTEXT)
1759 void *thx; /* Either a thread or an interpreter */
1760 /* pointer, depending on how we're built */
1761#endif
22d4bb9c
CB		 1762};
1763
1764
a0d0e21e
LW		 1765struct pipe_details
1766{
22d4bb9c 1767 pInfo next;
ff7adb52
CL		 1768 PerlIO *fp; /* file pointer to pipe mailbox */
1769 int useFILE; /* using stdio, not perlio */
748a9306
LW		 1770 int pid; /* PID of subprocess */
1771 int mode; /* == 'r' if pipe open for reading */
1772 int done; /* subprocess has completed */
ff7adb52 1773 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 1774 int closing; /* my_pclose is closing this pipe */
1775 unsigned long completion; /* termination status of subprocess */
1776 pPipe in; /* pipe in to sub */
1777 pPipe out; /* pipe out of sub */
1778 pPipe err; /* pipe of sub's sys$error */
1779 int in_done; /* true when in pipe finished */
1780 int out_done;
1781 int err_done;
a0d0e21e
LW		 1782};
1783
748a9306
LW		 1784struct exit_control_block
1785{
1786 struct exit_control_block *flink;
1787 unsigned long int (*exit_routine)();
1788 unsigned long int arg_count;
1789 unsigned long int *status_address;
1790 unsigned long int exit_status;
1791};
1792
d85f548a
JH		 1793typedef struct _closed_pipes Xpipe;
1794typedef struct _closed_pipes* pXpipe;
1795
1796struct _closed_pipes {
1797 int pid; /* PID of subprocess */
1798 unsigned long completion; /* termination status of subprocess */
1799};
1800#define NKEEPCLOSED 50
1801static Xpipe closed_list[NKEEPCLOSED];
1802static int closed_index = 0;
1803static int closed_num = 0;
1804
22d4bb9c
CB		 1805#define RETRY_DELAY "0 ::0.20"
1806#define MAX_RETRY 50
a0d0e21e 1807
22d4bb9c
CB		 1808static int pipe_ef = 0; /* first call to safe_popen inits these*/
1809static unsigned long mypid;
1810static unsigned long delaytime[2];
1811
1812static pInfo open_pipes = NULL;
1813static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 1814
ff7adb52
CL		 1815#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1816
1817
3eeba6fb 1818
748a9306 1819static unsigned long int
fd8cd3a3 1820pipe_exit_routine(pTHX)
748a9306 1821{
22d4bb9c 1822 pInfo info;
1e422769 1823 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 1824 int sts, did_stuff, need_eof, j;
1825
1826 /*
1827 flush any pending i/o
1828 */
1829 info = open_pipes;
1830 while (info) {
1831 if (info->fp) {
1832 if (!info->useFILE)
1833 PerlIO_flush(info->fp); /* first, flush data */
1834 else
1835 fflush((FILE *)info->fp);
1836 }
1837 info = info->next;
1838 }
3eeba6fb
CB		 1839
1840 /*
ff7adb52 1841 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 1842 don't hang
1843 */
1844 did_stuff = 0;
1845 info = open_pipes;
748a9306 1846
3eeba6fb 1847 while (info) {
b2b89246 1848 int need_eof;
b08af3f0 1849 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 1850 if (info->in && !info->in->shut_on_empty) {
1851 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1852 0, 0, 0, 0, 0, 0));
ff7adb52 1853 info->waiting = 1;
22d4bb9c 1854 did_stuff = 1;
748a9306 1855 }
22d4bb9c 1856 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1857 info = info->next;
1858 }
ff7adb52
CL		 1859
1860 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1861
1862 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1863 int nwait = 0;
1864
1865 info = open_pipes;
1866 while (info) {
1867 _ckvmssts(sys$setast(0));
1868 if (info->waiting && info->done)
1869 info->waiting = 0;
1870 nwait += info->waiting;
1871 _ckvmssts(sys$setast(1));
1872 info = info->next;
1873 }
1874 if (!nwait) break;
1875 sleep(1);
1876 }
3eeba6fb
CB		 1877
1878 did_stuff = 0;
1879 info = open_pipes;
1880 while (info) {
b08af3f0 1881 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1882 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1883 sts = sys$forcex(&info->pid,0,&abort);
1884 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1885 did_stuff = 1;
1886 }
b08af3f0 1887 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1888 info = info->next;
1889 }
ff7adb52
CL		 1890
1891 /* again, wait for effect */
1892
1893 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1894 int nwait = 0;
1895
1896 info = open_pipes;
1897 while (info) {
1898 _ckvmssts(sys$setast(0));
1899 if (info->waiting && info->done)
1900 info->waiting = 0;
1901 nwait += info->waiting;
1902 _ckvmssts(sys$setast(1));
1903 info = info->next;
1904 }
1905 if (!nwait) break;
1906 sleep(1);
1907 }
3eeba6fb
CB		 1908
1909 info = open_pipes;
1910 while (info) {
b08af3f0 1911 _ckvmssts(sys$setast(0));
3eeba6fb
CB		 1912 if (!info->done) { /* We tried to be nice . . . */
1913 sts = sys$delprc(&info->pid,0);
1914 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
3eeba6fb 1915 }
b08af3f0 1916 _ckvmssts(sys$setast(1));
3eeba6fb
CB		 1917 info = info->next;
1918 }
1919
1920 while(open_pipes) {
1e422769
PP		 1921 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1922 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 1923 }
1924 return retsts;
1925}
1926
1927static struct exit_control_block pipe_exitblock =
1928 {(struct exit_control_block *) 0,
1929 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1930
22d4bb9c
CB		 1931static void pipe_mbxtofd_ast(pPipe p);
1932static void pipe_tochild1_ast(pPipe p);
1933static void pipe_tochild2_ast(pPipe p);
748a9306 1934
a0d0e21e 1935static void
22d4bb9c 1936popen_completion_ast(pInfo info)
a0d0e21e 1937{
22d4bb9c
CB		 1938 pInfo i = open_pipes;
1939 int iss;
f7ddb74a 1940 int sts;
d85f548a
JH		 1941 pXpipe x;
1942
1943 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1944 closed_list[closed_index].pid = info->pid;
1945 closed_list[closed_index].completion = info->completion;
1946 closed_index++;
1947 if (closed_index == NKEEPCLOSED)
1948 closed_index = 0;
1949 closed_num++;
22d4bb9c
CB		 1950
1951 while (i) {
1952 if (i == info) break;
1953 i = i->next;
1954 }
1955 if (!i) return; /* unlinked, probably freed too */
1956
22d4bb9c
CB		 1957 info->done = TRUE;
1958
1959/*
1960 Writing to subprocess ...
1961 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1962
1963 chan_out may be waiting for "done" flag, or hung waiting
1964 for i/o completion to child...cancel the i/o. This will
1965 put it into "snarf mode" (done but no EOF yet) that discards
1966 input.
1967
1968 Output from subprocess (stdout, stderr) needs to be flushed and
1969 shut down. We try sending an EOF, but if the mbx is full the pipe
1970 routine should still catch the "shut_on_empty" flag, telling it to
1971 use immediate-style reads so that "mbx empty" -> EOF.
1972
1973
1974*/
1975 if (info->in && !info->in_done) { /* only for mode=w */
1976 if (info->in->shut_on_empty && info->in->need_wake) {
1977 info->in->need_wake = FALSE;
fd8cd3a3 1978 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 1979 } else {
fd8cd3a3 1980 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 1981 }
1982 }
1983
1984 if (info->out && !info->out_done) { /* were we also piping output? */
1985 info->out->shut_on_empty = TRUE;
1986 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1987 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1988 _ckvmssts_noperl(iss);
22d4bb9c
CB		 1989 }
1990
1991 if (info->err && !info->err_done) { /* we were piping stderr */
1992 info->err->shut_on_empty = TRUE;
1993 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1994 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 1995 _ckvmssts_noperl(iss);
a0d0e21e 1996 }
fd8cd3a3 1997 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 1998
a0d0e21e
LW		 1999}
2000
2fbb330f 2001static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 2002static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 2003
22d4bb9c
CB		 2004/*
2005 we actually differ from vmstrnenv since we use this to
2006 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2007 are pointing to the same thing
2008*/
2009
2010static unsigned short
fd8cd3a3 2011popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 2012{
2013 int iss;
2014 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2015 $DESCRIPTOR(d_log,"");
2016 struct _il3 {
2017 unsigned short length;
2018 unsigned short code;
2019 char * buffer_addr;
2020 unsigned short *retlenaddr;
2021 } itmlst[2];
2022 unsigned short l, ifi;
2023
2024 d_log.dsc$a_pointer = logical;
2025 d_log.dsc$w_length = strlen(logical);
2026
2027 itmlst[0].code = LNM$_STRING;
2028 itmlst[0].length = 255;
2029 itmlst[0].buffer_addr = result;
2030 itmlst[0].retlenaddr = &l;
2031
2032 itmlst[1].code = 0;
2033 itmlst[1].length = 0;
2034 itmlst[1].buffer_addr = 0;
2035 itmlst[1].retlenaddr = 0;
2036
2037 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2038 if (iss == SS$_NOLOGNAM) {
2039 iss = SS$_NORMAL;
2040 l = 0;
2041 }
2042 if (!(iss&1)) lib$signal(iss);
2043 result[l] = '\0';
2044/*
2045 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2046 strip it off and return the ifi, if any
2047*/
2048 ifi = 0;
2049 if (result[0] == 0x1b && result[1] == 0x00) {
2050 memcpy(&ifi,result+2,2);
2051 strcpy(result,result+4);
2052 }
2053 return ifi; /* this is the RMS internal file id */
2054}
2055
22d4bb9c
CB		 2056static void pipe_infromchild_ast(pPipe p);
2057
2058/*
2059 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2060 inside an AST routine without worrying about reentrancy and which Perl
2061 memory allocator is being used.
2062
2063 We read data and queue up the buffers, then spit them out one at a
2064 time to the output mailbox when the output mailbox is ready for one.
2065
2066*/
2067#define INITIAL_TOCHILDQUEUE 2
2068
2069static pPipe
fd8cd3a3 2070pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2071{
22d4bb9c
CB		 2072 pPipe p;
2073 pCBuf b;
2074 char mbx1[64], mbx2[64];
2075 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2076 DSC$K_CLASS_S, mbx1},
2077 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2078 DSC$K_CLASS_S, mbx2};
2079 unsigned int dviitm = DVI$_DEVBUFSIZ;
2080 int j, n;
2081
a02a5408 2082 Newx(p, 1, Pipe);
22d4bb9c 2083
fd8cd3a3
DS		 2084 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2085 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2086 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2087
2088 p->buf = 0;
2089 p->shut_on_empty = FALSE;
2090 p->need_wake = FALSE;
2091 p->type = 0;
2092 p->retry = 0;
2093 p->iosb.status = SS$_NORMAL;
2094 p->iosb2.status = SS$_NORMAL;
2095 p->free = RQE_ZERO;
2096 p->wait = RQE_ZERO;
2097 p->curr = 0;
2098 p->curr2 = 0;
2099 p->info = 0;
fd8cd3a3
DS		 2100#ifdef PERL_IMPLICIT_CONTEXT
2101 p->thx = aTHX;
2102#endif
22d4bb9c
CB		 2103
2104 n = sizeof(CBuf) + p->bufsize;
2105
2106 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2107 _ckvmssts(lib$get_vm(&n, &b));
2108 b->buf = (char *) b + sizeof(CBuf);
2109 _ckvmssts(lib$insqhi(b, &p->free));
2110 }
2111
2112 pipe_tochild2_ast(p);
2113 pipe_tochild1_ast(p);
2114 strcpy(wmbx, mbx1);
2115 strcpy(rmbx, mbx2);
2116 return p;
2117}
2118
2119/* reads the MBX Perl is writing, and queues */
2120
2121static void
2122pipe_tochild1_ast(pPipe p)
2123{
22d4bb9c
CB		 2124 pCBuf b = p->curr;
2125 int iss = p->iosb.status;
2126 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 2127 int sts;
fd8cd3a3
DS		 2128#ifdef PERL_IMPLICIT_CONTEXT
2129 pTHX = p->thx;
2130#endif
22d4bb9c
CB		 2131
2132 if (p->retry) {
2133 if (eof) {
2134 p->shut_on_empty = TRUE;
2135 b->eof = TRUE;
2136 _ckvmssts(sys$dassgn(p->chan_in));
2137 } else {
2138 _ckvmssts(iss);
2139 }
2140
2141 b->eof = eof;
2142 b->size = p->iosb.count;
f7ddb74a 2143 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 2144 if (p->need_wake) {
2145 p->need_wake = FALSE;
2146 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2147 }
2148 } else {
2149 p->retry = 1; /* initial call */
2150 }
2151
2152 if (eof) { /* flush the free queue, return when done */
2153 int n = sizeof(CBuf) + p->bufsize;
2154 while (1) {
2155 iss = lib$remqti(&p->free, &b);
2156 if (iss == LIB$_QUEWASEMP) return;
2157 _ckvmssts(iss);
2158 _ckvmssts(lib$free_vm(&n, &b));
2159 }
2160 }
2161
2162 iss = lib$remqti(&p->free, &b);
2163 if (iss == LIB$_QUEWASEMP) {
2164 int n = sizeof(CBuf) + p->bufsize;
2165 _ckvmssts(lib$get_vm(&n, &b));
2166 b->buf = (char *) b + sizeof(CBuf);
2167 } else {
2168 _ckvmssts(iss);
2169 }
2170
2171 p->curr = b;
2172 iss = sys$qio(0,p->chan_in,
2173 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2174 &p->iosb,
2175 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2176 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2177 _ckvmssts(iss);
2178}
2179
2180
2181/* writes queued buffers to output, waits for each to complete before
2182 doing the next */
2183
2184static void
2185pipe_tochild2_ast(pPipe p)
2186{
22d4bb9c
CB		 2187 pCBuf b = p->curr2;
2188 int iss = p->iosb2.status;
2189 int n = sizeof(CBuf) + p->bufsize;
2190 int done = (p->info && p->info->done) ||
2191 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 2192#if defined(PERL_IMPLICIT_CONTEXT)
2193 pTHX = p->thx;
2194#endif
22d4bb9c
CB		 2195
2196 do {
2197 if (p->type) { /* type=1 has old buffer, dispose */
2198 if (p->shut_on_empty) {
2199 _ckvmssts(lib$free_vm(&n, &b));
2200 } else {
2201 _ckvmssts(lib$insqhi(b, &p->free));
2202 }
2203 p->type = 0;
2204 }
2205
2206 iss = lib$remqti(&p->wait, &b);
2207 if (iss == LIB$_QUEWASEMP) {
2208 if (p->shut_on_empty) {
2209 if (done) {
2210 _ckvmssts(sys$dassgn(p->chan_out));
2211 *p->pipe_done = TRUE;
2212 _ckvmssts(sys$setef(pipe_ef));
2213 } else {
2214 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2215 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2216 }
2217 return;
2218 }
2219 p->need_wake = TRUE;
2220 return;
2221 }
2222 _ckvmssts(iss);
2223 p->type = 1;
2224 } while (done);
2225
2226
2227 p->curr2 = b;
2228 if (b->eof) {
2229 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2230 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2231 } else {
2232 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2233 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2234 }
2235
2236 return;
2237
2238}
2239
2240
2241static pPipe
fd8cd3a3 2242pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2243{
22d4bb9c
CB		 2244 pPipe p;
2245 char mbx1[64], mbx2[64];
2246 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2247 DSC$K_CLASS_S, mbx1},
2248 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2249 DSC$K_CLASS_S, mbx2};
2250 unsigned int dviitm = DVI$_DEVBUFSIZ;
2251
a02a5408 2252 Newx(p, 1, Pipe);
fd8cd3a3
DS		 2253 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2254 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2255
2256 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
a02a5408 2257 Newx(p->buf, p->bufsize, char);
22d4bb9c
CB		 2258 p->shut_on_empty = FALSE;
2259 p->info = 0;
2260 p->type = 0;
2261 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 2262#if defined(PERL_IMPLICIT_CONTEXT)
2263 p->thx = aTHX;
2264#endif
22d4bb9c
CB		 2265 pipe_infromchild_ast(p);
2266
2267 strcpy(wmbx, mbx1);
2268 strcpy(rmbx, mbx2);
2269 return p;
2270}
2271
2272static void
2273pipe_infromchild_ast(pPipe p)
2274{
22d4bb9c
CB		 2275 int iss = p->iosb.status;
2276 int eof = (iss == SS$_ENDOFFILE);
2277 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2278 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 2279#if defined(PERL_IMPLICIT_CONTEXT)
2280 pTHX = p->thx;
2281#endif
22d4bb9c
CB		 2282
2283 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2284 _ckvmssts(sys$dassgn(p->chan_out));
2285 p->chan_out = 0;
2286 }
2287
2288 /* read completed:
2289 input shutdown if EOF from self (done or shut_on_empty)
2290 output shutdown if closing flag set (my_pclose)
2291 send data/eof from child or eof from self
2292 otherwise, re-read (snarf of data from child)
2293 */
2294
2295 if (p->type == 1) {
2296 p->type = 0;
2297 if (myeof && p->chan_in) { /* input shutdown */
2298 _ckvmssts(sys$dassgn(p->chan_in));
2299 p->chan_in = 0;
2300 }
2301
2302 if (p->chan_out) {
2303 if (myeof || kideof) { /* pass EOF to parent */
2304 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2305 pipe_infromchild_ast, p,
2306 0, 0, 0, 0, 0, 0));
2307 return;
2308 } else if (eof) { /* eat EOF --- fall through to read*/
2309
2310 } else { /* transmit data */
2311 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2312 pipe_infromchild_ast,p,
2313 p->buf, p->iosb.count, 0, 0, 0, 0));
2314 return;
2315 }
2316 }
2317 }
2318
2319 /* everything shut? flag as done */
2320
2321 if (!p->chan_in && !p->chan_out) {
2322 *p->pipe_done = TRUE;
2323 _ckvmssts(sys$setef(pipe_ef));
2324 return;
2325 }
2326
2327 /* write completed (or read, if snarfing from child)
2328 if still have input active,
2329 queue read...immediate mode if shut_on_empty so we get EOF if empty
2330 otherwise,
2331 check if Perl reading, generate EOFs as needed
2332 */
2333
2334 if (p->type == 0) {
2335 p->type = 1;
2336 if (p->chan_in) {
2337 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2338 pipe_infromchild_ast,p,
2339 p->buf, p->bufsize, 0, 0, 0, 0);
2340 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2341 _ckvmssts(iss);
2342 } else { /* send EOFs for extra reads */
2343 p->iosb.status = SS$_ENDOFFILE;
2344 p->iosb.dvispec = 0;
2345 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2346 0, 0, 0,
2347 pipe_infromchild_ast, p, 0, 0, 0, 0));
2348 }
2349 }
2350}
2351
2352static pPipe
fd8cd3a3 2353pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 2354{
22d4bb9c
CB		 2355 pPipe p;
2356 char mbx[64];
2357 unsigned long dviitm = DVI$_DEVBUFSIZ;
2358 struct stat s;
2359 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2360 DSC$K_CLASS_S, mbx};
2361
2362 /* things like terminals and mbx's don't need this filter */
2363 if (fd && fstat(fd,&s) == 0) {
2364 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2365 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2366 DSC$K_CLASS_S, s.st_dev};
2367
2368 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2369 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2370 strcpy(out, s.st_dev);
2371 return 0;
2372 }
2373 }
2374
a02a5408 2375 Newx(p, 1, Pipe);
22d4bb9c 2376 p->fd_out = dup(fd);
fd8cd3a3 2377 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 2378 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
a02a5408 2379 Newx(p->buf, p->bufsize+1, char);
22d4bb9c
CB		 2380 p->shut_on_empty = FALSE;
2381 p->retry = 0;
2382 p->info = 0;
2383 strcpy(out, mbx);
2384
2385 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2386 pipe_mbxtofd_ast, p,
2387 p->buf, p->bufsize, 0, 0, 0, 0));
2388
2389 return p;
2390}
2391
2392static void
2393pipe_mbxtofd_ast(pPipe p)
2394{
22d4bb9c
CB		 2395 int iss = p->iosb.status;
2396 int done = p->info->done;
2397 int iss2;
2398 int eof = (iss == SS$_ENDOFFILE);
2399 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2400 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 2401#if defined(PERL_IMPLICIT_CONTEXT)
2402 pTHX = p->thx;
2403#endif
22d4bb9c
CB		 2404
2405 if (done && myeof) { /* end piping */
2406 close(p->fd_out);
2407 sys$dassgn(p->chan_in);
2408 *p->pipe_done = TRUE;
2409 _ckvmssts(sys$setef(pipe_ef));
2410 return;
2411 }
2412
2413 if (!err && !eof) { /* good data to send to file */
2414 p->buf[p->iosb.count] = '\n';
2415 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2416 if (iss2 < 0) {
2417 p->retry++;
2418 if (p->retry < MAX_RETRY) {
2419 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2420 return;
2421 }
2422 }
2423 p->retry = 0;
2424 } else if (err) {
2425 _ckvmssts(iss);
2426 }
2427
2428
2429 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2430 pipe_mbxtofd_ast, p,
2431 p->buf, p->bufsize, 0, 0, 0, 0);
2432 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2433 _ckvmssts(iss);
2434}
2435
2436
2437typedef struct _pipeloc PLOC;
2438typedef struct _pipeloc* pPLOC;
2439
2440struct _pipeloc {
2441 pPLOC next;
2442 char dir[NAM$C_MAXRSS+1];
2443};
2444static pPLOC head_PLOC = 0;
2445
5c0ae288 2446void
fd8cd3a3 2447free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 2448{
2449 pPLOC p, pnext;
ff7adb52 2450 pPLOC *pHead = (pPLOC *)head;
5c0ae288 2451
ff7adb52 2452 p = *pHead;
5c0ae288
CL		 2453 while (p) {
2454 pnext = p->next;
2455 Safefree(p);
2456 p = pnext;
2457 }
ff7adb52 2458 *pHead = 0;
5c0ae288 2459}
22d4bb9c
CB		 2460
2461static void
fd8cd3a3 2462store_pipelocs(pTHX)
22d4bb9c
CB		 2463{
2464 int i;
2465 pPLOC p;
ff7adb52 2466 AV *av = 0;
22d4bb9c
CB		 2467 SV *dirsv;
2468 GV *gv;
2469 char *dir, *x;
2470 char *unixdir;
2471 char temp[NAM$C_MAXRSS+1];
2472 STRLEN n_a;
2473
ff7adb52 2474 if (head_PLOC)
218fdd94 2475 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 2476
22d4bb9c
CB		 2477/* the . directory from @INC comes last */
2478
a02a5408 2479 Newx(p,1,PLOC);
22d4bb9c
CB		 2480 p->next = head_PLOC;
2481 head_PLOC = p;
2482 strcpy(p->dir,"./");
2483
2484/* get the directory from $^X */
2485
218fdd94
CL		 2486#ifdef PERL_IMPLICIT_CONTEXT
2487 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2488#else
22d4bb9c 2489 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 2490#endif
22d4bb9c
CB		 2491 strcpy(temp, PL_origargv[0]);
2492 x = strrchr(temp,']');
2493 if (x) x[1] = '\0';
2494
2495 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
a02a5408 2496 Newx(p,1,PLOC);
22d4bb9c
CB		 2497 p->next = head_PLOC;
2498 head_PLOC = p;
2499 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2500 p->dir[NAM$C_MAXRSS] = '\0';
2501 }
2502 }
2503
2504/* reverse order of @INC entries, skip "." since entered above */
2505
218fdd94
CL		 2506#ifdef PERL_IMPLICIT_CONTEXT
2507 if (aTHX)
2508#endif
ff7adb52
CL		 2509 if (PL_incgv) av = GvAVn(PL_incgv);
2510
2511 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 2512 dirsv = *av_fetch(av,i,TRUE);
2513
2514 if (SvROK(dirsv)) continue;
2515 dir = SvPVx(dirsv,n_a);
2516 if (strcmp(dir,".") == 0) continue;
2517 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2518 continue;
2519
a02a5408 2520 Newx(p,1,PLOC);
22d4bb9c
CB		 2521 p->next = head_PLOC;
2522 head_PLOC = p;
2523 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2524 p->dir[NAM$C_MAXRSS] = '\0';
2525 }
2526
2527/* most likely spot (ARCHLIB) put first in the list */
2528
2529#ifdef ARCHLIB_EXP
2530 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
a02a5408 2531 Newx(p,1,PLOC);
22d4bb9c
CB		 2532 p->next = head_PLOC;
2533 head_PLOC = p;
2534 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2535 p->dir[NAM$C_MAXRSS] = '\0';
2536 }
2537#endif
22d4bb9c
CB		 2538}
2539
2540
2541static char *
fd8cd3a3 2542find_vmspipe(pTHX)
22d4bb9c
CB		 2543{
2544 static int vmspipe_file_status = 0;
2545 static char vmspipe_file[NAM$C_MAXRSS+1];
2546
2547 /* already found? Check and use ... need read+execute permission */
2548
2549 if (vmspipe_file_status == 1) {
2550 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2551 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2552 return vmspipe_file;
2553 }
2554 vmspipe_file_status = 0;
2555 }
2556
2557 /* scan through stored @INC, $^X */
2558
2559 if (vmspipe_file_status == 0) {
2560 char file[NAM$C_MAXRSS+1];
2561 pPLOC p = head_PLOC;
2562
2563 while (p) {
2564 strcpy(file, p->dir);
2565 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2566 file[NAM$C_MAXRSS] = '\0';
2567 p = p->next;
2568
2569 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2570
2571 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2572 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2573 vmspipe_file_status = 1;
2574 return vmspipe_file;
2575 }
2576 }
2577 vmspipe_file_status = -1; /* failed, use tempfiles */
2578 }
2579
2580 return 0;
2581}
2582
2583static FILE *
fd8cd3a3 2584vmspipe_tempfile(pTHX)
22d4bb9c
CB		 2585{
2586 char file[NAM$C_MAXRSS+1];
2587 FILE *fp;
2588 static int index = 0;
2589 stat_t s0, s1;
2590
2591 /* create a tempfile */
2592
2593 /* we can't go from W, shr=get to R, shr=get without
2594 an intermediate vulnerable state, so don't bother trying...
2595
2596 and lib$spawn doesn't shr=put, so have to close the write
2597
2598 So... match up the creation date/time and the FID to
2599 make sure we're dealing with the same file
2600
2601 */
2602
2603 index++;
2604 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2605 fp = fopen(file,"w");
2606 if (!fp) {
2607 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2608 fp = fopen(file,"w");
2609 if (!fp) {
2610 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2611 fp = fopen(file,"w");
2612 }
2613 }
2614 if (!fp) return 0; /* we're hosed */
2615
f9ecfa39 2616 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 2617 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2618 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2619 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2620 fprintf(fp,"$ perl_on = \"set noon\"\n");
2621 fprintf(fp,"$ perl_exit = \"exit\"\n");
2622 fprintf(fp,"$ perl_del = \"delete\"\n");
2623 fprintf(fp,"$ pif = \"if\"\n");
2624 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 2625 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2626 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 2627 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 2628 fprintf(fp,"$! --- build command line to get max possible length\n");
2629 fprintf(fp,"$c=perl_popen_cmd0\n");
2630 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2631 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2632 fprintf(fp,"$x=perl_popen_cmd3\n");
2633 fprintf(fp,"$c=c+x\n");
22d4bb9c 2634 fprintf(fp,"$ perl_on\n");
f9ecfa39 2635 fprintf(fp,"$ 'c'\n");
22d4bb9c 2636 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 2637 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 2638 fprintf(fp,"$ perl_exit 'perl_status'\n");
2639 fsync(fileno(fp));
2640
2641 fgetname(fp, file, 1);
2642 fstat(fileno(fp), &s0);
2643 fclose(fp);
2644
2645 fp = fopen(file,"r","shr=get");
2646 if (!fp) return 0;
2647 fstat(fileno(fp), &s1);
2648
2649 if (s0.st_ino[0] != s1.st_ino[0] ||
2650 s0.st_ino[1] != s1.st_ino[1] ||
2651 s0.st_ino[2] != s1.st_ino[2] ||
2652 s0.st_ctime != s1.st_ctime ) {
2653 fclose(fp);
2654 return 0;
2655 }
2656
2657 return fp;
2658}
2659
2660
2661
8fde5078 2662static PerlIO *
2fbb330f 2663safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 2664{
748a9306 2665 static int handler_set_up = FALSE;
55f2b99c 2666 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 2667 /* The use of a GLOBAL table (as was done previously) rendered
2668 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
2669 * environment. Hence we've switched to LOCAL symbol table.
2670 */
2671 unsigned int table = LIB$K_CLI_LOCAL_SYM;
48b5a746 2672 int j, wait = 0;
ff7adb52 2673 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
22d4bb9c
CB		 2674 char in[512], out[512], err[512], mbx[512];
2675 FILE *tpipe = 0;
2676 char tfilebuf[NAM$C_MAXRSS+1];
2677 pInfo info;
48b5a746 2678 char cmd_sym_name[20];
22d4bb9c
CB		 2679 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2680 DSC$K_CLASS_S, symbol};
22d4bb9c 2681 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 2682 DSC$K_CLASS_S, 0};
48b5a746
CL		 2683 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2684 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 2685 struct dsc$descriptor_s *vmscmd;
22d4bb9c 2686 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 2687 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 2688 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 2689
afd8f436
JH		 2690 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2691
22d4bb9c
CB		 2692 /* once-per-program initialization...
2693 note that the SETAST calls and the dual test of pipe_ef
2694 makes sure that only the FIRST thread through here does
2695 the initialization...all other threads wait until it's
2696 done.
2697
2698 Yeah, uglier than a pthread call, it's got all the stuff inline
2699 rather than in a separate routine.
2700 */
2701
2702 if (!pipe_ef) {
2703 _ckvmssts(sys$setast(0));
2704 if (!pipe_ef) {
2705 unsigned long int pidcode = JPI$_PID;
2706 $DESCRIPTOR(d_delay, RETRY_DELAY);
2707 _ckvmssts(lib$get_ef(&pipe_ef));
2708 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2709 _ckvmssts(sys$bintim(&d_delay, delaytime));
2710 }
2711 if (!handler_set_up) {
2712 _ckvmssts(sys$dclexh(&pipe_exitblock));
2713 handler_set_up = TRUE;
2714 }
2715 _ckvmssts(sys$setast(1));
2716 }
2717
2718 /* see if we can find a VMSPIPE.COM */
2719
2720 tfilebuf[0] = '@';
fd8cd3a3 2721 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 2722 if (vmspipe) {
2723 strcpy(tfilebuf+1,vmspipe);
2724 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 2725 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 2726 if (!tpipe) { /* a fish popular in Boston */
2727 if (ckWARN(WARN_PIPE)) {
f98bc0c6 2728 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB		 2729 }
2730 return Nullfp;
2731 }
2732 fgetname(tpipe,tfilebuf+1,1);
2733 }
2734 vmspipedsc.dsc$a_pointer = tfilebuf;
2735 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 2736
218fdd94 2737 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 2738 if (!(sts & 1)) {
2739 switch (sts) {
2740 case RMS$_FNF: case RMS$_DNF:
2741 set_errno(ENOENT); break;
2742 case RMS$_DIR:
2743 set_errno(ENOTDIR); break;
2744 case RMS$_DEV:
2745 set_errno(ENODEV); break;
2746 case RMS$_PRV:
2747 set_errno(EACCES); break;
2748 case RMS$_SYN:
2749 set_errno(EINVAL); break;
2750 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2751 set_errno(E2BIG); break;
2752 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2753 _ckvmssts(sts); /* fall through */
2754 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2755 set_errno(EVMSERR);
2756 }
2757 set_vaxc_errno(sts);
ff7adb52 2758 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 2759 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 2760 }
ff7adb52 2761 *psts = sts;
a2669cfc
JH		 2762 return Nullfp;
2763 }
a02a5408 2764 Newx(info,1,Info);
22d4bb9c 2765
ff7adb52 2766 strcpy(mode,in_mode);
22d4bb9c
CB		 2767 info->mode = *mode;
2768 info->done = FALSE;
2769 info->completion = 0;
2770 info->closing = FALSE;
2771 info->in = 0;
2772 info->out = 0;
2773 info->err = 0;
ff7adb52
CL		 2774 info->fp = Nullfp;
2775 info->useFILE = 0;
2776 info->waiting = 0;
22d4bb9c
CB		 2777 info->in_done = TRUE;
2778 info->out_done = TRUE;
2779 info->err_done = TRUE;
0e06870b 2780 in[0] = out[0] = err[0] = '\0';
22d4bb9c 2781
ff7adb52
CL		 2782 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2783 info->useFILE = 1;
2784 strcpy(p,p+1);
2785 }
2786 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2787 wait = 1;
2788 strcpy(p,p+1);
2789 }
2790
22d4bb9c 2791 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 2792
fd8cd3a3 2793 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 2794 if (info->out) {
2795 info->out->pipe_done = &info->out_done;
2796 info->out_done = FALSE;
2797 info->out->info = info;
2798 }
ff7adb52 2799 if (!info->useFILE) {
22d4bb9c 2800 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 2801 } else {
2802 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2803 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2804 }
2805
22d4bb9c
CB		 2806 if (!info->fp && info->out) {
2807 sys$cancel(info->out->chan_out);
2808
2809 while (!info->out_done) {
2810 int done;
2811 _ckvmssts(sys$setast(0));
2812 done = info->out_done;
2813 if (!done) _ckvmssts(sys$clref(pipe_ef));
2814 _ckvmssts(sys$setast(1));
2815 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 2816 }
22d4bb9c
CB		 2817
2818 if (info->out->buf) Safefree(info->out->buf);
2819 Safefree(info->out);
2820 Safefree(info);
ff7adb52 2821 *psts = RMS$_FNF;
22d4bb9c 2822 return Nullfp;
0e06870b 2823 }
22d4bb9c 2824
fd8cd3a3 2825 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 2826 if (info->err) {
2827 info->err->pipe_done = &info->err_done;
2828 info->err_done = FALSE;
2829 info->err->info = info;
2830 }
a0d0e21e 2831
ff7adb52
CL		 2832 } else if (*mode == 'w') { /* piping to subroutine */
2833
2834 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2835 if (info->out) {
2836 info->out->pipe_done = &info->out_done;
2837 info->out_done = FALSE;
2838 info->out->info = info;
2839 }
2840
2841 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2842 if (info->err) {
2843 info->err->pipe_done = &info->err_done;
2844 info->err_done = FALSE;
2845 info->err->info = info;
2846 }
a0d0e21e 2847
fd8cd3a3 2848 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 2849 if (!info->useFILE) {
22d4bb9c 2850 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 2851 } else {
2852 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2853 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2854 }
2855
22d4bb9c
CB		 2856 if (info->in) {
2857 info->in->pipe_done = &info->in_done;
2858 info->in_done = FALSE;
2859 info->in->info = info;
2860 }
a0d0e21e 2861
22d4bb9c
CB		 2862 /* error cleanup */
2863 if (!info->fp && info->in) {
2864 info->done = TRUE;
2865 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2866 0, 0, 0, 0, 0, 0, 0, 0));
2867
2868 while (!info->in_done) {
2869 int done;
2870 _ckvmssts(sys$setast(0));
2871 done = info->in_done;
2872 if (!done) _ckvmssts(sys$clref(pipe_ef));
2873 _ckvmssts(sys$setast(1));
2874 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2875 }
a0d0e21e 2876
22d4bb9c
CB		 2877 if (info->in->buf) Safefree(info->in->buf);
2878 Safefree(info->in);
2879 Safefree(info);
ff7adb52 2880 *psts = RMS$_FNF;
0e06870b 2881 return Nullfp;
22d4bb9c 2882 }
a0d0e21e 2883
22d4bb9c 2884
ff7adb52 2885 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 2886 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 2887 if (info->out) {
2888 info->out->pipe_done = &info->out_done;
2889 info->out_done = FALSE;
2890 info->out->info = info;
2891 }
0e06870b 2892
fd8cd3a3 2893 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 2894 if (info->err) {
2895 info->err->pipe_done = &info->err_done;
2896 info->err_done = FALSE;
2897 info->err->info = info;
2898 }
748a9306 2899 }
22d4bb9c
CB		 2900
2901 symbol[MAX_DCL_SYMBOL] = '\0';
2902
2903 strncpy(symbol, in, MAX_DCL_SYMBOL);
2904 d_symbol.dsc$w_length = strlen(symbol);
2905 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2906
2907 strncpy(symbol, err, MAX_DCL_SYMBOL);
2908 d_symbol.dsc$w_length = strlen(symbol);
2909 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2910
0e06870b
CB		 2911 strncpy(symbol, out, MAX_DCL_SYMBOL);
2912 d_symbol.dsc$w_length = strlen(symbol);
2913 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 2914
218fdd94 2915 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 2916 while (*p && *p != '\n') p++;
2917 *p = '\0'; /* truncate on \n */
218fdd94 2918 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 2919 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2920 if (*p == '$') p++; /* remove leading $ */
2921 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 2922
2923 for (j = 0; j < 4; j++) {
2924 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2925 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2926
22d4bb9c
CB		 2927 strncpy(symbol, p, MAX_DCL_SYMBOL);
2928 d_symbol.dsc$w_length = strlen(symbol);
2929 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2930
48b5a746
CL		 2931 if (strlen(p) > MAX_DCL_SYMBOL) {
2932 p += MAX_DCL_SYMBOL;
2933 } else {
2934 p += strlen(p);
2935 }
2936 }
22d4bb9c 2937 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 2938 info->next=open_pipes; /* prepend to list */
2939 open_pipes=info;
22d4bb9c 2940 _ckvmssts(sys$setast(1));
55f2b99c
CB		 2941 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2942 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2943 * have SYS$COMMAND if we need it.
2944 */
2945 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 2946 0, &info->pid, &info->completion,
2947 0, popen_completion_ast,info,0,0,0));
2948
2949 /* if we were using a tempfile, close it now */
2950
2951 if (tpipe) fclose(tpipe);
2952
ff7adb52 2953 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 2954 we can get rid of ours */
2955
48b5a746
CL		 2956 for (j = 0; j < 4; j++) {
2957 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2958 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 2959 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 2960 }
22d4bb9c
CB		 2961 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2962 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 2963 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 2964 vms_execfree(vmscmd);
a0d0e21e 2965
218fdd94
CL		 2966#ifdef PERL_IMPLICIT_CONTEXT
2967 if (aTHX)
2968#endif
6b88bc9c 2969 PL_forkprocess = info->pid;
218fdd94 2970
ff7adb52
CL		 2971 if (wait) {
2972 int done = 0;
2973 while (!done) {
2974 _ckvmssts(sys$setast(0));
2975 done = info->done;
2976 if (!done) _ckvmssts(sys$clref(pipe_ef));
2977 _ckvmssts(sys$setast(1));
2978 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2979 }
2980 *psts = info->completion;
2fbb330f
JM		 2981/* Caller thinks it is open and tries to close it. */
2982/* This causes some problems, as it changes the error status */
2983/* my_pclose(info->fp); */
ff7adb52
CL		 2984 } else {
2985 *psts = SS$_NORMAL;
2986 }
a0d0e21e 2987 return info->fp;
1e422769
PP		 2988} /* end of safe_popen */
2989
2990
a15cef0c
CB		 2991/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2992PerlIO *
2fbb330f 2993Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 2994{
ff7adb52 2995 int sts;
1e422769
PP		 2996 TAINT_ENV();
2997 TAINT_PROPER("popen");
45bc9206 2998 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 2999 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 3000}
1e422769 3001
a0d0e21e
LW		 3002/*}}}*/
3003
a15cef0c
CB		 3004/*{{{ I32 my_pclose(PerlIO *fp)*/
3005I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 3006{
22d4bb9c 3007 pInfo info, last = NULL;
748a9306 3008 unsigned long int retsts;
22d4bb9c 3009 int done, iss;
a0d0e21e
LW		 3010
3011 for (info = open_pipes; info != NULL; last = info, info = info->next)
3012 if (info->fp == fp) break;
3013
1e422769
PP		 3014 if (info == NULL) { /* no such pipe open */
3015 set_errno(ECHILD); /* quoth POSIX */
3016 set_vaxc_errno(SS$_NONEXPR);
3017 return -1;
3018 }
748a9306 3019
bbce6d69
PP		 3020 /* If we were writing to a subprocess, insure that someone reading from
3021 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 3022 * produce an EOF record in the mailbox.
3023 *
3024 * well, at least sometimes it *does*, so we have to watch out for
3025 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3026 */
ff7adb52
CL		 3027 if (info->fp) {
3028 if (!info->useFILE)
a15cef0c 3029 PerlIO_flush(info->fp); /* first, flush data */
ff7adb52
CL		 3030 else
3031 fflush((FILE *)info->fp);
3032 }
22d4bb9c 3033
b08af3f0 3034 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 3035 info->closing = TRUE;
3036 done = info->done && info->in_done && info->out_done && info->err_done;
3037 /* hanging on write to Perl's input? cancel it */
3038 if (info->mode == 'r' && info->out && !info->out_done) {
3039 if (info->out->chan_out) {
3040 _ckvmssts(sys$cancel(info->out->chan_out));
3041 if (!info->out->chan_in) { /* EOF generation, need AST */
3042 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3043 }
3044 }
3045 }
3046 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3047 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3048 0, 0, 0, 0, 0, 0));
b08af3f0 3049 _ckvmssts(sys$setast(1));
ff7adb52
CL		 3050 if (info->fp) {
3051 if (!info->useFILE)
740ce14c 3052 PerlIO_close(info->fp);
ff7adb52
CL		 3053 else
3054 fclose((FILE *)info->fp);
3055 }
22d4bb9c
CB		 3056 /*
3057 we have to wait until subprocess completes, but ALSO wait until all
3058 the i/o completes...otherwise we'll be freeing the "info" structure
3059 that the i/o ASTs could still be using...
3060 */
3061
3062 while (!done) {
3063 _ckvmssts(sys$setast(0));
3064 done = info->done && info->in_done && info->out_done && info->err_done;
3065 if (!done) _ckvmssts(sys$clref(pipe_ef));
3066 _ckvmssts(sys$setast(1));
3067 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3068 }
3069 retsts = info->completion;
a0d0e21e 3070
a0d0e21e 3071 /* remove from list of open pipes */
b08af3f0 3072 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 3073 if (last) last->next = info->next;
3074 else open_pipes = info->next;
b08af3f0 3075 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 3076
3077 /* free buffers and structures */
3078
3079 if (info->in) {
3080 if (info->in->buf) Safefree(info->in->buf);
3081 Safefree(info->in);
3082 }
3083 if (info->out) {
3084 if (info->out->buf) Safefree(info->out->buf);
3085 Safefree(info->out);
3086 }
3087 if (info->err) {
3088 if (info->err->buf) Safefree(info->err->buf);
3089 Safefree(info->err);
3090 }
a0d0e21e
LW		 3091 Safefree(info);
3092
3093 return retsts;
748a9306 3094
a0d0e21e
LW		 3095} /* end of my_pclose() */
3096
119586db 3097#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 3098 /* Roll our own prototype because we want this regardless of whether
3099 * _VMS_WAIT is defined.
3100 */
3101 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3102#endif
3103/* sort-of waitpid; special handling of pipe clean-up for subprocesses
3104 created with popen(); otherwise partially emulate waitpid() unless
3105 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3106 Also check processes not considered by the CRTL waitpid().
3107 */
4fdae800
PP		 3108/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3109Pid_t
fd8cd3a3 3110Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 3111{
22d4bb9c
CB		 3112 pInfo info;
3113 int done;
aeb5cf3c 3114 int sts;
d85f548a 3115 int j;
aeb5cf3c
CB		 3116
3117 if (statusp) *statusp = 0;
a0d0e21e
LW		 3118
3119 for (info = open_pipes; info != NULL; info = info->next)
3120 if (info->pid == pid) break;
3121
3122 if (info != NULL) { /* we know about this child */
748a9306 3123 while (!info->done) {
22d4bb9c
CB		 3124 _ckvmssts(sys$setast(0));
3125 done = info->done;
3126 if (!done) _ckvmssts(sys$clref(pipe_ef));
3127 _ckvmssts(sys$setast(1));
3128 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 3129 }
3130
aeb5cf3c 3131 if (statusp) *statusp = info->completion;
a0d0e21e 3132 return pid;
d85f548a
JH		 3133 }
3134
3135 /* child that already terminated? */
aeb5cf3c 3136
d85f548a
JH		 3137 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3138 if (closed_list[j].pid == pid) {
3139 if (statusp) *statusp = closed_list[j].completion;
3140 return pid;
3141 }
a0d0e21e 3142 }
d85f548a
JH		 3143
3144 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 3145
119586db 3146#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 3147
3148 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3149 * in 7.2 did we get a version that fills in the VMS completion
3150 * status as Perl has always tried to do.
3151 */
3152
3153 sts = __vms_waitpid( pid, statusp, flags );
3154
3155 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3156 return sts;
3157
3158 /* If the real waitpid tells us the child does not exist, we
3159 * fall through here to implement waiting for a child that
3160 * was created by some means other than exec() (say, spawned
3161 * from DCL) or to wait for a process that is not a subprocess
3162 * of the current process.
3163 */
3164
119586db 3165#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 3166
21bc9d50 3167 {
a0d0e21e 3168 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 3169 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3170 unsigned long int pidcode = JPI$_PID, mypid;
3171 unsigned long int interval[2];
aeb5cf3c 3172 unsigned int jpi_iosb[2];
d85f548a 3173 struct itmlst_3 jpilist[2] = {
aeb5cf3c 3174 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 3175 { 0, 0, 0, 0}
3176 };
aeb5cf3c
CB		 3177
3178 if (pid <= 0) {
3179 /* Sorry folks, we don't presently implement rooting around for
3180 the first child we can find, and we definitely don't want to
3181 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3182 */
3183 set_errno(ENOTSUP);
3184 return -1;
3185 }
3186
d85f548a
JH		 3187 /* Get the owner of the child so I can warn if it's not mine. If the
3188 * process doesn't exist or I don't have the privs to look at it,
3189 * I can go home early.
aeb5cf3c
CB		 3190 */
3191 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3192 if (sts & 1) sts = jpi_iosb[0];
3193 if (!(sts & 1)) {
3194 switch (sts) {
3195 case SS$_NONEXPR:
3196 set_errno(ECHILD);
3197 break;
3198 case SS$_NOPRIV:
3199 set_errno(EACCES);
3200 break;
3201 default:
3202 _ckvmssts(sts);
3203 }
3204 set_vaxc_errno(sts);
3205 return -1;
3206 }
a0d0e21e 3207
3eeba6fb 3208 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 3209 /* remind folks they are asking for non-standard waitpid behavior */
3210 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 3211 if (ownerpid != mypid)
f98bc0c6 3212 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 3213 "waitpid: process %x is not a child of process %x",
3214 pid,mypid);
748a9306 3215 }
a0d0e21e 3216
d85f548a
JH		 3217 /* simply check on it once a second until it's not there anymore. */
3218
3219 _ckvmssts(sys$bintim(&intdsc,interval));
3220 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 3221 _ckvmssts(sys$schdwk(0,0,interval,0));
3222 _ckvmssts(sys$hiber());
d85f548a
JH		 3223 }
3224 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 3225
3226 _ckvmssts(sts);
a0d0e21e 3227 return pid;
21bc9d50 3228 }
a0d0e21e 3229} /* end of waitpid() */
a0d0e21e
LW		 3230/*}}}*/
3231/*}}}*/
3232/*}}}*/
3233
3234/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3235char *
3236my_gconvert(double val, int ndig, int trail, char *buf)
3237{
3238 static char __gcvtbuf[DBL_DIG+1];
3239 char *loc;
3240
3241 loc = buf ? buf : __gcvtbuf;
71be2cbc
PP		 3242
3243#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3244 if (val < 1) {
3245 sprintf(loc,"%.*g",ndig,val);
3246 return loc;
3247 }
3248#endif
3249
a0d0e21e
LW		 3250 if (val) {
3251 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3252 return gcvt(val,ndig,loc);
3253 }
3254 else {
3255 loc[0] = '0'; loc[1] = '\0';
3256 return loc;
3257 }
3258
3259}
3260/*}}}*/
3261
bbce6d69
PP		 3262
3263/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3264/* Shortcut for common case of simple calls to $PARSE and $SEARCH
3265 * to expand file specification. Allows for a single default file
3266 * specification and a simple mask of options. If outbuf is non-NULL,
3267 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3268 * the resultant file specification is placed. If outbuf is NULL, the
3269 * resultant file specification is placed into a static buffer.
3270 * The third argument, if non-NULL, is taken to be a default file
3271 * specification string. The fourth argument is unused at present.
3272 * rmesexpand() returns the address of the resultant string if
3273 * successful, and NULL on error.
3274 */
b8ffc8df 3275static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
96e4d5b1 3276
bbce6d69 3277static char *
2fbb330f 3278mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
bbce6d69
PP		 3279{
3280 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
96e4d5b1 3281 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
bbce6d69
PP		 3282 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3283 struct FAB myfab = cc$rms_fab;
3284 struct NAM mynam = cc$rms_nam;
3285 STRLEN speclen;
3eeba6fb 3286 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
f7ddb74a 3287 int sts;
bbce6d69
PP		 3288
3289 if (!filespec || !*filespec) {
3290 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3291 return NULL;
3292 }
3293 if (!outbuf) {
a02a5408 3294 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
bbce6d69
PP		 3295 else outbuf = __rmsexpand_retbuf;
3296 }
96e4d5b1
PP		 3297 if ((isunix = (strchr(filespec,'/') != NULL))) {
3298 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
3299 filespec = vmsfspec;
3300 }
bbce6d69 3301
2fbb330f 3302 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
bbce6d69
PP		 3303 myfab.fab$b_fns = strlen(filespec);
3304 myfab.fab$l_nam = &mynam;
3305
3306 if (defspec && *defspec) {
96e4d5b1
PP		 3307 if (strchr(defspec,'/') != NULL) {
3308 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
3309 defspec = tmpfspec;
3310 }
2fbb330f 3311 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
bbce6d69
PP		 3312 myfab.fab$b_dns = strlen(defspec);
3313 }
3314
3315 mynam.nam$l_esa = esa;
3316 mynam.nam$b_ess = sizeof esa;
3317 mynam.nam$l_rsa = outbuf;
3318 mynam.nam$b_rss = NAM$C_MAXRSS;
3319
3320 retsts = sys$parse(&myfab,0,0);
3321 if (!(retsts & 1)) {
17f28c40 3322 mynam.nam$b_nop |= NAM$M_SYNCHK;
f7ddb74a
JM		 3323#ifdef NAM$M_NO_SHORT_UPCASE
3324 if (decc_efs_case_preserve)
3325 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3326#endif
f282b18d 3327 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
bbce6d69
PP		 3328 retsts = sys$parse(&myfab,0,0);
3329 if (retsts & 1) goto expanded;
3330 }
17f28c40 3331 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
f7ddb74a 3332 sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 3333 if (out) Safefree(out);
3334 set_vaxc_errno(retsts);
3335 if (retsts == RMS$_PRV) set_errno(EACCES);
3336 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3337 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3338 else set_errno(EVMSERR);
3339 return NULL;
3340 }
3341 retsts = sys$search(&myfab,0,0);
3342 if (!(retsts & 1) && retsts != RMS$_FNF) {
17f28c40 3343 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a
JM		 3344#ifdef NAM$M_NO_SHORT_UPCASE
3345 if (decc_efs_case_preserve)
3346 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3347#endif
3348 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 3349 if (out) Safefree(out);
3350 set_vaxc_errno(retsts);
3351 if (retsts == RMS$_PRV) set_errno(EACCES);
3352 else set_errno(EVMSERR);
3353 return NULL;
3354 }
3355
3356 /* If the input filespec contained any lowercase characters,
3357 * downcase the result for compatibility with Unix-minded code. */
3358 expanded:
f7ddb74a
JM		 3359 if (!decc_efs_case_preserve) {
3360 for (out = myfab.fab$l_fna; *out; out++)
3361 if (islower(*out)) { haslower = 1; break; }
3362 }
bbce6d69
PP		 3363 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3364 else { out = esa; speclen = mynam.nam$b_esl; }
3eeba6fb
CB		 3365 /* Trim off null fields added by $PARSE
3366 * If type > 1 char, must have been specified in original or default spec
3367 * (not true for version; $SEARCH may have added version of existing file).
3368 */
3369 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3370 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3371 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3372 if (trimver || trimtype) {
3373 if (defspec && *defspec) {
3374 char defesa[NAM$C_MAXRSS];
3375 struct FAB deffab = cc$rms_fab;
3376 struct NAM defnam = cc$rms_nam;
3377
3378 deffab.fab$l_nam = &defnam;
f7ddb74a 3379 /* cast below ok for read only pointer */
2fbb330f 3380 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3eeba6fb
CB		 3381 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3382 defnam.nam$b_nop = NAM$M_SYNCHK;
f7ddb74a
JM		 3383#ifdef NAM$M_NO_SHORT_UPCASE
3384 if (decc_efs_case_preserve)
3385 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3386#endif
3eeba6fb
CB		 3387 if (sys$parse(&deffab,0,0) & 1) {
3388 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3389 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
3390 }
3391 }
3392 if (trimver) speclen = mynam.nam$l_ver - out;
3393 if (trimtype) {
3394 /* If we didn't already trim version, copy down */
3395 if (speclen > mynam.nam$l_ver - out)
3396 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
3397 speclen - (mynam.nam$l_ver - out));
3398 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
3399 }
3400 }
bbce6d69
PP		 3401 /* If we just had a directory spec on input, $PARSE "helpfully"
3402 * adds an empty name and type for us */
3403 if (mynam.nam$l_name == mynam.nam$l_type &&
3404 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3405 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3406 speclen = mynam.nam$l_name - out;
3407 out[speclen] = '\0';
f7ddb74a 3408 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
bbce6d69
PP		 3409
3410 /* Have we been working with an expanded, but not resultant, spec? */
96e4d5b1
PP		 3411 /* Also, convert back to Unix syntax if necessary. */
3412 if (!mynam.nam$b_rsl) {
3413 if (isunix) {
3414 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
3415 }
3416 else strcpy(outbuf,esa);
3417 }
3418 else if (isunix) {
3419 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
3420 strcpy(outbuf,tmpfspec);
3421 }
17f28c40 3422 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a
JM		 3423#ifdef NAM$M_NO_SHORT_UPCASE
3424 if (decc_efs_case_preserve)
3425 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3426#endif
17f28c40 3427 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
f7ddb74a 3428 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69
PP		 3429 return outbuf;
3430}
3431/*}}}*/
3432/* External entry points */
2fbb330f 3433char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 3434{ return do_rmsexpand(spec,buf,0,def,opt); }
2fbb330f 3435char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69
PP		 3436{ return do_rmsexpand(spec,buf,1,def,opt); }
3437
3438
a0d0e21e
LW		 3439/*
3440** The following routines are provided to make life easier when
3441** converting among VMS-style and Unix-style directory specifications.
3442** All will take input specifications in either VMS or Unix syntax. On
3443** failure, all return NULL. If successful, the routines listed below
748a9306 3444** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 3445** reformatted spec (and, therefore, subsequent calls to that routine
3446** will clobber the result), while the routines of the same names with
3447** a _ts suffix appended will return a pointer to a mallocd string
3448** containing the appropriately reformatted spec.
3449** In all cases, only explicit syntax is altered; no check is made that
3450** the resulting string is valid or that the directory in question
3451** actually exists.
3452**
3453** fileify_dirspec() - convert a directory spec into the name of the
3454** directory file (i.e. what you can stat() to see if it's a dir).
3455** The style (VMS or Unix) of the result is the same as the style
3456** of the parameter passed in.
3457** pathify_dirspec() - convert a directory spec into a path (i.e.
3458** what you prepend to a filename to indicate what directory it's in).
3459** The style (VMS or Unix) of the result is the same as the style
3460** of the parameter passed in.
3461** tounixpath() - convert a directory spec into a Unix-style path.
3462** tovmspath() - convert a directory spec into a VMS-style path.
3463** tounixspec() - convert any file spec into a Unix-style file spec.
3464** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 3465**
bd3fa61c 3466** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6
PP		 3467** Permission is given to distribute this code as part of the Perl
3468** standard distribution under the terms of the GNU General Public
3469** License or the Perl Artistic License. Copies of each may be
3470** found in the Perl standard distribution.
a0d0e21e
LW		 3471 */
3472
3473/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
b8ffc8df 3474static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
a0d0e21e
LW		 3475{
3476 static char __fileify_retbuf[NAM$C_MAXRSS+1];
b7ae7a0d 3477 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 3478 char *retspec, *cp1, *cp2, *lastdir;
61bb5906 3479 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2d9f3838 3480 unsigned short int trnlnm_iter_count;
f7ddb74a 3481 int sts;
a0d0e21e 3482
c07a80fd
PP		 3483 if (!dir || !*dir) {
3484 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3485 }
a0d0e21e 3486 dirlen = strlen(dir);
a2a90019 3487 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 3488 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 3489 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
3490 dir = "/sys$disk";
3491 dirlen = 9;
3492 }
3493 else
3494 dirlen = 1;
61bb5906
CB		 3495 }
3496 if (dirlen > NAM$C_MAXRSS) {
3497 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
c07a80fd 3498 }
f7ddb74a
JM		 3499 if (!strpbrk(dir+1,"/]>:") &&
3500 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 3501 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838
CB		 3502 trnlnm_iter_count = 0;
3503 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
3504 trnlnm_iter_count++;
3505 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
3506 }
b8ffc8df 3507 dirlen = strlen(trndir);
e518068a 3508 }
01b8edb6
PP		 3509 else {
3510 strncpy(trndir,dir,dirlen);
3511 trndir[dirlen] = '\0';
01b8edb6 3512 }
b8ffc8df
RGS		 3513
3514 /* At this point we are done with *dir and use *trndir which is a
3515 * copy that can be modified. *dir must not be modified.
3516 */
3517
c07a80fd
PP		 3518 /* If we were handed a rooted logical name or spec, treat it like a
3519 * simple directory, so that
3520 * $ Define myroot dev:[dir.]
3521 * ... do_fileify_dirspec("myroot",buf,1) ...
3522 * does something useful.
3523 */
b8ffc8df
RGS		 3524 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
3525 trndir[--dirlen] = '\0';
3526 trndir[dirlen-1] = ']';
c07a80fd 3527 }
b8ffc8df
RGS		 3528 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
3529 trndir[--dirlen] = '\0';
3530 trndir[dirlen-1] = '>';
46112e17 3531 }
e518068a 3532
b8ffc8df 3533 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d
PP		 3534 /* If we've got an explicit filename, we can just shuffle the string. */
3535 if (*(cp1+1)) hasfilename = 1;
3536 /* Similarly, we can just back up a level if we've got multiple levels
3537 of explicit directories in a VMS spec which ends with directories. */
3538 else {
b8ffc8df 3539 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 3540 if (*cp2 == '.') {
3541 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
3542 *cp2 = *cp1; *cp1 = '\0';
3543 hasfilename = 1;
3544 break;
3545 }
b7ae7a0d
PP		 3546 }
3547 if (*cp2 == '[' || *cp2 == '<') break;
3548 }
3549 }
3550 }
3551
f7ddb74a
JM		 3552 cp1 = strpbrk(trndir,"]:>"); /* Prepare for future change */
3553 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df
RGS		 3554 if (trndir[0] == '.') {
3555 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0'))
748a9306 3556 return do_fileify_dirspec("[]",buf,ts);
b8ffc8df
RGS		 3557 else if (trndir[1] == '.' &&
3558 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0')))
748a9306
LW		 3559 return do_fileify_dirspec("[-]",buf,ts);
3560 }
b8ffc8df 3561 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 3562 dirlen -= 1; /* to last element */
b8ffc8df 3563 lastdir = strrchr(trndir,'/');
a0d0e21e 3564 }
b8ffc8df 3565 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6
PP		 3566 /* If we have "/." or "/..", VMSify it and let the VMS code
3567 * below expand it, rather than repeating the code to handle
3568 * relative components of a filespec here */
4633a7c4
LW		 3569 do {
3570 if (*(cp1+2) == '.') cp1++;
3571 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
b8ffc8df 3572 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
fc1ce8cc
CB		 3573 if (strchr(vmsdir,'/') != NULL) {
3574 /* If do_tovmsspec() returned it, it must have VMS syntax
3575 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3576 * the time to check this here only so we avoid a recursion
3577 * loop; otherwise, gigo.
3578 */
3579 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3580 }
01b8edb6
PP		 3581 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3582 return do_tounixspec(trndir,buf,ts);
4633a7c4
LW		 3583 }
3584 cp1++;
3585 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 3586 lastdir = strrchr(trndir,'/');
748a9306 3587 }
b8ffc8df 3588 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
61bb5906
CB		 3589 /* Ditto for specs that end in an MFD -- let the VMS code
3590 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 3591
3592 /* This should not happen any more. Allowing the fake /000000
3593 * in a UNIX pathname causes all sorts of problems when trying
3594 * to run in UNIX emulation. So the VMS to UNIX conversions
3595 * now remove the fake /000000 directories.
3596 */
3597
b8ffc8df
RGS		 3598 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
3599 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
61bb5906
CB		 3600 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3601 return do_tounixspec(trndir,buf,ts);
3602 }
a0d0e21e 3603 else {
f7ddb74a 3604
b8ffc8df
RGS		 3605 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
3606 !(lastdir = cp1 = strrchr(trndir,']')) &&
3607 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 3608 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 3609 int ver; char *cp3;
f7ddb74a
JM		 3610
3611 /* For EFS or ODS-5 look for the last dot */
3612 if (decc_efs_charset) {
3613 cp2 = strrchr(cp1,'.');
3614 }
3615 if (vms_process_case_tolerant) {
3616 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3617 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3618 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3619 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3620 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 3621 (ver || *cp3)))))) {
f7ddb74a
JM		 3622 set_errno(ENOTDIR);
3623 set_vaxc_errno(RMS$_DIR);
3624 return NULL;
3625 }
3626 }
3627 else {
3628 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
3629 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
3630 !*(cp2+3) || *(cp2+3) != 'R' ||
3631 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3632 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3633 (ver || *cp3)))))) {
3634 set_errno(ENOTDIR);
3635 set_vaxc_errno(RMS$_DIR);
3636 return NULL;
3637 }
a0d0e21e 3638 }
b8ffc8df 3639 dirlen = cp2 - trndir;
a0d0e21e 3640 }
748a9306 3641 }
f7ddb74a
JM		 3642
3643 retlen = dirlen + 6;
748a9306 3644 if (buf) retspec = buf;
a02a5408 3645 else if (ts) Newx(retspec,retlen+1,char);
748a9306 3646 else retspec = __fileify_retbuf;
f7ddb74a
JM		 3647 memcpy(retspec,trndir,dirlen);
3648 retspec[dirlen] = '\0';
3649
a0d0e21e
LW		 3650 /* We've picked up everything up to the directory file name.
3651 Now just add the type and version, and we're set. */
f7ddb74a
JM		 3652 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
3653 strcat(retspec,".dir;1");
3654 else
3655 strcat(retspec,".DIR;1");
a0d0e21e
LW		 3656 return retspec;
3657 }
3658 else { /* VMS-style directory spec */
01b8edb6
PP		 3659 char esa[NAM$C_MAXRSS+1], term, *cp;
3660 unsigned long int sts, cmplen, haslower = 0;
a0d0e21e
LW		 3661 struct FAB dirfab = cc$rms_fab;
3662 struct NAM savnam, dirnam = cc$rms_nam;
3663
f7ddb74a 3664 dirfab.fab$b_fns = strlen(trndir);
b8ffc8df 3665 dirfab.fab$l_fna = trndir;
a0d0e21e 3666 dirfab.fab$l_nam = &dirnam;
748a9306
LW		 3667 dirfab.fab$l_dna = ".DIR;1";
3668 dirfab.fab$b_dns = 6;
a0d0e21e
LW		 3669 dirnam.nam$b_ess = NAM$C_MAXRSS;
3670 dirnam.nam$l_esa = esa;
f7ddb74a
JM		 3671#ifdef NAM$M_NO_SHORT_UPCASE
3672 if (decc_efs_case_preserve)
3673 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3674#endif
01b8edb6 3675
b8ffc8df 3676 for (cp = trndir; *cp; cp++)
01b8edb6 3677 if (islower(*cp)) { haslower = 1; break; }
e518068a 3678 if (!((sts = sys$parse(&dirfab))&1)) {
f7ddb74a 3679 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
e518068a
PP		 3680 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3681 sts = sys$parse(&dirfab) & 1;
3682 }
3683 if (!sts) {
748a9306
LW		 3684 set_errno(EVMSERR);
3685 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 3686 return NULL;
3687 }
e518068a
PP		 3688 }
3689 else {
3690 savnam = dirnam;
3691 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3692 /* Yes; fake the fnb bits so we'll check type below */
3693 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3694 }
752635ea
CB		 3695 else { /* No; just work with potential name */
3696 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3697 else {
3698 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3699 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
f7ddb74a 3700 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
e518068a
PP		 3701 return NULL;
3702 }
e518068a 3703 }
a0d0e21e 3704 }
748a9306
LW		 3705 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3706 cp1 = strchr(esa,']');
3707 if (!cp1) cp1 = strchr(esa,'>');
3708 if (cp1) { /* Should always be true */
3709 dirnam.nam$b_esl -= cp1 - esa - 1;
3710 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3711 }
3712 }
a0d0e21e
LW		 3713 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3714 /* Yep; check version while we're at it, if it's there. */
3715 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3716 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3717 /* Something other than .DIR[;1]. Bzzt. */
752635ea 3718 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
f7ddb74a 3719 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
748a9306
LW		 3720 set_errno(ENOTDIR);
3721 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 3722 return NULL;
3723 }
748a9306
LW		 3724 }
3725 esa[dirnam.nam$b_esl] = '\0';
3726 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3727 /* They provided at least the name; we added the type, if necessary, */
3728 if (buf) retspec = buf; /* in sys$parse() */
a02a5408 3729 else if (ts) Newx(retspec,dirnam.nam$b_esl+1,char);
748a9306
LW		 3730 else retspec = __fileify_retbuf;
3731 strcpy(retspec,esa);
752635ea 3732 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
f7ddb74a 3733 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
748a9306
LW		 3734 return retspec;
3735 }
c07a80fd
PP		 3736 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3737 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3738 *cp1 = '\0';
3739 dirnam.nam$b_esl -= 9;
3740 }
748a9306 3741 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
752635ea
CB		 3742 if (cp1 == NULL) { /* should never happen */
3743 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
f7ddb74a 3744 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
752635ea
CB		 3745 return NULL;
3746 }
748a9306
LW		 3747 term = *cp1;
3748 *cp1 = '\0';
3749 retlen = strlen(esa);
f7ddb74a
JM		 3750 cp1 = strrchr(esa,'.');
3751 /* ODS-5 directory specifications can have extra "." in them. */
3752 while (cp1 != NULL) {
3753 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
3754 break;
3755 else {
3756 cp1--;
3757 while ((cp1 > esa) && (*cp1 != '.'))
3758 cp1--;
3759 }
3760 if (cp1 == esa)
3761 cp1 = NULL;
3762 }
3763
3764 if ((cp1) != NULL) {
748a9306
LW		 3765 /* There's more than one directory in the path. Just roll back. */
3766 *cp1 = term;
3767 if (buf) retspec = buf;
a02a5408 3768 else if (ts) Newx(retspec,retlen+7,char);
748a9306
LW		 3769 else retspec = __fileify_retbuf;
3770 strcpy(retspec,esa);
a0d0e21e
LW		 3771 }
3772 else {
748a9306
LW		 3773 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3774 /* Go back and expand rooted logical name */
3775 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
f7ddb74a
JM		 3776#ifdef NAM$M_NO_SHORT_UPCASE
3777 if (decc_efs_case_preserve)
3778 dirnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3779#endif
748a9306 3780 if (!(sys$parse(&dirfab) & 1)) {
752635ea 3781 dirnam.nam$l_rlf = NULL;
f7ddb74a 3782 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
748a9306
LW		 3783 set_errno(EVMSERR);
3784 set_vaxc_errno(dirfab.fab$l_sts);
3785 return NULL;
3786 }
3787 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 3788 if (buf) retspec = buf;
a02a5408 3789 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 3790 else retspec = __fileify_retbuf;
748a9306 3791 cp1 = strstr(esa,"][");
46112e17 3792 if (!cp1) cp1 = strstr(esa,"]<");
748a9306
LW		 3793 dirlen = cp1 - esa;
3794 memcpy(retspec,esa,dirlen);
3795 if (!strncmp(cp1+2,"000000]",7)) {
3796 retspec[dirlen-1] = '\0';
f7ddb74a
JM		 3797 /* Not full ODS-5, just extra dots in directories for now */
3798 cp1 = retspec + dirlen - 1;
3799 while (cp1 > retspec)
3800 {
3801 if (*cp1 == '[')
3802 break;
3803 if (*cp1 == '.') {
3804 if (*(cp1-1) != '^')
3805 break;
3806 }
3807 cp1--;
3808 }
4633a7c4
LW		 3809 if (*cp1 == '.') *cp1 = ']';
3810 else {
3811 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3812 memcpy(cp1+1,"000000]",7);
3813 }
748a9306
LW		 3814 }
3815 else {
3816 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3817 retspec[retlen] = '\0';
3818 /* Convert last '.' to ']' */
f7ddb74a
JM		 3819 cp1 = retspec+retlen-1;
3820 while (*cp != '[') {
3821 cp1--;
3822 if (*cp1 == '.') {
3823 /* Do not trip on extra dots in ODS-5 directories */
3824 if ((cp1 == retspec) || (*(cp1-1) != '^'))
3825 break;
3826 }
3827 }
4633a7c4
LW		 3828 if (*cp1 == '.') *cp1 = ']';
3829 else {
3830 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3831 memcpy(cp1+1,"000000]",7);
3832 }
748a9306 3833 }
a0d0e21e 3834 }
748a9306 3835 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 3836 if (buf) retspec = buf;
a02a5408 3837 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e
LW		 3838 else retspec = __fileify_retbuf;
3839 cp1 = esa;
3840 cp2 = retspec;
3841 while (*cp1 != ':') *(cp2++) = *(cp1++);
3842 strcpy(cp2,":[000000]");
3843 cp1 += 2;
3844 strcpy(cp2+9,cp1);
3845 }
748a9306 3846 }
752635ea 3847 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
f7ddb74a 3848 dirfab.fab$b_dns = 0; sts = sys$parse(&dirfab,0,0);
748a9306 3849 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 3850 type and version, and we're done. */
3851 strcat(retspec,".DIR;1");
01b8edb6
PP		 3852
3853 /* $PARSE may have upcased filespec, so convert output to lower
3854 * case if input contained any lowercase characters. */
f7ddb74a 3855 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
a0d0e21e
LW		 3856 return retspec;
3857 }
3858} /* end of do_fileify_dirspec() */
3859/*}}}*/
3860/* External entry points */
b8ffc8df 3861char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
a0d0e21e 3862{ return do_fileify_dirspec(dir,buf,0); }
b8ffc8df 3863char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
a0d0e21e
LW		 3864{ return do_fileify_dirspec(dir,buf,1); }
3865
3866/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
b8ffc8df 3867static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
a0d0e21e
LW		 3868{
3869 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3870 unsigned long int retlen;
748a9306 3871 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];