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