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
Optimise index so that if the big string is ISO-8859-1 but the little
[perl5.git] / vms / vms.c
CommitLineData
748a9306 1/* vms.c
a0d0e21e 2 *
748a9306 3 * VMS-specific routines for perl5
22d4bb9c 4 * Version: 5.7.0
748a9306 5 *
2fbb330f 6 * August 2005 Convert VMS status code to UNIX status codes
22d4bb9c
CB		 7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 11 */
12
13#include <acedef.h>
14#include <acldef.h>
15#include <armdef.h>
748a9306 16#include <atrdef.h>
a0d0e21e 17#include <chpdef.h>
8fde5078 18#include <clidef.h>
a3e9d8c9 19#include <climsgdef.h>
a0d0e21e 20#include <descrip.h>
22d4bb9c 21#include <devdef.h>
a0d0e21e 22#include <dvidef.h>
748a9306 23#include <fibdef.h>
a0d0e21e
LW		 24#include <float.h>
25#include <fscndef.h>
26#include <iodef.h>
27#include <jpidef.h>
61bb5906 28#include <kgbdef.h>
f675dbe5 29#include <libclidef.h>
a0d0e21e
LW		 30#include <libdef.h>
31#include <lib$routines.h>
32#include <lnmdef.h>
aeb5cf3c 33#include <msgdef.h>
f7ddb74a
JM		 34#if __CRTL_VER >= 70301000 && !defined(__VAX)
35#include <ppropdef.h>
36#endif
748a9306 37#include <prvdef.h>
a0d0e21e
LW		 38#include <psldef.h>
39#include <rms.h>
40#include <shrdef.h>
41#include <ssdef.h>
42#include <starlet.h>
f86702cc 43#include <strdef.h>
44#include <str$routines.h>
a0d0e21e 45#include <syidef.h>
748a9306
LW		 46#include <uaidef.h>
47#include <uicdef.h>
2fbb330f
JM		 48#include <stsdef.h>
49#include <rmsdef.h>
a0d0e21e 50
f7ddb74a
JM		 51/* Set the maximum filespec size here as it is larger for EFS file
52 * specifications.
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
59 */
f7ddb74a 60#ifndef __VAX
2497a41f 61#ifndef VMS_MAXRSS
f7ddb74a 62#ifdef NAML$C_MAXRSS
18a3d61e 63#define VMS_MAXRSS (NAML$C_MAXRSS+1)
2497a41f
JM		 64#ifndef VMS_LONGNAME_SUPPORT
65#define VMS_LONGNAME_SUPPORT 1
66#endif /* VMS_LONGNAME_SUPPORT */
18a3d61e 67#endif /* NAML$C_MAXRSS */
2497a41f 68#endif /* VMS_MAXRSS */
f7ddb74a 69#endif
2497a41f
JM		 70
71/* temporary hack until support is complete */
72#ifdef VMS_LONGNAME_SUPPORT
73#undef VMS_LONGNAME_SUPPORT
74#undef VMS_MAXRSS
f7ddb74a 75#endif
2497a41f
JM		 76/* end of temporary hack until support is complete */
77
78#ifndef VMS_MAXRSS
18a3d61e 79#define VMS_MAXRSS (NAM$C_MAXRSS + 1)
f7ddb74a
JM		 80#endif
81
82#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
83int decc$feature_get_index(const char *name);
84char* decc$feature_get_name(int index);
85int decc$feature_get_value(int index, int mode);
86int decc$feature_set_value(int index, int mode, int value);
87#else
88#include <unixlib.h>
89#endif
90
7a7fd8e0 91#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 92
93static int set_feature_default(const char *name, int value)
94{
95 int status;
96 int index;
97
98 index = decc$feature_get_index(name);
99
100 status = decc$feature_set_value(index, 1, value);
101 if (index == -1 || (status == -1)) {
102 return -1;
103 }
104
105 status = decc$feature_get_value(index, 1);
106 if (status != value) {
107 return -1;
108 }
109
110return 0;
111}
112#endif
f7ddb74a 113
740ce14c 114/* Older versions of ssdef.h don't have these */
115#ifndef SS$_INVFILFOROP
116# define SS$_INVFILFOROP 3930
117#endif
118#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 119# define SS$_NOSUCHOBJECT 2696
120#endif
121
a15cef0c
CB		 122/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
123#define PERLIO_NOT_STDIO 0
124
2497a41f 125/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 126 * code below needs to get to the underlying CRTL routines. */
127#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 128#include "EXTERN.h"
129#include "perl.h"
748a9306 130#include "XSUB.h"
3eeba6fb
CB		 131/* Anticipating future expansion in lexical warnings . . . */
132#ifndef WARN_INTERNAL
133# define WARN_INTERNAL WARN_MISC
134#endif
a0d0e21e 135
22d4bb9c
CB		 136#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
137# define RTL_USES_UTC 1
138#endif
139
140
c07a80fd 141/* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
143#ifdef __GNUC__
482b294c 144# define uic$v_format uic$r_uic_form.uic$v_format
145# define uic$v_group uic$r_uic_form.uic$v_group
146# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 147# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
148# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
149# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
150# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
151#endif
152
c645ec3f
GS		 153#if defined(NEED_AN_H_ERRNO)
154dEXT int h_errno;
155#endif
c07a80fd 156
f7ddb74a
JM		 157#ifdef __DECC
158#pragma message disable pragma
159#pragma member_alignment save
160#pragma nomember_alignment longword
161#pragma message save
162#pragma message disable misalgndmem
163#endif
a0d0e21e
LW		 164struct itmlst_3 {
165 unsigned short int buflen;
166 unsigned short int itmcode;
167 void *bufadr;
748a9306 168 unsigned short int *retlen;
a0d0e21e 169};
f7ddb74a
JM		 170#ifdef __DECC
171#pragma message restore
172#pragma member_alignment restore
173#endif
a0d0e21e 174
4b19af01
CB		 175#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
176#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
177#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
178#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
179#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
f7ddb74a 180#define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
4b19af01
CB		 181#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
182#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
f7ddb74a 183#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 184#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
185#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
186
f7ddb74a
JM		 187static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
188static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
189static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
190static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
191
0e06870b
CB		 192/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
193#define PERL_LNM_MAX_ALLOWED_INDEX 127
194
2d9f3838
CB		 195/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
196 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
197 * the Perl facility.
198 */
199#define PERL_LNM_MAX_ITER 10
200
2497a41f
JM		 201 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
202#if __CRTL_VER >= 70302000 && !defined(__VAX)
203#define MAX_DCL_SYMBOL (8192)
204#define MAX_DCL_LINE_LENGTH (4096 - 4)
205#else
206#define MAX_DCL_SYMBOL (1024)
207#define MAX_DCL_LINE_LENGTH (1024 - 4)
208#endif
ff7adb52 209
01b8edb6 210static char *__mystrtolower(char *str)
211{
212 if (str) for (; *str; ++str) *str= tolower(*str);
213 return str;
214}
215
f675dbe5
CB		 216static struct dsc$descriptor_s fildevdsc =
217 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
218static struct dsc$descriptor_s crtlenvdsc =
219 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
220static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
221static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
222static struct dsc$descriptor_s **env_tables = defenv;
223static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
224
93948341
CB		 225/* True if we shouldn't treat barewords as logicals during directory */
226/* munching */
227static int no_translate_barewords;
228
22d4bb9c
CB		 229#ifndef RTL_USES_UTC
230static int tz_updated = 1;
231#endif
232
f7ddb74a
JM		 233/* DECC Features that may need to affect how Perl interprets
234 * displays filename information
235 */
236static int decc_disable_to_vms_logname_translation = 1;
237static int decc_disable_posix_root = 1;
238int decc_efs_case_preserve = 0;
239static int decc_efs_charset = 0;
240static int decc_filename_unix_no_version = 0;
241static int decc_filename_unix_only = 0;
242int decc_filename_unix_report = 0;
243int decc_posix_compliant_pathnames = 0;
244int decc_readdir_dropdotnotype = 0;
245static int vms_process_case_tolerant = 1;
246
2497a41f
JM		 247/* bug workarounds if needed */
248int decc_bug_readdir_efs1 = 0;
682e4b71 249int decc_bug_devnull = 1;
2497a41f
JM		 250int decc_bug_fgetname = 0;
251int decc_dir_barename = 0;
252
f7ddb74a
JM		 253/* Is this a UNIX file specification?
254 * No longer a simple check with EFS file specs
255 * For now, not a full check, but need to
256 * handle POSIX ^UP^ specifications
257 * Fixing to handle ^/ cases would require
258 * changes to many other conversion routines.
259 */
260
261static is_unix_filespec(const char *path)
262{
263int ret_val;
264const char * pch1;
265
266 ret_val = 0;
267 if (strncmp(path,"\"^UP^",5) != 0) {
268 pch1 = strchr(path, '/');
269 if (pch1 != NULL)
270 ret_val = 1;
271 else {
272
273 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
274 if (decc_filename_unix_report || decc_filename_unix_only) {
275 if (strcmp(path,".") == 0)
276 ret_val = 1;
277 }
278 }
279 }
280 return ret_val;
281}
282
283
fa537f88
CB		 284/* my_maxidx
285 * Routine to retrieve the maximum equivalence index for an input
286 * logical name. Some calls to this routine have no knowledge if
287 * the variable is a logical or not. So on error we return a max
288 * index of zero.
289 */
f7ddb74a 290/*{{{int my_maxidx(const char *lnm) */
fa537f88 291static int
f7ddb74a 292my_maxidx(const char *lnm)
fa537f88
CB		 293{
294 int status;
295 int midx;
296 int attr = LNM$M_CASE_BLIND;
297 struct dsc$descriptor lnmdsc;
298 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
299 {0, 0, 0, 0}};
300
301 lnmdsc.dsc$w_length = strlen(lnm);
302 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
303 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 304 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 305
306 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
307 if ((status & 1) == 0)
308 midx = 0;
309
310 return (midx);
311}
312/*}}}*/
313
f675dbe5 314/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 315int
fd8cd3a3 316Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 317 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 318{
f7ddb74a
JM		 319 const char *cp1;
320 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 321 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 322 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 323 int midx;
f675dbe5
CB		 324 unsigned char acmode;
325 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
326 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
327 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
328 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 329 {0, 0, 0, 0}};
f675dbe5 330 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 331#if defined(PERL_IMPLICIT_CONTEXT)
332 pTHX = NULL;
fd8cd3a3
DS		 333 if (PL_curinterp) {
334 aTHX = PERL_GET_INTERP;
cc077a9f 335 } else {
fd8cd3a3 336 aTHX = NULL;
cc077a9f
HM		 337 }
338#endif
748a9306 339
fa537f88 340 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 341 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
342 }
f7ddb74a 343 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 344 *cp2 = _toupper(*cp1);
345 if (cp1 - lnm > LNM$C_NAMLENGTH) {
346 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
347 return 0;
348 }
349 }
350 lnmdsc.dsc$w_length = cp1 - lnm;
351 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 352 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 353 secure = flags & PERL__TRNENV_SECURE;
354 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
355 if (!tabvec || !*tabvec) tabvec = env_tables;
356
357 for (curtab = 0; tabvec[curtab]; curtab++) {
358 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
359 if (!ivenv && !secure) {
360 char *eq, *end;
361 int i;
362 if (!environ) {
363 ivenv = 1;
5c84aa53 364 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 365 continue;
366 }
367 retsts = SS$_NOLOGNAM;
368 for (i = 0; environ[i]; i++) {
369 if ((eq = strchr(environ[i],'=')) &&
299d126a 370 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 371 !strncmp(environ[i],uplnm,eq - environ[i])) {
372 eq++;
373 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
374 if (!eqvlen) continue;
375 retsts = SS$_NORMAL;
376 break;
377 }
378 }
379 if (retsts != SS$_NOLOGNAM) break;
380 }
381 }
382 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
383 !str$case_blind_compare(&tmpdsc,&clisym)) {
384 if (!ivsym && !secure) {
385 unsigned short int deflen = LNM$C_NAMLENGTH;
386 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
387 /* dynamic dsc to accomodate possible long value */
388 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
389 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
390 if (retsts & 1) {
2497a41f 391 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 392 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 393 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 394 /* Special hack--we might be called before the interpreter's */
395 /* fully initialized, in which case either thr or PL_curcop */
396 /* might be bogus. We have to check, since ckWARN needs them */
397 /* both to be valid if running threaded */
cc077a9f 398 if (ckWARN(WARN_MISC)) {
f98bc0c6 399 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 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) {
843027b0 411 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 412 midx = my_maxidx(lnm);
413 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
414 lnmlst[1].bufadr = cp2;
fa537f88
CB		 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
fa537f88 422 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 423#endif
fa537f88
CB		 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")) ) ) {
18a3d61e 429 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 430 eqvlen -= 4;
431 }
f7ddb74a
JM		 432 cp2 += eqvlen;
433 *cp2 = '\0';
fa537f88
CB		 434 }
435 if ((retsts == SS$_IVLOGNAM) ||
436 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 437 }
fa537f88 438 else {
fa537f88
CB		 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{
f7ddb74a 485 const char *cp1;
fa537f88 486 static char *__my_getenv_eqv = NULL;
f7ddb74a 487 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 488 unsigned long int idx = 0;
bc10a425 489 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 490 int midx, flags;
61bb5906 491 SV *tmpsv;
a0d0e21e 492
f7ddb74a 493 midx = my_maxidx(lnm) + 1;
fa537f88 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 */
fa537f88 498 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 499 if (!tmpsv) return NULL;
500 eqv = SvPVX(tmpsv);
501 }
fa537f88
CB		 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 {
a02a5408 508 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 509 }
510 eqv = __my_getenv_eqv;
511 }
512
f7ddb74a 513 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 514 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 515 int len;
61bb5906 516 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 517
518 len = strlen(eqv);
519
520 /* Get rid of "000000/ in rooted filespecs */
521 if (len > 7) {
522 char * zeros;
523 zeros = strstr(eqv, "/000000/");
524 if (zeros != NULL) {
525 int mlen;
526 mlen = len - (zeros - eqv) - 7;
527 memmove(zeros, &zeros[7], mlen);
528 len = len - 7;
529 eqv[len] = '\0';
530 }
531 }
61bb5906 532 return eqv;
748a9306 533 }
a0d0e21e 534 else {
2512681b 535 /* Impose security constraints only if tainting */
bc10a425
CB		 536 if (sys) {
537 /* Impose security constraints only if tainting */
538 secure = PL_curinterp ? PL_tainting : will_taint;
539 saverr = errno; savvmserr = vaxc$errno;
540 }
843027b0
CB		 541 else {
542 secure = 0;
543 }
544
545 flags =
f675dbe5 546#ifdef SECURE_INTERNAL_GETENV
843027b0 547 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 548#else
843027b0 549 0
f675dbe5 550#endif
843027b0
CB		 551 ;
552
553 /* For the getenv interface we combine all the equivalence names
554 * of a search list logical into one value to acquire a maximum
555 * value length of 255*128 (assuming %ENV is using logicals).
556 */
557 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
558
559 /* If the name contains a semicolon-delimited index, parse it
560 * off and make sure we only retrieve the equivalence name for
561 * that index. */
562 if ((cp2 = strchr(lnm,';')) != NULL) {
563 strcpy(uplnm,lnm);
564 uplnm[cp2-lnm] = '\0';
565 idx = strtoul(cp2+1,NULL,0);
566 lnm = uplnm;
567 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
568 }
569
570 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
571
bc10a425
CB		 572 /* Discard NOLOGNAM on internal calls since we're often looking
573 * for an optional name, and this "error" often shows up as the
574 * (bogus) exit status for a die() call later on. */
575 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
576 return success ? eqv : Nullch;
a0d0e21e 577 }
a0d0e21e
LW		 578
579} /* end of my_getenv() */
580/*}}}*/
581
f675dbe5 582
a6c40364
GS		 583/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
584char *
fd8cd3a3 585Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 586{
f7ddb74a
JM		 587 const char *cp1;
588 char *buf, *cp2;
a6c40364 589 unsigned long idx = 0;
843027b0 590 int midx, flags;
fa537f88 591 static char *__my_getenv_len_eqv = NULL;
bc10a425 592 int secure, saverr, savvmserr;
cc077a9f
HM		 593 SV *tmpsv;
594
f7ddb74a 595 midx = my_maxidx(lnm) + 1;
fa537f88 596
cc077a9f
HM		 597 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
598 /* Set up a temporary buffer for the return value; Perl will
599 * clean it up at the next statement transition */
fa537f88 600 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 601 if (!tmpsv) return NULL;
602 buf = SvPVX(tmpsv);
603 }
fa537f88
CB		 604 else {
605 /* Assume no interpreter ==> single thread */
606 if (__my_getenv_len_eqv != NULL) {
607 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
608 }
609 else {
a02a5408 610 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 611 }
612 buf = __my_getenv_len_eqv;
613 }
614
f7ddb74a 615 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 616 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 617 char * zeros;
618
f675dbe5 619 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 620 *len = strlen(buf);
f7ddb74a
JM		 621
622 /* Get rid of "000000/ in rooted filespecs */
623 if (*len > 7) {
624 zeros = strstr(buf, "/000000/");
625 if (zeros != NULL) {
626 int mlen;
627 mlen = *len - (zeros - buf) - 7;
628 memmove(zeros, &zeros[7], mlen);
629 *len = *len - 7;
630 buf[*len] = '\0';
631 }
632 }
a6c40364 633 return buf;
f675dbe5
CB		 634 }
635 else {
bc10a425
CB		 636 if (sys) {
637 /* Impose security constraints only if tainting */
638 secure = PL_curinterp ? PL_tainting : will_taint;
639 saverr = errno; savvmserr = vaxc$errno;
640 }
843027b0
CB		 641 else {
642 secure = 0;
643 }
644
645 flags =
f675dbe5 646#ifdef SECURE_INTERNAL_GETENV
843027b0 647 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 648#else
843027b0 649 0
f675dbe5 650#endif
843027b0
CB		 651 ;
652
653 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
654
655 if ((cp2 = strchr(lnm,';')) != NULL) {
656 strcpy(buf,lnm);
657 buf[cp2-lnm] = '\0';
658 idx = strtoul(cp2+1,NULL,0);
659 lnm = buf;
660 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
661 }
662
663 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
664
f7ddb74a
JM		 665 /* Get rid of "000000/ in rooted filespecs */
666 if (*len > 7) {
667 char * zeros;
668 zeros = strstr(buf, "/000000/");
669 if (zeros != NULL) {
670 int mlen;
671 mlen = *len - (zeros - buf) - 7;
672 memmove(zeros, &zeros[7], mlen);
673 *len = *len - 7;
674 buf[*len] = '\0';
675 }
676 }
677
bc10a425
CB		 678 /* Discard NOLOGNAM on internal calls since we're often looking
679 * for an optional name, and this "error" often shows up as the
680 * (bogus) exit status for a die() call later on. */
681 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
682 return *len ? buf : Nullch;
f675dbe5
CB		 683 }
684
a6c40364 685} /* end of my_getenv_len() */
f675dbe5
CB		 686/*}}}*/
687
fd8cd3a3 688static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 689
690static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 691
740ce14c 692/*{{{ void prime_env_iter() */
693void
694prime_env_iter(void)
695/* Fill the %ENV associative array with all logical names we can
696 * find, in preparation for iterating over it.
697 */
698{
17f28c40 699 static int primed = 0;
3eeba6fb 700 HV *seenhv = NULL, *envhv;
22be8b3c 701 SV *sv = NULL;
f675dbe5 702 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 703 unsigned short int chan;
704#ifndef CLI$M_TRUSTED
705# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
706#endif
f675dbe5
CB		 707 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
708 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
709 long int i;
710 bool have_sym = FALSE, have_lnm = FALSE;
711 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
712 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
713 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
714 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
715 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 716#if defined(PERL_IMPLICIT_CONTEXT)
717 pTHX;
718#endif
3db8f154 719#if defined(USE_ITHREADS)
b2b3adea
HM		 720 static perl_mutex primenv_mutex;
721 MUTEX_INIT(&primenv_mutex);
61bb5906 722#endif
740ce14c 723
fd8cd3a3
DS		 724#if defined(PERL_IMPLICIT_CONTEXT)
725 /* We jump through these hoops because we can be called at */
726 /* platform-specific initialization time, which is before anything is */
727 /* set up--we can't even do a plain dTHX since that relies on the */
728 /* interpreter structure to be initialized */
fd8cd3a3
DS		 729 if (PL_curinterp) {
730 aTHX = PERL_GET_INTERP;
731 } else {
732 aTHX = NULL;
733 }
734#endif
fd8cd3a3 735
3eeba6fb 736 if (primed || !PL_envgv) return;
61bb5906
CB		 737 MUTEX_LOCK(&primenv_mutex);
738 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 739 envhv = GvHVn(PL_envgv);
740ce14c 740 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 741 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 742 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 743
f675dbe5
CB		 744 for (i = 0; env_tables[i]; i++) {
745 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
746 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
747 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 748 }
f675dbe5
CB		 749 if (have_sym || have_lnm) {
750 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
751 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
752 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
753 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 754 }
f675dbe5
CB		 755
756 for (i--; i >= 0; i--) {
757 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
758 char *start;
759 int j;
760 for (j = 0; environ[j]; j++) {
761 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 762 if (ckWARN(WARN_INTERNAL))
f98bc0c6 763 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 764 }
765 else {
766 start++;
22be8b3c
CB		 767 sv = newSVpv(start,0);
768 SvTAINTED_on(sv);
769 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 770 }
771 }
772 continue;
740ce14c 773 }
f675dbe5
CB		 774 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
775 !str$case_blind_compare(&tmpdsc,&clisym)) {
776 strcpy(cmd,"Show Symbol/Global *");
777 cmddsc.dsc$w_length = 20;
778 if (env_tables[i]->dsc$w_length == 12 &&
779 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
780 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
781 flags = defflags | CLI$M_NOLOGNAM;
782 }
783 else {
784 strcpy(cmd,"Show Logical *");
785 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
786 strcat(cmd," /Table=");
787 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
788 cmddsc.dsc$w_length = strlen(cmd);
789 }
790 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
791 flags = defflags | CLI$M_NOCLISYM;
792 }
793
794 /* Create a new subprocess to execute each command, to exclude the
795 * remote possibility that someone could subvert a mbx or file used
796 * to write multiple commands to a single subprocess.
797 */
798 do {
799 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
800 0,&riseandshine,0,0,&clidsc,&clitabdsc);
801 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
802 defflags &= ~CLI$M_TRUSTED;
803 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
804 _ckvmssts(retsts);
a02a5408 805 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 806 if (seenhv) SvREFCNT_dec(seenhv);
807 seenhv = newHV();
808 while (1) {
809 char *cp1, *cp2, *key;
810 unsigned long int sts, iosb[2], retlen, keylen;
811 register U32 hash;
812
813 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
814 if (sts & 1) sts = iosb[0] & 0xffff;
815 if (sts == SS$_ENDOFFILE) {
816 int wakect = 0;
817 while (substs == 0) { sys$hiber(); wakect++;}
818 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
819 _ckvmssts(substs);
820 break;
821 }
822 _ckvmssts(sts);
823 retlen = iosb[0] >> 16;
824 if (!retlen) continue; /* blank line */
825 buf[retlen] = '\0';
826 if (iosb[1] != subpid) {
827 if (iosb[1]) {
5c84aa53 828 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 829 }
830 continue;
831 }
3eeba6fb 832 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 833 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 834
835 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
836 if (*cp1 == '(' || /* Logical name table name */
837 *cp1 == '=' /* Next eqv of searchlist */) continue;
838 if (*cp1 == '"') cp1++;
839 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
840 key = cp1; keylen = cp2 - cp1;
841 if (keylen && hv_exists(seenhv,key,keylen)) continue;
842 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 843 while (*cp2 && *cp2 == '=') cp2++;
844 while (*cp2 && *cp2 == ' ') cp2++;
845 if (*cp2 == '"') { /* String translation; may embed "" */
846 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
847 cp2++; cp1--; /* Skip "" surrounding translation */
848 }
849 else { /* Numeric translation */
850 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
851 cp1--; /* stop on last non-space char */
852 }
853 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 855 continue;
856 }
5afd6d42 857 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 858
859 if (cp1 == cp2 && *cp2 == '.') {
860 /* A single dot usually means an unprintable character, such as a null
861 * to indicate a zero-length value. Get the actual value to make sure.
862 */
863 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 864 char eqv[MAX_DCL_SYMBOL+1];
ff79d39d
CB		 865 strncpy(lnm, key, keylen);
866 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
867 sv = newSVpvn(eqv, strlen(eqv));
868 }
869 else {
870 sv = newSVpvn(cp2,cp1 - cp2 + 1);
871 }
872
22be8b3c
CB		 873 SvTAINTED_on(sv);
874 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 875 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 876 }
f675dbe5
CB		 877 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
878 /* get the PPFs for this process, not the subprocess */
f7ddb74a 879 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 880 char eqv[LNM$C_NAMLENGTH+1];
881 int trnlen, i;
882 for (i = 0; ppfs[i]; i++) {
883 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 884 sv = newSVpv(eqv,trnlen);
885 SvTAINTED_on(sv);
886 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 887 }
740ce14c 888 }
889 }
f675dbe5
CB		 890 primed = 1;
891 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
892 if (buf) Safefree(buf);
893 if (seenhv) SvREFCNT_dec(seenhv);
894 MUTEX_UNLOCK(&primenv_mutex);
895 return;
896
740ce14c 897} /* end of prime_env_iter */
898/*}}}*/
740ce14c 899
f675dbe5 900
2c590a56 901/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 902/* Define or delete an element in the same "environment" as
903 * vmstrnenv(). If an element is to be deleted, it's removed from
904 * the first place it's found. If it's to be set, it's set in the
905 * place designated by the first element of the table vector.
3eeba6fb 906 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 907 */
f675dbe5 908int
2c590a56 909Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 910{
f7ddb74a
JM		 911 const char *cp1;
912 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 913 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 914 int nseg = 0, j;
a0d0e21e 915 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 916 struct itmlst_3 *ile, *ilist;
a0d0e21e 917 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 918 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
919 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
920 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
921 $DESCRIPTOR(local,"_LOCAL");
922
ed253963
CB		 923 if (!lnm) {
924 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
925 return SS$_IVLOGNAM;
926 }
927
f7ddb74a 928 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 929 *cp2 = _toupper(*cp1);
930 if (cp1 - lnm > LNM$C_NAMLENGTH) {
931 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
932 return SS$_IVLOGNAM;
933 }
934 }
a0d0e21e 935 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 936 if (!tabvec || !*tabvec) tabvec = env_tables;
937
3eeba6fb 938 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 939 for (curtab = 0; tabvec[curtab]; curtab++) {
940 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
941 int i;
299d126a 942 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 943 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 944 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 945 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 946#ifdef HAS_SETENV
0e06870b 947 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 948 }
949 }
950 ivenv = 1; retsts = SS$_NOLOGNAM;
951#else
3eeba6fb 952 if (ckWARN(WARN_INTERNAL))
f98bc0c6 953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 954 ivenv = 1; retsts = SS$_NOSUCHPGM;
955 break;
956 }
957 }
f675dbe5
CB		 958#endif
959 }
960 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
961 !str$case_blind_compare(&tmpdsc,&clisym)) {
962 unsigned int symtype;
963 if (tabvec[curtab]->dsc$w_length == 12 &&
964 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
965 !str$case_blind_compare(&tmpdsc,&local))
966 symtype = LIB$K_CLI_LOCAL_SYM;
967 else symtype = LIB$K_CLI_GLOBAL_SYM;
968 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 969 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
970 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 971 break;
972 }
973 else if (!ivlnm) {
974 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
975 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
976 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
977 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
978 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
979 }
a0d0e21e
LW		 980 }
981 }
f675dbe5
CB		 982 else { /* we're defining a value */
983 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
984#ifdef HAS_SETENV
3eeba6fb 985 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 986#else
3eeba6fb 987 if (ckWARN(WARN_INTERNAL))
f98bc0c6 988 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 989 retsts = SS$_NOSUCHPGM;
990#endif
991 }
992 else {
f7ddb74a 993 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 994 eqvdsc.dsc$w_length = strlen(eqv);
995 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
996 !str$case_blind_compare(&tmpdsc,&clisym)) {
997 unsigned int symtype;
998 if (tabvec[0]->dsc$w_length == 12 &&
999 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1000 !str$case_blind_compare(&tmpdsc,&local))
1001 symtype = LIB$K_CLI_LOCAL_SYM;
1002 else symtype = LIB$K_CLI_GLOBAL_SYM;
1003 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1004 }
3eeba6fb
CB		 1005 else {
1006 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1007 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1008
1009 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1010 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1011 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1012 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1013 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1014 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1015 }
1016
a02a5408 1017 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1018 ile = ilist;
1019 if (!ile) {
1020 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1021 return SS$_INSFMEM;
a1dfe751 1022 }
fa537f88
CB		 1023 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1024
1025 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1026 ile->itmcode = LNM$_STRING;
1027 ile->bufadr = c;
1028 if ((j+1) == nseg) {
1029 ile->buflen = strlen(c);
1030 /* in case we are truncating one that's too long */
1031 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1032 }
1033 else {
1034 ile->buflen = LNM$C_NAMLENGTH;
1035 }
1036 }
1037
1038 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1039 Safefree (ilist);
1040 }
1041 else {
1042 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1043 }
3eeba6fb 1044 }
f675dbe5
CB		 1045 }
1046 }
1047 if (!(retsts & 1)) {
1048 switch (retsts) {
1049 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1050 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1051 set_errno(EVMSERR); break;
1052 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1053 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1054 set_errno(EINVAL); break;
1055 case SS$_NOPRIV:
1056 set_errno(EACCES);
1057 default:
1058 _ckvmssts(retsts);
1059 set_errno(EVMSERR);
1060 }
1061 set_vaxc_errno(retsts);
1062 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1063 }
3eeba6fb
CB		 1064 else {
1065 /* We reset error values on success because Perl does an hv_fetch()
1066 * before each hv_store(), and if the thing we're setting didn't
1067 * previously exist, we've got a leftover error message. (Of course,
1068 * this fails in the face of
1069 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1070 * in that the error reported in $! isn't spurious,
1071 * but it's right more often than not.)
1072 */
f675dbe5
CB		 1073 set_errno(0); set_vaxc_errno(retsts);
1074 return 0;
1075 }
1076
1077} /* end of vmssetenv() */
1078/*}}}*/
a0d0e21e 1079
2c590a56 1080/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1081/* This has to be a function since there's a prototype for it in proto.h */
1082void
2c590a56 1083Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1084{
bc10a425
CB		 1085 if (lnm && *lnm) {
1086 int len = strlen(lnm);
1087 if (len == 7) {
1088 char uplnm[8];
22d4bb9c
CB		 1089 int i;
1090 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1091 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1092 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1093 return;
1094 }
1095 }
1096#ifndef RTL_USES_UTC
1097 if (len == 6 || len == 2) {
1098 char uplnm[7];
1099 int i;
1100 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1101 uplnm[len] = '\0';
1102 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1103 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1104 }
1105#endif
1106 }
f675dbe5
CB		 1107 (void) vmssetenv(lnm,eqv,NULL);
1108}
a0d0e21e
LW		 1109/*}}}*/
1110
27c67b75 1111/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1112/* vmssetuserlnm
1113 * sets a user-mode logical in the process logical name table
1114 * used for redirection of sys$error
1115 */
1116void
2fbb330f 1117Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1118{
1119 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1120 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1121 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1122 unsigned char acmode = PSL$C_USER;
1123 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1124 {0, 0, 0, 0}};
2fbb330f 1125 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1126 d_name.dsc$w_length = strlen(name);
1127
1128 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1129 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1130
1131 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1132 if (!(iss&1)) lib$signal(iss);
1133}
1134/*}}}*/
c07a80fd 1135
f675dbe5 1136
c07a80fd 1137/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1138/* my_crypt - VMS password hashing
1139 * my_crypt() provides an interface compatible with the Unix crypt()
1140 * C library function, and uses sys$hash_password() to perform VMS
1141 * password hashing. The quadword hashed password value is returned
1142 * as a NUL-terminated 8 character string. my_crypt() does not change
1143 * the case of its string arguments; in order to match the behavior
1144 * of LOGINOUT et al., alphabetic characters in both arguments must
1145 * be upcased by the caller.
2497a41f
JM		 1146 *
1147 * - fix me to call ACM services when available
c07a80fd 1148 */
1149char *
fd8cd3a3 1150Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1151{
1152# ifndef UAI$C_PREFERRED_ALGORITHM
1153# define UAI$C_PREFERRED_ALGORITHM 127
1154# endif
1155 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1156 unsigned short int salt = 0;
1157 unsigned long int sts;
1158 struct const_dsc {
1159 unsigned short int dsc$w_length;
1160 unsigned char dsc$b_type;
1161 unsigned char dsc$b_class;
1162 const char * dsc$a_pointer;
1163 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1164 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1165 struct itmlst_3 uailst[3] = {
1166 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1167 { sizeof salt, UAI$_SALT, &salt, 0},
1168 { 0, 0, NULL, NULL}};
1169 static char hash[9];
1170
1171 usrdsc.dsc$w_length = strlen(usrname);
1172 usrdsc.dsc$a_pointer = usrname;
1173 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1174 switch (sts) {
f282b18d 1175 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1176 set_errno(EACCES);
1177 break;
1178 case RMS$_RNF:
1179 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1180 break;
1181 default:
1182 set_errno(EVMSERR);
1183 }
1184 set_vaxc_errno(sts);
1185 if (sts != RMS$_RNF) return NULL;
1186 }
1187
1188 txtdsc.dsc$w_length = strlen(textpasswd);
1189 txtdsc.dsc$a_pointer = textpasswd;
1190 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1191 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1192 }
1193
1194 return (char *) hash;
1195
1196} /* end of my_crypt() */
1197/*}}}*/
1198
1199
2fbb330f 1200static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
b8ffc8df
RGS		 1201static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1202static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
a0d0e21e 1203
2497a41f
JM		 1204/* fixup barenames that are directories for internal use.
1205 * There have been problems with the consistent handling of UNIX
1206 * style directory names when routines are presented with a name that
1207 * has no directory delimitors at all. So this routine will eventually
1208 * fix the issue.
1209 */
1210static char * fixup_bare_dirnames(const char * name)
1211{
1212 if (decc_disable_to_vms_logname_translation) {
1213/* fix me */
1214 }
1215 return NULL;
1216}
1217
1218/* mp_do_kill_file
1219 * A little hack to get around a bug in some implemenation of remove()
1220 * that do not know how to delete a directory
1221 *
1222 * Delete any file to which user has control access, regardless of whether
1223 * delete access is explicitly allowed.
1224 * Limitations: User must have write access to parent directory.
1225 * Does not block signals or ASTs; if interrupted in midstream
1226 * may leave file with an altered ACL.
1227 * HANDLE WITH CARE!
1228 */
1229/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1230static int
1231mp_do_kill_file(pTHX_ const char *name, int dirflag)
1232{
1233 char *vmsname, *rspec;
1234 char *remove_name;
1235 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1236 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1237 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1238 struct myacedef {
1239 unsigned char myace$b_length;
1240 unsigned char myace$b_type;
1241 unsigned short int myace$w_flags;
1242 unsigned long int myace$l_access;
1243 unsigned long int myace$l_ident;
1244 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1245 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1246 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1247 struct itmlst_3
1248 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1249 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1250 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1251 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1252 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1253 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1254
1255 /* Expand the input spec using RMS, since the CRTL remove() and
1256 * system services won't do this by themselves, so we may miss
1257 * a file "hiding" behind a logical name or search list. */
1258 Newx(vmsname, NAM$C_MAXRSS+1, char);
1259 if (do_tovmsspec(name,vmsname,0) == NULL) {
1260 Safefree(vmsname);
1261 return -1;
1262 }
1263
1264 if (decc_posix_compliant_pathnames) {
1265 /* In POSIX mode, we prefer to remove the UNIX name */
1266 rspec = vmsname;
1267 remove_name = (char *)name;
1268 }
1269 else {
1270 Newx(rspec, NAM$C_MAXRSS+1, char);
e886094b 1271 if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
2497a41f
JM		 1272 Safefree(rspec);
1273 Safefree(vmsname);
1274 return -1;
1275 }
1276 Safefree(vmsname);
1277 remove_name = rspec;
1278 }
1279
1280#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1281 if (dirflag != 0) {
1282 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1283 Newx(remove_name, NAM$C_MAXRSS+1, char);
7ded3206 1284 do_pathify_dirspec(name, remove_name, 0);
2497a41f
JM		 1285 if (!rmdir(remove_name)) {
1286
1287 Safefree(remove_name);
1288 Safefree(rspec);
1289 return 0; /* Can we just get rid of it? */
1290 }
1291 }
1292 else {
1293 if (!rmdir(remove_name)) {
1294 Safefree(rspec);
1295 return 0; /* Can we just get rid of it? */
1296 }
1297 }
1298 }
1299 else
1300#endif
1301 if (!remove(remove_name)) {
1302 Safefree(rspec);
1303 return 0; /* Can we just get rid of it? */
1304 }
1305
1306 /* If not, can changing protections help? */
1307 if (vaxc$errno != RMS$_PRV) {
1308 Safefree(rspec);
1309 return -1;
1310 }
1311
1312 /* No, so we get our own UIC to use as a rights identifier,
1313 * and the insert an ACE at the head of the ACL which allows us
1314 * to delete the file.
1315 */
1316 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1317 fildsc.dsc$w_length = strlen(rspec);
1318 fildsc.dsc$a_pointer = rspec;
1319 cxt = 0;
1320 newace.myace$l_ident = oldace.myace$l_ident;
1321 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1322 switch (aclsts) {
1323 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1324 set_errno(ENOENT); break;
1325 case RMS$_DIR:
1326 set_errno(ENOTDIR); break;
1327 case RMS$_DEV:
1328 set_errno(ENODEV); break;
1329 case RMS$_SYN: case SS$_INVFILFOROP:
1330 set_errno(EINVAL); break;
1331 case RMS$_PRV:
1332 set_errno(EACCES); break;
1333 default:
1334 _ckvmssts(aclsts);
1335 }
1336 set_vaxc_errno(aclsts);
1337 Safefree(rspec);
1338 return -1;
1339 }
1340 /* Grab any existing ACEs with this identifier in case we fail */
1341 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1342 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1343 || fndsts == SS$_NOMOREACE ) {
1344 /* Add the new ACE . . . */
1345 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1346 goto yourroom;
1347
1348#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1349 if (dirflag != 0)
1350 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1351 Newx(remove_name, NAM$C_MAXRSS+1, char);
7ded3206 1352 do_pathify_dirspec(name, remove_name, 0);
2497a41f
JM		 1353 rmsts = rmdir(remove_name);
1354 Safefree(remove_name);
1355 }
1356 else {
1357 rmsts = rmdir(remove_name);
1358 }
1359 else
1360#endif
1361 rmsts = remove(remove_name);
1362 if (rmsts) {
1363 /* We blew it - dir with files in it, no write priv for
1364 * parent directory, etc. Put things back the way they were. */
1365 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1366 goto yourroom;
1367 if (fndsts & 1) {
1368 addlst[0].bufadr = &oldace;
1369 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1370 goto yourroom;
1371 }
1372 }
1373 }
1374
1375 yourroom:
1376 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1377 /* We just deleted it, so of course it's not there. Some versions of
1378 * VMS seem to return success on the unlock operation anyhow (after all
1379 * the unlock is successful), but others don't.
1380 */
1381 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1382 if (aclsts & 1) aclsts = fndsts;
1383 if (!(aclsts & 1)) {
1384 set_errno(EVMSERR);
1385 set_vaxc_errno(aclsts);
1386 Safefree(rspec);
1387 return -1;
1388 }
1389
1390 Safefree(rspec);
1391 return rmsts;
1392
1393} /* end of kill_file() */
1394/*}}}*/
1395
1396
a0d0e21e
LW		 1397/*{{{int do_rmdir(char *name)*/
1398int
b8ffc8df 1399Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e
LW		 1400{
1401 char dirfile[NAM$C_MAXRSS+1];
1402 int retval;
61bb5906 1403 Stat_t st;
a0d0e21e
LW		 1404
1405 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1406 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
7ded3206 1407 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
a0d0e21e
LW		 1408 return retval;
1409
1410} /* end of do_rmdir */
1411/*}}}*/
1412
1413/* kill_file
1414 * Delete any file to which user has control access, regardless of whether
1415 * delete access is explicitly allowed.
1416 * Limitations: User must have write access to parent directory.
1417 * Does not block signals or ASTs; if interrupted in midstream
1418 * may leave file with an altered ACL.
1419 * HANDLE WITH CARE!
1420 */
1421/*{{{int kill_file(char *name)*/
1422int
b8ffc8df 1423Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1424{
bbce6d69 1425 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
a0d0e21e 1426 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 1427 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e
LW		 1428 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1429 struct myacedef {
748a9306
LW		 1430 unsigned char myace$b_length;
1431 unsigned char myace$b_type;
1432 unsigned short int myace$w_flags;
1433 unsigned long int myace$l_access;
1434 unsigned long int myace$l_ident;
a0d0e21e
LW		 1435 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1436 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1437 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1438 struct itmlst_3
748a9306
LW		 1439 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1440 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1441 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1442 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1443 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1444 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 1445
bbce6d69 1446 /* Expand the input spec using RMS, since the CRTL remove() and
1447 * system services won't do this by themselves, so we may miss
1448 * a file "hiding" behind a logical name or search list. */
1449 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1450 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1451 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
740ce14c 1452 /* If not, can changing protections help? */
1453 if (vaxc$errno != RMS$_PRV) return -1;
a0d0e21e
LW		 1454
1455 /* No, so we get our own UIC to use as a rights identifier,
1456 * and the insert an ACE at the head of the ACL which allows us
1457 * to delete the file.
1458 */
748a9306 1459 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
bbce6d69 1460 fildsc.dsc$w_length = strlen(rspec);
1461 fildsc.dsc$a_pointer = rspec;
a0d0e21e 1462 cxt = 0;
748a9306 1463 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 1464 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
740ce14c 1465 switch (aclsts) {
f282b18d 1466 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
740ce14c 1467 set_errno(ENOENT); break;
f282b18d
CB		 1468 case RMS$_DIR:
1469 set_errno(ENOTDIR); break;
740ce14c 1470 case RMS$_DEV:
1471 set_errno(ENODEV); break;
f282b18d 1472 case RMS$_SYN: case SS$_INVFILFOROP:
740ce14c 1473 set_errno(EINVAL); break;
1474 case RMS$_PRV:
1475 set_errno(EACCES); break;
1476 default:
1477 _ckvmssts(aclsts);
1478 }
748a9306 1479 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1480 return -1;
1481 }
1482 /* Grab any existing ACEs with this identifier in case we fail */
1483 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a 1484 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1485 || fndsts == SS$_NOMOREACE ) {
a0d0e21e
LW		 1486 /* Add the new ACE . . . */
1487 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1488 goto yourroom;
748a9306 1489 if ((rmsts = remove(name))) {
a0d0e21e
LW		 1490 /* We blew it - dir with files in it, no write priv for
1491 * parent directory, etc. Put things back the way they were. */
1492 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1493 goto yourroom;
1494 if (fndsts & 1) {
1495 addlst[0].bufadr = &oldace;
1496 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1497 goto yourroom;
1498 }
1499 }
1500 }
1501
1502 yourroom:
b7ae7a0d 1503 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1504 /* We just deleted it, so of course it's not there. Some versions of
1505 * VMS seem to return success on the unlock operation anyhow (after all
1506 * the unlock is successful), but others don't.
1507 */
760ac839 1508 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
b7ae7a0d 1509 if (aclsts & 1) aclsts = fndsts;
a0d0e21e 1510 if (!(aclsts & 1)) {
748a9306
LW		 1511 set_errno(EVMSERR);
1512 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1513 return -1;
1514 }
1515
1516 return rmsts;
1517
1518} /* end of kill_file() */
1519/*}}}*/
1520
8cc95fdb 1521
84902520 1522/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 1523int
b8ffc8df 1524Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 1525{
1526 STRLEN dirlen = strlen(dir);
1527
a2a90019
CB		 1528 /* zero length string sometimes gives ACCVIO */
1529 if (dirlen == 0) return -1;
1530
8cc95fdb 1531 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1532 * null file name/type. However, it's commonplace under Unix,
1533 * so we'll allow it for a gain in portability.
1534 */
1535 if (dir[dirlen-1] == '/') {
1536 char *newdir = savepvn(dir,dirlen-1);
1537 int ret = mkdir(newdir,mode);
1538 Safefree(newdir);
1539 return ret;
1540 }
1541 else return mkdir(dir,mode);
1542} /* end of my_mkdir */
1543/*}}}*/
1544
ee8c7f54
CB		 1545/*{{{int my_chdir(char *)*/
1546int
b8ffc8df 1547Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 1548{
1549 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 1550
1551 /* zero length string sometimes gives ACCVIO */
1552 if (dirlen == 0) return -1;
f7ddb74a
JM		 1553 const char *dir1;
1554
1555 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1556 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1557 * so that existing scripts do not need to be changed.
1558 */
1559 dir1 = dir;
1560 while ((dirlen > 0) && (*dir1 == ' ')) {
1561 dir1++;
1562 dirlen--;
1563 }
ee8c7f54
CB		 1564
1565 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1566 * that implies
1567 * null file name/type. However, it's commonplace under Unix,
1568 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 1569 *
1570 * - Preview- '/' will be valid soon on VMS
ee8c7f54 1571 */
f7ddb74a 1572 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
ee8c7f54
CB		 1573 char *newdir = savepvn(dir,dirlen-1);
1574 int ret = chdir(newdir);
1575 Safefree(newdir);
1576 return ret;
1577 }
1578 else return chdir(dir);
1579} /* end of my_chdir */
1580/*}}}*/
8cc95fdb 1581
674d6c38
CB		 1582
1583/*{{{FILE *my_tmpfile()*/
1584FILE *
1585my_tmpfile(void)
1586{
1587 FILE *fp;
1588 char *cp;
674d6c38
CB		 1589
1590 if ((fp = tmpfile())) return fp;
1591
a02a5408 1592 Newx(cp,L_tmpnam+24,char);
2497a41f
JM		 1593 if (decc_filename_unix_only == 0)
1594 strcpy(cp,"Sys$Scratch:");
1595 else
1596 strcpy(cp,"/tmp/");
674d6c38
CB		 1597 tmpnam(cp+strlen(cp));
1598 strcat(cp,".Perltmp");
1599 fp = fopen(cp,"w+","fop=dlt");
1600 Safefree(cp);
1601 return fp;
1602}
1603/*}}}*/
1604
5c2d7af2
CB		 1605
1606#ifndef HOMEGROWN_POSIX_SIGNALS
1607/*
1608 * The C RTL's sigaction fails to check for invalid signal numbers so we
1609 * help it out a bit. The docs are correct, but the actual routine doesn't
1610 * do what the docs say it will.
1611 */
1612/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1613int
1614Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1615 struct sigaction* oact)
1616{
1617 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1618 SETERRNO(EINVAL, SS$_INVARG);
1619 return -1;
1620 }
1621 return sigaction(sig, act, oact);
1622}
1623/*}}}*/
1624#endif
1625
f2610a60
CL		 1626#ifdef KILL_BY_SIGPRC
1627#include <errnodef.h>
1628
05c058bc
CB		 1629/* We implement our own kill() using the undocumented system service
1630 sys$sigprc for one of two reasons:
1631
1632 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 1633 target process to do a sys$exit, which usually can't be handled
1634 gracefully...certainly not by Perl and the %SIG{} mechanism.
1635
05c058bc
CB		 1636 2.) If the kill() in the CRTL can't be called from a signal
1637 handler without disappearing into the ether, i.e., the signal
1638 it purportedly sends is never trapped. Still true as of VMS 7.3.
1639
1640 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 1641 in the target process rather than calling sys$exit.
1642
1643 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1644 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1645 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1646 with condition codes C$_SIG0+nsig*8, catching the exception on the
1647 target process and resignaling with appropriate arguments.
1648
1649 But we don't have that VMS 7.0+ exception handler, so if you
1650 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1651
1652 Also note that SIGTERM is listed in the docs as being "unimplemented",
1653 yet always seems to be signaled with a VMS condition code of 4 (and
1654 correctly handled for that code). So we hardwire it in.
1655
1656 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1657 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1658 than signalling with an unrecognized (and unhandled by CRTL) code.
1659*/
1660
1661#define _MY_SIG_MAX 17
1662
2e34cc90
CL		 1663unsigned int
1664Perl_sig_to_vmscondition(int sig)
f2610a60 1665{
2e34cc90 1666 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 1667 {
1668 0, /* 0 ZERO */
1669 SS$_HANGUP, /* 1 SIGHUP */
1670 SS$_CONTROLC, /* 2 SIGINT */
1671 SS$_CONTROLY, /* 3 SIGQUIT */
1672 SS$_RADRMOD, /* 4 SIGILL */
1673 SS$_BREAK, /* 5 SIGTRAP */
1674 SS$_OPCCUS, /* 6 SIGABRT */
1675 SS$_COMPAT, /* 7 SIGEMT */
1676#ifdef __VAX
1677 SS$_FLTOVF, /* 8 SIGFPE VAX */
1678#else
1679 SS$_HPARITH, /* 8 SIGFPE AXP */
1680#endif
1681 SS$_ABORT, /* 9 SIGKILL */
1682 SS$_ACCVIO, /* 10 SIGBUS */
1683 SS$_ACCVIO, /* 11 SIGSEGV */
1684 SS$_BADPARAM, /* 12 SIGSYS */
1685 SS$_NOMBX, /* 13 SIGPIPE */
1686 SS$_ASTFLT, /* 14 SIGALRM */
1687 4, /* 15 SIGTERM */
1688 0, /* 16 SIGUSR1 */
1689 0 /* 17 SIGUSR2 */
1690 };
1691
1692#if __VMS_VER >= 60200000
1693 static int initted = 0;
1694 if (!initted) {
1695 initted = 1;
1696 sig_code[16] = C$_SIGUSR1;
1697 sig_code[17] = C$_SIGUSR2;
1698 }
1699#endif
1700
2e34cc90
CL		 1701 if (sig < _SIG_MIN) return 0;
1702 if (sig > _MY_SIG_MAX) return 0;
1703 return sig_code[sig];
1704}
1705
2e34cc90
CL		 1706int
1707Perl_my_kill(int pid, int sig)
1708{
218fdd94 1709 dTHX;
2e34cc90
CL		 1710 int iss;
1711 unsigned int code;
1712 int sys$sigprc(unsigned int *pidadr,
1713 struct dsc$descriptor_s *prcname,
1714 unsigned int code);
1715
7a7fd8e0
JM		 1716 /* sig 0 means validate the PID */
1717 /*------------------------------*/
1718 if (sig == 0) {
1719 const unsigned long int jpicode = JPI$_PID;
1720 pid_t ret_pid;
1721 int status;
1722 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1723 if ($VMS_STATUS_SUCCESS(status))
1724 return 0;
1725 switch (status) {
1726 case SS$_NOSUCHNODE:
1727 case SS$_UNREACHABLE:
1728 case SS$_NONEXPR:
1729 errno = ESRCH;
1730 break;
1731 case SS$_NOPRIV:
1732 errno = EPERM;
1733 break;
1734 default:
1735 errno = EVMSERR;
1736 }
1737 vaxc$errno=status;
1738 return -1;
1739 }
1740
2e34cc90
CL		 1741 code = Perl_sig_to_vmscondition(sig);
1742
7a7fd8e0
JM		 1743 if (!code) {
1744 SETERRNO(EINVAL, SS$_BADPARAM);
1745 return -1;
1746 }
1747
1748 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1749 * signals are to be sent to multiple processes.
1750 * pid = 0 - all processes in group except ones that the system exempts
1751 * pid = -1 - all processes except ones that the system exempts
1752 * pid = -n - all processes in group (abs(n)) except ...
1753 * For now, just report as not supported.
1754 */
1755
1756 if (pid <= 0) {
1757 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 1758 return -1;
1759 }
1760
2e34cc90 1761 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 1762 if (iss&1) return 0;
1763
1764 switch (iss) {
1765 case SS$_NOPRIV:
1766 set_errno(EPERM); break;
1767 case SS$_NONEXPR:
1768 case SS$_NOSUCHNODE:
1769 case SS$_UNREACHABLE:
1770 set_errno(ESRCH); break;
1771 case SS$_INSFMEM:
1772 set_errno(ENOMEM); break;
1773 default:
1774 _ckvmssts(iss);
1775 set_errno(EVMSERR);
1776 }
1777 set_vaxc_errno(iss);
1778
1779 return -1;
1780}
1781#endif
1782
2fbb330f
JM		 1783/* Routine to convert a VMS status code to a UNIX status code.
1784** More tricky than it appears because of conflicting conventions with
1785** existing code.
1786**
1787** VMS status codes are a bit mask, with the least significant bit set for
1788** success.
1789**
1790** Special UNIX status of EVMSERR indicates that no translation is currently
1791** available, and programs should check the VMS status code.
1792**
1793** Programs compiled with _POSIX_EXIT have a special encoding that requires
1794** decoding.
1795*/
1796
1797#ifndef C_FACILITY_NO
1798#define C_FACILITY_NO 0x350000
1799#endif
1800#ifndef DCL_IVVERB
1801#define DCL_IVVERB 0x38090
1802#endif
1803
7a7fd8e0 1804int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 1805{
1806int facility;
1807int fac_sp;
1808int msg_no;
1809int msg_status;
1810int unix_status;
1811
1812 /* Assume the best or the worst */
1813 if (vms_status & STS$M_SUCCESS)
1814 unix_status = 0;
1815 else
1816 unix_status = EVMSERR;
1817
1818 msg_status = vms_status & ~STS$M_CONTROL;
1819
1820 facility = vms_status & STS$M_FAC_NO;
1821 fac_sp = vms_status & STS$M_FAC_SP;
1822 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1823
0968cdad 1824 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 1825 switch(msg_no) {
1826 case SS$_NORMAL:
1827 unix_status = 0;
1828 break;
1829 case SS$_ACCVIO:
1830 unix_status = EFAULT;
1831 break;
7a7fd8e0
JM		 1832 case SS$_DEVOFFLINE:
1833 unix_status = EBUSY;
1834 break;
1835 case SS$_CLEARED:
1836 unix_status = ENOTCONN;
1837 break;
1838 case SS$_IVCHAN:
2fbb330f
JM		 1839 case SS$_IVLOGNAM:
1840 case SS$_BADPARAM:
1841 case SS$_IVLOGTAB:
1842 case SS$_NOLOGNAM:
1843 case SS$_NOLOGTAB:
1844 case SS$_INVFILFOROP:
1845 case SS$_INVARG:
1846 case SS$_NOSUCHID:
1847 case SS$_IVIDENT:
1848 unix_status = EINVAL;
1849 break;
7a7fd8e0
JM		 1850 case SS$_UNSUPPORTED:
1851 unix_status = ENOTSUP;
1852 break;
2fbb330f
JM		 1853 case SS$_FILACCERR:
1854 case SS$_NOGRPPRV:
1855 case SS$_NOSYSPRV:
1856 unix_status = EACCES;
1857 break;
1858 case SS$_DEVICEFULL:
1859 unix_status = ENOSPC;
1860 break;
1861 case SS$_NOSUCHDEV:
1862 unix_status = ENODEV;
1863 break;
1864 case SS$_NOSUCHFILE:
1865 case SS$_NOSUCHOBJECT:
1866 unix_status = ENOENT;
1867 break;
fb38d079
JM		 1868 case SS$_ABORT: /* Fatal case */
1869 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1870 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 1871 unix_status = EINTR;
1872 break;
1873 case SS$_BUFFEROVF:
1874 unix_status = E2BIG;
1875 break;
1876 case SS$_INSFMEM:
1877 unix_status = ENOMEM;
1878 break;
1879 case SS$_NOPRIV:
1880 unix_status = EPERM;
1881 break;
1882 case SS$_NOSUCHNODE:
1883 case SS$_UNREACHABLE:
1884 unix_status = ESRCH;
1885 break;
1886 case SS$_NONEXPR:
1887 unix_status = ECHILD;
1888 break;
1889 default:
1890 if ((facility == 0) && (msg_no < 8)) {
1891 /* These are not real VMS status codes so assume that they are
1892 ** already UNIX status codes
1893 */
1894 unix_status = msg_no;
1895 break;
1896 }
1897 }
1898 }
1899 else {
1900 /* Translate a POSIX exit code to a UNIX exit code */
1901 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 1902 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 1903 }
1904 else {
7a7fd8e0
JM		 1905
1906 /* Documented traditional behavior for handling VMS child exits */
1907 /*--------------------------------------------------------------*/
1908 if (child_flag != 0) {
1909
1910 /* Success / Informational return 0 */
1911 /*----------------------------------*/
1912 if (msg_no & STS$K_SUCCESS)
1913 return 0;
1914
1915 /* Warning returns 1 */
1916 /*-------------------*/
1917 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1918 return 1;
1919
1920 /* Everything else pass through the severity bits */
1921 /*------------------------------------------------*/
1922 return (msg_no & STS$M_SEVERITY);
1923 }
1924
1925 /* Normal VMS status to ERRNO mapping attempt */
1926 /*--------------------------------------------*/
2fbb330f
JM		 1927 switch(msg_status) {
1928 /* case RMS$_EOF: */ /* End of File */
1929 case RMS$_FNF: /* File Not Found */
1930 case RMS$_DNF: /* Dir Not Found */
1931 unix_status = ENOENT;
1932 break;
1933 case RMS$_RNF: /* Record Not Found */
1934 unix_status = ESRCH;
1935 break;
1936 case RMS$_DIR:
1937 unix_status = ENOTDIR;
1938 break;
1939 case RMS$_DEV:
1940 unix_status = ENODEV;
1941 break;
7a7fd8e0
JM		 1942 case RMS$_IFI:
1943 case RMS$_FAC:
1944 case RMS$_ISI:
1945 unix_status = EBADF;
1946 break;
1947 case RMS$_FEX:
1948 unix_status = EEXIST;
1949 break;
2fbb330f
JM		 1950 case RMS$_SYN:
1951 case RMS$_FNM:
1952 case LIB$_INVSTRDES:
1953 case LIB$_INVARG:
1954 case LIB$_NOSUCHSYM:
1955 case LIB$_INVSYMNAM:
1956 case DCL_IVVERB:
1957 unix_status = EINVAL;
1958 break;
1959 case CLI$_BUFOVF:
1960 case RMS$_RTB:
1961 case CLI$_TKNOVF:
1962 case CLI$_RSLOVF:
1963 unix_status = E2BIG;
1964 break;
1965 case RMS$_PRV: /* No privilege */
1966 case RMS$_ACC: /* ACP file access failed */
1967 case RMS$_WLK: /* Device write locked */
1968 unix_status = EACCES;
1969 break;
1970 /* case RMS$_NMF: */ /* No more files */
1971 }
1972 }
1973 }
1974
1975 return unix_status;
1976}
1977
7a7fd8e0
JM		 1978/* Try to guess at what VMS error status should go with a UNIX errno
1979 * value. This is hard to do as there could be many possible VMS
1980 * error statuses that caused the errno value to be set.
1981 */
1982
1983int Perl_unix_status_to_vms(int unix_status)
1984{
1985int test_unix_status;
1986
1987 /* Trivial cases first */
1988 /*---------------------*/
1989 if (unix_status == EVMSERR)
1990 return vaxc$errno;
1991
1992 /* Is vaxc$errno sane? */
1993 /*---------------------*/
1994 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1995 if (test_unix_status == unix_status)
1996 return vaxc$errno;
1997
1998 /* If way out of range, must be VMS code already */
1999 /*-----------------------------------------------*/
2000 if (unix_status > EVMSERR)
2001 return unix_status;
2002
2003 /* If out of range, punt */
2004 /*-----------------------*/
2005 if (unix_status > __ERRNO_MAX)
2006 return SS$_ABORT;
2007
2008
2009 /* Ok, now we have to do it the hard way. */
2010 /*----------------------------------------*/
2011 switch(unix_status) {
2012 case 0: return SS$_NORMAL;
2013 case EPERM: return SS$_NOPRIV;
2014 case ENOENT: return SS$_NOSUCHOBJECT;
2015 case ESRCH: return SS$_UNREACHABLE;
2016 case EINTR: return SS$_ABORT;
2017 /* case EIO: */
2018 /* case ENXIO: */
2019 case E2BIG: return SS$_BUFFEROVF;
2020 /* case ENOEXEC */
2021 case EBADF: return RMS$_IFI;
2022 case ECHILD: return SS$_NONEXPR;
2023 /* case EAGAIN */
2024 case ENOMEM: return SS$_INSFMEM;
2025 case EACCES: return SS$_FILACCERR;
2026 case EFAULT: return SS$_ACCVIO;
2027 /* case ENOTBLK */
0968cdad 2028 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2029 case EEXIST: return RMS$_FEX;
2030 /* case EXDEV */
2031 case ENODEV: return SS$_NOSUCHDEV;
2032 case ENOTDIR: return RMS$_DIR;
2033 /* case EISDIR */
2034 case EINVAL: return SS$_INVARG;
2035 /* case ENFILE */
2036 /* case EMFILE */
2037 /* case ENOTTY */
2038 /* case ETXTBSY */
2039 /* case EFBIG */
2040 case ENOSPC: return SS$_DEVICEFULL;
2041 case ESPIPE: return LIB$_INVARG;
2042 /* case EROFS: */
2043 /* case EMLINK: */
2044 /* case EPIPE: */
2045 /* case EDOM */
2046 case ERANGE: return LIB$_INVARG;
2047 /* case EWOULDBLOCK */
2048 /* case EINPROGRESS */
2049 /* case EALREADY */
2050 /* case ENOTSOCK */
2051 /* case EDESTADDRREQ */
2052 /* case EMSGSIZE */
2053 /* case EPROTOTYPE */
2054 /* case ENOPROTOOPT */
2055 /* case EPROTONOSUPPORT */
2056 /* case ESOCKTNOSUPPORT */
2057 /* case EOPNOTSUPP */
2058 /* case EPFNOSUPPORT */
2059 /* case EAFNOSUPPORT */
2060 /* case EADDRINUSE */
2061 /* case EADDRNOTAVAIL */
2062 /* case ENETDOWN */
2063 /* case ENETUNREACH */
2064 /* case ENETRESET */
2065 /* case ECONNABORTED */
2066 /* case ECONNRESET */
2067 /* case ENOBUFS */
2068 /* case EISCONN */
2069 case ENOTCONN: return SS$_CLEARED;
2070 /* case ESHUTDOWN */
2071 /* case ETOOMANYREFS */
2072 /* case ETIMEDOUT */
2073 /* case ECONNREFUSED */
2074 /* case ELOOP */
2075 /* case ENAMETOOLONG */
2076 /* case EHOSTDOWN */
2077 /* case EHOSTUNREACH */
2078 /* case ENOTEMPTY */
2079 /* case EPROCLIM */
2080 /* case EUSERS */
2081 /* case EDQUOT */
2082 /* case ENOMSG */
2083 /* case EIDRM */
2084 /* case EALIGN */
2085 /* case ESTALE */
2086 /* case EREMOTE */
2087 /* case ENOLCK */
2088 /* case ENOSYS */
2089 /* case EFTYPE */
2090 /* case ECANCELED */
2091 /* case EFAIL */
2092 /* case EINPROG */
2093 case ENOTSUP:
2094 return SS$_UNSUPPORTED;
2095 /* case EDEADLK */
2096 /* case ENWAIT */
2097 /* case EILSEQ */
2098 /* case EBADCAT */
2099 /* case EBADMSG */
2100 /* case EABANDONED */
2101 default:
2102 return SS$_ABORT; /* punt */
2103 }
2104
2105 return SS$_ABORT; /* Should not get here */
2106}
2fbb330f
JM		 2107
2108
22d4bb9c
CB		 2109/* default piping mailbox size */
2110#define PERL_BUFSIZ 512
2111
674d6c38 2112
a0d0e21e 2113static void
fd8cd3a3 2114create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2115{
22d4bb9c
CB		 2116 unsigned long int mbxbufsiz;
2117 static unsigned long int syssize = 0;
2118 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2119 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2120 int sts;
2121
22d4bb9c
CB		 2122 if (!syssize) {
2123 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2124 /*
22d4bb9c
CB		 2125 * Get the SYSGEN parameter MAXBUF
2126 *
2127 * If the logical 'PERL_MBX_SIZE' is defined
2128 * use the value of the logical instead of PERL_BUFSIZ, but
2129 * keep the size between 128 and MAXBUF.
2130 *
a0d0e21e 2131 */
22d4bb9c
CB		 2132 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2133 }
2134
2135 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2136 mbxbufsiz = atoi(csize);
2137 } else {
2138 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2139 }
22d4bb9c
CB		 2140 if (mbxbufsiz < 128) mbxbufsiz = 128;
2141 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2142
f7ddb74a 2143 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2144
f7ddb74a 2145 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 2146 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2147
2148} /* end of create_mbx() */
2149
22d4bb9c 2150
a0d0e21e 2151/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2152
2153typedef struct _iosb IOSB;
2154typedef struct _iosb* pIOSB;
2155typedef struct _pipe Pipe;
2156typedef struct _pipe* pPipe;
2157typedef struct pipe_details Info;
2158typedef struct pipe_details* pInfo;
2159typedef struct _srqp RQE;
2160typedef struct _srqp* pRQE;
2161typedef struct _tochildbuf CBuf;
2162typedef struct _tochildbuf* pCBuf;
2163
2164struct _iosb {
2165 unsigned short status;
2166 unsigned short count;
2167 unsigned long dvispec;
2168};
2169
2170#pragma member_alignment save
2171#pragma nomember_alignment quadword
2172struct _srqp { /* VMS self-relative queue entry */
2173 unsigned long qptr[2];
2174};
2175#pragma member_alignment restore
2176static RQE RQE_ZERO = {0,0};
2177
2178struct _tochildbuf {
2179 RQE q;
2180 int eof;
2181 unsigned short size;
2182 char *buf;
2183};
2184
2185struct _pipe {
2186 RQE free;
2187 RQE wait;
2188 int fd_out;
2189 unsigned short chan_in;
2190 unsigned short chan_out;
2191 char *buf;
2192 unsigned int bufsize;
2193 IOSB iosb;
2194 IOSB iosb2;
2195 int *pipe_done;
2196 int retry;
2197 int type;
2198 int shut_on_empty;
2199 int need_wake;
2200 pPipe *home;
2201 pInfo info;
2202 pCBuf curr;
2203 pCBuf curr2;
fd8cd3a3
DS		 2204#if defined(PERL_IMPLICIT_CONTEXT)
2205 void *thx; /* Either a thread or an interpreter */
2206 /* pointer, depending on how we're built */
2207#endif
22d4bb9c
CB		 2208};
2209
2210
a0d0e21e
LW		 2211struct pipe_details
2212{
22d4bb9c 2213 pInfo next;
ff7adb52
CL		 2214 PerlIO *fp; /* file pointer to pipe mailbox */
2215 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2216 int pid; /* PID of subprocess */
2217 int mode; /* == 'r' if pipe open for reading */
2218 int done; /* subprocess has completed */
ff7adb52 2219 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2220 int closing; /* my_pclose is closing this pipe */
2221 unsigned long completion; /* termination status of subprocess */
2222 pPipe in; /* pipe in to sub */
2223 pPipe out; /* pipe out of sub */
2224 pPipe err; /* pipe of sub's sys$error */
2225 int in_done; /* true when in pipe finished */
2226 int out_done;
2227 int err_done;
a0d0e21e
LW		 2228};
2229
748a9306
LW		 2230struct exit_control_block
2231{
2232 struct exit_control_block *flink;
2233 unsigned long int (*exit_routine)();
2234 unsigned long int arg_count;
2235 unsigned long int *status_address;
2236 unsigned long int exit_status;
2237};
2238
d85f548a
JH		 2239typedef struct _closed_pipes Xpipe;
2240typedef struct _closed_pipes* pXpipe;
2241
2242struct _closed_pipes {
2243 int pid; /* PID of subprocess */
2244 unsigned long completion; /* termination status of subprocess */
2245};
2246#define NKEEPCLOSED 50
2247static Xpipe closed_list[NKEEPCLOSED];
2248static int closed_index = 0;
2249static int closed_num = 0;
2250
22d4bb9c
CB		 2251#define RETRY_DELAY "0 ::0.20"
2252#define MAX_RETRY 50
a0d0e21e 2253
22d4bb9c
CB		 2254static int pipe_ef = 0; /* first call to safe_popen inits these*/
2255static unsigned long mypid;
2256static unsigned long delaytime[2];
2257
2258static pInfo open_pipes = NULL;
2259static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2260
ff7adb52
CL		 2261#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2262
2263
3eeba6fb 2264
748a9306 2265static unsigned long int
fd8cd3a3 2266pipe_exit_routine(pTHX)
748a9306 2267{
22d4bb9c 2268 pInfo info;
1e422769 2269 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2270 int sts, did_stuff, need_eof, j;
2271
2272 /*
2273 flush any pending i/o
2274 */
2275 info = open_pipes;
2276 while (info) {
2277 if (info->fp) {
2278 if (!info->useFILE)
2279 PerlIO_flush(info->fp); /* first, flush data */
2280 else
2281 fflush((FILE *)info->fp);
2282 }
2283 info = info->next;
2284 }
3eeba6fb
CB		 2285
2286 /*
ff7adb52 2287 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2288 don't hang
2289 */
2290 did_stuff = 0;
2291 info = open_pipes;
748a9306 2292
3eeba6fb 2293 while (info) {
b2b89246 2294 int need_eof;
d4c83939 2295 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2296 if (info->in && !info->in->shut_on_empty) {
d4c83939 2297 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
22d4bb9c 2298 0, 0, 0, 0, 0, 0));
ff7adb52 2299 info->waiting = 1;
22d4bb9c 2300 did_stuff = 1;
748a9306 2301 }
d4c83939 2302 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2303 info = info->next;
2304 }
ff7adb52
CL		 2305
2306 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2307
2308 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2309 int nwait = 0;
2310
2311 info = open_pipes;
2312 while (info) {
d4c83939 2313 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2314 if (info->waiting && info->done)
2315 info->waiting = 0;
2316 nwait += info->waiting;
d4c83939 2317 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2318 info = info->next;
2319 }
2320 if (!nwait) break;
2321 sleep(1);
2322 }
3eeba6fb
CB		 2323
2324 did_stuff = 0;
2325 info = open_pipes;
2326 while (info) {
d4c83939 2327 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2328 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2329 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2330 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2331 did_stuff = 1;
2332 }
d4c83939 2333 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2334 info = info->next;
2335 }
ff7adb52
CL		 2336
2337 /* again, wait for effect */
2338
2339 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2340 int nwait = 0;
2341
2342 info = open_pipes;
2343 while (info) {
d4c83939 2344 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2345 if (info->waiting && info->done)
2346 info->waiting = 0;
2347 nwait += info->waiting;
d4c83939 2348 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2349 info = info->next;
2350 }
2351 if (!nwait) break;
2352 sleep(1);
2353 }
3eeba6fb
CB		 2354
2355 info = open_pipes;
2356 while (info) {
d4c83939 2357 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2358 if (!info->done) { /* We tried to be nice . . . */
2359 sts = sys$delprc(&info->pid,0);
d4c83939 2360 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb 2361 }
d4c83939 2362 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2363 info = info->next;
2364 }
2365
2366 while(open_pipes) {
1e422769 2367 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2368 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 2369 }
2370 return retsts;
2371}
2372
2373static struct exit_control_block pipe_exitblock =
2374 {(struct exit_control_block *) 0,
2375 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2376
22d4bb9c
CB		 2377static void pipe_mbxtofd_ast(pPipe p);
2378static void pipe_tochild1_ast(pPipe p);
2379static void pipe_tochild2_ast(pPipe p);
748a9306 2380
a0d0e21e 2381static void
22d4bb9c 2382popen_completion_ast(pInfo info)
a0d0e21e 2383{
22d4bb9c
CB		 2384 pInfo i = open_pipes;
2385 int iss;
f7ddb74a 2386 int sts;
d85f548a
JH		 2387 pXpipe x;
2388
2389 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2390 closed_list[closed_index].pid = info->pid;
2391 closed_list[closed_index].completion = info->completion;
2392 closed_index++;
2393 if (closed_index == NKEEPCLOSED)
2394 closed_index = 0;
2395 closed_num++;
22d4bb9c
CB		 2396
2397 while (i) {
2398 if (i == info) break;
2399 i = i->next;
2400 }
2401 if (!i) return; /* unlinked, probably freed too */
2402
22d4bb9c
CB		 2403 info->done = TRUE;
2404
2405/*
2406 Writing to subprocess ...
2407 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2408
2409 chan_out may be waiting for "done" flag, or hung waiting
2410 for i/o completion to child...cancel the i/o. This will
2411 put it into "snarf mode" (done but no EOF yet) that discards
2412 input.
2413
2414 Output from subprocess (stdout, stderr) needs to be flushed and
2415 shut down. We try sending an EOF, but if the mbx is full the pipe
2416 routine should still catch the "shut_on_empty" flag, telling it to
2417 use immediate-style reads so that "mbx empty" -> EOF.
2418
2419
2420*/
2421 if (info->in && !info->in_done) { /* only for mode=w */
2422 if (info->in->shut_on_empty && info->in->need_wake) {
2423 info->in->need_wake = FALSE;
fd8cd3a3 2424 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 2425 } else {
fd8cd3a3 2426 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 2427 }
2428 }
2429
2430 if (info->out && !info->out_done) { /* were we also piping output? */
2431 info->out->shut_on_empty = TRUE;
2432 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2433 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 2434 _ckvmssts_noperl(iss);
22d4bb9c
CB		 2435 }
2436
2437 if (info->err && !info->err_done) { /* we were piping stderr */
2438 info->err->shut_on_empty = TRUE;
2439 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2440 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 2441 _ckvmssts_noperl(iss);
a0d0e21e 2442 }
fd8cd3a3 2443 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 2444
a0d0e21e
LW		 2445}
2446
2fbb330f 2447static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 2448static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 2449
22d4bb9c
CB		 2450/*
2451 we actually differ from vmstrnenv since we use this to
2452 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2453 are pointing to the same thing
2454*/
2455
2456static unsigned short
fd8cd3a3 2457popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 2458{
2459 int iss;
2460 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2461 $DESCRIPTOR(d_log,"");
2462 struct _il3 {
2463 unsigned short length;
2464 unsigned short code;
2465 char * buffer_addr;
2466 unsigned short *retlenaddr;
2467 } itmlst[2];
2468 unsigned short l, ifi;
2469
2470 d_log.dsc$a_pointer = logical;
2471 d_log.dsc$w_length = strlen(logical);
2472
2473 itmlst[0].code = LNM$_STRING;
2474 itmlst[0].length = 255;
2475 itmlst[0].buffer_addr = result;
2476 itmlst[0].retlenaddr = &l;
2477
2478 itmlst[1].code = 0;
2479 itmlst[1].length = 0;
2480 itmlst[1].buffer_addr = 0;
2481 itmlst[1].retlenaddr = 0;
2482
2483 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2484 if (iss == SS$_NOLOGNAM) {
2485 iss = SS$_NORMAL;
2486 l = 0;
2487 }
2488 if (!(iss&1)) lib$signal(iss);
2489 result[l] = '\0';
2490/*
2491 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2492 strip it off and return the ifi, if any
2493*/
2494 ifi = 0;
2495 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 2496 memmove(&ifi,result+2,2);
22d4bb9c
CB		 2497 strcpy(result,result+4);
2498 }
2499 return ifi; /* this is the RMS internal file id */
2500}
2501
22d4bb9c
CB		 2502static void pipe_infromchild_ast(pPipe p);
2503
2504/*
2505 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2506 inside an AST routine without worrying about reentrancy and which Perl
2507 memory allocator is being used.
2508
2509 We read data and queue up the buffers, then spit them out one at a
2510 time to the output mailbox when the output mailbox is ready for one.
2511
2512*/
2513#define INITIAL_TOCHILDQUEUE 2
2514
2515static pPipe
fd8cd3a3 2516pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2517{
22d4bb9c
CB		 2518 pPipe p;
2519 pCBuf b;
2520 char mbx1[64], mbx2[64];
2521 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2522 DSC$K_CLASS_S, mbx1},
2523 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2524 DSC$K_CLASS_S, mbx2};
2525 unsigned int dviitm = DVI$_DEVBUFSIZ;
2526 int j, n;
2527
d4c83939
CB		 2528 n = sizeof(Pipe);
2529 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 2530
fd8cd3a3
DS		 2531 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2532 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2533 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2534
2535 p->buf = 0;
2536 p->shut_on_empty = FALSE;
2537 p->need_wake = FALSE;
2538 p->type = 0;
2539 p->retry = 0;
2540 p->iosb.status = SS$_NORMAL;
2541 p->iosb2.status = SS$_NORMAL;
2542 p->free = RQE_ZERO;
2543 p->wait = RQE_ZERO;
2544 p->curr = 0;
2545 p->curr2 = 0;
2546 p->info = 0;
fd8cd3a3
DS		 2547#ifdef PERL_IMPLICIT_CONTEXT
2548 p->thx = aTHX;
2549#endif
22d4bb9c
CB		 2550
2551 n = sizeof(CBuf) + p->bufsize;
2552
2553 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2554 _ckvmssts(lib$get_vm(&n, &b));
2555 b->buf = (char *) b + sizeof(CBuf);
2556 _ckvmssts(lib$insqhi(b, &p->free));
2557 }
2558
2559 pipe_tochild2_ast(p);
2560 pipe_tochild1_ast(p);
2561 strcpy(wmbx, mbx1);
2562 strcpy(rmbx, mbx2);
2563 return p;
2564}
2565
2566/* reads the MBX Perl is writing, and queues */
2567
2568static void
2569pipe_tochild1_ast(pPipe p)
2570{
22d4bb9c
CB		 2571 pCBuf b = p->curr;
2572 int iss = p->iosb.status;
2573 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 2574 int sts;
fd8cd3a3
DS		 2575#ifdef PERL_IMPLICIT_CONTEXT
2576 pTHX = p->thx;
2577#endif
22d4bb9c
CB		 2578
2579 if (p->retry) {
2580 if (eof) {
2581 p->shut_on_empty = TRUE;
2582 b->eof = TRUE;
2583 _ckvmssts(sys$dassgn(p->chan_in));
2584 } else {
2585 _ckvmssts(iss);
2586 }
2587
2588 b->eof = eof;
2589 b->size = p->iosb.count;
f7ddb74a 2590 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 2591 if (p->need_wake) {
2592 p->need_wake = FALSE;
2593 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2594 }
2595 } else {
2596 p->retry = 1; /* initial call */
2597 }
2598
2599 if (eof) { /* flush the free queue, return when done */
2600 int n = sizeof(CBuf) + p->bufsize;
2601 while (1) {
2602 iss = lib$remqti(&p->free, &b);
2603 if (iss == LIB$_QUEWASEMP) return;
2604 _ckvmssts(iss);
2605 _ckvmssts(lib$free_vm(&n, &b));
2606 }
2607 }
2608
2609 iss = lib$remqti(&p->free, &b);
2610 if (iss == LIB$_QUEWASEMP) {
2611 int n = sizeof(CBuf) + p->bufsize;
2612 _ckvmssts(lib$get_vm(&n, &b));
2613 b->buf = (char *) b + sizeof(CBuf);
2614 } else {
2615 _ckvmssts(iss);
2616 }
2617
2618 p->curr = b;
2619 iss = sys$qio(0,p->chan_in,
2620 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2621 &p->iosb,
2622 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2623 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2624 _ckvmssts(iss);
2625}
2626
2627
2628/* writes queued buffers to output, waits for each to complete before
2629 doing the next */
2630
2631static void
2632pipe_tochild2_ast(pPipe p)
2633{
22d4bb9c
CB		 2634 pCBuf b = p->curr2;
2635 int iss = p->iosb2.status;
2636 int n = sizeof(CBuf) + p->bufsize;
2637 int done = (p->info && p->info->done) ||
2638 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 2639#if defined(PERL_IMPLICIT_CONTEXT)
2640 pTHX = p->thx;
2641#endif
22d4bb9c
CB		 2642
2643 do {
2644 if (p->type) { /* type=1 has old buffer, dispose */
2645 if (p->shut_on_empty) {
2646 _ckvmssts(lib$free_vm(&n, &b));
2647 } else {
2648 _ckvmssts(lib$insqhi(b, &p->free));
2649 }
2650 p->type = 0;
2651 }
2652
2653 iss = lib$remqti(&p->wait, &b);
2654 if (iss == LIB$_QUEWASEMP) {
2655 if (p->shut_on_empty) {
2656 if (done) {
2657 _ckvmssts(sys$dassgn(p->chan_out));
2658 *p->pipe_done = TRUE;
2659 _ckvmssts(sys$setef(pipe_ef));
2660 } else {
2661 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2662 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2663 }
2664 return;
2665 }
2666 p->need_wake = TRUE;
2667 return;
2668 }
2669 _ckvmssts(iss);
2670 p->type = 1;
2671 } while (done);
2672
2673
2674 p->curr2 = b;
2675 if (b->eof) {
2676 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2677 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2678 } else {
2679 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2680 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2681 }
2682
2683 return;
2684
2685}
2686
2687
2688static pPipe
fd8cd3a3 2689pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2690{
22d4bb9c
CB		 2691 pPipe p;
2692 char mbx1[64], mbx2[64];
2693 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2694 DSC$K_CLASS_S, mbx1},
2695 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2696 DSC$K_CLASS_S, mbx2};
2697 unsigned int dviitm = DVI$_DEVBUFSIZ;
2698
d4c83939
CB		 2699 int n = sizeof(Pipe);
2700 _ckvmssts(lib$get_vm(&n, &p));
fd8cd3a3
DS		 2701 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2702 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2703
2704 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 2705 n = p->bufsize * sizeof(char);
2706 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 2707 p->shut_on_empty = FALSE;
2708 p->info = 0;
2709 p->type = 0;
2710 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 2711#if defined(PERL_IMPLICIT_CONTEXT)
2712 p->thx = aTHX;
2713#endif
22d4bb9c
CB		 2714 pipe_infromchild_ast(p);
2715
2716 strcpy(wmbx, mbx1);
2717 strcpy(rmbx, mbx2);
2718 return p;
2719}
2720
2721static void
2722pipe_infromchild_ast(pPipe p)
2723{
22d4bb9c
CB		 2724 int iss = p->iosb.status;
2725 int eof = (iss == SS$_ENDOFFILE);
2726 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2727 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 2728#if defined(PERL_IMPLICIT_CONTEXT)
2729 pTHX = p->thx;
2730#endif
22d4bb9c
CB		 2731
2732 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2733 _ckvmssts(sys$dassgn(p->chan_out));
2734 p->chan_out = 0;
2735 }
2736
2737 /* read completed:
2738 input shutdown if EOF from self (done or shut_on_empty)
2739 output shutdown if closing flag set (my_pclose)
2740 send data/eof from child or eof from self
2741 otherwise, re-read (snarf of data from child)
2742 */
2743
2744 if (p->type == 1) {
2745 p->type = 0;
2746 if (myeof && p->chan_in) { /* input shutdown */
2747 _ckvmssts(sys$dassgn(p->chan_in));
2748 p->chan_in = 0;
2749 }
2750
2751 if (p->chan_out) {
2752 if (myeof || kideof) { /* pass EOF to parent */
2753 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2754 pipe_infromchild_ast, p,
2755 0, 0, 0, 0, 0, 0));
2756 return;
2757 } else if (eof) { /* eat EOF --- fall through to read*/
2758
2759 } else { /* transmit data */
2760 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2761 pipe_infromchild_ast,p,
2762 p->buf, p->iosb.count, 0, 0, 0, 0));
2763 return;
2764 }
2765 }
2766 }
2767
2768 /* everything shut? flag as done */
2769
2770 if (!p->chan_in && !p->chan_out) {
2771 *p->pipe_done = TRUE;
2772 _ckvmssts(sys$setef(pipe_ef));
2773 return;
2774 }
2775
2776 /* write completed (or read, if snarfing from child)
2777 if still have input active,
2778 queue read...immediate mode if shut_on_empty so we get EOF if empty
2779 otherwise,
2780 check if Perl reading, generate EOFs as needed
2781 */
2782
2783 if (p->type == 0) {
2784 p->type = 1;
2785 if (p->chan_in) {
2786 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2787 pipe_infromchild_ast,p,
2788 p->buf, p->bufsize, 0, 0, 0, 0);
2789 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2790 _ckvmssts(iss);
2791 } else { /* send EOFs for extra reads */
2792 p->iosb.status = SS$_ENDOFFILE;
2793 p->iosb.dvispec = 0;
2794 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2795 0, 0, 0,
2796 pipe_infromchild_ast, p, 0, 0, 0, 0));
2797 }
2798 }
2799}
2800
2801static pPipe
fd8cd3a3 2802pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 2803{
22d4bb9c
CB		 2804 pPipe p;
2805 char mbx[64];
2806 unsigned long dviitm = DVI$_DEVBUFSIZ;
2807 struct stat s;
2808 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2809 DSC$K_CLASS_S, mbx};
a480973c 2810 int n = sizeof(Pipe);
22d4bb9c
CB		 2811
2812 /* things like terminals and mbx's don't need this filter */
2813 if (fd && fstat(fd,&s) == 0) {
2814 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2815 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2816 DSC$K_CLASS_S, s.st_dev};
2817
2818 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2819 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2820 strcpy(out, s.st_dev);
2821 return 0;
2822 }
2823 }
2824
d4c83939 2825 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 2826 p->fd_out = dup(fd);
fd8cd3a3 2827 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 2828 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 2829 n = (p->bufsize+1) * sizeof(char);
2830 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 2831 p->shut_on_empty = FALSE;
2832 p->retry = 0;
2833 p->info = 0;
2834 strcpy(out, mbx);
2835
2836 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2837 pipe_mbxtofd_ast, p,
2838 p->buf, p->bufsize, 0, 0, 0, 0));
2839
2840 return p;
2841}
2842
2843static void
2844pipe_mbxtofd_ast(pPipe p)
2845{
22d4bb9c
CB		 2846 int iss = p->iosb.status;
2847 int done = p->info->done;
2848 int iss2;
2849 int eof = (iss == SS$_ENDOFFILE);
2850 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2851 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 2852#if defined(PERL_IMPLICIT_CONTEXT)
2853 pTHX = p->thx;
2854#endif
22d4bb9c
CB		 2855
2856 if (done && myeof) { /* end piping */
2857 close(p->fd_out);
2858 sys$dassgn(p->chan_in);
2859 *p->pipe_done = TRUE;
2860 _ckvmssts(sys$setef(pipe_ef));
2861 return;
2862 }
2863
2864 if (!err && !eof) { /* good data to send to file */
2865 p->buf[p->iosb.count] = '\n';
2866 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2867 if (iss2 < 0) {
2868 p->retry++;
2869 if (p->retry < MAX_RETRY) {
2870 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2871 return;
2872 }
2873 }
2874 p->retry = 0;
2875 } else if (err) {
2876 _ckvmssts(iss);
2877 }
2878
2879
2880 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2881 pipe_mbxtofd_ast, p,
2882 p->buf, p->bufsize, 0, 0, 0, 0);
2883 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2884 _ckvmssts(iss);
2885}
2886
2887
2888typedef struct _pipeloc PLOC;
2889typedef struct _pipeloc* pPLOC;
2890
2891struct _pipeloc {
2892 pPLOC next;
2893 char dir[NAM$C_MAXRSS+1];
2894};
2895static pPLOC head_PLOC = 0;
2896
5c0ae288 2897void
fd8cd3a3 2898free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 2899{
2900 pPLOC p, pnext;
ff7adb52 2901 pPLOC *pHead = (pPLOC *)head;
5c0ae288 2902
ff7adb52 2903 p = *pHead;
5c0ae288
CL		 2904 while (p) {
2905 pnext = p->next;
e0ef6b43 2906 PerlMem_free(p);
5c0ae288
CL		 2907 p = pnext;
2908 }
ff7adb52 2909 *pHead = 0;
5c0ae288 2910}
22d4bb9c
CB		 2911
2912static void
fd8cd3a3 2913store_pipelocs(pTHX)
22d4bb9c
CB		 2914{
2915 int i;
2916 pPLOC p;
ff7adb52 2917 AV *av = 0;
22d4bb9c
CB		 2918 SV *dirsv;
2919 GV *gv;
2920 char *dir, *x;
2921 char *unixdir;
2922 char temp[NAM$C_MAXRSS+1];
2923 STRLEN n_a;
2924
ff7adb52 2925 if (head_PLOC)
218fdd94 2926 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 2927
22d4bb9c
CB		 2928/* the . directory from @INC comes last */
2929
e0ef6b43 2930 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 2931 p->next = head_PLOC;
2932 head_PLOC = p;
2933 strcpy(p->dir,"./");
2934
2935/* get the directory from $^X */
2936
218fdd94
CL		 2937#ifdef PERL_IMPLICIT_CONTEXT
2938 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2939#else
22d4bb9c 2940 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 2941#endif
22d4bb9c
CB		 2942 strcpy(temp, PL_origargv[0]);
2943 x = strrchr(temp,']');
2497a41f
JM		 2944 if (x == NULL) {
2945 x = strrchr(temp,'>');
2946 if (x == NULL) {
2947 /* It could be a UNIX path */
2948 x = strrchr(temp,'/');
2949 }
2950 }
2951 if (x)
2952 x[1] = '\0';
2953 else {
2954 /* Got a bare name, so use default directory */
2955 temp[0] = '.';
2956 temp[1] = '\0';
2957 }
22d4bb9c
CB		 2958
2959 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
e0ef6b43 2960 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 2961 p->next = head_PLOC;
2962 head_PLOC = p;
2963 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2964 p->dir[NAM$C_MAXRSS] = '\0';
2965 }
2966 }
2967
2968/* reverse order of @INC entries, skip "." since entered above */
2969
218fdd94
CL		 2970#ifdef PERL_IMPLICIT_CONTEXT
2971 if (aTHX)
2972#endif
ff7adb52
CL		 2973 if (PL_incgv) av = GvAVn(PL_incgv);
2974
2975 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 2976 dirsv = *av_fetch(av,i,TRUE);
2977
2978 if (SvROK(dirsv)) continue;
2979 dir = SvPVx(dirsv,n_a);
2980 if (strcmp(dir,".") == 0) continue;
2981 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2982 continue;
2983
e0ef6b43 2984 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 2985 p->next = head_PLOC;
2986 head_PLOC = p;
2987 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2988 p->dir[NAM$C_MAXRSS] = '\0';
2989 }
2990
2991/* most likely spot (ARCHLIB) put first in the list */
2992
2993#ifdef ARCHLIB_EXP
2994 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
e0ef6b43 2995 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 2996 p->next = head_PLOC;
2997 head_PLOC = p;
2998 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2999 p->dir[NAM$C_MAXRSS] = '\0';
3000 }
3001#endif
22d4bb9c
CB		 3002}
3003
3004
3005static char *
fd8cd3a3 3006find_vmspipe(pTHX)
22d4bb9c
CB		 3007{
3008 static int vmspipe_file_status = 0;
3009 static char vmspipe_file[NAM$C_MAXRSS+1];
3010
3011 /* already found? Check and use ... need read+execute permission */
3012
3013 if (vmspipe_file_status == 1) {
3014 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3015 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3016 return vmspipe_file;
3017 }
3018 vmspipe_file_status = 0;
3019 }
3020
3021 /* scan through stored @INC, $^X */
3022
3023 if (vmspipe_file_status == 0) {
3024 char file[NAM$C_MAXRSS+1];
3025 pPLOC p = head_PLOC;
3026
3027 while (p) {
3028 strcpy(file, p->dir);
3029 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3030 file[NAM$C_MAXRSS] = '\0';
3031 p = p->next;
3032
3033 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3034
3035 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3036 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3037 vmspipe_file_status = 1;
3038 return vmspipe_file;
3039 }
3040 }
3041 vmspipe_file_status = -1; /* failed, use tempfiles */
3042 }
3043
3044 return 0;
3045}
3046
3047static FILE *
fd8cd3a3 3048vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3049{
3050 char file[NAM$C_MAXRSS+1];
3051 FILE *fp;
3052 static int index = 0;
2497a41f
JM		 3053 Stat_t s0, s1;
3054 int cmp_result;
22d4bb9c
CB		 3055
3056 /* create a tempfile */
3057
3058 /* we can't go from W, shr=get to R, shr=get without
3059 an intermediate vulnerable state, so don't bother trying...
3060
3061 and lib$spawn doesn't shr=put, so have to close the write
3062
3063 So... match up the creation date/time and the FID to
3064 make sure we're dealing with the same file
3065
3066 */
3067
3068 index++;
2497a41f
JM		 3069 if (!decc_filename_unix_only) {
3070 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3071 fp = fopen(file,"w");
3072 if (!fp) {
22d4bb9c
CB		 3073 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3074 fp = fopen(file,"w");
3075 if (!fp) {
3076 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3077 fp = fopen(file,"w");
2497a41f
JM		 3078 }
3079 }
3080 }
3081 else {
3082 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3083 fp = fopen(file,"w");
3084 if (!fp) {
3085 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3086 fp = fopen(file,"w");
3087 if (!fp) {
3088 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3089 fp = fopen(file,"w");
3090 }
3091 }
22d4bb9c
CB		 3092 }
3093 if (!fp) return 0; /* we're hosed */
3094
f9ecfa39 3095 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3096 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3097 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3098 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3099 fprintf(fp,"$ perl_on = \"set noon\"\n");
3100 fprintf(fp,"$ perl_exit = \"exit\"\n");
3101 fprintf(fp,"$ perl_del = \"delete\"\n");
3102 fprintf(fp,"$ pif = \"if\"\n");
3103 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3104 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3105 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3106 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3107 fprintf(fp,"$! --- build command line to get max possible length\n");
3108 fprintf(fp,"$c=perl_popen_cmd0\n");
3109 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3110 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3111 fprintf(fp,"$x=perl_popen_cmd3\n");
3112 fprintf(fp,"$c=c+x\n");
22d4bb9c 3113 fprintf(fp,"$ perl_on\n");
f9ecfa39 3114 fprintf(fp,"$ 'c'\n");
22d4bb9c 3115 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3116 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3117 fprintf(fp,"$ perl_exit 'perl_status'\n");
3118 fsync(fileno(fp));
3119
3120 fgetname(fp, file, 1);
2497a41f 3121 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3122 fclose(fp);
3123
2497a41f
JM		 3124 if (decc_filename_unix_only)
3125 do_tounixspec(file, file, 0);
22d4bb9c
CB		 3126 fp = fopen(file,"r","shr=get");
3127 if (!fp) return 0;
2497a41f
JM		 3128 fstat(fileno(fp), (struct stat *)&s1);
3129
682e4b71 3130 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3131 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3132 fclose(fp);
3133 return 0;
3134 }
3135
3136 return fp;
3137}
3138
3139
3140
8fde5078 3141static PerlIO *
2fbb330f 3142safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 3143{
748a9306 3144 static int handler_set_up = FALSE;
55f2b99c 3145 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 3146 /* The use of a GLOBAL table (as was done previously) rendered
3147 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3148 * environment. Hence we've switched to LOCAL symbol table.
3149 */
3150 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 3151 int j, wait = 0, n;
ff7adb52 3152 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
22d4bb9c
CB		 3153 char in[512], out[512], err[512], mbx[512];
3154 FILE *tpipe = 0;
3155 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 3156 pInfo info = NULL;
48b5a746 3157 char cmd_sym_name[20];
22d4bb9c
CB		 3158 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3159 DSC$K_CLASS_S, symbol};
22d4bb9c 3160 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 3161 DSC$K_CLASS_S, 0};
48b5a746
CL		 3162 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3163 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 3164 struct dsc$descriptor_s *vmscmd;
22d4bb9c 3165 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 3166 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 3167 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 3168
afd8f436
JH		 3169 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3170
22d4bb9c
CB		 3171 /* once-per-program initialization...
3172 note that the SETAST calls and the dual test of pipe_ef
3173 makes sure that only the FIRST thread through here does
3174 the initialization...all other threads wait until it's
3175 done.
3176
3177 Yeah, uglier than a pthread call, it's got all the stuff inline
3178 rather than in a separate routine.
3179 */
3180
3181 if (!pipe_ef) {
3182 _ckvmssts(sys$setast(0));
3183 if (!pipe_ef) {
3184 unsigned long int pidcode = JPI$_PID;
3185 $DESCRIPTOR(d_delay, RETRY_DELAY);
3186 _ckvmssts(lib$get_ef(&pipe_ef));
3187 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3188 _ckvmssts(sys$bintim(&d_delay, delaytime));
3189 }
3190 if (!handler_set_up) {
3191 _ckvmssts(sys$dclexh(&pipe_exitblock));
3192 handler_set_up = TRUE;
3193 }
3194 _ckvmssts(sys$setast(1));
3195 }
3196
3197 /* see if we can find a VMSPIPE.COM */
3198
3199 tfilebuf[0] = '@';
fd8cd3a3 3200 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 3201 if (vmspipe) {
3202 strcpy(tfilebuf+1,vmspipe);
3203 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 3204 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 3205 if (!tpipe) { /* a fish popular in Boston */
3206 if (ckWARN(WARN_PIPE)) {
f98bc0c6 3207 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB		 3208 }
3209 return Nullfp;
3210 }
3211 fgetname(tpipe,tfilebuf+1,1);
3212 }
3213 vmspipedsc.dsc$a_pointer = tfilebuf;
3214 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 3215
218fdd94 3216 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 3217 if (!(sts & 1)) {
3218 switch (sts) {
3219 case RMS$_FNF: case RMS$_DNF:
3220 set_errno(ENOENT); break;
3221 case RMS$_DIR:
3222 set_errno(ENOTDIR); break;
3223 case RMS$_DEV:
3224 set_errno(ENODEV); break;
3225 case RMS$_PRV:
3226 set_errno(EACCES); break;
3227 case RMS$_SYN:
3228 set_errno(EINVAL); break;
3229 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3230 set_errno(E2BIG); break;
3231 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3232 _ckvmssts(sts); /* fall through */
3233 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3234 set_errno(EVMSERR);
3235 }
3236 set_vaxc_errno(sts);
ff7adb52 3237 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 3238 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 3239 }
ff7adb52 3240 *psts = sts;
a2669cfc
JH		 3241 return Nullfp;
3242 }
d4c83939
CB		 3243 n = sizeof(Info);
3244 _ckvmssts(lib$get_vm(&n, &info));
22d4bb9c 3245
ff7adb52 3246 strcpy(mode,in_mode);
22d4bb9c
CB		 3247 info->mode = *mode;
3248 info->done = FALSE;
3249 info->completion = 0;
3250 info->closing = FALSE;
3251 info->in = 0;
3252 info->out = 0;
3253 info->err = 0;
ff7adb52
CL		 3254 info->fp = Nullfp;
3255 info->useFILE = 0;
3256 info->waiting = 0;
22d4bb9c
CB		 3257 info->in_done = TRUE;
3258 info->out_done = TRUE;
3259 info->err_done = TRUE;
0e06870b 3260 in[0] = out[0] = err[0] = '\0';
22d4bb9c 3261
ff7adb52
CL		 3262 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3263 info->useFILE = 1;
3264 strcpy(p,p+1);
3265 }
3266 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3267 wait = 1;
3268 strcpy(p,p+1);
3269 }
3270
22d4bb9c 3271 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 3272
fd8cd3a3 3273 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 3274 if (info->out) {
3275 info->out->pipe_done = &info->out_done;
3276 info->out_done = FALSE;
3277 info->out->info = info;
3278 }
ff7adb52 3279 if (!info->useFILE) {
22d4bb9c 3280 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 3281 } else {
3282 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3283 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3284 }
3285
22d4bb9c
CB		 3286 if (!info->fp && info->out) {
3287 sys$cancel(info->out->chan_out);
3288
3289 while (!info->out_done) {
3290 int done;
3291 _ckvmssts(sys$setast(0));
3292 done = info->out_done;
3293 if (!done) _ckvmssts(sys$clref(pipe_ef));
3294 _ckvmssts(sys$setast(1));
3295 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 3296 }
22d4bb9c 3297
d4c83939
CB		 3298 if (info->out->buf) {
3299 n = info->out->bufsize * sizeof(char);
3300 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3301 }
3302 n = sizeof(Pipe);
3303 _ckvmssts(lib$free_vm(&n, &info->out));
3304 n = sizeof(Info);
3305 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 3306 *psts = RMS$_FNF;
22d4bb9c 3307 return Nullfp;
0e06870b 3308 }
22d4bb9c 3309
fd8cd3a3 3310 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 3311 if (info->err) {
3312 info->err->pipe_done = &info->err_done;
3313 info->err_done = FALSE;
3314 info->err->info = info;
3315 }
a0d0e21e 3316
ff7adb52
CL		 3317 } else if (*mode == 'w') { /* piping to subroutine */
3318
3319 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3320 if (info->out) {
3321 info->out->pipe_done = &info->out_done;
3322 info->out_done = FALSE;
3323 info->out->info = info;
3324 }
3325
3326 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3327 if (info->err) {
3328 info->err->pipe_done = &info->err_done;
3329 info->err_done = FALSE;
3330 info->err->info = info;
3331 }
a0d0e21e 3332
fd8cd3a3 3333 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 3334 if (!info->useFILE) {
a480973c 3335 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 3336 } else {
3337 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3338 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3339 }
3340
22d4bb9c
CB		 3341 if (info->in) {
3342 info->in->pipe_done = &info->in_done;
3343 info->in_done = FALSE;
3344 info->in->info = info;
3345 }
a0d0e21e 3346
22d4bb9c
CB		 3347 /* error cleanup */
3348 if (!info->fp && info->in) {
3349 info->done = TRUE;
3350 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3351 0, 0, 0, 0, 0, 0, 0, 0));
3352
3353 while (!info->in_done) {
3354 int done;
3355 _ckvmssts(sys$setast(0));
3356 done = info->in_done;
3357 if (!done) _ckvmssts(sys$clref(pipe_ef));
3358 _ckvmssts(sys$setast(1));
3359 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3360 }
a0d0e21e 3361
d4c83939
CB		 3362 if (info->in->buf) {
3363 n = info->in->bufsize * sizeof(char);
3364 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3365 }
3366 n = sizeof(Pipe);
3367 _ckvmssts(lib$free_vm(&n, &info->in));
3368 n = sizeof(Info);
3369 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 3370 *psts = RMS$_FNF;
0e06870b 3371 return Nullfp;
22d4bb9c 3372 }
a0d0e21e 3373
22d4bb9c 3374
ff7adb52 3375 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 3376 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 3377 if (info->out) {
3378 info->out->pipe_done = &info->out_done;
3379 info->out_done = FALSE;
3380 info->out->info = info;
3381 }
0e06870b 3382
fd8cd3a3 3383 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 3384 if (info->err) {
3385 info->err->pipe_done = &info->err_done;
3386 info->err_done = FALSE;
3387 info->err->info = info;
3388 }
748a9306 3389 }
22d4bb9c
CB		 3390
3391 symbol[MAX_DCL_SYMBOL] = '\0';
3392
3393 strncpy(symbol, in, MAX_DCL_SYMBOL);
3394 d_symbol.dsc$w_length = strlen(symbol);
3395 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3396
3397 strncpy(symbol, err, MAX_DCL_SYMBOL);
3398 d_symbol.dsc$w_length = strlen(symbol);
3399 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3400
0e06870b
CB		 3401 strncpy(symbol, out, MAX_DCL_SYMBOL);
3402 d_symbol.dsc$w_length = strlen(symbol);
3403 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 3404
218fdd94 3405 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 3406 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3407 if (*p == '$') p++; /* remove leading $ */
3408 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 3409
3410 for (j = 0; j < 4; j++) {
3411 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3412 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3413
22d4bb9c
CB		 3414 strncpy(symbol, p, MAX_DCL_SYMBOL);
3415 d_symbol.dsc$w_length = strlen(symbol);
3416 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3417
48b5a746
CL		 3418 if (strlen(p) > MAX_DCL_SYMBOL) {
3419 p += MAX_DCL_SYMBOL;
3420 } else {
3421 p += strlen(p);
3422 }
3423 }
22d4bb9c 3424 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 3425 info->next=open_pipes; /* prepend to list */
3426 open_pipes=info;
22d4bb9c 3427 _ckvmssts(sys$setast(1));
55f2b99c
CB		 3428 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3429 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3430 * have SYS$COMMAND if we need it.
3431 */
3432 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 3433 0, &info->pid, &info->completion,
3434 0, popen_completion_ast,info,0,0,0));
3435
3436 /* if we were using a tempfile, close it now */
3437
3438 if (tpipe) fclose(tpipe);
3439
ff7adb52 3440 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 3441 we can get rid of ours */
3442
48b5a746
CL		 3443 for (j = 0; j < 4; j++) {
3444 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3445 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 3446 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 3447 }
22d4bb9c
CB		 3448 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3449 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 3450 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 3451 vms_execfree(vmscmd);
a0d0e21e 3452
218fdd94
CL		 3453#ifdef PERL_IMPLICIT_CONTEXT
3454 if (aTHX)
3455#endif
6b88bc9c 3456 PL_forkprocess = info->pid;
218fdd94 3457
ff7adb52
CL		 3458 if (wait) {
3459 int done = 0;
3460 while (!done) {
3461 _ckvmssts(sys$setast(0));
3462 done = info->done;
3463 if (!done) _ckvmssts(sys$clref(pipe_ef));
3464 _ckvmssts(sys$setast(1));
3465 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3466 }
3467 *psts = info->completion;
2fbb330f
JM		 3468/* Caller thinks it is open and tries to close it. */
3469/* This causes some problems, as it changes the error status */
3470/* my_pclose(info->fp); */
ff7adb52
CL		 3471 } else {
3472 *psts = SS$_NORMAL;
3473 }
a0d0e21e 3474 return info->fp;
1e422769 3475} /* end of safe_popen */
3476
3477
a15cef0c
CB		 3478/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3479PerlIO *
2fbb330f 3480Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 3481{
ff7adb52 3482 int sts;
1e422769 3483 TAINT_ENV();
3484 TAINT_PROPER("popen");
45bc9206 3485 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 3486 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 3487}
1e422769 3488
a0d0e21e
LW		 3489/*}}}*/
3490
a15cef0c
CB		 3491/*{{{ I32 my_pclose(PerlIO *fp)*/
3492I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 3493{
22d4bb9c 3494 pInfo info, last = NULL;
748a9306 3495 unsigned long int retsts;
d4c83939 3496 int done, iss, n;
a0d0e21e
LW		 3497
3498 for (info = open_pipes; info != NULL; last = info, info = info->next)
3499 if (info->fp == fp) break;
3500
1e422769 3501 if (info == NULL) { /* no such pipe open */
3502 set_errno(ECHILD); /* quoth POSIX */
3503 set_vaxc_errno(SS$_NONEXPR);
3504 return -1;
3505 }
748a9306 3506
bbce6d69 3507 /* If we were writing to a subprocess, insure that someone reading from
3508 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 3509 * produce an EOF record in the mailbox.
3510 *
3511 * well, at least sometimes it *does*, so we have to watch out for
3512 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3513 */
ff7adb52
CL		 3514 if (info->fp) {
3515 if (!info->useFILE)
d4c83939 3516 PerlIO_flush(info->fp); /* first, flush data */
ff7adb52
CL		 3517 else
3518 fflush((FILE *)info->fp);
3519 }
22d4bb9c 3520
b08af3f0 3521 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 3522 info->closing = TRUE;
3523 done = info->done && info->in_done && info->out_done && info->err_done;
3524 /* hanging on write to Perl's input? cancel it */
3525 if (info->mode == 'r' && info->out && !info->out_done) {
3526 if (info->out->chan_out) {
3527 _ckvmssts(sys$cancel(info->out->chan_out));
3528 if (!info->out->chan_in) { /* EOF generation, need AST */
3529 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3530 }
3531 }
3532 }
3533 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3534 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3535 0, 0, 0, 0, 0, 0));
b08af3f0 3536 _ckvmssts(sys$setast(1));
ff7adb52
CL		 3537 if (info->fp) {
3538 if (!info->useFILE)
d4c83939 3539 PerlIO_close(info->fp);
ff7adb52
CL		 3540 else
3541 fclose((FILE *)info->fp);
3542 }
22d4bb9c
CB		 3543 /*
3544 we have to wait until subprocess completes, but ALSO wait until all
3545 the i/o completes...otherwise we'll be freeing the "info" structure
3546 that the i/o ASTs could still be using...
3547 */
3548
3549 while (!done) {
3550 _ckvmssts(sys$setast(0));
3551 done = info->done && info->in_done && info->out_done && info->err_done;
3552 if (!done) _ckvmssts(sys$clref(pipe_ef));
3553 _ckvmssts(sys$setast(1));
3554 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3555 }
3556 retsts = info->completion;
a0d0e21e 3557
a0d0e21e 3558 /* remove from list of open pipes */
b08af3f0 3559 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 3560 if (last) last->next = info->next;
3561 else open_pipes = info->next;
b08af3f0 3562 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 3563
3564 /* free buffers and structures */
3565
3566 if (info->in) {
d4c83939
CB		 3567 if (info->in->buf) {
3568 n = info->in->bufsize * sizeof(char);
3569 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3570 }
3571 n = sizeof(Pipe);
3572 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 3573 }
3574 if (info->out) {
d4c83939
CB		 3575 if (info->out->buf) {
3576 n = info->out->bufsize * sizeof(char);
3577 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3578 }
3579 n = sizeof(Pipe);
3580 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 3581 }
3582 if (info->err) {
d4c83939
CB		 3583 if (info->err->buf) {
3584 n = info->err->bufsize * sizeof(char);
3585 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3586 }
3587 n = sizeof(Pipe);
3588 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 3589 }
d4c83939
CB		 3590 n = sizeof(Info);
3591 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 3592
3593 return retsts;
748a9306 3594
a0d0e21e
LW		 3595} /* end of my_pclose() */
3596
119586db 3597#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 3598 /* Roll our own prototype because we want this regardless of whether
3599 * _VMS_WAIT is defined.
3600 */
3601 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3602#endif
3603/* sort-of waitpid; special handling of pipe clean-up for subprocesses
3604 created with popen(); otherwise partially emulate waitpid() unless
3605 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3606 Also check processes not considered by the CRTL waitpid().
3607 */
4fdae800 3608/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3609Pid_t
fd8cd3a3 3610Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 3611{
22d4bb9c
CB		 3612 pInfo info;
3613 int done;
aeb5cf3c 3614 int sts;
d85f548a 3615 int j;
aeb5cf3c
CB		 3616
3617 if (statusp) *statusp = 0;
a0d0e21e
LW		 3618
3619 for (info = open_pipes; info != NULL; info = info->next)
3620 if (info->pid == pid) break;
3621
3622 if (info != NULL) { /* we know about this child */
748a9306 3623 while (!info->done) {
22d4bb9c
CB		 3624 _ckvmssts(sys$setast(0));
3625 done = info->done;
3626 if (!done) _ckvmssts(sys$clref(pipe_ef));
3627 _ckvmssts(sys$setast(1));
3628 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 3629 }
3630
aeb5cf3c 3631 if (statusp) *statusp = info->completion;
a0d0e21e 3632 return pid;
d85f548a
JH		 3633 }
3634
3635 /* child that already terminated? */
aeb5cf3c 3636
d85f548a
JH		 3637 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3638 if (closed_list[j].pid == pid) {
3639 if (statusp) *statusp = closed_list[j].completion;
3640 return pid;
3641 }
a0d0e21e 3642 }
d85f548a
JH		 3643
3644 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 3645
119586db 3646#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 3647
3648 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3649 * in 7.2 did we get a version that fills in the VMS completion
3650 * status as Perl has always tried to do.
3651 */
3652
3653 sts = __vms_waitpid( pid, statusp, flags );
3654
3655 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3656 return sts;
3657
3658 /* If the real waitpid tells us the child does not exist, we
3659 * fall through here to implement waiting for a child that
3660 * was created by some means other than exec() (say, spawned
3661 * from DCL) or to wait for a process that is not a subprocess
3662 * of the current process.
3663 */
3664
119586db 3665#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 3666
21bc9d50 3667 {
a0d0e21e 3668 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 3669 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3670 unsigned long int pidcode = JPI$_PID, mypid;
3671 unsigned long int interval[2];
aeb5cf3c 3672 unsigned int jpi_iosb[2];
d85f548a 3673 struct itmlst_3 jpilist[2] = {
aeb5cf3c 3674 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 3675 { 0, 0, 0, 0}
3676 };
aeb5cf3c
CB		 3677
3678 if (pid <= 0) {
3679 /* Sorry folks, we don't presently implement rooting around for
3680 the first child we can find, and we definitely don't want to
3681 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3682 */
3683 set_errno(ENOTSUP);
3684 return -1;
3685 }
3686
d85f548a
JH		 3687 /* Get the owner of the child so I can warn if it's not mine. If the
3688 * process doesn't exist or I don't have the privs to look at it,
3689 * I can go home early.
aeb5cf3c
CB		 3690 */
3691 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3692 if (sts & 1) sts = jpi_iosb[0];
3693 if (!(sts & 1)) {
3694 switch (sts) {
3695 case SS$_NONEXPR:
3696 set_errno(ECHILD);
3697 break;
3698 case SS$_NOPRIV:
3699 set_errno(EACCES);
3700 break;
3701 default:
3702 _ckvmssts(sts);
3703 }
3704 set_vaxc_errno(sts);
3705 return -1;
3706 }
a0d0e21e 3707
3eeba6fb 3708 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 3709 /* remind folks they are asking for non-standard waitpid behavior */
3710 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 3711 if (ownerpid != mypid)
f98bc0c6 3712 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 3713 "waitpid: process %x is not a child of process %x",
3714 pid,mypid);
748a9306 3715 }
a0d0e21e 3716
d85f548a
JH		 3717 /* simply check on it once a second until it's not there anymore. */
3718
3719 _ckvmssts(sys$bintim(&intdsc,interval));
3720 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 3721 _ckvmssts(sys$schdwk(0,0,interval,0));
3722 _ckvmssts(sys$hiber());
d85f548a
JH		 3723 }
3724 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 3725
3726 _ckvmssts(sts);
a0d0e21e 3727 return pid;
21bc9d50 3728 }
a0d0e21e 3729} /* end of waitpid() */
a0d0e21e
LW		 3730/*}}}*/
3731/*}}}*/
3732/*}}}*/
3733
3734/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3735char *
3736my_gconvert(double val, int ndig, int trail, char *buf)
3737{
3738 static char __gcvtbuf[DBL_DIG+1];
3739 char *loc;
3740
3741 loc = buf ? buf : __gcvtbuf;
71be2cbc 3742
3743#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3744 if (val < 1) {
3745 sprintf(loc,"%.*g",ndig,val);
3746 return loc;
3747 }
3748#endif
3749
a0d0e21e
LW		 3750 if (val) {
3751 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3752 return gcvt(val,ndig,loc);
3753 }
3754 else {
3755 loc[0] = '0'; loc[1] = '\0';
3756 return loc;
3757 }
3758
3759}
3760/*}}}*/
3761
a480973c
JM		 3762#if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3763static int rms_free_search_context(struct FAB * fab)
3764{
3765struct NAM * nam;
3766
3767 nam = fab->fab$l_nam;
3768 nam->nam$b_nop |= NAM$M_SYNCHK;
3769 nam->nam$l_rlf = NULL;
3770 fab->fab$b_dns = 0;
3771 return sys$parse(fab, NULL, NULL);
3772}
3773
3774#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3775#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3776#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3777#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3778#define rms_nam_esll(nam) nam.nam$b_esl
3779#define rms_nam_esl(nam) nam.nam$b_esl
3780#define rms_nam_name(nam) nam.nam$l_name
3781#define rms_nam_namel(nam) nam.nam$l_name
3782#define rms_nam_type(nam) nam.nam$l_type
3783#define rms_nam_typel(nam) nam.nam$l_type
3784#define rms_nam_ver(nam) nam.nam$l_ver
3785#define rms_nam_verl(nam) nam.nam$l_ver
3786#define rms_nam_rsll(nam) nam.nam$b_rsl
3787#define rms_nam_rsl(nam) nam.nam$b_rsl
3788#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3789#define rms_set_fna(fab, nam, name, size) \
3790 fab.fab$b_fns = size; fab.fab$l_fna = name;
3791#define rms_get_fna(fab, nam) fab.fab$l_fna
3792#define rms_set_dna(fab, nam, name, size) \
3793 fab.fab$b_dns = size; fab.fab$l_dna = name;
3794#define rms_nam_dns(fab, nam) fab.fab$b_dns;
3795#define rms_set_esa(fab, nam, name, size) \
3796 nam.nam$b_ess = size; nam.nam$l_esa = name;
3797#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3798 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3799#define rms_set_rsa(nam, name, size) \
3800 nam.nam$l_rsa = name; nam.nam$b_rss = size;
3801#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3802 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3803
3804#else
3805static int rms_free_search_context(struct FAB * fab)
3806{
3807struct NAML * nam;
3808
3809 nam = fab->fab$l_naml;
3810 nam->naml$b_nop |= NAM$M_SYNCHK;
3811 nam->naml$l_rlf = NULL;
3812 nam->naml$l_long_defname_size = 0;
3813 fab->fab$b_dns = 0;
3814 return sys$parse(fab, NULL, NULL);
3815}
3816
3817#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3818#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3819#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3820#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3821#define rms_nam_esll(nam) nam.naml$l_long_expand_size
3822#define rms_nam_esl(nam) nam.naml$b_esl
3823#define rms_nam_name(nam) nam.naml$l_name
3824#define rms_nam_namel(nam) nam.naml$l_long_name
3825#define rms_nam_type(nam) nam.naml$l_type
3826#define rms_nam_typel(nam) nam.naml$l_long_type
3827#define rms_nam_ver(nam) nam.naml$l_ver
3828#define rms_nam_verl(nam) nam.naml$l_long_ver
3829#define rms_nam_rsll(nam) nam.naml$l_long_result_size
3830#define rms_nam_rsl(nam) nam.naml$b_rsl
3831#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3832#define rms_set_fna(fab, nam, name, size) \
3833 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3834 nam.naml$l_long_filename_size = size; \
3835 nam.naml$l_long_filename = name
3836#define rms_get_fna(fab, nam) nam.naml$l_long_filename
3837#define rms_set_dna(fab, nam, name, size) \
3838 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3839 nam.naml$l_long_defname_size = size; \
3840 nam.naml$l_long_defname = name
3841#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3842#define rms_set_esa(fab, nam, name, size) \
3843 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3844 nam.naml$l_long_expand_alloc = size; \
3845 nam.naml$l_long_expand = name
3846#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3847 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3848 nam.naml$l_long_expand = l_name; \
3849 nam.naml$l_long_expand_alloc = l_size;
3850#define rms_set_rsa(nam, name, size) \
3851 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3852 nam.naml$l_long_result = name; \
3853 nam.naml$l_long_result_alloc = size;
3854#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3855 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3856 nam.naml$l_long_result = l_name; \
3857 nam.naml$l_long_result_alloc = l_size;
3858
3859#endif
3860
bbce6d69 3861
3862/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3863/* Shortcut for common case of simple calls to $PARSE and $SEARCH
3864 * to expand file specification. Allows for a single default file
3865 * specification and a simple mask of options. If outbuf is non-NULL,
3866 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3867 * the resultant file specification is placed. If outbuf is NULL, the
3868 * resultant file specification is placed into a static buffer.
3869 * The third argument, if non-NULL, is taken to be a default file
3870 * specification string. The fourth argument is unused at present.
3871 * rmesexpand() returns the address of the resultant string if
3872 * successful, and NULL on error.
e886094b
JM		 3873 *
3874 * New functionality for previously unused opts value:
3875 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
bbce6d69 3876 */
b8ffc8df 3877static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
96e4d5b1 3878
18a3d61e
JM		 3879#if defined(__VAX) || !defined(NAML$C_MAXRSS)
3880/* ODS-2 only version */
bbce6d69 3881static char *
2fbb330f 3882mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
bbce6d69 3883{
3884 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
96e4d5b1 3885 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
bbce6d69 3886 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3887 struct FAB myfab = cc$rms_fab;
3888 struct NAM mynam = cc$rms_nam;
3889 STRLEN speclen;
3eeba6fb 3890 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
f7ddb74a 3891 int sts;
bbce6d69 3892
3893 if (!filespec || !*filespec) {
3894 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3895 return NULL;
3896 }
3897 if (!outbuf) {
a02a5408 3898 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
bbce6d69 3899 else outbuf = __rmsexpand_retbuf;
3900 }
2497a41f
JM		 3901 isunix = is_unix_filespec(filespec);
3902 if (isunix) {
18a3d61e
JM		 3903 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3904 if (out)
3905 Safefree(out);
3906 return NULL;
3907 }
96e4d5b1 3908 filespec = vmsfspec;
3909 }
bbce6d69 3910
2fbb330f 3911 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
bbce6d69 3912 myfab.fab$b_fns = strlen(filespec);
3913 myfab.fab$l_nam = &mynam;
3914
3915 if (defspec && *defspec) {
96e4d5b1 3916 if (strchr(defspec,'/') != NULL) {
18a3d61e
JM		 3917 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3918 if (out)
3919 Safefree(out);
3920 return NULL;
3921 }
96e4d5b1 3922 defspec = tmpfspec;
3923 }
2fbb330f 3924 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
bbce6d69 3925 myfab.fab$b_dns = strlen(defspec);
3926 }
3927
3928 mynam.nam$l_esa = esa;
3929 mynam.nam$b_ess = sizeof esa;
3930 mynam.nam$l_rsa = outbuf;
3931 mynam.nam$b_rss = NAM$C_MAXRSS;
3932
18a3d61e
JM		 3933#ifdef NAM$M_NO_SHORT_UPCASE
3934 if (decc_efs_case_preserve)
3935 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3936#endif
3937
bbce6d69 3938 retsts = sys$parse(&myfab,0,0);
3939 if (!(retsts & 1)) {
17f28c40 3940 mynam.nam$b_nop |= NAM$M_SYNCHK;
f282b18d 3941 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
bbce6d69 3942 retsts = sys$parse(&myfab,0,0);
3943 if (retsts & 1) goto expanded;
3944 }
17f28c40 3945 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
f7ddb74a 3946 sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69 3947 if (out) Safefree(out);
3948 set_vaxc_errno(retsts);
3949 if (retsts == RMS$_PRV) set_errno(EACCES);
3950 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3951 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3952 else set_errno(EVMSERR);
3953 return NULL;
3954 }
3955 retsts = sys$search(&myfab,0,0);
3956 if (!(retsts & 1) && retsts != RMS$_FNF) {
17f28c40 3957 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 3958 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
bbce6d69 3959 if (out) Safefree(out);
3960 set_vaxc_errno(retsts);
3961 if (retsts == RMS$_PRV) set_errno(EACCES);
3962 else set_errno(EVMSERR);
3963 return NULL;
3964 }
3965
3966 /* If the input filespec contained any lowercase characters,
3967 * downcase the result for compatibility with Unix-minded code. */
3968 expanded:
f7ddb74a
JM		 3969 if (!decc_efs_case_preserve) {
3970 for (out = myfab.fab$l_fna; *out; out++)
3971 if (islower(*out)) { haslower = 1; break; }
3972 }
bbce6d69 3973 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3974 else { out = esa; speclen = mynam.nam$b_esl; }
3eeba6fb
CB		 3975 /* Trim off null fields added by $PARSE
3976 * If type > 1 char, must have been specified in original or default spec
3977 * (not true for version; $SEARCH may have added version of existing file).
3978 */
3979 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3980 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3981 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3982 if (trimver || trimtype) {
3983 if (defspec && *defspec) {
3984 char defesa[NAM$C_MAXRSS];
3985 struct FAB deffab = cc$rms_fab;
3986 struct NAM defnam = cc$rms_nam;
3987
3988 deffab.fab$l_nam = &defnam;
f7ddb74a 3989 /* cast below ok for read only pointer */
2fbb330f 3990 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3eeba6fb
CB		 3991 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3992 defnam.nam$b_nop = NAM$M_SYNCHK;
f7ddb74a
JM		 3993#ifdef NAM$M_NO_SHORT_UPCASE
3994 if (decc_efs_case_preserve)
3995 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3996#endif
3eeba6fb
CB		 3997 if (sys$parse(&deffab,0,0) & 1) {
3998 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
3999 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4000 }
4001 }
2497a41f
JM		 4002 if (trimver) {
4003 if (*mynam.nam$l_ver != '\"')
4004 speclen = mynam.nam$l_ver - out;
4005 }
3eeba6fb
CB		 4006 if (trimtype) {
4007 /* If we didn't already trim version, copy down */
4008 if (speclen > mynam.nam$l_ver - out)
18a3d61e 4009 memmove(mynam.nam$l_type, mynam.nam$l_ver,
3eeba6fb
CB		 4010 speclen - (mynam.nam$l_ver - out));
4011 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4012 }
4013 }
bbce6d69 4014 /* If we just had a directory spec on input, $PARSE "helpfully"
4015 * adds an empty name and type for us */
4016 if (mynam.nam$l_name == mynam.nam$l_type &&
4017 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4018 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4019 speclen = mynam.nam$l_name - out;
2497a41f
JM		 4020
4021 /* Posix format specifications must have matching quotes */
4022 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4023 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4024 out[speclen] = '\"';
4025 speclen++;
4026 }
4027 }
4028
bbce6d69 4029 out[speclen] = '\0';
f7ddb74a 4030 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
bbce6d69 4031
4032 /* Have we been working with an expanded, but not resultant, spec? */
96e4d5b1 4033 /* Also, convert back to Unix syntax if necessary. */
e886094b
JM		 4034 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4035 isunix = 0;
4036
96e4d5b1 4037 if (!mynam.nam$b_rsl) {
4038 if (isunix) {
4039 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4040 }
4041 else strcpy(outbuf,esa);
4042 }
4043 else if (isunix) {
4044 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4045 strcpy(outbuf,tmpfspec);
4046 }
17f28c40 4047 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
18a3d61e
JM		 4048 mynam.nam$l_rsa = NULL;
4049 mynam.nam$b_rss = 0;
4050 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4051 return outbuf;
4052}
4053#else
4054/* ODS-5 supporting routine */
4055static char *
4056mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4057{
4058 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4059 char * vmsfspec, *tmpfspec;
4060 char * esa, *cp, *out = NULL;
4061 char * esal;
4062 char * outbufl;
4063 struct FAB myfab = cc$rms_fab;
a480973c 4064 rms_setup_nam(mynam);
18a3d61e
JM		 4065 STRLEN speclen;
4066 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4067 int sts;
4068
4069 if (!filespec || !*filespec) {
4070 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4071 return NULL;
4072 }
4073 if (!outbuf) {
4074 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4075 else outbuf = __rmsexpand_retbuf;
4076 }
4077
4078 vmsfspec = NULL;
4079 tmpfspec = NULL;
4080 outbufl = NULL;
4081 isunix = is_unix_filespec(filespec);
4082 if (isunix) {
4083 Newx(vmsfspec, VMS_MAXRSS, char);
4084 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4085 Safefree(vmsfspec);
4086 if (out)
4087 Safefree(out);
4088 return NULL;
4089 }
4090 filespec = vmsfspec;
4091
4092 /* Unless we are forcing to VMS format, a UNIX input means
4093 * UNIX output, and that requires long names to be used
4094 */
4095 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4096 opts |= PERL_RMSEXPAND_M_LONG;
4097 else {
4098 isunix = 0;
4099 }
4100 }
4101
a480973c
JM		 4102 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4103 rms_bind_fab_nam(myfab, mynam);
18a3d61e
JM		 4104
4105 if (defspec && *defspec) {
4106 int t_isunix;
4107 t_isunix = is_unix_filespec(defspec);
4108 if (t_isunix) {
4109 Newx(tmpfspec, VMS_MAXRSS, char);
4110 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4111 Safefree(tmpfspec);
4112 if (vmsfspec != NULL)
4113 Safefree(vmsfspec);
4114 if (out)
4115 Safefree(out);
4116 return NULL;
4117 }
4118 defspec = tmpfspec;
4119 }
a480973c 4120 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
18a3d61e
JM		 4121 }
4122
4123 Newx(esa, NAM$C_MAXRSS + 1, char);
a480973c 4124#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 4125 Newx(esal, NAML$C_MAXRSS + 1, char);
a480973c
JM		 4126#endif
4127 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
18a3d61e
JM		 4128
4129 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4130 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
18a3d61e
JM		 4131 }
4132 else {
a480973c 4133#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 4134 Newx(outbufl, VMS_MAXRSS, char);
a480973c
JM		 4135 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4136#else
4137 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4138#endif
18a3d61e
JM		 4139 }
4140
f7ddb74a
JM		 4141#ifdef NAM$M_NO_SHORT_UPCASE
4142 if (decc_efs_case_preserve)
a480973c 4143 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4144#endif
18a3d61e
JM		 4145
4146 /* First attempt to parse as an existing file */
4147 retsts = sys$parse(&myfab,0,0);
4148 if (!(retsts & STS$K_SUCCESS)) {
4149
4150 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 4151 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
18a3d61e
JM		 4152 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4153 retsts = sys$parse(&myfab,0,0);
4154 if (retsts & STS$K_SUCCESS) goto expanded;
4155 }
4156
4157 /* Still could not parse the file specification */
4158 /*----------------------------------------------*/
a480973c 4159 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 4160 if (out) Safefree(out);
4161 if (tmpfspec != NULL)
4162 Safefree(tmpfspec);
4163 if (vmsfspec != NULL)
4164 Safefree(vmsfspec);
4165 Safefree(esa);
4166 Safefree(esal);
4167 set_vaxc_errno(retsts);
4168 if (retsts == RMS$_PRV) set_errno(EACCES);
4169 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4170 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4171 else set_errno(EVMSERR);
4172 return NULL;
4173 }
4174 retsts = sys$search(&myfab,0,0);
4175 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 4176 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 4177 if (out) Safefree(out);
4178 if (tmpfspec != NULL)
4179 Safefree(tmpfspec);
4180 if (vmsfspec != NULL)
4181 Safefree(vmsfspec);
4182 Safefree(esa);
4183 Safefree(esal);
4184 set_vaxc_errno(retsts);
4185 if (retsts == RMS$_PRV) set_errno(EACCES);
4186 else set_errno(EVMSERR);
4187 return NULL;
4188 }
4189
4190 /* If the input filespec contained any lowercase characters,
4191 * downcase the result for compatibility with Unix-minded code. */
4192 expanded:
4193 if (!decc_efs_case_preserve) {
a480973c 4194 for (out = rms_get_fna(myfab, mynam); *out; out++)
18a3d61e
JM		 4195 if (islower(*out)) { haslower = 1; break; }
4196 }
4197
4198 /* Is a long or a short name expected */
4199 /*------------------------------------*/
4200 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4201 if (rms_nam_rsll(mynam)) {
18a3d61e 4202 out = outbuf;
a480973c 4203 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 4204 }
4205 else {
4206 out = esal; /* Not esa */
a480973c 4207 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 4208 }
4209 }
4210 else {
a480973c 4211 if (rms_nam_rsl(mynam)) {
18a3d61e 4212 out = outbuf;
a480973c 4213 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 4214 }
4215 else {
4216 out = esa; /* Not esal */
a480973c 4217 speclen = rms_nam_esl(mynam);
18a3d61e
JM		 4218 }
4219 }
4220 /* Trim off null fields added by $PARSE
4221 * If type > 1 char, must have been specified in original or default spec
4222 * (not true for version; $SEARCH may have added version of existing file).
4223 */
a480973c 4224 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 4225 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 4226 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4227 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 4228 }
4229 else {
a480973c
JM		 4230 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4231 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 4232 }
4233 if (trimver || trimtype) {
4234 if (defspec && *defspec) {
4235 char *defesal = NULL;
4236 Newx(defesal, NAML$C_MAXRSS + 1, char);
4237 if (defesal != NULL) {
4238 struct FAB deffab = cc$rms_fab;
a480973c 4239 rms_setup_nam(defnam);
18a3d61e 4240
a480973c
JM		 4241 rms_bind_fab_nam(deffab, defnam);
4242
4243 /* Cast ok */
4244 rms_set_fna
4245 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4246
4247 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4248
4249 rms_set_nam_nop(defnam, 0);
4250 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 4251#ifdef NAM$M_NO_SHORT_UPCASE
4252 if (decc_efs_case_preserve)
a480973c 4253 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e
JM		 4254#endif
4255 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4256 if (trimver) {
a480973c 4257 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 4258 }
4259 if (trimtype) {
a480973c 4260 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 4261 }
4262 }
4263 Safefree(defesal);
4264 }
4265 }
4266 if (trimver) {
4267 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 4268 if (*(rms_nam_verl(mynam)) != '\"')
4269 speclen = rms_nam_verl(mynam) - out;
18a3d61e
JM		 4270 }
4271 else {
a480973c
JM		 4272 if (*(rms_nam_ver(mynam)) != '\"')
4273 speclen = rms_nam_ver(mynam) - out;
18a3d61e
JM		 4274 }
4275 }
4276 if (trimtype) {
4277 /* If we didn't already trim version, copy down */
4278 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4279 if (speclen > rms_nam_verl(mynam) - out)
18a3d61e 4280 memmove
a480973c
JM		 4281 (rms_nam_typel(mynam),
4282 rms_nam_verl(mynam),
4283 speclen - (rms_nam_verl(mynam) - out));
4284 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 4285 }
4286 else {
a480973c 4287 if (speclen > rms_nam_ver(mynam) - out)
18a3d61e 4288 memmove
a480973c
JM		 4289 (rms_nam_type(mynam),
4290 rms_nam_ver(mynam),
4291 speclen - (rms_nam_ver(mynam) - out));
4292 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 4293 }
4294 }
4295 }
4296
4297 /* Done with these copies of the input files */
4298 /*-------------------------------------------*/
4299 if (vmsfspec != NULL)
4300 Safefree(vmsfspec);
4301 if (tmpfspec != NULL)
4302 Safefree(tmpfspec);
4303
4304 /* If we just had a directory spec on input, $PARSE "helpfully"
4305 * adds an empty name and type for us */
4306 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 4307 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4308 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4309 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4310 speclen = rms_nam_namel(mynam) - out;
18a3d61e
JM		 4311 }
4312 else {
a480973c
JM		 4313 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4314 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4315 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4316 speclen = rms_nam_name(mynam) - out;
18a3d61e
JM		 4317 }
4318
4319 /* Posix format specifications must have matching quotes */
4320 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4321 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4322 out[speclen] = '\"';
4323 speclen++;
4324 }
4325 }
4326 out[speclen] = '\0';
4327 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4328
4329 /* Have we been working with an expanded, but not resultant, spec? */
4330 /* Also, convert back to Unix syntax if necessary. */
4331
a480973c 4332 if (!rms_nam_rsll(mynam)) {
18a3d61e
JM		 4333 if (isunix) {
4334 if (do_tounixspec(esa,outbuf,0) == NULL) {
4335 Safefree(esal);
4336 Safefree(esa);
4337 return NULL;
4338 }
4339 }
4340 else strcpy(outbuf,esa);
4341 }
4342 else if (isunix) {
4343 Newx(tmpfspec, VMS_MAXRSS, char);
4344 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4345 Safefree(esa);
4346 Safefree(esal);
4347 Safefree(tmpfspec);
4348 return NULL;
4349 }
4350 strcpy(outbuf,tmpfspec);
4351 Safefree(tmpfspec);
4352 }
4353
a480973c
JM		 4354 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4355 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 4356 Safefree(esa);
4357 Safefree(esal);
bbce6d69 4358 return outbuf;
4359}
18a3d61e 4360#endif
bbce6d69 4361/*}}}*/
4362/* External entry points */
2fbb330f 4363char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 4364{ return do_rmsexpand(spec,buf,0,def,opt); }
2fbb330f 4365char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 4366{ return do_rmsexpand(spec,buf,1,def,opt); }
4367
4368
a0d0e21e
LW		 4369/*
4370** The following routines are provided to make life easier when
4371** converting among VMS-style and Unix-style directory specifications.
4372** All will take input specifications in either VMS or Unix syntax. On
4373** failure, all return NULL. If successful, the routines listed below
748a9306 4374** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 4375** reformatted spec (and, therefore, subsequent calls to that routine
4376** will clobber the result), while the routines of the same names with
4377** a _ts suffix appended will return a pointer to a mallocd string
4378** containing the appropriately reformatted spec.
4379** In all cases, only explicit syntax is altered; no check is made that
4380** the resulting string is valid or that the directory in question
4381** actually exists.
4382**
4383** fileify_dirspec() - convert a directory spec into the name of the
4384** directory file (i.e. what you can stat() to see if it's a dir).
4385** The style (VMS or Unix) of the result is the same as the style
4386** of the parameter passed in.
4387** pathify_dirspec() - convert a directory spec into a path (i.e.
4388** what you prepend to a filename to indicate what directory it's in).
4389** The style (VMS or Unix) of the result is the same as the style
4390** of the parameter passed in.
4391** tounixpath() - convert a directory spec into a Unix-style path.
4392** tovmspath() - convert a directory spec into a VMS-style path.
4393** tounixspec() - convert any file spec into a Unix-style file spec.
4394** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 4395**
bd3fa61c 4396** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 4397** Permission is given to distribute this code as part of the Perl
4398** standard distribution under the terms of the GNU General Public
4399** License or the Perl Artistic License. Copies of each may be
4400** found in the Perl standard distribution.
a0d0e21e
LW		 4401 */
4402
a480973c 4403/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
b8ffc8df 4404static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
a0d0e21e 4405{
a480973c 4406 static char __fileify_retbuf[VMS_MAXRSS];
b7ae7a0d 4407 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 4408 char *retspec, *cp1, *cp2, *lastdir;
a480973c 4409 char *trndir, *vmsdir;
2d9f3838 4410 unsigned short int trnlnm_iter_count;
f7ddb74a 4411 int sts;
a0d0e21e 4412
c07a80fd 4413 if (!dir || !*dir) {
4414 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4415 }
a0d0e21e 4416 dirlen = strlen(dir);
a2a90019 4417 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 4418 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 4419 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4420 dir = "/sys$disk";
4421 dirlen = 9;
4422 }
4423 else
4424 dirlen = 1;
61bb5906 4425 }
a480973c
JM		 4426 if (dirlen > (VMS_MAXRSS - 1)) {
4427 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4428 return NULL;
c07a80fd 4429 }
a480973c 4430 Newx(trndir, VMS_MAXRSS + 1, char);
f7ddb74a
JM		 4431 if (!strpbrk(dir+1,"/]>:") &&
4432 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 4433 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838
CB		 4434 trnlnm_iter_count = 0;
4435 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4436 trnlnm_iter_count++;
4437 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4438 }
b8ffc8df 4439 dirlen = strlen(trndir);
e518068a 4440 }
01b8edb6 4441 else {
4442 strncpy(trndir,dir,dirlen);
4443 trndir[dirlen] = '\0';
01b8edb6 4444 }
b8ffc8df
RGS		 4445
4446 /* At this point we are done with *dir and use *trndir which is a
4447 * copy that can be modified. *dir must not be modified.
4448 */
4449
c07a80fd 4450 /* If we were handed a rooted logical name or spec, treat it like a
4451 * simple directory, so that
4452 * $ Define myroot dev:[dir.]
4453 * ... do_fileify_dirspec("myroot",buf,1) ...
4454 * does something useful.
4455 */
b8ffc8df
RGS		 4456 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4457 trndir[--dirlen] = '\0';
4458 trndir[dirlen-1] = ']';
c07a80fd 4459 }
b8ffc8df
RGS		 4460 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4461 trndir[--dirlen] = '\0';
4462 trndir[dirlen-1] = '>';
46112e17 4463 }
e518068a 4464
b8ffc8df 4465 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 4466 /* If we've got an explicit filename, we can just shuffle the string. */
4467 if (*(cp1+1)) hasfilename = 1;
4468 /* Similarly, we can just back up a level if we've got multiple levels
4469 of explicit directories in a VMS spec which ends with directories. */
4470 else {
b8ffc8df 4471 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 4472 if (*cp2 == '.') {
4473 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4474 *cp2 = *cp1; *cp1 = '\0';
4475 hasfilename = 1;
4476 break;
4477 }
b7ae7a0d 4478 }
4479 if (*cp2 == '[' || *cp2 == '<') break;
4480 }
4481 }
4482 }
4483
a480973c
JM		 4484 Newx(vmsdir, VMS_MAXRSS + 1, char);
4485 cp1 = strpbrk(trndir,"]:>");
f7ddb74a 4486 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df 4487 if (trndir[0] == '.') {
a480973c
JM		 4488 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4489 Safefree(trndir);
4490 Safefree(vmsdir);
748a9306 4491 return do_fileify_dirspec("[]",buf,ts);
a480973c 4492 }
b8ffc8df 4493 else if (trndir[1] == '.' &&
a480973c
JM		 4494 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4495 Safefree(trndir);
4496 Safefree(vmsdir);
748a9306 4497 return do_fileify_dirspec("[-]",buf,ts);
a480973c 4498 }
748a9306 4499 }
b8ffc8df 4500 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 4501 dirlen -= 1; /* to last element */
b8ffc8df 4502 lastdir = strrchr(trndir,'/');
a0d0e21e 4503 }
b8ffc8df 4504 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 4505 /* If we have "/." or "/..", VMSify it and let the VMS code
4506 * below expand it, rather than repeating the code to handle
4507 * relative components of a filespec here */
4633a7c4
LW		 4508 do {
4509 if (*(cp1+2) == '.') cp1++;
4510 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c
JM		 4511 char * ret_chr;
4512 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4513 Safefree(trndir);
4514 Safefree(vmsdir);
4515 return NULL;
4516 }
fc1ce8cc
CB		 4517 if (strchr(vmsdir,'/') != NULL) {
4518 /* If do_tovmsspec() returned it, it must have VMS syntax
4519 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4520 * the time to check this here only so we avoid a recursion
4521 * loop; otherwise, gigo.
4522 */
a480973c
JM		 4523 Safefree(trndir);
4524 Safefree(vmsdir);
4525 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4526 return NULL;
fc1ce8cc 4527 }
a480973c
JM		 4528 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4529 Safefree(trndir);
4530 Safefree(vmsdir);
4531 return NULL;
4532 }
4533 ret_chr = do_tounixspec(trndir,buf,ts);
4534 Safefree(trndir);
4535 Safefree(vmsdir);
4536 return ret_chr;
4633a7c4
LW		 4537 }
4538 cp1++;
4539 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 4540 lastdir = strrchr(trndir,'/');
748a9306 4541 }
b8ffc8df 4542 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 4543 char * ret_chr;
61bb5906
CB		 4544 /* Ditto for specs that end in an MFD -- let the VMS code
4545 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 4546
4547 /* This should not happen any more. Allowing the fake /000000
4548 * in a UNIX pathname causes all sorts of problems when trying
4549 * to run in UNIX emulation. So the VMS to UNIX conversions
4550 * now remove the fake /000000 directories.
4551 */
4552
b8ffc8df 4553 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
a480973c
JM		 4554 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4555 Safefree(trndir);
4556 Safefree(vmsdir);
4557 return NULL;
4558 }
4559 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4560 Safefree(trndir);
4561 Safefree(vmsdir);
4562 return NULL;
4563 }
4564 ret_chr = do_tounixspec(trndir,buf,ts);
4565 Safefree(trndir);
4566 Safefree(vmsdir);
4567 return ret_chr;
61bb5906 4568 }
a0d0e21e 4569 else {
f7ddb74a 4570
b8ffc8df
RGS		 4571 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4572 !(lastdir = cp1 = strrchr(trndir,']')) &&
4573 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 4574 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 4575 int ver; char *cp3;
f7ddb74a
JM		 4576
4577 /* For EFS or ODS-5 look for the last dot */
4578 if (decc_efs_charset) {
4579 cp2 = strrchr(cp1,'.');
4580 }
4581 if (vms_process_case_tolerant) {
4582 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4583 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4584 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4585 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4586 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 4587 (ver || *cp3)))))) {
a480973c
JM		 4588 Safefree(trndir);
4589 Safefree(vmsdir);
f7ddb74a
JM		 4590 set_errno(ENOTDIR);
4591 set_vaxc_errno(RMS$_DIR);
4592 return NULL;
4593 }
4594 }
4595 else {
4596 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4597 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4598 !*(cp2+3) || *(cp2+3) != 'R' ||
4599 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4600 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4601 (ver || *cp3)))))) {
a480973c
JM		 4602 Safefree(trndir);
4603 Safefree(vmsdir);
f7ddb74a
JM		 4604 set_errno(ENOTDIR);
4605 set_vaxc_errno(RMS$_DIR);
4606 return NULL;
4607 }
a0d0e21e 4608 }
b8ffc8df 4609 dirlen = cp2 - trndir;
a0d0e21e 4610 }
748a9306 4611 }
f7ddb74a
JM		 4612
4613 retlen = dirlen + 6;
748a9306 4614 if (buf) retspec = buf;
a02a5408 4615 else if (ts) Newx(retspec,retlen+1,char);
748a9306 4616 else retspec = __fileify_retbuf;
f7ddb74a
JM		 4617 memcpy(retspec,trndir,dirlen);
4618 retspec[dirlen] = '\0';
4619
a0d0e21e
LW		 4620 /* We've picked up everything up to the directory file name.
4621 Now just add the type and version, and we're set. */
f7ddb74a
JM		 4622 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4623 strcat(retspec,".dir;1");
4624 else
4625 strcat(retspec,".DIR;1");
a480973c
JM		 4626 Safefree(trndir);
4627 Safefree(vmsdir);
a0d0e21e
LW		 4628 return retspec;
4629 }
4630 else { /* VMS-style directory spec */
a480973c
JM		 4631
4632 char *esa, term, *cp;
01b8edb6 4633 unsigned long int sts, cmplen, haslower = 0;
a480973c
JM		 4634 unsigned int nam_fnb;
4635 char * nam_type;
a0d0e21e 4636 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 4637 rms_setup_nam(savnam);
4638 rms_setup_nam(dirnam);
4639
4640 Newx(esa, VMS_MAXRSS + 1, char);
4641 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4642 rms_bind_fab_nam(dirfab, dirnam);
4643 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4644 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
f7ddb74a
JM		 4645#ifdef NAM$M_NO_SHORT_UPCASE
4646 if (decc_efs_case_preserve)
a480973c 4647 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4648#endif
01b8edb6 4649
b8ffc8df 4650 for (cp = trndir; *cp; cp++)
01b8edb6 4651 if (islower(*cp)) { haslower = 1; break; }
a480973c 4652 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
f7ddb74a 4653 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 4654 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4655 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 4656 }
4657 if (!sts) {
a480973c
JM		 4658 Safefree(esa);
4659 Safefree(trndir);
4660 Safefree(vmsdir);
748a9306
LW		 4661 set_errno(EVMSERR);
4662 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 4663 return NULL;
4664 }
e518068a 4665 }
4666 else {
4667 savnam = dirnam;
a480973c
JM		 4668 /* Does the file really exist? */
4669 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 4670 /* Yes; fake the fnb bits so we'll check type below */
a480973c 4671 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 4672 }
752635ea
CB		 4673 else { /* No; just work with potential name */
4674 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4675 else {
a480973c
JM		 4676 Safefree(esa);
4677 Safefree(trndir);
4678 Safefree(vmsdir);
752635ea 4679 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
a480973c 4680 sts = rms_free_search_context(&dirfab);
e518068a 4681 return NULL;
4682 }
e518068a 4683 }
a0d0e21e 4684 }
a480973c 4685 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
748a9306
LW		 4686 cp1 = strchr(esa,']');
4687 if (!cp1) cp1 = strchr(esa,'>');
4688 if (cp1) { /* Should always be true */
a480973c
JM		 4689 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4690 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
748a9306
LW		 4691 }
4692 }
a480973c 4693 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 4694 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 4695 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4696 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 4697 /* Something other than .DIR[;1]. Bzzt. */
a480973c
JM		 4698 sts = rms_free_search_context(&dirfab);
4699 Safefree(esa);
4700 Safefree(trndir);
4701 Safefree(vmsdir);
748a9306
LW		 4702 set_errno(ENOTDIR);
4703 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 4704 return NULL;
4705 }
748a9306 4706 }
a480973c
JM		 4707 esa[rms_nam_esll(dirnam)] = '\0';
4708 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306
LW		 4709 /* They provided at least the name; we added the type, if necessary, */
4710 if (buf) retspec = buf; /* in sys$parse() */
a480973c 4711 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
748a9306
LW		 4712 else retspec = __fileify_retbuf;
4713 strcpy(retspec,esa);
a480973c
JM		 4714 sts = rms_free_search_context(&dirfab);
4715 Safefree(trndir);
4716 Safefree(esa);
4717 Safefree(vmsdir);
748a9306
LW		 4718 return retspec;
4719 }
c07a80fd 4720 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4721 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4722 *cp1 = '\0';
a480973c 4723 rms_nam_esll(dirnam) -= 9;
c07a80fd 4724 }
748a9306 4725 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
752635ea 4726 if (cp1 == NULL) { /* should never happen */
a480973c
JM		 4727 sts = rms_free_search_context(&dirfab);
4728 Safefree(trndir);
4729 Safefree(esa);
4730 Safefree(vmsdir);
752635ea
CB		 4731 return NULL;
4732 }
748a9306
LW		 4733 term = *cp1;
4734 *cp1 = '\0';
4735 retlen = strlen(esa);
f7ddb74a
JM		 4736 cp1 = strrchr(esa,'.');
4737 /* ODS-5 directory specifications can have extra "." in them. */
4738 while (cp1 != NULL) {
4739 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4740 break;
4741 else {
4742 cp1--;
4743 while ((cp1 > esa) && (*cp1 != '.'))
4744 cp1--;
4745 }
4746 if (cp1 == esa)
4747 cp1 = NULL;
4748 }
4749
4750 if ((cp1) != NULL) {
748a9306
LW		 4751 /* There's more than one directory in the path. Just roll back. */
4752 *cp1 = term;
4753 if (buf) retspec = buf;
a02a5408 4754 else if (ts) Newx(retspec,retlen+7,char);
748a9306
LW		 4755 else retspec = __fileify_retbuf;
4756 strcpy(retspec,esa);
a0d0e21e
LW		 4757 }
4758 else {
a480973c 4759 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 4760 /* Go back and expand rooted logical name */
a480973c 4761 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 4762#ifdef NAM$M_NO_SHORT_UPCASE
4763 if (decc_efs_case_preserve)
a480973c 4764 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4765#endif
a480973c
JM		 4766 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4767 sts = rms_free_search_context(&dirfab);
4768 Safefree(esa);
4769 Safefree(trndir);
4770 Safefree(vmsdir);
748a9306
LW		 4771 set_errno(EVMSERR);
4772 set_vaxc_errno(dirfab.fab$l_sts);
4773 return NULL;
4774 }
a480973c 4775 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 4776 if (buf) retspec = buf;
a02a5408 4777 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 4778 else retspec = __fileify_retbuf;
748a9306 4779 cp1 = strstr(esa,"][");
46112e17 4780 if (!cp1) cp1 = strstr(esa,"]<");
748a9306
LW		 4781 dirlen = cp1 - esa;
4782 memcpy(retspec,esa,dirlen);
4783 if (!strncmp(cp1+2,"000000]",7)) {
4784 retspec[dirlen-1] = '\0';
f7ddb74a
JM		 4785 /* Not full ODS-5, just extra dots in directories for now */
4786 cp1 = retspec + dirlen - 1;
4787 while (cp1 > retspec)
4788 {
4789 if (*cp1 == '[')
4790 break;
4791 if (*cp1 == '.') {
4792 if (*(cp1-1) != '^')
4793 break;
4794 }
4795 cp1--;
4796 }
4633a7c4
LW		 4797 if (*cp1 == '.') *cp1 = ']';
4798 else {
4799 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 4800 memmove(cp1+1,"000000]",7);
4633a7c4 4801 }
748a9306
LW		 4802 }
4803 else {
18a3d61e 4804 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
748a9306
LW		 4805 retspec[retlen] = '\0';
4806 /* Convert last '.' to ']' */
f7ddb74a
JM		 4807 cp1 = retspec+retlen-1;
4808 while (*cp != '[') {
4809 cp1--;
4810 if (*cp1 == '.') {
4811 /* Do not trip on extra dots in ODS-5 directories */
4812 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4813 break;
4814 }
4815 }
4633a7c4
LW		 4816 if (*cp1 == '.') *cp1 = ']';
4817 else {
4818 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 4819 memmove(cp1+1,"000000]",7);
4633a7c4 4820 }
748a9306 4821 }
a0d0e21e 4822 }
748a9306 4823 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 4824 if (buf) retspec = buf;
a02a5408 4825 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e
LW		 4826 else retspec = __fileify_retbuf;
4827 cp1 = esa;
4828 cp2 = retspec;
bbdb6c9a 4829 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 4830 strcpy(cp2,":[000000]");
4831 cp1 += 2;
4832 strcpy(cp2+9,cp1);
4833 }
748a9306 4834 }
a480973c 4835 sts = rms_free_search_context(&dirfab);
748a9306 4836 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 4837 type and version, and we're done. */
4838 strcat(retspec,".DIR;1");
01b8edb6 4839
4840 /* $PARSE may have upcased filespec, so convert output to lower
4841 * case if input contained any lowercase characters. */
f7ddb74a 4842 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
a480973c
JM		 4843 Safefree(trndir);
4844 Safefree(esa);
4845 Safefree(vmsdir);
a0d0e21e
LW		 4846 return retspec;
4847 }
4848} /* end of do_fileify_dirspec() */
4849/*}}}*/
4850/* External entry points */
b8ffc8df 4851char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
a0d0e21e 4852{ return do_fileify_dirspec(dir,buf,0); }
b8ffc8df 4853char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
a0d0e21e
LW		 4854{ return do_fileify_dirspec(dir,buf,1); }
4855
4856/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
b8ffc8df 4857static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
a0d0e21e 4858{
a480973c 4859 static char __pathify_retbuf[VMS_MAXRSS];
a0d0e21e 4860 unsigned long int retlen;
a480973c 4861 char *retpath, *cp1, *cp2, *trndir;
2d9f3838 4862 unsigned short int trnlnm_iter_count;
baf3cf9c 4863 STRLEN trnlen;
f7ddb74a 4864 int sts;
a0d0e21e 4865
c07a80fd 4866 if (!dir || !*dir) {
4867 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4868 }
4869
a480973c 4870 Newx(trndir, VMS_MAXRSS, char);
c07a80fd 4871 if (*dir) strcpy(trndir,dir);
a480973c 4872 else getcwd(trndir,VMS_MAXRSS - 1);
c07a80fd 4873
2d9f3838 4874 trnlnm_iter_count = 0;
93948341
CB		 4875 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4876 && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 4877 trnlnm_iter_count++;
4878 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
baf3cf9c 4879 trnlen = strlen(trndir);
a0d0e21e 4880
c07a80fd 4881 /* Trap simple rooted lnms, and return lnm:[000000] */
4882 if (!strcmp(trndir+trnlen-2,".]")) {
4883 if (buf) retpath = buf;
a02a5408 4884 else if (ts) Newx(retpath,strlen(dir)+10,char);
c07a80fd 4885 else retpath = __pathify_retbuf;
4886 strcpy(retpath,dir);
4887 strcat(retpath,":[000000]");
a480973c 4888 Safefree(trndir);
c07a80fd 4889 return retpath;
4890 }
4891 }
748a9306 4892
b8ffc8df
RGS		 4893 /* At this point we do not work with *dir, but the copy in
4894 * *trndir that is modifiable.
4895 */
4896
4897 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4898 if (*trndir == '.' && (*(trndir+1) == '\0' ||
4899 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4900 retlen = 2 + (*(trndir+1) != '\0');
748a9306 4901 else {
b8ffc8df
RGS		 4902 if ( !(cp1 = strrchr(trndir,'/')) &&
4903 !(cp1 = strrchr(trndir,']')) &&
4904 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
f86702cc 4905 if ((cp2 = strchr(cp1,'.')) != NULL &&
4906 (*(cp2-1) != '/' || /* Trailing '.', '..', */
4907 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
4908 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4909 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 4910 int ver; char *cp3;
f7ddb74a
JM		 4911
4912 /* For EFS or ODS-5 look for the last dot */
4913 if (decc_efs_charset) {
4914 cp2 = strrchr(cp1,'.');
4915 }
4916 if (vms_process_case_tolerant) {
4917 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4918 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4919 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4920 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4921 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 4922 (ver || *cp3)))))) {
a480973c 4923 Safefree(trndir);
f7ddb74a
JM		 4924 set_errno(ENOTDIR);
4925 set_vaxc_errno(RMS$_DIR);
4926 return NULL;
4927 }
4928 }
4929 else {
4930 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4931 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4932 !*(cp2+3) || *(cp2+3) != 'R' ||
4933 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4934 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4935 (ver || *cp3)))))) {
a480973c 4936 Safefree(trndir);
f7ddb74a
JM		 4937 set_errno(ENOTDIR);
4938 set_vaxc_errno(RMS$_DIR);
4939 return NULL;
4940 }
4941 }
b8ffc8df 4942 retlen = cp2 - trndir + 1;
a0d0e21e 4943 }
748a9306 4944 else { /* No file type present. Treat the filename as a directory. */
b8ffc8df 4945 retlen = strlen(trndir) + 1;
a0d0e21e
LW		 4946 }
4947 }
a0d0e21e 4948 if (buf) retpath = buf;
a02a5408 4949 else if (ts) Newx(retpath,retlen+1,char);
a0d0e21e 4950 else retpath = __pathify_retbuf;
b8ffc8df 4951 strncpy(retpath, trndir, retlen-1);
a0d0e21e
LW		 4952 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4953 retpath[retlen-1] = '/'; /* with '/', add it. */
4954 retpath[retlen] = '\0';
4955 }
4956 else retpath[retlen-1] = '\0';
4957 }
4958 else { /* VMS-style directory spec */
a480973c 4959 char *esa, *cp;
01b8edb6 4960 unsigned long int sts, cmplen, haslower;
a0d0e21e 4961 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 4962 int dirlen;
4963 rms_setup_nam(savnam);
4964 rms_setup_nam(dirnam);
a0d0e21e 4965
b7ae7a0d 4966 /* If we've got an explicit filename, we can just shuffle the string. */
b8ffc8df
RGS		 4967 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4968 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
b7ae7a0d 4969 if ((cp2 = strchr(cp1,'.')) != NULL) {
4970 int ver; char *cp3;
f7ddb74a
JM		 4971 if (vms_process_case_tolerant) {
4972 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4973 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4974 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4975 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4976 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 4977 (ver || *cp3)))))) {
a480973c 4978 Safefree(trndir);
f7ddb74a
JM		 4979 set_errno(ENOTDIR);
4980 set_vaxc_errno(RMS$_DIR);
4981 return NULL;
4982 }
4983 }
4984 else {
4985 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4986 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4987 !*(cp2+3) || *(cp2+3) != 'R' ||
4988 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4989 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4990 (ver || *cp3)))))) {
a480973c 4991 Safefree(trndir);
f7ddb74a
JM		 4992 set_errno(ENOTDIR);
4993 set_vaxc_errno(RMS$_DIR);
4994 return NULL;
4995 }
4996 }
b7ae7a0d 4997 }
4998 else { /* No file type, so just draw name into directory part */
4999 for (cp2 = cp1; *cp2; cp2++) ;
5000 }
5001 *cp2 = *cp1;
5002 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5003 *cp1 = '.';
5004 /* We've now got a VMS 'path'; fall through */
5005 }
a480973c
JM		 5006
5007 dirlen = strlen(trndir);
5008 if (trndir[dirlen-1] == ']' ||
5009 trndir[dirlen-1] == '>' ||
5010 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
748a9306 5011 if (buf) retpath = buf;
f7ddb74a 5012 else if (ts) Newx(retpath,strlen(trndir)+1,char);
748a9306 5013 else retpath = __pathify_retbuf;
b8ffc8df 5014 strcpy(retpath,trndir);
a480973c 5015 Safefree(trndir);
748a9306 5016 return retpath;
a480973c
JM		 5017 }
5018 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5019 Newx(esa, VMS_MAXRSS, char);
5020 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5021 rms_bind_fab_nam(dirfab, dirnam);
5022 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
f7ddb74a
JM		 5023#ifdef NAM$M_NO_SHORT_UPCASE
5024 if (decc_efs_case_preserve)
a480973c 5025 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5026#endif
01b8edb6 5027
b8ffc8df 5028 for (cp = trndir; *cp; cp++)
01b8edb6 5029 if (islower(*cp)) { haslower = 1; break; }
5030
a480973c 5031 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
f7ddb74a 5032 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 5033 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5034 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 5035 }
5036 if (!sts) {
a480973c
JM		 5037 Safefree(trndir);
5038 Safefree(esa);
748a9306
LW		 5039 set_errno(EVMSERR);
5040 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 5041 return NULL;
5042 }
a0d0e21e 5043 }
e518068a 5044 else {
5045 savnam = dirnam;
a480973c
JM		 5046 /* Does the file really exist? */
5047 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
e518068a 5048 if (dirfab.fab$l_sts != RMS$_FNF) {
f7ddb74a 5049 int sts1;
a480973c
JM		 5050 sts1 = rms_free_search_context(&dirfab);
5051 Safefree(trndir);
5052 Safefree(esa);
e518068a 5053 set_errno(EVMSERR);
5054 set_vaxc_errno(dirfab.fab$l_sts);
5055 return NULL;
5056 }
5057 dirnam = savnam; /* No; just work with potential name */
5058 }
5059 }
a480973c 5060 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 5061 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 5062 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5063 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
f7ddb74a 5064 int sts2;
a0d0e21e 5065 /* Something other than .DIR[;1]. Bzzt. */
a480973c
JM		 5066 sts2 = rms_free_search_context(&dirfab);
5067 Safefree(trndir);
5068 Safefree(esa);
748a9306
LW		 5069 set_errno(ENOTDIR);
5070 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 5071 return NULL;
5072 }
a0d0e21e 5073 }
748a9306
LW		 5074 /* OK, the type was fine. Now pull any file name into the
5075 directory path. */
a480973c 5076 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
a0d0e21e 5077 else {
748a9306 5078 cp1 = strrchr(esa,'>');
a480973c 5079 *(rms_nam_typel(dirnam)) = '>';
a0d0e21e 5080 }
748a9306 5081 *cp1 = '.';
a480973c
JM		 5082 *(rms_nam_typel(dirnam) + 1) = '\0';
5083 retlen = (rms_nam_typel(dirnam)) - esa + 2;
a0d0e21e 5084 if (buf) retpath = buf;
a02a5408 5085 else if (ts) Newx(retpath,retlen,char);
a0d0e21e
LW		 5086 else retpath = __pathify_retbuf;
5087 strcpy(retpath,esa);
a480973c
JM		 5088 Safefree(esa);
5089 sts = rms_free_search_context(&dirfab);
01b8edb6 5090 /* $PARSE may have upcased filespec, so convert output to lower
5091 * case if input contained any lowercase characters. */
f7ddb74a 5092 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
a0d0e21e
LW		 5093 }
5094
a480973c 5095 Safefree(trndir);
a0d0e21e
LW		 5096 return retpath;
5097} /* end of do_pathify_dirspec() */
5098/*}}}*/
5099/* External entry points */
b8ffc8df 5100char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
a0d0e21e 5101{ return do_pathify_dirspec(dir,buf,0); }
b8ffc8df 5102char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
a0d0e21e
LW		 5103{ return do_pathify_dirspec(dir,buf,1); }
5104
2497a41f 5105/*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
b8ffc8df 5106static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
a0d0e21e 5107{
a480973c
JM		 5108 static char __tounixspec_retbuf[VMS_MAXRSS];
5109 char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
b8ffc8df 5110 const char *cp2;
a480973c 5111 int devlen, dirlen, retlen = VMS_MAXRSS;
0f20d7df 5112 int expand = 1; /* guarantee room for leading and trailing slashes */
2d9f3838 5113 unsigned short int trnlnm_iter_count;
f7ddb74a 5114 int cmp_rslt;
a0d0e21e 5115
748a9306 5116 if (spec == NULL) return NULL;
e518068a 5117 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
a0d0e21e 5118 if (buf) rslt = buf;
e518068a 5119 else if (ts) {
5120 retlen = strlen(spec);
5121 cp1 = strchr(spec,'[');
5122 if (!cp1) cp1 = strchr(spec,'<');
5123 if (cp1) {
f86702cc 5124 for (cp1++; *cp1; cp1++) {
5125 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
5126 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5127 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5128 }
e518068a 5129 }
a02a5408 5130 Newx(rslt,retlen+2+2*expand,char);
e518068a 5131 }
a0d0e21e 5132 else rslt = __tounixspec_retbuf;
f7ddb74a 5133
2497a41f
JM		 5134 /* New VMS specific format needs translation
5135 * glob passes filenames with trailing '\n' and expects this preserved.
5136 */
5137 if (decc_posix_compliant_pathnames) {
5138 if (strncmp(spec, "\"^UP^", 5) == 0) {
5139 char * uspec;
5140 char *tunix;
5141 int tunix_len;
5142 int nl_flag;
5143
5144 Newx(tunix, VMS_MAXRSS + 1,char);
5145 strcpy(tunix, spec);
5146 tunix_len = strlen(tunix);
5147 nl_flag = 0;
5148 if (tunix[tunix_len - 1] == '\n') {
5149 tunix[tunix_len - 1] = '\"';
5150 tunix[tunix_len] = '\0';
5151 tunix_len--;
5152 nl_flag = 1;
5153 }
5154 uspec = decc$translate_vms(tunix);
5155 Safefree(tunix);
5156 if ((int)uspec > 0) {
5157 strcpy(rslt,uspec);
5158 if (nl_flag) {
5159 strcat(rslt,"\n");
5160 }
5161 else {
5162 /* If we can not translate it, makemaker wants as-is */
5163 strcpy(rslt, spec);
5164 }
5165 return rslt;
5166 }
5167 }
5168 }
5169
f7ddb74a
JM		 5170 cmp_rslt = 0; /* Presume VMS */
5171 cp1 = strchr(spec, '/');
5172 if (cp1 == NULL)
5173 cmp_rslt = 0;
5174
5175 /* Look for EFS ^/ */
5176 if (decc_efs_charset) {
5177 while (cp1 != NULL) {
5178 cp2 = cp1 - 1;
5179 if (*cp2 != '^') {
5180 /* Found illegal VMS, assume UNIX */
5181 cmp_rslt = 1;
5182 break;
5183 }
5184 cp1++;
5185 cp1 = strchr(cp1, '/');
5186 }
5187 }
5188
5189 /* Look for "." and ".." */
5190 if (decc_filename_unix_report) {
5191 if (spec[0] == '.') {
5192 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5193 cmp_rslt = 1;
5194 }
5195 else {
5196 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5197 cmp_rslt = 1;
5198 }
5199 }
5200 }
5201 }
5202 /* This is already UNIX or at least nothing VMS understands */
5203 if (cmp_rslt) {
a0d0e21e
LW		 5204 strcpy(rslt,spec);
5205 return rslt;
5206 }
5207
5208 cp1 = rslt;
5209 cp2 = spec;
5210 dirend = strrchr(spec,']');
5211 if (dirend == NULL) dirend = strrchr(spec,'>');
5212 if (dirend == NULL) dirend = strchr(spec,':');
5213 if (dirend == NULL) {
5214 strcpy(rslt,spec);
5215 return rslt;
5216 }
f7ddb74a
JM		 5217
5218 /* Special case 1 - sys$posix_root = / */
5219#if __CRTL_VER >= 70000000
5220 if (!decc_disable_posix_root) {
5221 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5222 *cp1 = '/';
5223 cp1++;
5224 cp2 = cp2 + 15;
5225 }
5226 }
5227#endif
5228
5229 /* Special case 2 - Convert NLA0: to /dev/null */
5230#if __CRTL_VER < 70000000
5231 cmp_rslt = strncmp(spec,"NLA0:", 5);
5232 if (cmp_rslt != 0)
5233 cmp_rslt = strncmp(spec,"nla0:", 5);
5234#else
5235 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5236#endif
5237 if (cmp_rslt == 0) {
5238 strcpy(rslt, "/dev/null");
5239 cp1 = cp1 + 9;
5240 cp2 = cp2 + 5;
5241 if (spec[6] != '\0') {
5242 cp1[9] == '/';
5243 cp1++;
5244 cp2++;
5245 }
5246 }
5247
5248 /* Also handle special case "SYS$SCRATCH:" */
5249#if __CRTL_VER < 70000000
5250 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5251 if (cmp_rslt != 0)
5252 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5253#else
5254 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5255#endif
5256 if (cmp_rslt == 0) {
5257 int islnm;
5258
5259 islnm = my_trnlnm(tmp, "TMP", 0);
5260 if (!islnm) {
5261 strcpy(rslt, "/tmp");
5262 cp1 = cp1 + 4;
5263 cp2 = cp2 + 12;
5264 if (spec[12] != '\0') {
5265 cp1[4] == '/';
5266 cp1++;
5267 cp2++;
5268 }
5269 }
5270 }
5271
a5f75d66 5272 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 5273 *(cp1++) = '/';
5274 }
5275 else { /* the VMS spec begins with directories */
5276 cp2++;
a5f75d66 5277 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 5278 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
a5f75d66
AD		 5279 return rslt;
5280 }
f7ddb74a 5281 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
a0d0e21e
LW		 5282 if (getcwd(tmp,sizeof tmp,1) == NULL) {
5283 if (ts) Safefree(rslt);
5284 return NULL;
5285 }
2d9f3838 5286 trnlnm_iter_count = 0;
a0d0e21e
LW		 5287 do {
5288 cp3 = tmp;
5289 while (*cp3 != ':' && *cp3) cp3++;
5290 *(cp3++) = '\0';
5291 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 5292 trnlnm_iter_count++;
5293 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 5294 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 5295 if (ts && !buf &&
e518068a 5296 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 5297 retlen = devlen + dirlen;
f86702cc 5298 Renew(rslt,retlen+1+2*expand,char);
5299 cp1 = rslt;
5300 }
5301 cp3 = tmp;
5302 *(cp1++) = '/';
5303 while (*cp3) {
5304 *(cp1++) = *(cp3++);
5305 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
a0d0e21e 5306 }
f86702cc 5307 *(cp1++) = '/';
5308 }
f7ddb74a
JM		 5309 if ((*cp2 == '^')) {
5310 /* EFS file escape, pass the next character as is */
5311 /* Fix me: HEX encoding for UNICODE not implemented */
5312 cp2++;
5313 }
f86702cc 5314 else if ( *cp2 == '.') {
5315 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5316 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5317 cp2 += 3;
5318 }
5319 else cp2++;
a0d0e21e 5320 }
a0d0e21e
LW		 5321 }
5322 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 5323 if ((*cp2 == '^')) {
5324 /* EFS file escape, pass the next character as is */
5325 /* Fix me: HEX encoding for UNICODE not implemented */
5326 cp2++;
5327 *(cp1++) = *cp2;
5328 }
a0d0e21e
LW		 5329 if (*cp2 == ':') {
5330 *(cp1++) = '/';
5331 if (*(cp2+1) == '[') cp2++;
5332 }
f86702cc 5333 else if (*cp2 == ']' || *cp2 == '>') {
5334 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5335 }
f7ddb74a 5336 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 5337 *(cp1++) = '/';
e518068a 5338 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5339 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5340 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5341 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5342 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5343 }
f86702cc 5344 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5345 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5346 cp2 += 2;
5347 }
a0d0e21e
LW		 5348 }
5349 else if (*cp2 == '-') {
5350 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5351 while (*cp2 == '-') {
5352 cp2++;
5353 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5354 }
5355 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5356 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 5357 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 5358 return NULL;
5359 }
a0d0e21e
LW		 5360 }
5361 else *(cp1++) = *cp2;
5362 }
5363 else *(cp1++) = *cp2;
5364 }
5365 while (*cp2) *(cp1++) = *(cp2++);
5366 *cp1 = '\0';
5367
f7ddb74a
JM		 5368 /* This still leaves /000000/ when working with a
5369 * VMS device root or concealed root.
5370 */
5371 {
5372 int ulen;
5373 char * zeros;
5374
5375 ulen = strlen(rslt);
5376
5377 /* Get rid of "000000/ in rooted filespecs */
5378 if (ulen > 7) {
5379 zeros = strstr(rslt, "/000000/");
5380 if (zeros != NULL) {
5381 int mlen;
5382 mlen = ulen - (zeros - rslt) - 7;
5383 memmove(zeros, &zeros[7], mlen);
5384 ulen = ulen - 7;
5385 rslt[ulen] = '\0';
5386 }
5387 }
5388 }
5389
a0d0e21e
LW		 5390 return rslt;
5391
5392} /* end of do_tounixspec() */
5393/*}}}*/
5394/* External entry points */
b8ffc8df
RGS		 5395char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5396char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
a0d0e21e 5397
2497a41f
JM		 5398#if __CRTL_VER >= 80200000 && !defined(__VAX)
5399
5400static int posix_to_vmsspec
5401 (char *vmspath, int vmspath_len, const char *unixpath) {
5402int sts;
5403struct FAB myfab = cc$rms_fab;
5404struct NAML mynam = cc$rms_naml;
5405struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5406 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5407char *esa;
5408char *vms_delim;
5409int dir_flag;
5410int unixlen;
5411
5412 /* If not a posix spec already, convert it */
5413 dir_flag = 0;
5414 unixlen = strlen(unixpath);
5415 if (unixlen == 0) {
5416 vmspath[0] = '\0';
5417 return SS$_NORMAL;
5418 }
5419 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5420 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5421 }
5422 else {
5423 /* This is already a VMS specification, no conversion */
5424 unixlen--;
5425 strncpy(vmspath,unixpath, vmspath_len);
5426 }
5427 vmspath[vmspath_len] = 0;
5428 if (unixpath[unixlen - 1] == '/')
5429 dir_flag = 1;
a480973c 5430 Newx(esa, VMS_MAXRSS, char);
2497a41f
JM		 5431 myfab.fab$l_fna = vmspath;
5432 myfab.fab$b_fns = strlen(vmspath);
5433 myfab.fab$l_naml = &mynam;
5434 mynam.naml$l_esa = NULL;
5435 mynam.naml$b_ess = 0;
5436 mynam.naml$l_long_expand = esa;
a480973c 5437 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
2497a41f
JM		 5438 mynam.naml$l_rsa = NULL;
5439 mynam.naml$b_rss = 0;
5440 if (decc_efs_case_preserve)
5441 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5442 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5443
5444 /* Set up the remaining naml fields */
5445 sts = sys$parse(&myfab);
5446
5447 /* It failed! Try again as a UNIX filespec */
5448 if (!(sts & 1)) {
5449 Safefree(esa);
5450 return sts;
5451 }
5452
5453 /* get the Device ID and the FID */
5454 sts = sys$search(&myfab);
5455 /* on any failure, returned the POSIX ^UP^ filespec */
5456 if (!(sts & 1)) {
5457 Safefree(esa);
5458 return sts;
5459 }
5460 specdsc.dsc$a_pointer = vmspath;
5461 specdsc.dsc$w_length = vmspath_len;
5462
5463 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5464 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5465 sts = lib$fid_to_name
5466 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5467
5468 /* on any failure, returned the POSIX ^UP^ filespec */
5469 if (!(sts & 1)) {
5470 /* This can happen if user does not have permission to read directories */
5471 if (strncmp(unixpath,"\"^UP^",5) != 0)
5472 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5473 else
5474 strcpy(vmspath, unixpath);
5475 }
5476 else {
5477 vmspath[specdsc.dsc$w_length] = 0;
5478
5479 /* Are we expecting a directory? */
5480 if (dir_flag != 0) {
5481 int i;
5482 char *eptr;
5483
5484 eptr = NULL;
5485
5486 i = specdsc.dsc$w_length - 1;
5487 while (i > 0) {
5488 int zercnt;
5489 zercnt = 0;
5490 /* Version must be '1' */
5491 if (vmspath[i--] != '1')
5492 break;
5493 /* Version delimiter is one of ".;" */
5494 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5495 break;
5496 i--;
5497 if (vmspath[i--] != 'R')
5498 break;
5499 if (vmspath[i--] != 'I')
5500 break;
5501 if (vmspath[i--] != 'D')
5502 break;
5503 if (vmspath[i--] != '.')
5504 break;
5505 eptr = &vmspath[i+1];
5506 while (i > 0) {
5507 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5508 if (vmspath[i-1] != '^') {
5509 if (zercnt != 6) {
5510 *eptr = vmspath[i];
5511 eptr[1] = '\0';
5512 vmspath[i] = '.';
5513 break;
5514 }
5515 else {
5516 /* Get rid of 6 imaginary zero directory filename */
5517 vmspath[i+1] = '\0';
5518 }
5519 }
5520 }
5521 if (vmspath[i] == '0')
5522 zercnt++;
5523 else
5524 zercnt = 10;
5525 i--;
5526 }
5527 break;
5528 }
5529 }
5530 }
5531 Safefree(esa);
5532 return sts;
5533}
5534
5535/* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5536static int posix_to_vmsspec_hardway
5537 (char *vmspath, int vmspath_len, const char *unixpath) {
5538
5539char *esa;
5540const char *unixptr;
5541char *vmsptr;
5542const char *lastslash;
5543const char *lastdot;
5544int unixlen;
5545int vmslen;
5546int dir_start;
5547int dir_dot;
5548int quoted;
5549
5550
5551 unixptr = unixpath;
5552 dir_dot = 0;
5553
5554 /* Ignore leading "/" characters */
5555 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5556 unixptr++;
5557 }
5558 unixlen = strlen(unixptr);
5559
5560 /* Do nothing with blank paths */
5561 if (unixlen == 0) {
5562 vmspath[0] = '\0';
5563 return SS$_NORMAL;
5564 }
5565
5566 lastslash = strrchr(unixptr,'/');
5567 lastdot = strrchr(unixptr,'.');
5568
5569
5570 /* last dot is last dot or past end of string */
5571 if (lastdot == NULL)
5572 lastdot = unixptr + unixlen;
5573
5574 /* if no directories, set last slash to beginning of string */
5575 if (lastslash == NULL) {
5576 lastslash = unixptr;
5577 }
5578 else {
5579 /* Watch out for trailing "." after last slash, still a directory */
5580 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5581 lastslash = unixptr + unixlen;
5582 }
5583
5584 /* Watch out for traiing ".." after last slash, still a directory */
5585 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5586 lastslash = unixptr + unixlen;
5587 }
5588
5589 /* dots in directories are aways escaped */
5590 if (lastdot < lastslash)
5591 lastdot = unixptr + unixlen;
5592 }
5593
5594 /* if (unixptr < lastslash) then we are in a directory */
5595
5596 dir_start = 0;
5597 quoted = 0;
5598
5599 vmsptr = vmspath;
5600 vmslen = 0;
5601
5602 /* This could have a "^UP^ on the front */
5603 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5604 quoted = 1;
5605 unixptr+= 5;
5606 }
5607
5608 /* Start with the UNIX path */
5609 if (*unixptr != '/') {
5610 /* relative paths */
5611 if (lastslash > unixptr) {
5612 int dotdir_seen;
5613
5614 /* skip leading ./ */
5615 dotdir_seen = 0;
5616 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5617 dotdir_seen = 1;
5618 unixptr++;
5619 unixptr++;
5620 }
5621
5622 /* Are we still in a directory? */
5623 if (unixptr <= lastslash) {
5624 *vmsptr++ = '[';
5625 vmslen = 1;
5626 dir_start = 1;
5627
5628 /* if not backing up, then it is relative forward. */
5629 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5630 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5631 *vmsptr++ = '.';
5632 vmslen++;
5633 dir_dot = 1;
5634 }
5635 }
5636 else {
5637 if (dotdir_seen) {
5638 /* Perl wants an empty directory here to tell the difference
5639 * between a DCL commmand and a filename
5640 */
5641 *vmsptr++ = '[';
5642 *vmsptr++ = ']';
5643 vmslen = 2;
5644 }
5645 }
5646 }
5647 else {
5648 /* Handle two special files . and .. */
5649 if (unixptr[0] == '.') {
5650 if (unixptr[1] == '\0') {
5651 *vmsptr++ = '[';
5652 *vmsptr++ = ']';
5653 vmslen += 2;
5654 *vmsptr++ = '\0';
5655 return SS$_NORMAL;
5656 }
5657 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5658 *vmsptr++ = '[';
5659 *vmsptr++ = '-';
5660 *vmsptr++ = ']';
5661 vmslen += 3;
5662 *vmsptr++ = '\0';
5663 return SS$_NORMAL;
5664 }
5665 }
5666 }
5667 }
5668 else { /* Absolute PATH handling */
5669 int sts;
5670 char * nextslash;
5671 int seg_len;
5672 /* Need to find out where root is */
5673
5674 /* In theory, this procedure should never get an absolute POSIX pathname
5675 * that can not be found on the POSIX root.
5676 * In practice, that can not be relied on, and things will show up
5677 * here that are a VMS device name or concealed logical name instead.
5678 * So to make things work, this procedure must be tolerant.
5679 */
5680 Newx(esa, vmspath_len, char);
5681
5682 sts = SS$_NORMAL;
5683 nextslash = strchr(&unixptr[1],'/');
5684 seg_len = 0;
5685 if (nextslash != NULL) {
5686 seg_len = nextslash - &unixptr[1];
5687 strncpy(vmspath, unixptr, seg_len + 1);
5688 vmspath[seg_len+1] = 0;
5689 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5690 }
5691
5692 if (sts & 1) {
5693 /* This is verified to be a real path */
5694
5695 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5696 strcpy(vmspath, esa);
5697 vmslen = strlen(vmspath);
5698 vmsptr = vmspath + vmslen;
5699 unixptr++;
5700 if (unixptr < lastslash) {
5701 char * rptr;
5702 vmsptr--;
5703 *vmsptr++ = '.';
5704 dir_start = 1;
5705 dir_dot = 1;
5706 if (vmslen > 7) {
5707 int cmp;
5708 rptr = vmsptr - 7;
5709 cmp = strcmp(rptr,"000000.");
5710 if (cmp == 0) {
5711 vmslen -= 7;
5712 vmsptr -= 7;
5713 vmsptr[1] = '\0';
5714 } /* removing 6 zeros */
5715 } /* vmslen < 7, no 6 zeros possible */
5716 } /* Not in a directory */
5717 } /* end of verified real path handling */
5718 else {
5719 int add_6zero;
5720 int islnm;
5721
5722 /* Ok, we have a device or a concealed root that is not in POSIX
5723 * or we have garbage. Make the best of it.
5724 */
5725
5726 /* Posix to VMS destroyed this, so copy it again */
5727 strncpy(vmspath, &unixptr[1], seg_len);
5728 vmspath[seg_len] = 0;
5729 vmslen = seg_len;
5730 vmsptr = &vmsptr[vmslen];
5731 islnm = 0;
5732
5733 /* Now do we need to add the fake 6 zero directory to it? */
5734 add_6zero = 1;
5735 if ((*lastslash == '/') && (nextslash < lastslash)) {
5736 /* No there is another directory */
5737 add_6zero = 0;
5738 }
5739 else {
5740 int trnend;
5741
5742 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206
CB		 5743 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5744 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 5745
5746 /* if this was a logical name, ']' or '>' must be present */
5747 /* if not a logical name, then assume a device and hope. */
5748 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5749
5750 /* if log name and trailing '.' then rooted - treat as device */
5751 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5752
5753 /* Fix me, if not a logical name, a device lookup should be
5754 * done to see if the device is file structured. If the device
5755 * is not file structured, the 6 zeros should not be put on.
5756 *
5757 * As it is, perl is occasionally looking for dev:[000000]tty.
5758 * which looks a little strange.
5759 */
5760
5761 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5762 /* No real directory present */
5763 add_6zero = 1;
5764 }
5765 }
5766
5767 /* Put the device delimiter on */
5768 *vmsptr++ = ':';
5769 vmslen++;
5770 unixptr = nextslash;
5771 unixptr++;
5772
5773 /* Start directory if needed */
5774 if (!islnm || add_6zero) {
5775 *vmsptr++ = '[';
5776 vmslen++;
5777 dir_start = 1;
5778 }
5779
5780 /* add fake 000000] if needed */
5781 if (add_6zero) {
5782 *vmsptr++ = '0';
5783 *vmsptr++ = '0';
5784 *vmsptr++ = '0';
5785 *vmsptr++ = '0';
5786 *vmsptr++ = '0';
5787 *vmsptr++ = '0';
5788 *vmsptr++ = ']';
5789 vmslen += 7;
5790 dir_start = 0;
5791 }
5792
5793 } /* non-POSIX translation */
5794 Safefree(esa);
5795 } /* End of relative/absolute path handling */
5796
5797 while ((*unixptr) && (vmslen < vmspath_len)){
5798 int dash_flag;
5799
5800 dash_flag = 0;
5801
5802 if (dir_start != 0) {
5803
5804 /* First characters in a directory are handled special */
5805 while ((*unixptr == '/') ||
5806 ((*unixptr == '.') &&
5807 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5808 int loop_flag;
5809
5810 loop_flag = 0;
5811
5812 /* Skip redundant / in specification */
5813 while ((*unixptr == '/') && (dir_start != 0)) {
5814 loop_flag = 1;
5815 unixptr++;
5816 if (unixptr == lastslash)
5817 break;
5818 }
5819 if (unixptr == lastslash)
5820 break;
5821
5822 /* Skip redundant ./ characters */
5823 while ((*unixptr == '.') &&
5824 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5825 loop_flag = 1;
5826 unixptr++;
5827 if (unixptr == lastslash)
5828 break;
5829 if (*unixptr == '/')
5830 unixptr++;
5831 }
5832 if (unixptr == lastslash)
5833 break;
5834
5835 /* Skip redundant ../ characters */
5836 while ((*unixptr == '.') && (unixptr[1] == '.') &&
5837 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5838 /* Set the backing up flag */
5839 loop_flag = 1;
5840 dir_dot = 0;
5841 dash_flag = 1;
5842 *vmsptr++ = '-';
5843 vmslen++;
5844 unixptr++; /* first . */
5845 unixptr++; /* second . */
5846 if (unixptr == lastslash)
5847 break;
5848 if (*unixptr == '/') /* The slash */
5849 unixptr++;
5850 }
5851 if (unixptr == lastslash)
5852 break;
5853
5854 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5855 /* Not needed when VMS is pretending to be UNIX. */
5856
5857 /* Is this loop stuck because of too many dots? */
5858 if (loop_flag == 0) {
5859 /* Exit the loop and pass the rest through */
5860 break;
5861 }
5862 }
5863
5864 /* Are we done with directories yet? */
5865 if (unixptr >= lastslash) {
5866
5867 /* Watch out for trailing dots */
5868 if (dir_dot != 0) {
5869 vmslen --;
5870 vmsptr--;
5871 }
5872 *vmsptr++ = ']';
5873 vmslen++;
5874 dash_flag = 0;
5875 dir_start = 0;
5876 if (*unixptr == '/')
5877 unixptr++;
5878 }
5879 else {
5880 /* Have we stopped backing up? */
5881 if (dash_flag) {
5882 *vmsptr++ = '.';
5883 vmslen++;
5884 dash_flag = 0;
5885 /* dir_start continues to be = 1 */
5886 }
5887 if (*unixptr == '-') {
5888 *vmsptr++ = '^';
5889 *vmsptr++ = *unixptr++;
5890 vmslen += 2;
5891 dir_start = 0;
5892
5893 /* Now are we done with directories yet? */
5894 if (unixptr >= lastslash) {
5895
5896 /* Watch out for trailing dots */
5897 if (dir_dot != 0) {
5898 vmslen --;
5899 vmsptr--;
5900 }
5901
5902 *vmsptr++ = ']';
5903 vmslen++;
5904 dash_flag = 0;
5905 dir_start = 0;
5906 }
5907 }
5908 }
5909 }
5910
5911 /* All done? */
5912 if (*unixptr == '\0')
5913 break;
5914
5915 /* Normal characters - More EFS work probably needed */
5916 dir_start = 0;
5917 dir_dot = 0;
5918
5919 switch(*unixptr) {
5920 case '/':
5921 /* remove multiple / */
5922 while (unixptr[1] == '/') {
5923 unixptr++;
5924 }
5925 if (unixptr == lastslash) {
5926 /* Watch out for trailing dots */
5927 if (dir_dot != 0) {
5928 vmslen --;
5929 vmsptr--;
5930 }
5931 *vmsptr++ = ']';
5932 }
5933 else {
5934 dir_start = 1;
5935 *vmsptr++ = '.';
5936 dir_dot = 1;
5937
5938 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5939 /* Not needed when VMS is pretending to be UNIX. */
5940
5941 }
5942 dash_flag = 0;
5943 if (*unixptr != '\0')
5944 unixptr++;
5945 vmslen++;
5946 break;
5947 case '?':
5948 *vmsptr++ = '%';
5949 vmslen++;
5950 unixptr++;
5951 break;
5952 case ' ':
5953 *vmsptr++ = '^';
5954 *vmsptr++ = '_';
5955 vmslen += 2;
5956 unixptr++;
5957 break;
5958 case '.':
5959 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5960 *vmsptr++ = '^';
5961 *vmsptr++ = '.';
5962 vmslen += 2;
5963 unixptr++;
5964
5965 /* trailing dot ==> '^..' on VMS */
5966 if (*unixptr == '\0') {
5967 *vmsptr++ = '.';
5968 vmslen++;
5969 }
5970 *vmsptr++ = *unixptr++;
5971 vmslen ++;
5972 }
5973 if (quoted && (unixptr[1] == '\0')) {
5974 unixptr++;
5975 break;
5976 }
5977 *vmsptr++ = '^';
5978 *vmsptr++ = *unixptr++;
5979 vmslen += 2;
5980 break;
5981 case '~':
5982 case ';':
5983 case '\\':
5984 *vmsptr++ = '^';
5985 *vmsptr++ = *unixptr++;
5986 vmslen += 2;
5987 break;
5988 default:
5989 if (*unixptr != '\0') {
5990 *vmsptr++ = *unixptr++;
5991 vmslen++;
5992 }
5993 break;
5994 }
5995 }
5996
5997 /* Make sure directory is closed */
5998 if (unixptr == lastslash) {
5999 char *vmsptr2;
6000 vmsptr2 = vmsptr - 1;
6001
6002 if (*vmsptr2 != ']') {
6003 *vmsptr2--;
6004
6005 /* directories do not end in a dot bracket */
6006 if (*vmsptr2 == '.') {
6007 vmsptr2--;
6008
6009 /* ^. is allowed */
6010 if (*vmsptr2 != '^') {
6011 vmsptr--; /* back up over the dot */
6012 }
6013 }
6014 *vmsptr++ = ']';
6015 }
6016 }
6017 else {
6018 char *vmsptr2;
6019 /* Add a trailing dot if a file with no extension */
6020 vmsptr2 = vmsptr - 1;
6021 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6022 (*lastdot != '.')) {
6023 *vmsptr++ = '.';
6024 vmslen++;
6025 }
6026 }
6027
6028 *vmsptr = '\0';
6029 return SS$_NORMAL;
6030}
6031#endif
6032
a0d0e21e 6033/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
b8ffc8df 6034static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
a480973c 6035 static char __tovmsspec_retbuf[VMS_MAXRSS];
e518068a 6036 char *rslt, *dirend;
f7ddb74a
JM		 6037 char *lastdot;
6038 char *vms_delim;
b8ffc8df
RGS		 6039 register char *cp1;
6040 const char *cp2;
e518068a 6041 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 6042 int rslt_len;
6043 int no_type_seen;
a0d0e21e 6044
748a9306 6045 if (path == NULL) return NULL;
2497a41f 6046 rslt_len = VMS_MAXRSS;
a0d0e21e 6047 if (buf) rslt = buf;
a480973c 6048 else if (ts) Newx(rslt, VMS_MAXRSS, char);
a0d0e21e 6049 else rslt = __tovmsspec_retbuf;
748a9306 6050 if (strpbrk(path,"]:>") ||
a0d0e21e 6051 (dirend = strrchr(path,'/')) == NULL) {
748a9306
LW		 6052 if (path[0] == '.') {
6053 if (path[1] == '\0') strcpy(rslt,"[]");
6054 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6055 else strcpy(rslt,path); /* probably garbage */
6056 }
6057 else strcpy(rslt,path);
a0d0e21e
LW		 6058 return rslt;
6059 }
f7ddb74a 6060
2497a41f
JM		 6061 /* Posix specifications are now a native VMS format */
6062 /*--------------------------------------------------*/
6063#if __CRTL_VER >= 80200000 && !defined(__VAX)
6064 if (decc_posix_compliant_pathnames) {
6065 if (strncmp(path,"\"^UP^",5) == 0) {
6066 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6067 return rslt;
6068 }
6069 }
6070#endif
6071
f7ddb74a
JM		 6072 vms_delim = strpbrk(path,"]:>");
6073
2497a41f
JM		 6074 if ((vms_delim != NULL) ||
6075 ((dirend = strrchr(path,'/')) == NULL)) {
6076
6077 /* VMS special characters found! */
6078
6079 if (path[0] == '.') {
6080 if (path[1] == '\0') strcpy(rslt,"[]");
6081 else if (path[1] == '.' && path[2] == '\0')
6082 strcpy(rslt,"[-]");
6083
6084 /* Dot preceeding a device or directory ? */
6085 else {
6086 /* If not in POSIX mode, pass it through and hope it works */
6087#if __CRTL_VER >= 80200000 && !defined(__VAX)
6088 if (!decc_posix_compliant_pathnames)
6089 strcpy(rslt,path); /* probably garbage */
6090 else
6091 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6092#else
6093 strcpy(rslt,path); /* probably garbage */
6094#endif
6095 }
6096 }
6097 else {
6098
6099 /* If no VMS characters and in POSIX mode, convert it!
6100 * This is the easiest way to get directory specifications
6101 * handled correctly in POSIX mode
6102 */
6103#if __CRTL_VER >= 80200000 && !defined(__VAX)
6104 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6105 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6106 else {
6107 /* No unix path separators - presume VMS already */
6108 strcpy(rslt,path);
6109 }
6110#else
6111 strcpy(rslt,path); /* probably garbage */
6112#endif
6113 }
6114 return rslt;
6115 }
6116
6117/* If POSIX mode active, handle the conversion */
6118#if __CRTL_VER >= 80200000 && !defined(__VAX)
6119 if (decc_posix_compliant_pathnames) {
6120 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6121 return rslt;
6122 }
6123#endif
f7ddb74a 6124
f86702cc 6125 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 6126 if (!*(dirend+2)) dirend +=2;
6127 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
f86702cc 6128 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 6129 }
f7ddb74a 6130
a0d0e21e
LW		 6131 cp1 = rslt;
6132 cp2 = path;
f7ddb74a 6133 lastdot = strrchr(cp2,'.');
a0d0e21e 6134 if (*cp2 == '/') {
a480973c 6135 char *trndev;
e518068a 6136 int islnm, rooted;
6137 STRLEN trnend;
6138
b7ae7a0d 6139 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 6140 if (!*(cp2+1)) {
f7ddb74a
JM		 6141 if (decc_disable_posix_root) {
6142 strcpy(rslt,"sys$disk:[000000]");
6143 }
6144 else {
6145 strcpy(rslt,"sys$posix_root:[000000]");
6146 }
61bb5906
CB		 6147 return rslt;
6148 }
a0d0e21e 6149 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 6150 *cp1 = '\0';
a480973c 6151 Newx(trndev, VMS_MAXRSS, char);
c07a80fd 6152 islnm = my_trnlnm(rslt,trndev,0);
f7ddb74a
JM		 6153
6154 /* DECC special handling */
6155 if (!islnm) {
6156 if (strcmp(rslt,"bin") == 0) {
6157 strcpy(rslt,"sys$system");
6158 cp1 = rslt + 10;
6159 *cp1 = 0;
6160 islnm = my_trnlnm(rslt,trndev,0);
6161 }
6162 else if (strcmp(rslt,"tmp") == 0) {
6163 strcpy(rslt,"sys$scratch");
6164 cp1 = rslt + 11;
6165 *cp1 = 0;
6166 islnm = my_trnlnm(rslt,trndev,0);
6167 }
6168 else if (!decc_disable_posix_root) {
6169 strcpy(rslt, "sys$posix_root");
6170 cp1 = rslt + 13;
6171 *cp1 = 0;
6172 cp2 = path;
6173 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6174 islnm = my_trnlnm(rslt,trndev,0);
6175 }
6176 else if (strcmp(rslt,"dev") == 0) {
6177 if (strncmp(cp2,"/null", 5) == 0) {
6178 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6179 strcpy(rslt,"NLA0");
6180 cp1 = rslt + 4;
6181 *cp1 = 0;
6182 cp2 = cp2 + 5;
6183 islnm = my_trnlnm(rslt,trndev,0);
6184 }
6185 }
6186 }
6187 }
6188
e518068a 6189 trnend = islnm ? strlen(trndev) - 1 : 0;
6190 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6191 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6192 /* If the first element of the path is a logical name, determine
6193 * whether it has to be translated so we can add more directories. */
6194 if (!islnm || rooted) {
6195 *(cp1++) = ':';
6196 *(cp1++) = '[';
6197 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6198 else cp2++;
6199 }
6200 else {
6201 if (cp2 != dirend) {
e518068a 6202 strcpy(rslt,trndev);
6203 cp1 = rslt + trnend;
755b3d5d
JM		 6204 if (*cp2 != 0) {
6205 *(cp1++) = '.';
6206 cp2++;
6207 }
e518068a 6208 }
6209 else {
f7ddb74a
JM		 6210 if (decc_disable_posix_root) {
6211 *(cp1++) = ':';
6212 hasdir = 0;
6213 }
e518068a 6214 }
6215 }
a480973c 6216 Safefree(trndev);
748a9306 6217 }
a0d0e21e
LW		 6218 else {
6219 *(cp1++) = '[';
748a9306
LW		 6220 if (*cp2 == '.') {
6221 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6222 cp2 += 2; /* skip over "./" - it's redundant */
6223 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6224 }
6225 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6226 *(cp1++) = '-'; /* "../" --> "-" */
6227 cp2 += 3;
6228 }
f86702cc 6229 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6230 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6231 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6232 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6233 cp2 += 4;
6234 }
f7ddb74a
JM		 6235 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6236 /* Escape the extra dots in EFS file specifications */
6237 *(cp1++) = '^';
6238 }
748a9306
LW		 6239 if (cp2 > dirend) cp2 = dirend;
6240 }
6241 else *(cp1++) = '.';
6242 }
6243 for (; cp2 < dirend; cp2++) {
6244 if (*cp2 == '/') {
01b8edb6 6245 if (*(cp2-1) == '/') continue;
748a9306
LW		 6246 if (*(cp1-1) != '.') *(cp1++) = '.';
6247 infront = 0;
6248 }
6249 else if (!infront && *cp2 == '.') {
01b8edb6 6250 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6251 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 6252 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6253 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 6254 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 6255 else { /* back up over previous directory name */
6256 cp1--;
6257 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6258 if (*(cp1-1) == '[') {
6259 memcpy(cp1,"000000.",7);
6260 cp1 += 7;
6261 }
748a9306
LW		 6262 }
6263 cp2 += 2;
01b8edb6 6264 if (cp2 == dirend) break;
748a9306 6265 }
f86702cc 6266 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6267 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6268 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6269 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6270 if (!*(cp2+3)) {
6271 *(cp1++) = '.'; /* Simulate trailing '/' */
6272 cp2 += 2; /* for loop will incr this to == dirend */
6273 }
6274 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6275 }
f7ddb74a
JM		 6276 else {
6277 if (decc_efs_charset == 0)
6278 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6279 else {
6280 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6281 *(cp1++) = '.';
6282 }
6283 }
748a9306
LW		 6284 }
6285 else {
e518068a 6286 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 6287 if (*cp2 == '.') {
6288 if (decc_efs_charset == 0)
6289 *(cp1++) = '_';
6290 else {
6291 *(cp1++) = '^';
6292 *(cp1++) = '.';
6293 }
6294 }
748a9306
LW		 6295 else *(cp1++) = *cp2;
6296 infront = 1;
6297 }
a0d0e21e 6298 }
748a9306 6299 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 6300 if (hasdir) *(cp1++) = ']';
748a9306 6301 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 6302 /* fixme for ODS5 */
6303 no_type_seen = 0;
6304 if (cp2 > lastdot)
6305 no_type_seen = 1;
6306 while (*cp2) {
6307 switch(*cp2) {
6308 case '?':
6309 *(cp1++) = '%';
6310 cp2++;
6311 case ' ':
6312 *(cp1)++ = '^';
6313 *(cp1)++ = '_';
6314 cp2++;
6315 break;
6316 case '.':
6317 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6318 decc_readdir_dropdotnotype) {
6319 *(cp1)++ = '^';
6320 *(cp1)++ = '.';
6321 cp2++;
6322
6323 /* trailing dot ==> '^..' on VMS */
6324 if (*cp2 == '\0') {
6325 *(cp1++) = '.';
6326 no_type_seen = 0;
6327 }
6328 }
6329 else {
6330 *(cp1++) = *(cp2++);
6331 no_type_seen = 0;
6332 }
6333 break;
6334 case '\"':
6335 case '~':
6336 case '`':
6337 case '!':
6338 case '#':
6339 case '%':
6340 case '^':
6341 case '&':
6342 case '(':
6343 case ')':
6344 case '=':
6345 case '+':
6346 case '\'':
6347 case '@':
6348 case '[':
6349 case ']':
6350 case '{':
6351 case '}':
6352 case ':':
6353 case '\\':
6354 case '|':
6355 case '<':
6356 case '>':
6357 *(cp1++) = '^';
6358 *(cp1++) = *(cp2++);
6359 break;
6360 case ';':
6361 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6362 * which is wrong. UNIX notation should be ".dir. unless
6363 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6364 * changing this behavior could break more things at this time.
2497a41f
JM		 6365 * efs character set effectively does not allow "." to be a version
6366 * delimiter as a further complication about changing this.
f7ddb74a
JM		 6367 */
6368 if (decc_filename_unix_report != 0) {
6369 *(cp1++) = '^';
6370 }
6371 *(cp1++) = *(cp2++);
6372 break;
6373 default:
6374 *(cp1++) = *(cp2++);
6375 }
6376 }
6377 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6378 char *lcp1;
6379 lcp1 = cp1;
6380 lcp1--;
6381 /* Fix me for "^]", but that requires making sure that you do
6382 * not back up past the start of the filename
6383 */
6384 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6385 *cp1++ = '.';
6386 }
a0d0e21e
LW		 6387 *cp1 = '\0';
6388
6389 return rslt;
6390
6391} /* end of do_tovmsspec() */
6392/*}}}*/
6393/* External entry points */
2fbb330f
JM		 6394char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6395char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
a0d0e21e
LW		 6396
6397/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
b8ffc8df 6398static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
a480973c 6399 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 6400 int vmslen;
a480973c 6401 char *pathified, *vmsified, *cp;
a0d0e21e 6402
748a9306 6403 if (path == NULL) return NULL;
a480973c
JM		 6404 Newx(pathified, VMS_MAXRSS, char);
6405 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6406 Safefree(pathified);
6407 return NULL;
6408 }
6409 Newx(vmsified, VMS_MAXRSS, char);
6410 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6411 Safefree(pathified);
6412 Safefree(vmsified);
6413 return NULL;
6414 }
6415 Safefree(pathified);
6416 if (buf) {
6417 Safefree(vmsified);
6418 return buf;
6419 }
a0d0e21e
LW		 6420 else if (ts) {
6421 vmslen = strlen(vmsified);
a02a5408 6422 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 6423 memcpy(cp,vmsified,vmslen);
6424 cp[vmslen] = '\0';
a480973c 6425 Safefree(vmsified);
a0d0e21e
LW		 6426 return cp;
6427 }
6428 else {
6429 strcpy(__tovmspath_retbuf,vmsified);
a480973c 6430 Safefree(vmsified);
a0d0e21e
LW		 6431 return __tovmspath_retbuf;
6432 }
6433
6434} /* end of do_tovmspath() */
6435/*}}}*/
6436/* External entry points */
b8ffc8df
RGS		 6437char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6438char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
a0d0e21e
LW		 6439
6440
6441/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
b8ffc8df 6442static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
a480973c 6443 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 6444 int unixlen;
a480973c 6445 char *pathified, *unixified, *cp;
a0d0e21e 6446
748a9306 6447 if (path == NULL) return NULL;
a480973c
JM		 6448 Newx(pathified, VMS_MAXRSS, char);
6449 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6450 Safefree(pathified);
6451 return NULL;
6452 }
6453 Newx(unixified, VMS_MAXRSS, char);
6454 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6455 Safefree(pathified);
6456 Safefree(unixified);
6457 return NULL;
6458 }
6459 Safefree(pathified);
6460 if (buf) {
6461 Safefree(unixified);
6462 return buf;
6463 }
a0d0e21e
LW		 6464 else if (ts) {
6465 unixlen = strlen(unixified);
a02a5408 6466 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 6467 memcpy(cp,unixified,unixlen);
6468 cp[unixlen] = '\0';
a480973c 6469 Safefree(unixified);
a0d0e21e
LW		 6470 return cp;
6471 }
6472 else {
6473 strcpy(__tounixpath_retbuf,unixified);
a480973c 6474 Safefree(unixified);
a0d0e21e
LW		 6475 return __tounixpath_retbuf;
6476 }
6477
6478} /* end of do_tounixpath() */
6479/*}}}*/
6480/* External entry points */
b8ffc8df
RGS		 6481char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6482char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
a0d0e21e
LW		 6483
6484/*
6485 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6486 *
6487 *****************************************************************************
6488 * *
6489 * Copyright (C) 1989-1994 by *
6490 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6491 * *
6492 * Permission is hereby granted for the reproduction of this software, *
6493 * on condition that this copyright notice is included in the reproduction, *
6494 * and that such reproduction is not for purposes of profit or material *
6495 * gain. *
6496 * *
6497 * 27-Aug-1994 Modified for inclusion in perl5 *
bd3fa61c 6498 * by Charles Bailey bailey@newman.upenn.edu *
a0d0e21e
LW		 6499 *****************************************************************************
6500 */
6501
6502/*
6503 * getredirection() is intended to aid in porting C programs
6504 * to VMS (Vax-11 C). The native VMS environment does not support
6505 * '>' and '<' I/O redirection, or command line wild card expansion,
6506 * or a command line pipe mechanism using the '|' AND background
6507 * command execution '&'. All of these capabilities are provided to any
6508 * C program which calls this procedure as the first thing in the
6509 * main program.
6510 * The piping mechanism will probably work with almost any 'filter' type
6511 * of program. With suitable modification, it may useful for other
6512 * portability problems as well.
6513 *
6514 * Author: Mark Pizzolato mark@infocomm.com
6515 */
6516struct list_item
6517 {
6518 struct list_item *next;
6519 char *value;
6520 };
6521
6522static void add_item(struct list_item **head,
6523 struct list_item **tail,
6524 char *value,
6525 int *count);
6526
4b19af01
CB		 6527static void mp_expand_wild_cards(pTHX_ char *item,
6528 struct list_item **head,
6529 struct list_item **tail,
6530 int *count);
a0d0e21e 6531
8df869cb 6532static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 6533
fd8cd3a3 6534static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 6535
6536/*{{{ void getredirection(int *ac, char ***av)*/
84902520 6537static void
4b19af01 6538mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 6539/*
6540 * Process vms redirection arg's. Exit if any error is seen.
6541 * If getredirection() processes an argument, it is erased
6542 * from the vector. getredirection() returns a new argc and argv value.
6543 * In the event that a background command is requested (by a trailing "&"),
6544 * this routine creates a background subprocess, and simply exits the program.
6545 *
6546 * Warning: do not try to simplify the code for vms. The code
6547 * presupposes that getredirection() is called before any data is
6548 * read from stdin or written to stdout.
6549 *
6550 * Normal usage is as follows:
6551 *
6552 * main(argc, argv)
6553 * int argc;
6554 * char *argv[];
6555 * {
6556 * getredirection(&argc, &argv);
6557 * }
6558 */
6559{
6560 int argc = *ac; /* Argument Count */
6561 char **argv = *av; /* Argument Vector */
6562 char *ap; /* Argument pointer */
6563 int j; /* argv[] index */
6564 int item_count = 0; /* Count of Items in List */
6565 struct list_item *list_head = 0; /* First Item in List */
6566 struct list_item *list_tail; /* Last Item in List */
6567 char *in = NULL; /* Input File Name */
6568 char *out = NULL; /* Output File Name */
6569 char *outmode = "w"; /* Mode to Open Output File */
6570 char *err = NULL; /* Error File Name */
6571 char *errmode = "w"; /* Mode to Open Error File */
6572 int cmargc = 0; /* Piped Command Arg Count */
6573 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 6574
6575 /*
6576 * First handle the case where the last thing on the line ends with
6577 * a '&'. This indicates the desire for the command to be run in a
6578 * subprocess, so we satisfy that desire.
6579 */
6580 ap = argv[argc-1];
6581 if (0 == strcmp("&", ap))
8c3eed29 6582 exit(background_process(aTHX_ --argc, argv));
e518068a 6583 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 6584 {
6585 ap[strlen(ap)-1] = '\0';
8c3eed29 6586 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 6587 }
6588 /*
6589 * Now we handle the general redirection cases that involve '>', '>>',
6590 * '<', and pipes '|'.
6591 */
6592 for (j = 0; j < argc; ++j)
6593 {
6594 if (0 == strcmp("<", argv[j]))
6595 {
6596 if (j+1 >= argc)
6597 {
fd71b04b 6598 fprintf(stderr,"No input file after < on command line");
748a9306 6599 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6600 }
6601 in = argv[++j];
6602 continue;
6603 }
6604 if ('<' == *(ap = argv[j]))
6605 {
6606 in = 1 + ap;
6607 continue;
6608 }
6609 if (0 == strcmp(">", ap))
6610 {
6611 if (j+1 >= argc)
6612 {
fd71b04b 6613 fprintf(stderr,"No output file after > on command line");
748a9306 6614 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6615 }
6616 out = argv[++j];
6617 continue;
6618 }
6619 if ('>' == *ap)
6620 {
6621 if ('>' == ap[1])
6622 {
6623 outmode = "a";
6624 if ('\0' == ap[2])
6625 out = argv[++j];
6626 else
6627 out = 2 + ap;
6628 }
6629 else
6630 out = 1 + ap;
6631 if (j >= argc)
6632 {
fd71b04b 6633 fprintf(stderr,"No output file after > or >> on command line");
748a9306 6634 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6635 }
6636 continue;
6637 }
6638 if (('2' == *ap) && ('>' == ap[1]))
6639 {
6640 if ('>' == ap[2])
6641 {
6642 errmode = "a";
6643 if ('\0' == ap[3])
6644 err = argv[++j];
6645 else
6646 err = 3 + ap;
6647 }
6648 else
6649 if ('\0' == ap[2])
6650 err = argv[++j];
6651 else
748a9306 6652 err = 2 + ap;
a0d0e21e
LW		 6653 if (j >= argc)
6654 {
fd71b04b 6655 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 6656 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6657 }
6658 continue;
6659 }
6660 if (0 == strcmp("|", argv[j]))
6661 {
6662 if (j+1 >= argc)
6663 {
fd71b04b 6664 fprintf(stderr,"No command into which to pipe on command line");
748a9306 6665 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6666 }
6667 cmargc = argc-(j+1);
6668 cmargv = &argv[j+1];
6669 argc = j;
6670 continue;
6671 }
6672 if ('|' == *(ap = argv[j]))
6673 {
6674 ++argv[j];
6675 cmargc = argc-j;
6676 cmargv = &argv[j];
6677 argc = j;
6678 continue;
6679 }
6680 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6681 }
6682 /*
6683 * Allocate and fill in the new argument vector, Some Unix's terminate
6684 * the list with an extra null pointer.
6685 */
a480973c 6686 Newx(argv, item_count+1, char *);
e0ef6b43 6687 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
a0d0e21e
LW		 6688 *av = argv;
6689 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6690 argv[j] = list_head->value;
6691 *ac = item_count;
6692 if (cmargv != NULL)
6693 {
6694 if (out != NULL)
6695 {
fd71b04b 6696 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 6697 exit(LIB$_INVARGORD);
a0d0e21e 6698 }
fd8cd3a3 6699 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 6700 }
6701
6702 /* Check for input from a pipe (mailbox) */
6703
a5f75d66 6704 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 6705 {
6706 char mbxname[L_tmpnam];
6707 long int bufsize;
6708 long int dvi_item = DVI$_DEVBUFSIZ;
6709 $DESCRIPTOR(mbxnam, "");
6710 $DESCRIPTOR(mbxdevnam, "");
6711
6712 /* Input from a pipe, reopen it in binary mode to disable */
6713 /* carriage control processing. */
6714
fd71b04b 6715 fgetname(stdin, mbxname);
a0d0e21e
LW		 6716 mbxnam.dsc$a_pointer = mbxname;
6717 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6718 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6719 mbxdevnam.dsc$a_pointer = mbxname;
6720 mbxdevnam.dsc$w_length = sizeof(mbxname);
6721 dvi_item = DVI$_DEVNAM;
6722 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6723 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 6724 set_errno(0);
6725 set_vaxc_errno(1);
a0d0e21e
LW		 6726 freopen(mbxname, "rb", stdin);
6727 if (errno != 0)
6728 {
fd71b04b 6729 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 6730 exit(vaxc$errno);
a0d0e21e
LW		 6731 }
6732 }
6733 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6734 {
fd71b04b 6735 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 6736 exit(vaxc$errno);
a0d0e21e
LW		 6737 }
6738 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6739 {
fd71b04b 6740 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 6741 exit(vaxc$errno);
a0d0e21e 6742 }
fd8cd3a3 6743 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 6744
748a9306 6745 if (err != NULL) {
71d7ec5d 6746 if (strcmp(err,"&1") == 0) {
a15cef0c 6747 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 6748 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 6749 } else {
748a9306
LW		 6750 FILE *tmperr;
6751 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6752 {
fd71b04b 6753 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 6754 exit(vaxc$errno);
6755 }
6756 fclose(tmperr);
a15cef0c 6757 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 6758 {
6759 exit(vaxc$errno);
6760 }
fd8cd3a3 6761 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 6762 }
71d7ec5d 6763 }
a0d0e21e 6764#ifdef ARGPROC_DEBUG
740ce14c 6765 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 6766 for (j = 0; j < *ac; ++j)
740ce14c 6767 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 6768#endif
b7ae7a0d 6769 /* Clear errors we may have hit expanding wildcards, so they don't
6770 show up in Perl's $! later */
6771 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 6772} /* end of getredirection() */
6773/*}}}*/
6774
6775static void add_item(struct list_item **head,
6776 struct list_item **tail,
6777 char *value,
6778 int *count)
6779{
6780 if (*head == 0)
6781 {
e0ef6b43 6782 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
a0d0e21e
LW		 6783 *tail = *head;
6784 }
6785 else {
e0ef6b43 6786 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
a0d0e21e
LW		 6787 *tail = (*tail)->next;
6788 }
6789 (*tail)->value = value;
6790 ++(*count);
6791}
6792
4b19af01 6793static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 6794 struct list_item **head,
6795 struct list_item **tail,
6796 int *count)
6797{
6798int expcount = 0;
748a9306 6799unsigned long int context = 0;
a0d0e21e 6800int isunix = 0;
773da73d 6801int item_len = 0;
a0d0e21e
LW		 6802char *had_version;
6803char *had_device;
6804int had_directory;
f675dbe5 6805char *devdir,*cp;
a480973c 6806char *vmsspec;
a0d0e21e 6807$DESCRIPTOR(filespec, "");
748a9306 6808$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 6809$DESCRIPTOR(resultspec, "");
a480973c
JM		 6810unsigned long int lff_flags = 0;
6811int sts;
6812
6813#ifdef VMS_LONGNAME_SUPPORT
6814 lff_flags = LIB$M_FIL_LONG_NAMES;
6815#endif
a0d0e21e 6816
f675dbe5
CB		 6817 for (cp = item; *cp; cp++) {
6818 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6819 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6820 }
6821 if (!*cp || isspace(*cp))
a0d0e21e
LW		 6822 {
6823 add_item(head, tail, item, count);
6824 return;
6825 }
773da73d
JH		 6826 else
6827 {
6828 /* "double quoted" wild card expressions pass as is */
6829 /* From DCL that means using e.g.: */
6830 /* perl program """perl.*""" */
6831 item_len = strlen(item);
6832 if ( '"' == *item && '"' == item[item_len-1] )
6833 {
6834 item++;
6835 item[item_len-2] = '\0';
6836 add_item(head, tail, item, count);
6837 return;
6838 }
6839 }
a0d0e21e
LW		 6840 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6841 resultspec.dsc$b_class = DSC$K_CLASS_D;
6842 resultspec.dsc$a_pointer = NULL;
a480973c 6843 Newx(vmsspec, VMS_MAXRSS, char);
748a9306 6844 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e
LW		 6845 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6846 if (!isunix || !filespec.dsc$a_pointer)
6847 filespec.dsc$a_pointer = item;
6848 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6849 /*
6850 * Only return version specs, if the caller specified a version
6851 */
6852 had_version = strchr(item, ';');
6853 /*
6854 * Only return device and directory specs, if the caller specifed either.
6855 */
6856 had_device = strchr(item, ':');
6857 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6858
a480973c
JM		 6859 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6860 (&filespec, &resultspec, &context,
6861 &defaultspec, 0, 0, &lff_flags)))
a0d0e21e
LW		 6862 {
6863 char *string;
6864 char *c;
6865
a02a5408 6866 Newx(string,resultspec.dsc$w_length+1,char);
a0d0e21e
LW		 6867 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6868 string[resultspec.dsc$w_length] = '\0';
6869 if (NULL == had_version)
f7ddb74a 6870 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 6871 if ((!had_directory) && (had_device == NULL))
6872 {
6873 if (NULL == (devdir = strrchr(string, ']')))
6874 devdir = strrchr(string, '>');
6875 strcpy(string, devdir + 1);
6876 }
6877 /*
6878 * Be consistent with what the C RTL has already done to the rest of
6879 * the argv items and lowercase all of these names.
6880 */
f7ddb74a
JM		 6881 if (!decc_efs_case_preserve) {
6882 for (c = string; *c; ++c)
a0d0e21e
LW		 6883 if (isupper(*c))
6884 *c = tolower(*c);
f7ddb74a 6885 }
f86702cc 6886 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 6887 add_item(head, tail, string, count);
6888 ++expcount;
a480973c
JM		 6889 }
6890 Safefree(vmsspec);
c07a80fd 6891 if (sts != RMS$_NMF)
6892 {
6893 set_vaxc_errno(sts);
6894 switch (sts)
6895 {
f282b18d 6896 case RMS$_FNF: case RMS$_DNF:
c07a80fd 6897 set_errno(ENOENT); break;
f282b18d
CB		 6898 case RMS$_DIR:
6899 set_errno(ENOTDIR); break;
c07a80fd 6900 case RMS$_DEV:
6901 set_errno(ENODEV); break;
f282b18d 6902 case RMS$_FNM: case RMS$_SYN:
c07a80fd 6903 set_errno(EINVAL); break;
6904 case RMS$_PRV:
6905 set_errno(EACCES); break;
6906 default:
b7ae7a0d 6907 _ckvmssts_noperl(sts);
c07a80fd 6908 }
6909 }
a0d0e21e
LW		 6910 if (expcount == 0)
6911 add_item(head, tail, item, count);
b7ae7a0d 6912 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6913 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 6914}
6915
6916static int child_st[2];/* Event Flag set when child process completes */
6917
748a9306 6918static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 6919
748a9306 6920static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 6921{
6922short iosb[4];
6923
6924 if (0 == child_st[0])
6925 {
6926#ifdef ARGPROC_DEBUG
740ce14c 6927 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 6928#endif
6929 fflush(stdout); /* Have to flush pipe for binary data to */
6930 /* terminate properly -- <tp@mccall.com> */
6931 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6932 sys$dassgn(child_chan);
6933 fclose(stdout);
6934 sys$synch(0, child_st);
6935 }
6936 return(1);
6937}
6938
6939static void sig_child(int chan)
6940{
6941#ifdef ARGPROC_DEBUG
740ce14c 6942 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 6943#endif
6944 if (child_st[0] == 0)
6945 child_st[0] = 1;
6946}
6947
748a9306 6948static struct exit_control_block exit_block =
a0d0e21e
LW		 6949 {
6950 0,
6951 exit_handler,
6952 1,
6953 &exit_block.exit_status,
6954 0
6955 };
6956
ff7adb52
CL		 6957static void
6958pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 6959{
ff7adb52 6960 PerlIO *fp;
218fdd94 6961 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 6962 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6963 int sts, j, l, ismcr, quote, tquote = 0;
6964
218fdd94
CL		 6965 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
6966 vms_execfree(vmscmd);
ff7adb52
CL		 6967
6968 j = l = 0;
6969 p = subcmd;
6970 q = cmargv[0];
6971 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
6972 && toupper(*(q+2)) == 'R' && !*(q+3);
6973
6974 while (q && l < MAX_DCL_LINE_LENGTH) {
6975 if (!*q) {
6976 if (j > 0 && quote) {
6977 *p++ = '"';
6978 l++;
6979 }
6980 q = cmargv[++j];
6981 if (q) {
6982 if (ismcr && j > 1) quote = 1;
6983 tquote = (strchr(q,' ')) != NULL || *q == '\0';
6984 *p++ = ' ';
6985 l++;
6986 if (quote || tquote) {
6987 *p++ = '"';
6988 l++;
6989 }
6990 }
6991 } else {
6992 if ((quote||tquote) && *q == '"') {
6993 *p++ = '"';
6994 l++;
a0d0e21e 6995 }
ff7adb52
CL		 6996 *p++ = *q++;
6997 l++;
6998 }
6999 }
7000 *p = '\0';
a0d0e21e 7001
218fdd94 7002 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
ff7adb52
CL		 7003 if (fp == Nullfp) {
7004 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
a0d0e21e
LW		 7005 }
7006}
7007
8df869cb 7008static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 7009{
a480973c 7010char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 7011$DESCRIPTOR(value, "");
7012static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7013static $DESCRIPTOR(null, "NLA0:");
7014static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7015char pidstring[80];
7016$DESCRIPTOR(pidstr, "");
7017int pid;
748a9306 7018unsigned long int flags = 17, one = 1, retsts;
a480973c 7019int len;
a0d0e21e
LW		 7020
7021 strcat(command, argv[0]);
a480973c
JM		 7022 len = strlen(command);
7023 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e
LW		 7024 {
7025 strcat(command, " \"");
7026 strcat(command, *(++argv));
7027 strcat(command, "\"");
a480973c 7028 len = strlen(command);
a0d0e21e
LW		 7029 }
7030 value.dsc$a_pointer = command;
7031 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 7032 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 7033 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7034 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 7035 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 7036 }
7037 else {
b7ae7a0d 7038 _ckvmssts_noperl(retsts);
748a9306 7039 }
a0d0e21e 7040#ifdef ARGPROC_DEBUG
740ce14c 7041 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 7042#endif
7043 sprintf(pidstring, "%08X", pid);
740ce14c 7044 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 7045 pidstr.dsc$a_pointer = pidstring;
7046 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7047 lib$set_symbol(&pidsymbol, &pidstr);
7048 return(SS$_NORMAL);
7049}
7050/*}}}*/
7051/***** End of code taken from Mark Pizzolato's argproc.c package *****/
7052
84902520
TB		 7053
7054/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 7055/* Older VAXC header files lack these constants */
7056#ifndef JPI$_RIGHTS_SIZE
7057# define JPI$_RIGHTS_SIZE 817
7058#endif
7059#ifndef KGB$M_SUBSYSTEM
7060# define KGB$M_SUBSYSTEM 0x8
7061#endif
a480973c 7062
e0ef6b43
CB		 7063/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7064
84902520
TB		 7065/*{{{void vms_image_init(int *, char ***)*/
7066void
7067vms_image_init(int *argcp, char ***argvp)
7068{
f675dbe5
CB		 7069 char eqv[LNM$C_NAMLENGTH+1] = "";
7070 unsigned int len, tabct = 8, tabidx = 0;
7071 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 7072 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7073 unsigned short int dummy, rlen;
f675dbe5 7074 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 7075#if defined(PERL_IMPLICIT_CONTEXT)
7076 pTHX = NULL;
7077#endif
61bb5906
CB		 7078 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7079 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7080 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7081 { 0, 0, 0, 0} };
84902520 7082
2e34cc90 7083#ifdef KILL_BY_SIGPRC
f7ddb74a 7084 Perl_csighandler_init();
2e34cc90
CL		 7085#endif
7086
fd8cd3a3
DS		 7087 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7088 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 7089 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7090 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 7091 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 7092 will_taint = TRUE;
84902520
TB		 7093 break;
7094 }
7095 }
61bb5906 7096 /* Rights identifiers might trigger tainting as well. */
f675dbe5 7097 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 7098 while (rlen < rsz) {
7099 /* We didn't get all the identifiers on the first pass. Allocate a
7100 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7101 * were needed to hold all identifiers at time of last call; we'll
7102 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 7103 * If it gave us less than it wanted to despite ample buffer space,
7104 * something's broken. Is your system missing a system identifier?
61bb5906 7105 */
22d4bb9c
CB		 7106 if (rsz <= jpilist[1].buflen) {
7107 /* Perl_croak accvios when used this early in startup. */
7108 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7109 rsz, (unsigned long) jpilist[1].buflen,
7110 "Check your rights database for corruption.\n");
7111 exit(SS$_ABORT);
7112 }
e0ef6b43
CB		 7113 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7114 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
61bb5906 7115 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 7116 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7117 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 7118 }
7119 mask = jpilist[1].bufadr;
7120 /* Check attribute flags for each identifier (2nd longword); protected
7121 * subsystem identifiers trigger tainting.
7122 */
7123 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7124 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 7125 will_taint = TRUE;
61bb5906
CB		 7126 break;
7127 }
7128 }
7129 if (mask != rlst) Safefree(mask);
7130 }
f7ddb74a
JM		 7131
7132 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7133 * logical, some versions of the CRTL will add a phanthom /000000/
7134 * directory. This needs to be removed.
7135 */
7136 if (decc_filename_unix_report) {
7137 char * zeros;
7138 int ulen;
7139 ulen = strlen(argvp[0][0]);
7140 if (ulen > 7) {
7141 zeros = strstr(argvp[0][0], "/000000/");
7142 if (zeros != NULL) {
7143 int mlen;
7144 mlen = ulen - (zeros - argvp[0][0]) - 7;
7145 memmove(zeros, &zeros[7], mlen);
7146 ulen = ulen - 7;
7147 argvp[0][0][ulen] = '\0';
7148 }
7149 }
7150 /* It also may have a trailing dot that needs to be removed otherwise
7151 * it will be converted to VMS mode incorrectly.
7152 */
7153 ulen--;
7154 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7155 argvp[0][0][ulen] = '\0';
7156 }
7157
61bb5906 7158 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 7159 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 7160 * hasn't been allocated when vms_image_init() is called.
7161 */
f675dbe5 7162 if (will_taint) {
ec618cdf
CB		 7163 char **newargv, **oldargv;
7164 oldargv = *argvp;
e0ef6b43 7165 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
ec618cdf 7166 newargv[0] = oldargv[0];
e0ef6b43 7167 newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
ec618cdf
CB		 7168 strcpy(newargv[1], "-T");
7169 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7170 (*argcp)++;
7171 newargv[*argcp] = NULL;
61bb5906
CB		 7172 /* We orphan the old argv, since we don't know where it's come from,
7173 * so we don't know how to free it.
7174 */
ec618cdf 7175 *argvp = newargv;
61bb5906 7176 }
f675dbe5
CB		 7177 else { /* Did user explicitly request tainting? */
7178 int i;
7179 char *cp, **av = *argvp;
7180 for (i = 1; i < *argcp; i++) {
7181 if (*av[i] != '-') break;
7182 for (cp = av[i]+1; *cp; cp++) {
7183 if (*cp == 'T') { will_taint = 1; break; }
7184 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7185 strchr("DFIiMmx",*cp)) break;
7186 }
7187 if (will_taint) break;
7188 }
7189 }
7190
7191 for (tabidx = 0;
7192 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7193 tabidx++) {
e0ef6b43 7194 if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
f675dbe5
CB		 7195 else if (tabidx >= tabct) {
7196 tabct += 8;
e0ef6b43 7197 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
f675dbe5 7198 }
e0ef6b43 7199 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
f675dbe5
CB		 7200 tabvec[tabidx]->dsc$w_length = 0;
7201 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7202 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7203 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 7204 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 7205 }
7206 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7207
84902520 7208 getredirection(argcp,argvp);
3bc25146
CB		 7209#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7210 {
7211# include <reentrancy.h>
f7ddb74a 7212 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 7213 }
7214#endif
84902520
TB		 7215 return;
7216}
7217/*}}}*/
7218
7219
a0d0e21e
LW		 7220/* trim_unixpath()
7221 * Trim Unix-style prefix off filespec, so it looks like what a shell
7222 * glob expansion would return (i.e. from specified prefix on, not
7223 * full path). Note that returned filespec is Unix-style, regardless
7224 * of whether input filespec was VMS-style or Unix-style.
7225 *
a3e9d8c9 7226 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 7227 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7228 * vector of options; at present, only bit 0 is used, and if set tells
7229 * trim unixpath to try the current default directory as a prefix when
7230 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 7231 *
7232 * Returns !=0 on success, with trimmed filespec replacing contents of
7233 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 7234 */
f86702cc 7235/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 7236int
2fbb330f 7237Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 7238{
a480973c 7239 char *unixified, *unixwild,
f86702cc 7240 *template, *base, *end, *cp1, *cp2;
7241 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 7242
a480973c 7243 Newx(unixwild, VMS_MAXRSS, char);
a3e9d8c9 7244 if (!wildspec || !fspec) return 0;
2fbb330f 7245 template = unixwild;
a3e9d8c9 7246 if (strpbrk(wildspec,"]>:") != NULL) {
a480973c
JM		 7247 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7248 Safefree(unixwild);
7249 return 0;
7250 }
a3e9d8c9 7251 }
2fbb330f 7252 else {
a480973c
JM		 7253 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7254 unixwild[VMS_MAXRSS-1] = 0;
2fbb330f 7255 }
a480973c 7256 Newx(unixified, VMS_MAXRSS, char);
a0d0e21e 7257 if (strpbrk(fspec,"]>:") != NULL) {
a480973c
JM		 7258 if (do_tounixspec(fspec,unixified,0) == NULL) {
7259 Safefree(unixwild);
7260 Safefree(unixified);
7261 return 0;
7262 }
a0d0e21e 7263 else base = unixified;
a3e9d8c9 7264 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7265 * check to see that final result fits into (isn't longer than) fspec */
7266 reslen = strlen(fspec);
a0d0e21e
LW		 7267 }
7268 else base = fspec;
a3e9d8c9 7269
7270 /* No prefix or absolute path on wildcard, so nothing to remove */
7271 if (!*template || *template == '/') {
a480973c
JM		 7272 Safefree(unixwild);
7273 if (base == fspec) {
7274 Safefree(unixified);
7275 return 1;
7276 }
a3e9d8c9 7277 tmplen = strlen(unixified);
a480973c
JM		 7278 if (tmplen > reslen) {
7279 Safefree(unixified);
7280 return 0; /* not enough space */
7281 }
a3e9d8c9 7282 /* Copy unixified resultant, including trailing NUL */
7283 memmove(fspec,unixified,tmplen+1);
a480973c 7284 Safefree(unixified);
a3e9d8c9 7285 return 1;
7286 }
a0d0e21e 7287
f86702cc 7288 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7289 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7290 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7291 for (cp1 = end ;cp1 >= base; cp1--)
7292 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7293 { cp1++; break; }
7294 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
a480973c
JM		 7295 Safefree(unixified);
7296 Safefree(unixwild);
a3e9d8c9 7297 return 1;
7298 }
f86702cc 7299 else {
a480973c 7300 char *tpl, *lcres;
f86702cc 7301 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7302 int ells = 1, totells, segdirs, match;
a480973c 7303 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 7304 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7305
7306 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7307 totells = ells;
7308 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
a480973c 7309 Newx(tpl, VMS_MAXRSS, char);
f86702cc 7310 if (ellipsis == template && opts & 1) {
7311 /* Template begins with an ellipsis. Since we can't tell how many
7312 * directory names at the front of the resultant to keep for an
7313 * arbitrary starting point, we arbitrarily choose the current
7314 * default directory as a starting point. If it's there as a prefix,
7315 * clip it off. If not, fall through and act as if the leading
7316 * ellipsis weren't there (i.e. return shortest possible path that
7317 * could match template).
7318 */
a480973c
JM		 7319 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7320 Safefree(tpl);
7321 Safefree(unixified);
7322 Safefree(unixwild);
7323 return 0;
7324 }
f7ddb74a
JM		 7325 if (!decc_efs_case_preserve) {
7326 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7327 if (_tolower(*cp1) != _tolower(*cp2)) break;
7328 }
f86702cc 7329 segdirs = dirs - totells; /* Min # of dirs we must have left */
7330 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7331 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 7332 memmove(fspec,cp2+1,end - cp2);
a480973c
JM		 7333 Safefree(unixified);
7334 Safefree(unixwild);
7335 Safefree(tpl);
f86702cc 7336 return 1;
a3e9d8c9 7337 }
a3e9d8c9 7338 }
f86702cc 7339 /* First off, back up over constant elements at end of path */
7340 if (dirs) {
7341 for (front = end ; front >= base; front--)
7342 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 7343 }
a480973c
JM		 7344 Newx(lcres, VMS_MAXRSS, char);
7345 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7346 cp1++,cp2++) {
7347 if (!decc_efs_case_preserve) {
7348 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7349 }
7350 else {
7351 *cp2 = *cp1;
7352 }
7353 }
7354 if (cp1 != '\0') {
7355 Safefree(unixified);
7356 Safefree(unixwild);
7357 Safefree(lcres);
7358 Safefree(tpl);
7359 return 0; /* Path too long. */
f7ddb74a 7360 }
f86702cc 7361 lcend = cp2;
7362 *cp2 = '\0'; /* Pick up with memcpy later */
7363 lcfront = lcres + (front - base);
7364 /* Now skip over each ellipsis and try to match the path in front of it. */
7365 while (ells--) {
7366 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7367 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7368 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7369 if (cp1 < template) break; /* template started with an ellipsis */
7370 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7371 ellipsis = cp1; continue;
7372 }
a480973c 7373 wilddsc.dsc$a_pointer = tpl;
f86702cc 7374 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7375 nextell = cp1;
7376 for (segdirs = 0, cp2 = tpl;
a480973c 7377 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 7378 cp1++, cp2++) {
7379 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 7380 else {
7381 if (!decc_efs_case_preserve) {
7382 *cp2 = _tolower(*cp1); /* else lowercase for match */
7383 }
7384 else {
7385 *cp2 = *cp1; /* else preserve case for match */
7386 }
7387 }
f86702cc 7388 if (*cp2 == '/') segdirs++;
7389 }
a480973c
JM		 7390 if (cp1 != ellipsis - 1) {
7391 Safefree(unixified);
7392 Safefree(unixwild);
7393 Safefree(lcres);
7394 Safefree(tpl);
7395 return 0; /* Path too long */
7396 }
f86702cc 7397 /* Back up at least as many dirs as in template before matching */
7398 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7399 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7400 for (match = 0; cp1 > lcres;) {
7401 resdsc.dsc$a_pointer = cp1;
7402 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7403 match++;
7404 if (match == 1) lcfront = cp1;
7405 }
7406 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7407 }
a480973c
JM		 7408 if (!match) {
7409 Safefree(unixified);
7410 Safefree(unixwild);
7411 Safefree(lcres);
7412 Safefree(tpl);
7413 return 0; /* Can't find prefix ??? */
7414 }
f86702cc 7415 if (match > 1 && opts & 1) {
7416 /* This ... wildcard could cover more than one set of dirs (i.e.
7417 * a set of similar dir names is repeated). If the template
7418 * contains more than 1 ..., upstream elements could resolve the
7419 * ambiguity, but it's not worth a full backtracking setup here.
7420 * As a quick heuristic, clip off the current default directory
7421 * if it's present to find the trimmed spec, else use the
7422 * shortest string that this ... could cover.
7423 */
7424 char def[NAM$C_MAXRSS+1], *st;
7425
a480973c
JM		 7426 if (getcwd(def, sizeof def,0) == NULL) {
7427 Safefree(unixified);
7428 Safefree(unixwild);
7429 Safefree(lcres);
7430 Safefree(tpl);
7431 return 0;
7432 }
f7ddb74a
JM		 7433 if (!decc_efs_case_preserve) {
7434 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7435 if (_tolower(*cp1) != _tolower(*cp2)) break;
7436 }
f86702cc 7437 segdirs = dirs - totells; /* Min # of dirs we must have left */
7438 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7439 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 7440 memmove(fspec,cp2+1,end - cp2);
a480973c
JM		 7441 Safefree(lcres);
7442 Safefree(unixified);
7443 Safefree(unixwild);
7444 Safefree(tpl);
f86702cc 7445 return 1;
7446 }
7447 /* Nope -- stick with lcfront from above and keep going. */
7448 }
7449 }
18a3d61e 7450 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
a480973c
JM		 7451 Safefree(unixified);
7452 Safefree(unixwild);
7453 Safefree(lcres);
7454 Safefree(tpl);
a3e9d8c9 7455 return 1;
f86702cc 7456 ellipsis = nextell;
a0d0e21e 7457 }
a0d0e21e
LW		 7458
7459} /* end of trim_unixpath() */
7460/*}}}*/
7461
a0d0e21e
LW		 7462
7463/*
7464 * VMS readdir() routines.
7465 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 7466 *
bd3fa61c 7467 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 7468 * Minor modifications to original routines.
7469 */
7470
a9852f7c
CB		 7471/* readdir may have been redefined by reentr.h, so make sure we get
7472 * the local version for what we do here.
7473 */
7474#ifdef readdir
7475# undef readdir
7476#endif
7477#if !defined(PERL_IMPLICIT_CONTEXT)
7478# define readdir Perl_readdir
7479#else
7480# define readdir(a) Perl_readdir(aTHX_ a)
7481#endif
7482
a0d0e21e
LW		 7483 /* Number of elements in vms_versions array */
7484#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7485
7486/*
7487 * Open a directory, return a handle for later use.
7488 */
7489/*{{{ DIR *opendir(char*name) */
ddcbaa1c 7490DIR *
b8ffc8df 7491Perl_opendir(pTHX_ const char *name)
a0d0e21e 7492{
ddcbaa1c 7493 DIR *dd;
a0d0e21e 7494 char dir[NAM$C_MAXRSS+1];
61bb5906
CB		 7495 Stat_t sb;
7496
a0d0e21e 7497 if (do_tovmspath(name,dir,0) == NULL) {
61bb5906 7498 return NULL;
a0d0e21e 7499 }
ada67d10
CB		 7500 /* Check access before stat; otherwise stat does not
7501 * accurately report whether it's a directory.
7502 */
7503 if (!cando_by_name(S_IRUSR,0,dir)) {
fac786e7 7504 /* cando_by_name has already set errno */
ada67d10
CB		 7505 return NULL;
7506 }
61bb5906
CB		 7507 if (flex_stat(dir,&sb) == -1) return NULL;
7508 if (!S_ISDIR(sb.st_mode)) {
7509 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7510 return NULL;
7511 }
61bb5906 7512 /* Get memory for the handle, and the pattern. */
ddcbaa1c 7513 Newx(dd,1,DIR);
a02a5408 7514 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 7515
7516 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 7517 sprintf(dd->pattern, "%s*.*",dir);
a0d0e21e
LW		 7518 dd->context = 0;
7519 dd->count = 0;
7520 dd->vms_wantversions = 0;
7521 dd->pat.dsc$a_pointer = dd->pattern;
7522 dd->pat.dsc$w_length = strlen(dd->pattern);
7523 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7524 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 7525#if defined(USE_ITHREADS)
a02a5408 7526 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 7527 MUTEX_INIT( (perl_mutex *) dd->mutex );
7528#else
7529 dd->mutex = NULL;
7530#endif
a0d0e21e
LW		 7531
7532 return dd;
7533} /* end of opendir() */
7534/*}}}*/
7535
7536/*
7537 * Set the flag to indicate we want versions or not.
7538 */
7539/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7540void
ddcbaa1c 7541vmsreaddirversions(DIR *dd, int flag)
a0d0e21e
LW		 7542{
7543 dd->vms_wantversions = flag;
7544}
7545/*}}}*/
7546
7547/*
7548 * Free up an opened directory.
7549 */
7550/*{{{ void closedir(DIR *dd)*/
7551void
ddcbaa1c 7552Perl_closedir(DIR *dd)
a0d0e21e 7553{
f7ddb74a
JM		 7554 int sts;
7555
7556 sts = lib$find_file_end(&dd->context);
a0d0e21e 7557 Safefree(dd->pattern);
3bc25146 7558#if defined(USE_ITHREADS)
a9852f7c
CB		 7559 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7560 Safefree(dd->mutex);
7561#endif
f7ddb74a 7562 Safefree(dd);
a0d0e21e
LW		 7563}
7564/*}}}*/
7565
7566/*
7567 * Collect all the version numbers for the current file.
7568 */
7569static void
ddcbaa1c 7570collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 7571{
7572 struct dsc$descriptor_s pat;
7573 struct dsc$descriptor_s res;
ddcbaa1c 7574 struct dirent *e;
a0d0e21e
LW		 7575 char *p, *text, buff[sizeof dd->entry.d_name];
7576 int i;
7577 unsigned long context, tmpsts;
7578
7579 /* Convenient shorthand. */
7580 e = &dd->entry;
7581
7582 /* Add the version wildcard, ignoring the "*.*" put on before */
7583 i = strlen(dd->pattern);
a02a5408 7584 Newx(text,i + e->d_namlen + 3,char);
f7ddb74a
JM		 7585 strcpy(text, dd->pattern);
7586 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 7587
7588 /* Set up the pattern descriptor. */
7589 pat.dsc$a_pointer = text;
7590 pat.dsc$w_length = i + e->d_namlen - 1;
7591 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7592 pat.dsc$b_class = DSC$K_CLASS_S;
7593
7594 /* Set up result descriptor. */
7595 res.dsc$a_pointer = buff;
7596 res.dsc$w_length = sizeof buff - 2;
7597 res.dsc$b_dtype = DSC$K_DTYPE_T;
7598 res.dsc$b_class = DSC$K_CLASS_S;
7599
7600 /* Read files, collecting versions. */
7601 for (context = 0, e->vms_verscount = 0;
7602 e->vms_verscount < VERSIZE(e);
7603 e->vms_verscount++) {
7604 tmpsts = lib$find_file(&pat, &res, &context);
7605 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 7606 _ckvmssts(tmpsts);
a0d0e21e 7607 buff[sizeof buff - 1] = '\0';
748a9306 7608 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 7609 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7610 else
7611 e->vms_versions[e->vms_verscount] = -1;
7612 }
7613
748a9306 7614 _ckvmssts(lib$find_file_end(&context));
a0d0e21e
LW		 7615 Safefree(text);
7616
7617} /* end of collectversions() */
7618
7619/*
7620 * Read the next entry from the directory.
7621 */
7622/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 7623struct dirent *
7624Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 7625{
7626 struct dsc$descriptor_s res;
7627 char *p, buff[sizeof dd->entry.d_name];
a0d0e21e
LW		 7628 unsigned long int tmpsts;
7629
7630 /* Set up result descriptor, and get next file. */
7631 res.dsc$a_pointer = buff;
7632 res.dsc$w_length = sizeof buff - 2;
7633 res.dsc$b_dtype = DSC$K_DTYPE_T;
7634 res.dsc$b_class = DSC$K_CLASS_S;
a0d0e21e 7635 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4633a7c4
LW		 7636 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7637 if (!(tmpsts & 1)) {
7638 set_vaxc_errno(tmpsts);
7639 switch (tmpsts) {
7640 case RMS$_PRV:
c07a80fd 7641 set_errno(EACCES); break;
4633a7c4 7642 case RMS$_DEV:
c07a80fd 7643 set_errno(ENODEV); break;
4633a7c4 7644 case RMS$_DIR:
f282b18d
CB		 7645 set_errno(ENOTDIR); break;
7646 case RMS$_FNF: case RMS$_DNF:
c07a80fd 7647 set_errno(ENOENT); break;
4633a7c4
LW		 7648 default:
7649 set_errno(EVMSERR);
7650 }
7651 return NULL;
7652 }
7653 dd->count++;
a0d0e21e 7654 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
f7ddb74a
JM		 7655 if (!decc_efs_case_preserve) {
7656 buff[sizeof buff - 1] = '\0';
7657 for (p = buff; *p; p++) *p = _tolower(*p);
7658 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7659 *p = '\0';
7660 }
7661 else {
7662 /* we don't want to force to lowercase, just null terminate */
7663 buff[res.dsc$w_length] = '\0';
7664 }
f675dbe5
CB		 7665 for (p = buff; *p; p++) *p = _tolower(*p);
7666 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
a0d0e21e
LW		 7667 *p = '\0';
7668
7669 /* Skip any directory component and just copy the name. */
f7ddb74a
JM		 7670 if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7671 else strcpy(dd->entry.d_name, buff);
a0d0e21e
LW		 7672
7673 /* Clobber the version. */
748a9306 7674 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
a0d0e21e
LW		 7675
7676 dd->entry.d_namlen = strlen(dd->entry.d_name);
7677 dd->entry.vms_verscount = 0;
fd8cd3a3 7678 if (dd->vms_wantversions) collectversions(aTHX_ dd);
a0d0e21e
LW		 7679 return &dd->entry;
7680
7681} /* end of readdir() */
7682/*}}}*/
7683
7684/*
a9852f7c
CB		 7685 * Read the next entry from the directory -- thread-safe version.
7686 */
7687/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7688int
ddcbaa1c 7689Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 7690{
7691 int retval;
7692
7693 MUTEX_LOCK( (perl_mutex *) dd->mutex );
7694
7ded3206 7695 entry = readdir(dd);
a9852f7c
CB		 7696 *result = entry;
7697 retval = ( *result == NULL ? errno : 0 );
7698
7699 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7700
7701 return retval;
7702
7703} /* end of readdir_r() */
7704/*}}}*/
7705
7706/*
a0d0e21e
LW		 7707 * Return something that can be used in a seekdir later.
7708 */
7709/*{{{ long telldir(DIR *dd)*/
7710long
ddcbaa1c 7711Perl_telldir(DIR *dd)
a0d0e21e
LW		 7712{
7713 return dd->count;
7714}
7715/*}}}*/
7716
7717/*
7718 * Return to a spot where we used to be. Brute force.
7719 */
7720/*{{{ void seekdir(DIR *dd,long count)*/
7721void
ddcbaa1c 7722Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e
LW		 7723{
7724 int vms_wantversions;
a0d0e21e
LW		 7725
7726 /* If we haven't done anything yet... */
7727 if (dd->count == 0)
7728 return;
7729
7730 /* Remember some state, and clear it. */
7731 vms_wantversions = dd->vms_wantversions;
7732 dd->vms_wantversions = 0;
748a9306 7733 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 7734 dd->context = 0;
7735
7736 /* The increment is in readdir(). */
7737 for (dd->count = 0; dd->count < count; )
f7ddb74a 7738 readdir(dd);
a0d0e21e
LW		 7739
7740 dd->vms_wantversions = vms_wantversions;
7741
7742} /* end of seekdir() */
7743/*}}}*/
7744
7745/* VMS subprocess management
7746 *
7747 * my_vfork() - just a vfork(), after setting a flag to record that
7748 * the current script is trying a Unix-style fork/exec.
7749 *
7750 * vms_do_aexec() and vms_do_exec() are called in response to the
7751 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 7752 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 7753 * execvp (for those who really want to try this under VMS).
7754 * Otherwise, they do exactly what the perl docs say exec should
7755 * do - terminate the current script and invoke a new command
7756 * (See below for notes on command syntax.)
7757 *
7758 * do_aspawn() and do_spawn() implement the VMS side of the perl
7759 * 'system' function.
7760 *
7761 * Note on command arguments to perl 'exec' and 'system': When handled
7762 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7763 * are concatenated to form a DCL command string. If the first arg
7764 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 7765 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 7766 * the first token of the command is taken as the filespec of an image
7767 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 7768 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 7769 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 7770 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 7771 * but I hope it will form a happy medium between what VMS folks expect
7772 * from lib$spawn and what Unix folks expect from exec.
7773 */
7774
7775static int vfork_called;
7776
7777/*{{{int my_vfork()*/
7778int
7779my_vfork()
7780{
748a9306 7781 vfork_called++;
a0d0e21e
LW		 7782 return vfork();
7783}
7784/*}}}*/
7785
4633a7c4 7786
a0d0e21e 7787static void
218fdd94
CL		 7788vms_execfree(struct dsc$descriptor_s *vmscmd)
7789{
7790 if (vmscmd) {
7791 if (vmscmd->dsc$a_pointer) {
7792 Safefree(vmscmd->dsc$a_pointer);
7793 }
7794 Safefree(vmscmd);
4633a7c4
LW		 7795 }
7796}
7797
7798static char *
fd8cd3a3 7799setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 7800{
4633a7c4 7801 char *junk, *tmps = Nullch;
a0d0e21e
LW		 7802 register size_t cmdlen = 0;
7803 size_t rlen;
7804 register SV **idx;
2d8e6c8d 7805 STRLEN n_a;
a0d0e21e
LW		 7806
7807 idx = mark;
4633a7c4
LW		 7808 if (really) {
7809 tmps = SvPV(really,rlen);
7810 if (*tmps) {
7811 cmdlen += rlen + 1;
7812 idx++;
7813 }
a0d0e21e
LW		 7814 }
7815
7816 for (idx++; idx <= sp; idx++) {
7817 if (*idx) {
7818 junk = SvPVx(*idx,rlen);
7819 cmdlen += rlen ? rlen + 1 : 0;
7820 }
7821 }
a02a5408 7822 Newx(PL_Cmd,cmdlen+1,char);
a0d0e21e 7823
4633a7c4 7824 if (tmps && *tmps) {
6b88bc9c 7825 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 7826 mark++;
7827 }
6b88bc9c 7828 else *PL_Cmd = '\0';
a0d0e21e
LW		 7829 while (++mark <= sp) {
7830 if (*mark) {
3eeba6fb
CB		 7831 char *s = SvPVx(*mark,n_a);
7832 if (!*s) continue;
7833 if (*PL_Cmd) strcat(PL_Cmd," ");
7834 strcat(PL_Cmd,s);
a0d0e21e
LW		 7835 }
7836 }
6b88bc9c 7837 return PL_Cmd;
a0d0e21e
LW		 7838
7839} /* end of setup_argstr() */
7840
4633a7c4 7841
a0d0e21e 7842static unsigned long int
2fbb330f 7843setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 7844 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 7845{
aa779de1 7846 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
e886094b
JM		 7847 char image_name[NAM$C_MAXRSS+1];
7848 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 7849 $DESCRIPTOR(defdsc,".EXE");
8012a33e 7850 $DESCRIPTOR(defdsc2,".");
a0d0e21e 7851 $DESCRIPTOR(resdsc,resspec);
218fdd94 7852 struct dsc$descriptor_s *vmscmd;
a0d0e21e 7853 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 7854 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1 7855 register char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 7856 char * cmd;
7857 int cmdlen;
aa779de1 7858 register int isdcl;
a0d0e21e 7859
a02a5408 7860 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
2fbb330f
JM		 7861
7862 /* Make a copy for modification */
7863 cmdlen = strlen(incmd);
7864 Newx(cmd, cmdlen+1, char);
7865 strncpy(cmd, incmd, cmdlen);
7866 cmd[cmdlen] = 0;
e886094b
JM		 7867 image_name[0] = 0;
7868 image_argv[0] = 0;
2fbb330f 7869
218fdd94
CL		 7870 vmscmd->dsc$a_pointer = NULL;
7871 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
7872 vmscmd->dsc$b_class = DSC$K_CLASS_S;
7873 vmscmd->dsc$w_length = 0;
7874 if (pvmscmd) *pvmscmd = vmscmd;
7875
ff7adb52
CL		 7876 if (suggest_quote) *suggest_quote = 0;
7877
2fbb330f 7878 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
a2669cfc 7879 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 7880 Safefree(cmd);
7881 }
7882
a0d0e21e 7883 s = cmd;
2fbb330f 7884
a0d0e21e 7885 while (*s && isspace(*s)) s++;
aa779de1
CB		 7886
7887 if (*s == '@' || *s == '$') {
7888 vmsspec[0] = *s; rest = s + 1;
7889 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7890 }
7891 else { cp = vmsspec; rest = s; }
7892 if (*rest == '.' || *rest == '/') {
7893 char *cp2;
7894 for (cp2 = resspec;
7895 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7896 rest++, cp2++) *cp2 = *rest;
7897 *cp2 = '\0';
7898 if (do_tovmsspec(resspec,cp,0)) {
7899 s = vmsspec;
7900 if (*rest) {
7901 for (cp2 = vmsspec + strlen(vmsspec);
7902 *rest && cp2 - vmsspec < sizeof vmsspec;
7903 rest++, cp2++) *cp2 = *rest;
7904 *cp2 = '\0';
a0d0e21e
LW		 7905 }
7906 }
7907 }
aa779de1
CB		 7908 /* Intuit whether verb (first word of cmd) is a DCL command:
7909 * - if first nonspace char is '@', it's a DCL indirection
7910 * otherwise
7911 * - if verb contains a filespec separator, it's not a DCL command
7912 * - if it doesn't, caller tells us whether to default to a DCL
7913 * command, or to a local image unless told it's DCL (by leading '$')
7914 */
ff7adb52
CL		 7915 if (*s == '@') {
7916 isdcl = 1;
7917 if (suggest_quote) *suggest_quote = 1;
7918 } else {
aa779de1
CB		 7919 register char *filespec = strpbrk(s,":<[.;");
7920 rest = wordbreak = strpbrk(s," \"\t/");
7921 if (!wordbreak) wordbreak = s + strlen(s);
7922 if (*s == '$') check_img = 0;
7923 if (filespec && (filespec < wordbreak)) isdcl = 0;
7924 else isdcl = !check_img;
7925 }
7926
3eeba6fb 7927 if (!isdcl) {
aa779de1
CB		 7928 imgdsc.dsc$a_pointer = s;
7929 imgdsc.dsc$w_length = wordbreak - s;
a0d0e21e 7930 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8012a33e
CB		 7931 if (!(retsts&1)) {
7932 _ckvmssts(lib$find_file_end(&cxt));
7933 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
2497a41f
JM		 7934 if (!(retsts & 1) && *s == '$') {
7935 _ckvmssts(lib$find_file_end(&cxt));
7936 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7937 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7938 if (!(retsts&1)) {
7939 _ckvmssts(lib$find_file_end(&cxt));
7940 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7941 }
7942 }
aa779de1 7943 }
8012a33e
CB		 7944 _ckvmssts(lib$find_file_end(&cxt));
7945
aa779de1 7946 if (retsts & 1) {
8012a33e 7947 FILE *fp;
a0d0e21e
LW		 7948 s = resspec;
7949 while (*s && !isspace(*s)) s++;
7950 *s = '\0';
8012a33e
CB		 7951
7952 /* check that it's really not DCL with no file extension */
e886094b 7953 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 7954 if (fp) {
2497a41f
JM		 7955 char b[256] = {0,0,0,0};
7956 read(fileno(fp), b, 256);
8012a33e 7957 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 7958 if (isdcl) {
e886094b
JM		 7959 int shebang_len;
7960
2497a41f 7961 /* Check for script */
e886094b
JM		 7962 shebang_len = 0;
7963 if ((b[0] == '#') && (b[1] == '!'))
7964 shebang_len = 2;
7965#ifdef ALTERNATE_SHEBANG
7966 else {
7967 shebang_len = strlen(ALTERNATE_SHEBANG);
7968 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7969 char * perlstr;
7970 perlstr = strstr("perl",b);
7971 if (perlstr == NULL)
7972 shebang_len = 0;
7973 }
7974 else
7975 shebang_len = 0;
7976 }
7977#endif
7978
7979 if (shebang_len > 0) {
7980 int i;
7981 int j;
7982 char tmpspec[NAM$C_MAXRSS + 1];
7983
7984 i = shebang_len;
7985 /* Image is following after white space */
7986 /*--------------------------------------*/
7987 while (isprint(b[i]) && isspace(b[i]))
7988 i++;
7989
7990 j = 0;
7991 while (isprint(b[i]) && !isspace(b[i])) {
7992 tmpspec[j++] = b[i++];
7993 if (j >= NAM$C_MAXRSS)
7994 break;
7995 }
7996 tmpspec[j] = '\0';
7997
7998 /* There may be some default parameters to the image */
7999 /*---------------------------------------------------*/
8000 j = 0;
8001 while (isprint(b[i])) {
8002 image_argv[j++] = b[i++];
8003 if (j >= NAM$C_MAXRSS)
8004 break;
8005 }
8006 while ((j > 0) && !isprint(image_argv[j-1]))
8007 j--;
8008 image_argv[j] = 0;
8009
2497a41f 8010 /* It will need to be converted to VMS format and validated */
e886094b
JM		 8011 if (tmpspec[0] != '\0') {
8012 char * iname;
8013
8014 /* Try to find the exact program requested to be run */
8015 /*---------------------------------------------------*/
8016 iname = do_rmsexpand
8017 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8018 if (iname != NULL) {
8019 if (cando_by_name(S_IXUSR,0,image_name)) {
8020 /* MCR prefix needed */
8021 isdcl = 0;
8022 }
8023 else {
8024 /* Try again with a null type */
8025 /*----------------------------*/
8026 iname = do_rmsexpand
8027 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8028 if (iname != NULL) {
8029 if (cando_by_name(S_IXUSR,0,image_name)) {
8030 /* MCR prefix needed */
8031 isdcl = 0;
8032 }
8033 }
8034 }
8035
8036 /* Did we find the image to run the script? */
8037 /*------------------------------------------*/
8038 if (isdcl) {
8039 char *tchr;
8040
8041 /* Assume DCL or foreign command exists */
8042 /*--------------------------------------*/
8043 tchr = strrchr(tmpspec, '/');
8044 if (tchr != NULL) {
8045 tchr++;
8046 }
8047 else {
8048 tchr = tmpspec;
8049 }
8050 strcpy(image_name, tchr);
8051 }
8052 }
8053 }
2497a41f
JM		 8054 }
8055 }
8012a33e
CB		 8056 fclose(fp);
8057 }
8058 if (check_img && isdcl) return RMS$_FNF;
8059
3eeba6fb 8060 if (cando_by_name(S_IXUSR,0,resspec)) {
e886094b 8061 Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8012a33e 8062 if (!isdcl) {
218fdd94 8063 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
e886094b
JM		 8064 if (image_name[0] != 0) {
8065 strcat(vmscmd->dsc$a_pointer, image_name);
8066 strcat(vmscmd->dsc$a_pointer, " ");
8067 }
8068 } else if (image_name[0] != 0) {
8069 strcpy(vmscmd->dsc$a_pointer, image_name);
8070 strcat(vmscmd->dsc$a_pointer, " ");
8012a33e 8071 } else {
218fdd94 8072 strcpy(vmscmd->dsc$a_pointer,"@");
8012a33e 8073 }
e886094b
JM		 8074 if (suggest_quote) *suggest_quote = 1;
8075
8076 /* If there is an image name, use original command */
8077 if (image_name[0] == 0)
8078 strcat(vmscmd->dsc$a_pointer,resspec);
8079 else {
8080 rest = cmd;
8081 while (*rest && isspace(*rest)) rest++;
8082 }
8083
8084 if (image_argv[0] != 0) {
8085 strcat(vmscmd->dsc$a_pointer,image_argv);
8086 strcat(vmscmd->dsc$a_pointer, " ");
8087 }
8088 if (rest) {
8089 int rest_len;
8090 int vmscmd_len;
8091
8092 rest_len = strlen(rest);
8093 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8094 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8095 strcat(vmscmd->dsc$a_pointer,rest);
8096 else
8097 retsts = CLI$_BUFOVF;
8098 }
218fdd94 8099 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
2fbb330f 8100 Safefree(cmd);
218fdd94 8101 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb
CB		 8102 }
8103 else retsts = RMS$_PRV;
a0d0e21e
LW		 8104 }
8105 }
3eeba6fb 8106 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94
CL		 8107 vmscmd->dsc$w_length = strlen(cmd);
8108/* if (cmd == PL_Cmd) {
8109 vmscmd->dsc$a_pointer = PL_Cmd;
ff7adb52
CL		 8110 if (suggest_quote) *suggest_quote = 1;
8111 }
218fdd94
CL		 8112 else */
8113 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
ff7adb52 8114
2fbb330f
JM		 8115 Safefree(cmd);
8116
ff7adb52
CL		 8117 /* check if it's a symbol (for quoting purposes) */
8118 if (suggest_quote && !*suggest_quote) {
8119 int iss;
8120 char equiv[LNM$C_NAMLENGTH];
8121 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8122 eqvdsc.dsc$a_pointer = equiv;
8123
218fdd94 8124 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 8125 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8126 }
3eeba6fb
CB		 8127 if (!(retsts & 1)) {
8128 /* just hand off status values likely to be due to user error */
8129 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8130 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8131 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8132 else { _ckvmssts(retsts); }
8133 }
a0d0e21e 8134
218fdd94 8135 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 8136
a0d0e21e
LW		 8137} /* end of setup_cmddsc() */
8138
a3e9d8c9 8139
a0d0e21e
LW		 8140/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8141bool
fd8cd3a3 8142Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 8143{
a0d0e21e
LW		 8144 if (sp > mark) {
8145 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 8146 vfork_called--;
8147 if (vfork_called < 0) {
5c84aa53 8148 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 8149 vfork_called = 0;
8150 }
8151 else return do_aexec(really,mark,sp);
a0d0e21e 8152 }
4633a7c4 8153 /* no vfork - act VMSish */
fd8cd3a3 8154 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
748a9306 8155
a0d0e21e
LW		 8156 }
8157
8158 return FALSE;
8159} /* end of vms_do_aexec() */
8160/*}}}*/
8161
8162/* {{{bool vms_do_exec(char *cmd) */
8163bool
2fbb330f 8164Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 8165{
218fdd94 8166 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 8167
8168 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 8169 vfork_called--;
8170 if (vfork_called < 0) {
5c84aa53 8171 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 8172 vfork_called = 0;
8173 }
8174 else return do_exec(cmd);
a0d0e21e 8175 }
748a9306
LW		 8176
8177 { /* no vfork - act VMSish */
748a9306 8178 unsigned long int retsts;
a0d0e21e 8179
1e422769 8180 TAINT_ENV();
8181 TAINT_PROPER("exec");
218fdd94
CL		 8182 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8183 retsts = lib$do_command(vmscmd);
a0d0e21e 8184
09b7f37c 8185 switch (retsts) {
f282b18d 8186 case RMS$_FNF: case RMS$_DNF:
09b7f37c 8187 set_errno(ENOENT); break;
f282b18d 8188 case RMS$_DIR:
09b7f37c 8189 set_errno(ENOTDIR); break;
f282b18d
CB		 8190 case RMS$_DEV:
8191 set_errno(ENODEV); break;
09b7f37c
CB		 8192 case RMS$_PRV:
8193 set_errno(EACCES); break;
8194 case RMS$_SYN:
8195 set_errno(EINVAL); break;
a2669cfc 8196 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 8197 set_errno(E2BIG); break;
8198 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8199 _ckvmssts(retsts); /* fall through */
8200 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8201 set_errno(EVMSERR);
8202 }
748a9306 8203 set_vaxc_errno(retsts);
3eeba6fb 8204 if (ckWARN(WARN_EXEC)) {
f98bc0c6 8205 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 8206 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 8207 }
218fdd94 8208 vms_execfree(vmscmd);
a0d0e21e
LW		 8209 }
8210
8211 return FALSE;
8212
8213} /* end of vms_do_exec() */
8214/*}}}*/
8215
2fbb330f 8216unsigned long int Perl_do_spawn(pTHX_ const char *);
a0d0e21e 8217
61bb5906 8218/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
a0d0e21e 8219unsigned long int
fd8cd3a3 8220Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
a0d0e21e 8221{
fd8cd3a3 8222 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
a0d0e21e
LW		 8223
8224 return SS$_ABORT;
8225} /* end of do_aspawn() */
8226/*}}}*/
8227
8228/* {{{unsigned long int do_spawn(char *cmd) */
8229unsigned long int
2fbb330f 8230Perl_do_spawn(pTHX_ const char *cmd)
a0d0e21e 8231{
209030df 8232 unsigned long int sts, substs;
a0d0e21e 8233
1e422769 8234 TAINT_ENV();
8235 TAINT_PROPER("spawn");
748a9306 8236 if (!cmd || !*cmd) {
09b7f37c 8237 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 8238 if (!(sts & 1)) {
8239 switch (sts) {
209030df
JH		 8240 case RMS$_FNF: case RMS$_DNF:
8241 set_errno(ENOENT); break;
8242 case RMS$_DIR:
8243 set_errno(ENOTDIR); break;
8244 case RMS$_DEV:
8245 set_errno(ENODEV); break;
8246 case RMS$_PRV:
8247 set_errno(EACCES); break;
8248 case RMS$_SYN:
8249 set_errno(EINVAL); break;
8250 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8251 set_errno(E2BIG); break;
8252 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8253 _ckvmssts(sts); /* fall through */
8254 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8255 set_errno(EVMSERR);
c8795d8b
JH		 8256 }
8257 set_vaxc_errno(sts);
8258 if (ckWARN(WARN_EXEC)) {
f98bc0c6 8259 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 8260 Strerror(errno));
8261 }
09b7f37c 8262 }
c8795d8b 8263 sts = substs;
48023aa8
CL		 8264 }
8265 else {
2fbb330f
JM		 8266 PerlIO * fp;
8267 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8268 if (fp != NULL)
8269 my_pclose(fp);
48023aa8 8270 }
48023aa8 8271 return sts;
a0d0e21e
LW		 8272} /* end of do_spawn() */
8273/*}}}*/
8274
bc10a425
CB		 8275
8276static unsigned int *sockflags, sockflagsize;
8277
8278/*
8279 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8280 * routines found in some versions of the CRTL can't deal with sockets.
8281 * We don't shim the other file open routines since a socket isn't
8282 * likely to be opened by a name.
8283 */
275feba9
CB		 8284/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8285FILE *my_fdopen(int fd, const char *mode)
bc10a425 8286{
f7ddb74a 8287 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 8288
8289 if (fp) {
8290 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 8291 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 8292 if (!sockflagsize || fdoff > sockflagsize) {
8293 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 8294 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 8295 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8296 sockflagsize = fdoff + 2;
8297 }
2497a41f 8298 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 8299 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8300 }
8301 return fp;
8302
8303}
8304/*}}}*/
8305
8306
8307/*
8308 * Clear the corresponding bit when the (possibly) socket stream is closed.
8309 * There still a small hole: we miss an implicit close which might occur
8310 * via freopen(). >> Todo
8311 */
8312/*{{{ int my_fclose(FILE *fp)*/
8313int my_fclose(FILE *fp) {
8314 if (fp) {
8315 unsigned int fd = fileno(fp);
8316 unsigned int fdoff = fd / sizeof(unsigned int);
8317
8318 if (sockflagsize && fdoff <= sockflagsize)
8319 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8320 }
8321 return fclose(fp);
8322}
8323/*}}}*/
8324
8325
a0d0e21e
LW		 8326/*
8327 * A simple fwrite replacement which outputs itmsz*nitm chars without
8328 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 8329 * We are using fputs, which depends on a terminating null. We may
8330 * well be writing binary data, so we need to accommodate not only
8331 * data with nulls sprinkled in the middle but also data with no null
8332 * byte at the end.
a0d0e21e 8333 */
a15cef0c 8334/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 8335int
a15cef0c 8336my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 8337{
22d4bb9c 8338 register char *cp, *end, *cpd, *data;
bc10a425
CB		 8339 register unsigned int fd = fileno(dest);
8340 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 8341 int retval;
bc10a425
CB		 8342 int bufsize = itmsz * nitm + 1;
8343
8344 if (fdoff < sockflagsize &&
8345 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8346 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8347 return nitm;
8348 }
22d4bb9c 8349
bc10a425 8350 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 8351 memcpy( data, src, itmsz*nitm );
8352 data[itmsz*nitm] = '\0';
a0d0e21e 8353
22d4bb9c
CB		 8354 end = data + itmsz * nitm;
8355 retval = (int) nitm; /* on success return # items written */
a0d0e21e 8356
22d4bb9c
CB		 8357 cpd = data;
8358 while (cpd <= end) {
8359 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8360 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 8361 if (cp < end)
22d4bb9c
CB		 8362 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8363 cpd = cp + 1;
a0d0e21e
LW		 8364 }
8365
bc10a425 8366 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 8367 return retval;
a0d0e21e
LW		 8368
8369} /* end of my_fwrite() */
8370/*}}}*/
8371
d27fe803
JH		 8372/*{{{ int my_flush(FILE *fp)*/
8373int
fd8cd3a3 8374Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 8375{
8376 int res;
93948341 8377 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 8378#ifdef VMS_DO_SOCKETS
61bb5906 8379 Stat_t s;
d27fe803
JH		 8380 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8381#endif
8382 res = fsync(fileno(fp));
8383 }
22d4bb9c
CB		 8384/*
8385 * If the flush succeeded but set end-of-file, we need to clear
8386 * the error because our caller may check ferror(). BTW, this
8387 * probably means we just flushed an empty file.
8388 */
8389 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8390
d27fe803
JH		 8391 return res;
8392}
8393/*}}}*/
8394
748a9306
LW		 8395/*
8396 * Here are replacements for the following Unix routines in the VMS environment:
8397 * getpwuid Get information for a particular UIC or UID
8398 * getpwnam Get information for a named user
8399 * getpwent Get information for each user in the rights database
8400 * setpwent Reset search to the start of the rights database
8401 * endpwent Finish searching for users in the rights database
8402 *
8403 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8404 * (defined in pwd.h), which contains the following fields:-
8405 * struct passwd {
8406 * char *pw_name; Username (in lower case)
8407 * char *pw_passwd; Hashed password
8408 * unsigned int pw_uid; UIC
8409 * unsigned int pw_gid; UIC group number
8410 * char *pw_unixdir; Default device/directory (VMS-style)
8411 * char *pw_gecos; Owner name
8412 * char *pw_dir; Default device/directory (Unix-style)
8413 * char *pw_shell; Default CLI name (eg. DCL)
8414 * };
8415 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8416 *
8417 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8418 * not the UIC member number (eg. what's returned by getuid()),
8419 * getpwuid() can accept either as input (if uid is specified, the caller's
8420 * UIC group is used), though it won't recognise gid=0.
8421 *
8422 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8423 * information about other users in your group or in other groups, respectively.
8424 * If the required privilege is not available, then these routines fill only
8425 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8426 * string).
8427 *
8428 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8429 */
8430
8431/* sizes of various UAF record fields */
8432#define UAI$S_USERNAME 12
8433#define UAI$S_IDENT 31
8434#define UAI$S_OWNER 31
8435#define UAI$S_DEFDEV 31
8436#define UAI$S_DEFDIR 63
8437#define UAI$S_DEFCLI 31
8438#define UAI$S_PWD 8
8439
8440#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8441 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8442 (uic).uic$v_group != UIC$K_WILD_GROUP)
8443
4633a7c4
LW		 8444static char __empty[]= "";
8445static struct passwd __passwd_empty=
748a9306
LW		 8446 {(char *) __empty, (char *) __empty, 0, 0,
8447 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8448static int contxt= 0;
8449static struct passwd __pwdcache;
8450static char __pw_namecache[UAI$S_IDENT+1];
8451
748a9306
LW		 8452/*
8453 * This routine does most of the work extracting the user information.
8454 */
fd8cd3a3 8455static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 8456{
748a9306
LW		 8457 static struct {
8458 unsigned char length;
8459 char pw_gecos[UAI$S_OWNER+1];
8460 } owner;
8461 static union uicdef uic;
8462 static struct {
8463 unsigned char length;
8464 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8465 } defdev;
8466 static struct {
8467 unsigned char length;
8468 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8469 } defdir;
8470 static struct {
8471 unsigned char length;
8472 char pw_shell[UAI$S_DEFCLI+1];
8473 } defcli;
8474 static char pw_passwd[UAI$S_PWD+1];
8475
8476 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8477 struct dsc$descriptor_s name_desc;
c07a80fd 8478 unsigned long int sts;
748a9306 8479
4633a7c4 8480 static struct itmlst_3 itmlst[]= {
748a9306
LW		 8481 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8482 {sizeof(uic), UAI$_UIC, &uic, &luic},
8483 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8484 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8485 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8486 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8487 {0, 0, NULL, NULL}};
8488
8489 name_desc.dsc$w_length= strlen(name);
8490 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8491 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 8492 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 8493
8494/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 8495 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8496 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8497 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8498 }
8499 else { _ckvmssts(sts); }
8500 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 8501
8502 if ((int) owner.length < lowner) lowner= (int) owner.length;
8503 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8504 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8505 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8506 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8507 owner.pw_gecos[lowner]= '\0';
8508 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8509 defcli.pw_shell[ldefcli]= '\0';
8510 if (valid_uic(uic)) {
8511 pwd->pw_uid= uic.uic$l_uic;
8512 pwd->pw_gid= uic.uic$v_group;
8513 }
8514 else
5c84aa53 8515 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 8516 pwd->pw_passwd= pw_passwd;
8517 pwd->pw_gecos= owner.pw_gecos;
8518 pwd->pw_dir= defdev.pw_dir;
8519 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8520 pwd->pw_shell= defcli.pw_shell;
8521 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8522 int ldir;
8523 ldir= strlen(pwd->pw_unixdir) - 1;
8524 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8525 }
8526 else
8527 strcpy(pwd->pw_unixdir, pwd->pw_dir);
f7ddb74a
JM		 8528 if (!decc_efs_case_preserve)
8529 __mystrtolower(pwd->pw_unixdir);
c07a80fd 8530 return 1;
a0d0e21e 8531}
748a9306
LW		 8532
8533/*
8534 * Get information for a named user.
8535*/
8536/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 8537struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 8538{
8539 struct dsc$descriptor_s name_desc;
8540 union uicdef uic;
aa689395 8541 unsigned long int status, sts;
748a9306
LW		 8542
8543 __pwdcache = __passwd_empty;
fd8cd3a3 8544 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 8545 /* We still may be able to determine pw_uid and pw_gid */
8546 name_desc.dsc$w_length= strlen(name);
8547 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8548 name_desc.dsc$b_class= DSC$K_CLASS_S;
8549 name_desc.dsc$a_pointer= (char *) name;
aa689395 8550 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 8551 __pwdcache.pw_uid= uic.uic$l_uic;
8552 __pwdcache.pw_gid= uic.uic$v_group;
8553 }
c07a80fd 8554 else {
aa689395 8555 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8556 set_vaxc_errno(sts);
8557 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 8558 return NULL;
8559 }
aa689395 8560 else { _ckvmssts(sts); }
c07a80fd 8561 }
748a9306 8562 }
748a9306
LW		 8563 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8564 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8565 __pwdcache.pw_name= __pw_namecache;
8566 return &__pwdcache;
8567} /* end of my_getpwnam() */
a0d0e21e
LW		 8568/*}}}*/
8569
748a9306
LW		 8570/*
8571 * Get information for a particular UIC or UID.
8572 * Called by my_getpwent with uid=-1 to list all users.
8573*/
8574/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 8575struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 8576{
748a9306
LW		 8577 const $DESCRIPTOR(name_desc,__pw_namecache);
8578 unsigned short lname;
8579 union uicdef uic;
8580 unsigned long int status;
8581
8582 if (uid == (unsigned int) -1) {
8583 do {
8584 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8585 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 8586 set_vaxc_errno(status);
8587 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 8588 my_endpwent();
8589 return NULL;
8590 }
8591 else { _ckvmssts(status); }
8592 } while (!valid_uic (uic));
8593 }
8594 else {
8595 uic.uic$l_uic= uid;
c07a80fd 8596 if (!uic.uic$v_group)
76e3520e 8597 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 8598 if (valid_uic(uic))
8599 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8600 else status = SS$_IVIDENT;
c07a80fd 8601 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8602 status == RMS$_PRV) {
8603 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8604 return NULL;
8605 }
8606 else { _ckvmssts(status); }
748a9306
LW		 8607 }
8608 __pw_namecache[lname]= '\0';
01b8edb6 8609 __mystrtolower(__pw_namecache);
748a9306
LW		 8610
8611 __pwdcache = __passwd_empty;
8612 __pwdcache.pw_name = __pw_namecache;
8613
8614/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8615 The identifier's value is usually the UIC, but it doesn't have to be,
8616 so if we can, we let fillpasswd update this. */
8617 __pwdcache.pw_uid = uic.uic$l_uic;
8618 __pwdcache.pw_gid = uic.uic$v_group;
8619
fd8cd3a3 8620 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 8621 return &__pwdcache;
a0d0e21e 8622
748a9306
LW		 8623} /* end of my_getpwuid() */
8624/*}}}*/
8625
8626/*
8627 * Get information for next user.
8628*/
8629/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 8630struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 8631{
8632 return (my_getpwuid((unsigned int) -1));
8633}
8634/*}}}*/
a0d0e21e 8635
748a9306
LW		 8636/*
8637 * Finish searching rights database for users.
8638*/
8639/*{{{void my_endpwent()*/
fd8cd3a3 8640void Perl_my_endpwent(pTHX)
748a9306
LW		 8641{
8642 if (contxt) {
8643 _ckvmssts(sys$finish_rdb(&contxt));
8644 contxt= 0;
8645 }
a0d0e21e
LW		 8646}
8647/*}}}*/
748a9306 8648
61bb5906
CB		 8649#ifdef HOMEGROWN_POSIX_SIGNALS
8650 /* Signal handling routines, pulled into the core from POSIX.xs.
8651 *
8652 * We need these for threads, so they've been rolled into the core,
8653 * rather than left in POSIX.xs.
8654 *
8655 * (DRS, Oct 23, 1997)
8656 */
5b411029 8657
61bb5906
CB		 8658 /* sigset_t is atomic under VMS, so these routines are easy */
8659/*{{{int my_sigemptyset(sigset_t *) */
5b411029 8660int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 8661 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8662 *set = 0; return 0;
5b411029 8663}
61bb5906
CB		 8664/*}}}*/
8665
8666
8667/*{{{int my_sigfillset(sigset_t *)*/
5b411029 8668int my_sigfillset(sigset_t *set) {
61bb5906
CB		 8669 int i;
8670 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8671 for (i = 0; i < NSIG; i++) *set |= (1 << i);
8672 return 0;
5b411029 8673}
61bb5906
CB		 8674/*}}}*/
8675
8676
8677/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 8678int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 8679 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8680 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8681 *set |= (1 << (sig - 1));
8682 return 0;
5b411029 8683}
61bb5906
CB		 8684/*}}}*/
8685
8686
8687/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 8688int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 8689 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8690 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8691 *set &= ~(1 << (sig - 1));
8692 return 0;
5b411029 8693}
61bb5906
CB		 8694/*}}}*/
8695
8696
8697/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 8698int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 8699 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8700 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 8701 return *set & (1 << (sig - 1));
5b411029 8702}
61bb5906 8703/*}}}*/
5b411029 8704
5b411029 8705
61bb5906
CB		 8706/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8707int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8708 sigset_t tempmask;
8709
8710 /* If set and oset are both null, then things are badly wrong. Bail out. */
8711 if ((oset == NULL) && (set == NULL)) {
8712 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 8713 return -1;
8714 }
5b411029 8715
61bb5906
CB		 8716 /* If set's null, then we're just handling a fetch. */
8717 if (set == NULL) {
8718 tempmask = sigblock(0);
8719 }
8720 else {
8721 switch (how) {
8722 case SIG_SETMASK:
8723 tempmask = sigsetmask(*set);
8724 break;
8725 case SIG_BLOCK:
8726 tempmask = sigblock(*set);
8727 break;
8728 case SIG_UNBLOCK:
8729 tempmask = sigblock(0);
8730 sigsetmask(*oset & ~tempmask);
8731 break;
8732 default:
8733 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8734 return -1;
8735 }
8736 }
8737
8738 /* Did they pass us an oset? If so, stick our holding mask into it */
8739 if (oset)
8740 *oset = tempmask;
5b411029 8741
61bb5906 8742 return 0;
5b411029 8743}
61bb5906
CB		 8744/*}}}*/
8745#endif /* HOMEGROWN_POSIX_SIGNALS */
8746
5b411029 8747
ff0cee69 8748/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8749 * my_utime(), and flex_stat(), all of which operate on UTC unless
8750 * VMSISH_TIMES is true.
8751 */
8752/* method used to handle UTC conversions:
8753 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 8754 */
ff0cee69 8755static int gmtime_emulation_type;
8756/* number of secs to add to UTC POSIX-style time to get local time */
8757static long int utc_offset_secs;
e518068a 8758
ff0cee69 8759/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8760 * in vmsish.h. #undef them here so we can call the CRTL routines
8761 * directly.
e518068a 8762 */
8763#undef gmtime
ff0cee69 8764#undef localtime
8765#undef time
8766
61bb5906 8767
a44ceb8e
CB		 8768/*
8769 * DEC C previous to 6.0 corrupts the behavior of the /prefix
8770 * qualifier with the extern prefix pragma. This provisional
8771 * hack circumvents this prefix pragma problem in previous
8772 * precompilers.
8773 */
8774#if defined(__VMS_VER) && __VMS_VER >= 70000000
8775# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8776# pragma __extern_prefix save
8777# pragma __extern_prefix "" /* set to empty to prevent prefixing */
8778# define gmtime decc$__utctz_gmtime
8779# define localtime decc$__utctz_localtime
8780# define time decc$__utc_time
8781# pragma __extern_prefix restore
8782
8783 struct tm *gmtime(), *localtime();
8784
8785# endif
8786#endif
8787
8788
61bb5906
CB		 8789static time_t toutc_dst(time_t loc) {
8790 struct tm *rsltmp;
8791
8792 if ((rsltmp = localtime(&loc)) == NULL) return -1;
8793 loc -= utc_offset_secs;
8794 if (rsltmp->tm_isdst) loc -= 3600;
8795 return loc;
8796}
32da55ab 8797#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 8798 ((gmtime_emulation_type || my_time(NULL)), \
8799 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8800 ((secs) - utc_offset_secs))))
8801
8802static time_t toloc_dst(time_t utc) {
8803 struct tm *rsltmp;
8804
8805 utc += utc_offset_secs;
8806 if ((rsltmp = localtime(&utc)) == NULL) return -1;
8807 if (rsltmp->tm_isdst) utc += 3600;
8808 return utc;
8809}
32da55ab 8810#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 8811 ((gmtime_emulation_type || my_time(NULL)), \
8812 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8813 ((secs) + utc_offset_secs))))
8814
22d4bb9c
CB		 8815#ifndef RTL_USES_UTC
8816/*
8817
8818 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
8819 DST starts on 1st sun of april at 02:00 std time
8820 ends on last sun of october at 02:00 dst time
8821 see the UCX management command reference, SET CONFIG TIMEZONE
8822 for formatting info.
8823
8824 No, it's not as general as it should be, but then again, NOTHING
8825 will handle UK times in a sensible way.
8826*/
8827
8828
8829/*
8830 parse the DST start/end info:
8831 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8832*/
8833
8834static char *
8835tz_parse_startend(char *s, struct tm *w, int *past)
8836{
8837 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8838 int ly, dozjd, d, m, n, hour, min, sec, j, k;
8839 time_t g;
8840
8841 if (!s) return 0;
8842 if (!w) return 0;
8843 if (!past) return 0;
8844
8845 ly = 0;
8846 if (w->tm_year % 4 == 0) ly = 1;
8847 if (w->tm_year % 100 == 0) ly = 0;
8848 if (w->tm_year+1900 % 400 == 0) ly = 1;
8849 if (ly) dinm[1]++;
8850
8851 dozjd = isdigit(*s);
8852 if (*s == 'J' || *s == 'j' || dozjd) {
8853 if (!dozjd && !isdigit(*++s)) return 0;
8854 d = *s++ - '0';
8855 if (isdigit(*s)) {
8856 d = d*10 + *s++ - '0';
8857 if (isdigit(*s)) {
8858 d = d*10 + *s++ - '0';
8859 }
8860 }
8861 if (d == 0) return 0;
8862 if (d > 366) return 0;
8863 d--;
8864 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
8865 g = d * 86400;
8866 dozjd = 1;
8867 } else if (*s == 'M' || *s == 'm') {
8868 if (!isdigit(*++s)) return 0;
8869 m = *s++ - '0';
8870 if (isdigit(*s)) m = 10*m + *s++ - '0';
8871 if (*s != '.') return 0;
8872 if (!isdigit(*++s)) return 0;
8873 n = *s++ - '0';
8874 if (n < 1 || n > 5) return 0;
8875 if (*s != '.') return 0;
8876 if (!isdigit(*++s)) return 0;
8877 d = *s++ - '0';
8878 if (d > 6) return 0;
8879 }
8880
8881 if (*s == '/') {
8882 if (!isdigit(*++s)) return 0;
8883 hour = *s++ - '0';
8884 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8885 if (*s == ':') {
8886 if (!isdigit(*++s)) return 0;
8887 min = *s++ - '0';
8888 if (isdigit(*s)) min = 10*min + *s++ - '0';
8889 if (*s == ':') {
8890 if (!isdigit(*++s)) return 0;
8891 sec = *s++ - '0';
8892 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8893 }
8894 }
8895 } else {
8896 hour = 2;
8897 min = 0;
8898 sec = 0;
8899 }
8900
8901 if (dozjd) {
8902 if (w->tm_yday < d) goto before;
8903 if (w->tm_yday > d) goto after;
8904 } else {
8905 if (w->tm_mon+1 < m) goto before;
8906 if (w->tm_mon+1 > m) goto after;
8907
8908 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
8909 k = d - j; /* mday of first d */
8910 if (k <= 0) k += 7;
8911 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
8912 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8913 if (w->tm_mday < k) goto before;
8914 if (w->tm_mday > k) goto after;
8915 }
8916
8917 if (w->tm_hour < hour) goto before;
8918 if (w->tm_hour > hour) goto after;
8919 if (w->tm_min < min) goto before;
8920 if (w->tm_min > min) goto after;
8921 if (w->tm_sec < sec) goto before;
8922 goto after;
8923
8924before:
8925 *past = 0;
8926 return s;
8927after:
8928 *past = 1;
8929 return s;
8930}
8931
8932
8933
8934
8935/* parse the offset: (+|-)hh[:mm[:ss]] */
8936
8937static char *
8938tz_parse_offset(char *s, int *offset)
8939{
8940 int hour = 0, min = 0, sec = 0;
8941 int neg = 0;
8942 if (!s) return 0;
8943 if (!offset) return 0;
8944
8945 if (*s == '-') {neg++; s++;}
8946 if (*s == '+') s++;
8947 if (!isdigit(*s)) return 0;
8948 hour = *s++ - '0';
8949 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8950 if (hour > 24) return 0;
8951 if (*s == ':') {
8952 if (!isdigit(*++s)) return 0;
8953 min = *s++ - '0';
8954 if (isdigit(*s)) min = min*10 + (*s++ - '0');
8955 if (min > 59) return 0;
8956 if (*s == ':') {
8957 if (!isdigit(*++s)) return 0;
8958 sec = *s++ - '0';
8959 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8960 if (sec > 59) return 0;
8961 }
8962 }
8963
8964 *offset = (hour*60+min)*60 + sec;
8965 if (neg) *offset = -*offset;
8966 return s;
8967}
8968
8969/*
8970 input time is w, whatever type of time the CRTL localtime() uses.
8971 sets dst, the zone, and the gmtoff (seconds)
8972
8973 caches the value of TZ and UCX$TZ env variables; note that
8974 my_setenv looks for these and sets a flag if they're changed
8975 for efficiency.
8976
8977 We have to watch out for the "australian" case (dst starts in
8978 october, ends in april)...flagged by "reverse" and checked by
8979 scanning through the months of the previous year.
8980
8981*/
8982
8983static int
fd8cd3a3 8984tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 8985{
8986 time_t when;
8987 struct tm *w2;
8988 char *s,*s2;
8989 char *dstzone, *tz, *s_start, *s_end;
8990 int std_off, dst_off, isdst;
8991 int y, dststart, dstend;
8992 static char envtz[1025]; /* longer than any logical, symbol, ... */
8993 static char ucxtz[1025];
8994 static char reversed = 0;
8995
8996 if (!w) return 0;
8997
8998 if (tz_updated) {
8999 tz_updated = 0;
9000 reversed = -1; /* flag need to check */
9001 envtz[0] = ucxtz[0] = '\0';
9002 tz = my_getenv("TZ",0);
9003 if (tz) strcpy(envtz, tz);
9004 tz = my_getenv("UCX$TZ",0);
9005 if (tz) strcpy(ucxtz, tz);
9006 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9007 }
9008 tz = envtz;
9009 if (!*tz) tz = ucxtz;
9010
9011 s = tz;
9012 while (isalpha(*s)) s++;
9013 s = tz_parse_offset(s, &std_off);
9014 if (!s) return 0;
9015 if (!*s) { /* no DST, hurray we're done! */
9016 isdst = 0;
9017 goto done;
9018 }
9019
9020 dstzone = s;
9021 while (isalpha(*s)) s++;
9022 s2 = tz_parse_offset(s, &dst_off);
9023 if (s2) {
9024 s = s2;
9025 } else {
9026 dst_off = std_off - 3600;
9027 }
9028
9029 if (!*s) { /* default dst start/end?? */
9030 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9031 s = strchr(ucxtz,',');
9032 }
9033 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9034 }
9035 if (*s != ',') return 0;
9036
9037 when = *w;
9038 when = _toutc(when); /* convert to utc */
9039 when = when - std_off; /* convert to pseudolocal time*/
9040
9041 w2 = localtime(&when);
9042 y = w2->tm_year;
9043 s_start = s+1;
9044 s = tz_parse_startend(s_start,w2,&dststart);
9045 if (!s) return 0;
9046 if (*s != ',') return 0;
9047
9048 when = *w;
9049 when = _toutc(when); /* convert to utc */
9050 when = when - dst_off; /* convert to pseudolocal time*/
9051 w2 = localtime(&when);
9052 if (w2->tm_year != y) { /* spans a year, just check one time */
9053 when += dst_off - std_off;
9054 w2 = localtime(&when);
9055 }
9056 s_end = s+1;
9057 s = tz_parse_startend(s_end,w2,&dstend);
9058 if (!s) return 0;
9059
9060 if (reversed == -1) { /* need to check if start later than end */
9061 int j, ds, de;
9062
9063 when = *w;
9064 if (when < 2*365*86400) {
9065 when += 2*365*86400;
9066 } else {
9067 when -= 365*86400;
9068 }
9069 w2 =localtime(&when);
9070 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9071
9072 for (j = 0; j < 12; j++) {
9073 w2 =localtime(&when);
f7ddb74a
JM		 9074 tz_parse_startend(s_start,w2,&ds);
9075 tz_parse_startend(s_end,w2,&de);
22d4bb9c
CB		 9076 if (ds != de) break;
9077 when += 30*86400;
9078 }
9079 reversed = 0;
9080 if (de && !ds) reversed = 1;
9081 }
9082
9083 isdst = dststart && !dstend;
9084 if (reversed) isdst = dststart || !dstend;
9085
9086done:
9087 if (dst) *dst = isdst;
9088 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9089 if (isdst) tz = dstzone;
9090 if (zone) {
9091 while(isalpha(*tz)) *zone++ = *tz++;
9092 *zone = '\0';
9093 }
9094 return 1;
9095}
9096
9097#endif /* !RTL_USES_UTC */
61bb5906 9098
ff0cee69 9099/* my_time(), my_localtime(), my_gmtime()
61bb5906 9100 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 9101 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 9102 * Note: We need to use these functions even when the CRTL has working
9103 * UTC support, since they also handle C<use vmsish qw(times);>
9104 *
ff0cee69 9105 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 9106 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 9107 */
9108
9109/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 9110time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 9111{
e518068a 9112 time_t when;
61bb5906 9113 struct tm *tm_p;
e518068a 9114
9115 if (gmtime_emulation_type == 0) {
61bb5906
CB		 9116 int dstnow;
9117 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9118 /* results of calls to gmtime() and localtime() */
9119 /* for same &base */
ff0cee69 9120
e518068a 9121 gmtime_emulation_type++;
ff0cee69 9122 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 9123 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 9124
e518068a 9125 gmtime_emulation_type++;
f675dbe5 9126 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 9127 gmtime_emulation_type++;
22d4bb9c 9128 utc_offset_secs = 0;
5c84aa53 9129 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 9130 }
9131 else { utc_offset_secs = atol(off); }
e518068a 9132 }
ff0cee69 9133 else { /* We've got a working gmtime() */
9134 struct tm gmt, local;
e518068a 9135
ff0cee69 9136 gmt = *tm_p;
9137 tm_p = localtime(&base);
9138 local = *tm_p;
9139 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9140 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9141 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9142 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9143 }
e518068a 9144 }
ff0cee69 9145
9146 when = time(NULL);
61bb5906
CB		 9147# ifdef VMSISH_TIME
9148# ifdef RTL_USES_UTC
9149 if (VMSISH_TIME) when = _toloc(when);
9150# else
9151 if (!VMSISH_TIME) when = _toutc(when);
9152# endif
9153# endif
ff0cee69 9154 if (timep != NULL) *timep = when;
9155 return when;
9156
9157} /* end of my_time() */
9158/*}}}*/
9159
9160
9161/*{{{struct tm *my_gmtime(const time_t *timep)*/
9162struct tm *
fd8cd3a3 9163Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 9164{
9165 char *p;
9166 time_t when;
61bb5906 9167 struct tm *rsltmp;
ff0cee69 9168
68dc0745 9169 if (timep == NULL) {
9170 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9171 return NULL;
9172 }
9173 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 9174
9175 when = *timep;
9176# ifdef VMSISH_TIME
61bb5906
CB		 9177 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9178# endif
9179# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9180 return gmtime(&when);
9181# else
ff0cee69 9182 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 9183 rsltmp = localtime(&when);
9184 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9185 return rsltmp;
9186#endif
e518068a 9187} /* end of my_gmtime() */
e518068a 9188/*}}}*/
9189
9190
ff0cee69 9191/*{{{struct tm *my_localtime(const time_t *timep)*/
9192struct tm *
fd8cd3a3 9193Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 9194{
22d4bb9c 9195 time_t when, whenutc;
61bb5906 9196 struct tm *rsltmp;
22d4bb9c 9197 int dst, offset;
ff0cee69 9198
68dc0745 9199 if (timep == NULL) {
9200 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9201 return NULL;
9202 }
9203 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 9204 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 9205
9206 when = *timep;
61bb5906 9207# ifdef RTL_USES_UTC
ff0cee69 9208# ifdef VMSISH_TIME
61bb5906 9209 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 9210# endif
61bb5906 9211 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 9212 return localtime(&when);
22d4bb9c
CB		 9213
9214# else /* !RTL_USES_UTC */
9215 whenutc = when;
61bb5906 9216# ifdef VMSISH_TIME
22d4bb9c
CB		 9217 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9218 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 9219# endif
22d4bb9c
CB		 9220 dst = -1;
9221#ifndef RTL_USES_UTC
32af7c23 9222 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 9223 when = whenutc - offset; /* pseudolocal time*/
9224 }
61bb5906
CB		 9225# endif
9226 /* CRTL localtime() wants local time as input, so does no tz correction */
9227 rsltmp = localtime(&when);
22d4bb9c 9228 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 9229 return rsltmp;
22d4bb9c 9230# endif
ff0cee69 9231
9232} /* end of my_localtime() */
9233/*}}}*/
9234
9235/* Reset definitions for later calls */
9236#define gmtime(t) my_gmtime(t)
9237#define localtime(t) my_localtime(t)
9238#define time(t) my_time(t)
9239
9240
9241/* my_utime - update modification time of a file
9242 * calling sequence is identical to POSIX utime(), but under
9243 * VMS only the modification time is changed; ODS-2 does not
9244 * maintain access times. Restrictions differ from the POSIX
9245 * definition in that the time can be changed as long as the
9246 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9247 * no separate checks are made to insure that the caller is the
9248 * owner of the file or has special privs enabled.
9249 * Code here is based on Joe Meadows' FILE utility.
9250 */
9251
9252/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9253 * to VMS epoch (01-JAN-1858 00:00:00.00)
9254 * in 100 ns intervals.
9255 */
9256static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9257
94a11853
CB		 9258/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9259int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 9260{
9261 register int i;
f7ddb74a 9262 int sts;
ff0cee69 9263 long int bintime[2], len = 2, lowbit, unixtime,
9264 secscale = 10000000; /* seconds --> 100 ns intervals */
9265 unsigned long int chan, iosb[2], retsts;
9266 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9267 struct FAB myfab = cc$rms_fab;
9268 struct NAM mynam = cc$rms_nam;
9269#if defined (__DECC) && defined (__VAX)
9270 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9271 * at least through VMS V6.1, which causes a type-conversion warning.
9272 */
9273# pragma message save
9274# pragma message disable cvtdiftypes
9275#endif
9276 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9277 struct fibdef myfib;
9278#if defined (__DECC) && defined (__VAX)
9279 /* This should be right after the declaration of myatr, but due
9280 * to a bug in VAX DEC C, this takes effect a statement early.
9281 */
9282# pragma message restore
9283#endif
f7ddb74a 9284 /* cast ok for read only parameter */
ff0cee69 9285 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9286 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9287 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9288
9289 if (file == NULL || *file == '\0') {
9290 set_errno(ENOENT);
9291 set_vaxc_errno(LIB$_INVARG);
9292 return -1;
9293 }
f7ddb74a 9294 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
ff0cee69 9295
9296 if (utimes != NULL) {
9297 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9298 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9299 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9300 * as input, we force the sign bit to be clear by shifting unixtime right
9301 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9302 */
9303 lowbit = (utimes->modtime & 1) ? secscale : 0;
9304 unixtime = (long int) utimes->modtime;
61bb5906
CB		 9305# ifdef VMSISH_TIME
9306 /* If input was UTC; convert to local for sys svc */
9307 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 9308# endif
1a6334fb 9309 unixtime >>= 1; secscale <<= 1;
ff0cee69 9310 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9311 if (!(retsts & 1)) {
9312 set_errno(EVMSERR);
9313 set_vaxc_errno(retsts);
9314 return -1;
9315 }
9316 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9317 if (!(retsts & 1)) {
9318 set_errno(EVMSERR);
9319 set_vaxc_errno(retsts);
9320 return -1;
9321 }
9322 }
9323 else {
9324 /* Just get the current time in VMS format directly */
9325 retsts = sys$gettim(bintime);
9326 if (!(retsts & 1)) {
9327 set_errno(EVMSERR);
9328 set_vaxc_errno(retsts);
9329 return -1;
9330 }
9331 }
9332
9333 myfab.fab$l_fna = vmsspec;
9334 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9335 myfab.fab$l_nam = &mynam;
9336 mynam.nam$l_esa = esa;
9337 mynam.nam$b_ess = (unsigned char) sizeof esa;
9338 mynam.nam$l_rsa = rsa;
9339 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 9340 if (decc_efs_case_preserve)
9341 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 9342
9343 /* Look for the file to be affected, letting RMS parse the file
9344 * specification for us as well. I have set errno using only
9345 * values documented in the utime() man page for VMS POSIX.
9346 */
9347 retsts = sys$parse(&myfab,0,0);
9348 if (!(retsts & 1)) {
9349 set_vaxc_errno(retsts);
9350 if (retsts == RMS$_PRV) set_errno(EACCES);
9351 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9352 else set_errno(EVMSERR);
9353 return -1;
9354 }
9355 retsts = sys$search(&myfab,0,0);
9356 if (!(retsts & 1)) {
752635ea 9357 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9358 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9359 set_vaxc_errno(retsts);
9360 if (retsts == RMS$_PRV) set_errno(EACCES);
9361 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9362 else set_errno(EVMSERR);
9363 return -1;
9364 }
9365
9366 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 9367 /* cast ok for read only parameter */
ff0cee69 9368 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9369
9370 retsts = sys$assign(&devdsc,&chan,0,0);
9371 if (!(retsts & 1)) {
752635ea 9372 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9373 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9374 set_vaxc_errno(retsts);
9375 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9376 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9377 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9378 else set_errno(EVMSERR);
9379 return -1;
9380 }
9381
9382 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9383 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9384
9385 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 9386#if defined(__DECC) || defined(__DECCXX)
ff0cee69 9387 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9388 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9389 /* This prevents the revision time of the file being reset to the current
9390 * time as a result of our IO$_MODIFY $QIO. */
9391 myfib.fib$l_acctl = FIB$M_NORECORD;
9392#else
9393 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9394 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9395 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9396#endif
9397 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 9398 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9399 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9400 _ckvmssts(sys$dassgn(chan));
9401 if (retsts & 1) retsts = iosb[0];
9402 if (!(retsts & 1)) {
9403 set_vaxc_errno(retsts);
9404 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9405 else set_errno(EVMSERR);
9406 return -1;
9407 }
9408
9409 return 0;
9410} /* end of my_utime() */
9411/*}}}*/
9412
748a9306 9413/*
2497a41f 9414 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 9415 * basic stat, but gets it right when asked to stat
9416 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9417 */
9418
2497a41f 9419#ifndef _USE_STD_STAT
748a9306
LW		 9420/* encode_dev packs a VMS device name string into an integer to allow
9421 * simple comparisons. This can be used, for example, to check whether two
9422 * files are located on the same device, by comparing their encoded device
9423 * names. Even a string comparison would not do, because stat() reuses the
9424 * device name buffer for each call; so without encode_dev, it would be
9425 * necessary to save the buffer and use strcmp (this would mean a number of
9426 * changes to the standard Perl code, to say nothing of what a Perl script
9427 * would have to do.
9428 *
9429 * The device lock id, if it exists, should be unique (unless perhaps compared
9430 * with lock ids transferred from other nodes). We have a lock id if the disk is
9431 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9432 * device names. Thus we use the lock id in preference, and only if that isn't
9433 * available, do we try to pack the device name into an integer (flagged by
9434 * the sign bit (LOCKID_MASK) being set).
9435 *
e518068a 9436 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 9437 * name and its encoded form, but it seems very unlikely that we will find
9438 * two files on different disks that share the same encoded device names,
9439 * and even more remote that they will share the same file id (if the test
9440 * is to check for the same file).
9441 *
9442 * A better method might be to use sys$device_scan on the first call, and to
9443 * search for the device, returning an index into the cached array.
9444 * The number returned would be more intelligable.
9445 * This is probably not worth it, and anyway would take quite a bit longer
9446 * on the first call.
9447 */
9448#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 9449static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 9450{
9451 int i;
9452 unsigned long int f;
aa689395 9453 mydev_t enc;
748a9306
LW		 9454 char c;
9455 const char *q;
9456
9457 if (!dev || !dev[0]) return 0;
9458
9459#if LOCKID_MASK
9460 {
9461 struct dsc$descriptor_s dev_desc;
9462 unsigned long int status, lockid, item = DVI$_LOCKID;
9463
9464 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9465 can try that first. */
9466 dev_desc.dsc$w_length = strlen (dev);
9467 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9468 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 9469 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
748a9306
LW		 9470 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9471 if (lockid) return (lockid & ~LOCKID_MASK);
9472 }
a0d0e21e 9473#endif
748a9306
LW		 9474
9475 /* Otherwise we try to encode the device name */
9476 enc = 0;
9477 f = 1;
9478 i = 0;
9479 for (q = dev + strlen(dev); q--; q >= dev) {
9480 if (isdigit (*q))
9481 c= (*q) - '0';
9482 else if (isalpha (toupper (*q)))
9483 c= toupper (*q) - 'A' + (char)10;
9484 else
9485 continue; /* Skip '$'s */
9486 i++;
9487 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9488 if (i>1) f *= 36;
9489 enc += f * (unsigned long int) c;
9490 }
9491 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9492
9493} /* end of encode_dev() */
2497a41f 9494#endif
748a9306
LW		 9495
9496static char namecache[NAM$C_MAXRSS+1];
9497
9498static int
9499is_null_device(name)
9500 const char *name;
9501{
2497a41f 9502 if (decc_bug_devnull != 0) {
682e4b71 9503 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 9504 return 1;
9505 }
748a9306
LW		 9506 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9507 The underscore prefix, controller letter, and unit number are
9508 independently optional; for our purposes, the colon punctuation
9509 is not. The colon can be trailed by optional directory and/or
9510 filename, but two consecutive colons indicates a nodename rather
9511 than a device. [pr] */
9512 if (*name == '_') ++name;
9513 if (tolower(*name++) != 'n') return 0;
9514 if (tolower(*name++) != 'l') return 0;
9515 if (tolower(*name) == 'a') ++name;
9516 if (*name == '0') ++name;
9517 return (*name++ == ':') && (*name != ':');
9518}
9519
6b88bc9c 9520/* Do the permissions allow some operation? Assumes PL_statcache already set. */
748a9306 9521/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
61bb5906 9522 * subset of the applicable information.
748a9306 9523 */
146174a9 9524bool
03e3cfa3 9525Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
748a9306 9526{
22d4bb9c 9527 char fname_phdev[NAM$C_MAXRSS+1];
2497a41f
JM		 9528#if __CRTL_VER >= 80200000 && !defined(__VAX)
9529 /* Namecache not workable with symbolic links, as symbolic links do
9530 * not have extensions and directories do in VMS mode. So in order
9531 * to test this, the did and ino_t must be used.
9532 *
9533 * Fix-me - Hide the information in the new stat structure
9534 * Get rid of the namecache.
9535 */
9536 if (decc_posix_compliant_pathnames == 0)
9537#endif
9538 if (statbufp == &PL_statcache)
9539 return cando_by_name(bit,effective,namecache);
9540 {
748a9306
LW		 9541 char fname[NAM$C_MAXRSS+1];
9542 unsigned long int retsts;
9543 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9544 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9545
9546 /* If the struct mystat is stale, we're OOL; stat() overwrites the
9547 device name on successive calls */
61bb5906
CB		 9548 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9549 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
748a9306
LW		 9550 namdsc.dsc$a_pointer = fname;
9551 namdsc.dsc$w_length = sizeof fname - 1;
9552
61bb5906 9553 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
aa689395 9554 &namdsc,&namdsc.dsc$w_length,0,0);
748a9306
LW		 9555 if (retsts & 1) {
9556 fname[namdsc.dsc$w_length] = '\0';
22d4bb9c
CB		 9557/*
9558 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9559 * but if someone has redefined that logical, Perl gets very lost. Since
9560 * we have the physical device name from the stat buffer, just paste it on.
9561 */
9562 strcpy( fname_phdev, statbufp->st_devnam );
9563 strcat( fname_phdev, strrchr(fname, ':') );
9564
9565 return cando_by_name(bit,effective,fname_phdev);
748a9306
LW		 9566 }
9567 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
5c84aa53 9568 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
748a9306
LW		 9569 return FALSE;
9570 }
9571 _ckvmssts(retsts);
9572 return FALSE; /* Should never get to here */
9573 }
e518068a 9574} /* end of cando() */
748a9306
LW		 9575/*}}}*/
9576
c07a80fd 9577
03e3cfa3 9578/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
748a9306 9579I32
03e3cfa3 9580Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
748a9306
LW		 9581{
9582 static char usrname[L_cuserid];
9583 static struct dsc$descriptor_s usrdsc =
9584 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
a5f75d66 9585 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
748a9306 9586 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2d9f3838 9587 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 9588 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9589 union prvdef curprv;
9590 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9591 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
ada67d10
CB		 9592 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9593 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9594 {0,0,0,0}};
9595 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 9596 {0,0,0,0}};
ada67d10 9597 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
748a9306
LW		 9598
9599 if (!fname || !*fname) return FALSE;
01b8edb6 9600 /* Make sure we expand logical names, since sys$check_access doesn't */
9601 if (!strpbrk(fname,"/]>:")) {
9602 strcpy(fileified,fname);
2d9f3838
CB		 9603 trnlnm_iter_count = 0;
9604 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9605 trnlnm_iter_count++;
9606 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9607 }
01b8edb6 9608 fname = fileified;
9609 }
a5f75d66
AD		 9610 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9611 retlen = namdsc.dsc$w_length = strlen(vmsname);
9612 namdsc.dsc$a_pointer = vmsname;
9613 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9614 vmsname[retlen-1] == ':') {
9615 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9616 namdsc.dsc$w_length = strlen(fileified);
9617 namdsc.dsc$a_pointer = fileified;
9618 }
9619
748a9306 9620 switch (bit) {
f282b18d
CB		 9621 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9622 access = ARM$M_EXECUTE; break;
9623 case S_IRUSR: case S_IRGRP: case S_IROTH:
9624 access = ARM$M_READ; break;
9625 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9626 access = ARM$M_WRITE; break;
9627 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9628 access = ARM$M_DELETE; break;
748a9306
LW		 9629 default:
9630 return FALSE;
9631 }
9632
ada67d10
CB		 9633 /* Before we call $check_access, create a user profile with the current
9634 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 9635 * UAF and might give false positives or negatives. This only works on
9636 * VMS versions v6.0 and later since that's when sys$create_user_profile
9637 * became available.
ada67d10
CB		 9638 */
9639
9640 /* get current process privs and username */
9641 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9642 _ckvmssts(iosb[0]);
9643
baf3cf9c
CB		 9644#if defined(__VMS_VER) && __VMS_VER >= 60000000
9645
ada67d10
CB		 9646 /* find out the space required for the profile */
9647 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9648 &usrprodsc.dsc$w_length,0));
9649
9650 /* allocate space for the profile and get it filled in */
a02a5408 9651 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
ada67d10
CB		 9652 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9653 &usrprodsc.dsc$w_length,0));
9654
9655 /* use the profile to check access to the file; free profile & analyze results */
9656 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9657 Safefree(usrprodsc.dsc$a_pointer);
9658 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c
CB		 9659
9660#else
9661
9662 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9663
9664#endif
9665
bbce6d69 9666 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 9667 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 9668 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 9669 set_vaxc_errno(retsts);
9670 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9671 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9672 else set_errno(ENOENT);
a3e9d8c9 9673 return FALSE;
9674 }
ada67d10 9675 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
3a385817
GS		 9676 return TRUE;
9677 }
748a9306
LW		 9678 _ckvmssts(retsts);
9679
9680 return FALSE; /* Should never get here */
9681
9682} /* end of cando_by_name() */
9683/*}}}*/
9684
9685
61bb5906 9686/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 9687int
fd8cd3a3 9688Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 9689{
b7ae7a0d 9690 if (!fstat(fd,(stat_t *) statbufp)) {
75796008
JM		 9691 if (statbufp == (Stat_t *) &PL_statcache) {
9692 char *cptr;
9693
9694 /* Save name for cando by name in VMS format */
9695 cptr = getname(fd, namecache, 1);
9696
9697 /* This should not happen, but just in case */
9698 if (cptr == NULL)
9699 namecache[0] = '\0';
9700 }
682e4b71
JM		 9701
9702 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
2497a41f
JM		 9703#ifndef _USE_STD_STAT
9704 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9705 statbufp->st_devnam[63] = 0;
fd8cd3a3 9706 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
2497a41f
JM		 9707#else
9708 /* todo:
9709 * The device is only encoded so that Perl_cando can use it to
9710 * look up ACLS. So rmsexpand it to the 255 character version
9711 * and store it in ->st_devnam. rmsexpand needs to be fixed
9712 * for long filenames and symbolic links first. This also seems
9713 * to remove the need for a namecache that could be stale.
9714 */
9715#endif
9716
61bb5906
CB		 9717# ifdef RTL_USES_UTC
9718# ifdef VMSISH_TIME
9719 if (VMSISH_TIME) {
9720 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9721 statbufp->st_atime = _toloc(statbufp->st_atime);
9722 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9723 }
9724# endif
9725# else
ff0cee69 9726# ifdef VMSISH_TIME
9727 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9728# else
9729 if (1) {
9730# endif
61bb5906
CB		 9731 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9732 statbufp->st_atime = _toutc(statbufp->st_atime);
9733 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 9734 }
61bb5906 9735#endif
b7ae7a0d 9736 return 0;
9737 }
9738 return -1;
748a9306
LW		 9739
9740} /* end of flex_fstat() */
9741/*}}}*/
9742
2497a41f
JM		 9743#if !defined(__VAX) && __CRTL_VER >= 80200000
9744#ifdef lstat
9745#undef lstat
9746#endif
9747#else
9748#ifdef lstat
9749#undef lstat
9750#endif
9751#define lstat(_x, _y) stat(_x, _y)
9752#endif
9753
7ded3206
CB		 9754#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
9755
2497a41f
JM		 9756static int
9757Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306
LW		 9758{
9759 char fileified[NAM$C_MAXRSS+1];
cc077a9f 9760 char temp_fspec[NAM$C_MAXRSS+300];
bbce6d69 9761 int retval = -1;
9543c6b6 9762 int saved_errno, saved_vaxc_errno;
748a9306 9763
e956e27a 9764 if (!fspec) return retval;
9543c6b6 9765 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
cc077a9f 9766 strcpy(temp_fspec, fspec);
6b88bc9c 9767 if (statbufp == (Stat_t *) &PL_statcache)
cc077a9f 9768 do_tovmsspec(temp_fspec,namecache,0);
2497a41f
JM		 9769 if (decc_bug_devnull != 0) {
9770 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9771 memset(statbufp,0,sizeof *statbufp);
9772 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9773 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9774 statbufp->st_uid = 0x00010001;
9775 statbufp->st_gid = 0x0001;
9776 time((time_t *)&statbufp->st_mtime);
9777 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9778 return 0;
9779 }
748a9306
LW		 9780 }
9781
bbce6d69 9782 /* Try for a directory name first. If fspec contains a filename without
61bb5906 9783 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 9784 * and sea:[wine.dark]water. exist, we prefer the directory here.
9785 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9786 * not sea:[wine.dark]., if the latter exists. If the intended target is
9787 * the file with null type, specify this by calling flex_stat() with
9788 * a '.' at the end of fspec.
2497a41f
JM		 9789 *
9790 * If we are in Posix filespec mode, accept the filename as is.
bbce6d69 9791 */
2497a41f
JM		 9792#if __CRTL_VER >= 80200000 && !defined(__VAX)
9793 if (decc_posix_compliant_pathnames == 0) {
9794#endif
cc077a9f 9795 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
2497a41f
JM		 9796 if (lstat_flag == 0)
9797 retval = stat(fileified,(stat_t *) statbufp);
9798 else
9799 retval = lstat(fileified,(stat_t *) statbufp);
6b88bc9c 9800 if (!retval && statbufp == (Stat_t *) &PL_statcache)
aa689395 9801 strcpy(namecache,fileified);
748a9306 9802 }
2497a41f
JM		 9803 if (retval) {
9804 if (lstat_flag == 0)
9805 retval = stat(temp_fspec,(stat_t *) statbufp);
9806 else
9807 retval = lstat(temp_fspec,(stat_t *) statbufp);
9808 }
9809#if __CRTL_VER >= 80200000 && !defined(__VAX)
9810 } else {
9811 if (lstat_flag == 0)
9812 retval = stat(temp_fspec,(stat_t *) statbufp);
9813 else
9814 retval = lstat(temp_fspec,(stat_t *) statbufp);
9815 }
9816#endif
ff0cee69 9817 if (!retval) {
682e4b71 9818 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
2497a41f
JM		 9819#ifndef _USE_STD_STAT
9820 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9821 statbufp->st_devnam[63] = 0;
fd8cd3a3 9822 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
2497a41f
JM		 9823#else
9824 /* todo:
9825 * The device is only encoded so that Perl_cando can use it to
9826 * look up ACLS. So rmsexpand it to the 255 character version
9827 * and store it in ->st_devnam. rmsexpand needs to be fixed
9828 * for long filenames and symbolic links first. This also seems
9829 * to remove the need for a namecache that could be stale.
9830 */
9831#endif
61bb5906
CB		 9832# ifdef RTL_USES_UTC
9833# ifdef VMSISH_TIME
9834 if (VMSISH_TIME) {
9835 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9836 statbufp->st_atime = _toloc(statbufp->st_atime);
9837 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9838 }
9839# endif
9840# else
ff0cee69 9841# ifdef VMSISH_TIME
9842 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9843# else
9844 if (1) {
9845# endif
61bb5906
CB		 9846 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9847 statbufp->st_atime = _toutc(statbufp->st_atime);
9848 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 9849 }
61bb5906 9850# endif
ff0cee69 9851 }
9543c6b6
CB		 9852 /* If we were successful, leave errno where we found it */
9853 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
748a9306
LW		 9854 return retval;
9855
2497a41f
JM		 9856} /* end of flex_stat_int() */
9857
9858
9859/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9860int
9861Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9862{
7ded3206 9863 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 9864}
9865/*}}}*/
9866
9867/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9868int
9869Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9870{
7ded3206 9871 return flex_stat_int(fspec, statbufp, 1);
2497a41f 9872}
748a9306
LW		 9873/*}}}*/
9874
b7ae7a0d 9875
c07a80fd 9876/*{{{char *my_getlogin()*/
9877/* VMS cuserid == Unix getlogin, except calling sequence */
9878char *
2fbb330f 9879my_getlogin(void)
c07a80fd 9880{
9881 static char user[L_cuserid];
9882 return cuserid(user);
9883}
9884/*}}}*/
9885
9886
a5f75d66
AD		 9887/* rmscopy - copy a file using VMS RMS routines
9888 *
9889 * Copies contents and attributes of spec_in to spec_out, except owner
9890 * and protection information. Name and type of spec_in are used as
a3e9d8c9 9891 * defaults for spec_out. The third parameter specifies whether rmscopy()
9892 * should try to propagate timestamps from the input file to the output file.
9893 * If it is less than 0, no timestamps are preserved. If it is 0, then
9894 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
9895 * propagated to the output file at creation iff the output file specification
9896 * did not contain an explicit name or type, and the revision date is always
9897 * updated at the end of the copy operation. If it is greater than 0, then
9898 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9899 * other than the revision date should be propagated, and bit 1 indicates
9900 * that the revision date should be propagated.
9901 *
9902 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 9903 *
bd3fa61c 9904 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 9905 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 9906 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
9907 * as part of the Perl standard distribution under the terms of the
9908 * GNU General Public License or the Perl Artistic License. Copies
9909 * of each may be found in the Perl standard distribution.
a480973c 9910 */ /* FIXME */
a3e9d8c9 9911/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c 9912#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a5f75d66 9913int
2fbb330f 9914Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
a5f75d66
AD		 9915{
9916 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9917 rsa[NAM$C_MAXRSS], ubf[32256];
9918 unsigned long int i, sts, sts2;
9919 struct FAB fab_in, fab_out;
9920 struct RAB rab_in, rab_out;
9921 struct NAM nam;
9922 struct XABDAT xabdat;
9923 struct XABFHC xabfhc;
9924 struct XABRDT xabrdt;
9925 struct XABSUM xabsum;
9926
9927 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
9928 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9929 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9930 return 0;
9931 }
9932
9933 fab_in = cc$rms_fab;
9934 fab_in.fab$l_fna = vmsin;
9935 fab_in.fab$b_fns = strlen(vmsin);
9936 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9937 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9938 fab_in.fab$l_fop = FAB$M_SQO;
9939 fab_in.fab$l_nam = &nam;
a3e9d8c9 9940 fab_in.fab$l_xab = (void *) &xabdat;
a5f75d66
AD		 9941
9942 nam = cc$rms_nam;
9943 nam.nam$l_rsa = rsa;
9944 nam.nam$b_rss = sizeof(rsa);
9945 nam.nam$l_esa = esa;
9946 nam.nam$b_ess = sizeof (esa);
9947 nam.nam$b_esl = nam.nam$b_rsl = 0;
f7ddb74a
JM		 9948#ifdef NAM$M_NO_SHORT_UPCASE
9949 if (decc_efs_case_preserve)
9950 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9951#endif
a5f75d66
AD		 9952
9953 xabdat = cc$rms_xabdat; /* To get creation date */
a3e9d8c9 9954 xabdat.xab$l_nxt = (void *) &xabfhc;
a5f75d66
AD		 9955
9956 xabfhc = cc$rms_xabfhc; /* To get record length */
a3e9d8c9 9957 xabfhc.xab$l_nxt = (void *) &xabsum;
a5f75d66
AD		 9958
9959 xabsum = cc$rms_xabsum; /* To get key and area information */
9960
9961 if (!((sts = sys$open(&fab_in)) & 1)) {
9962 set_vaxc_errno(sts);
9963 switch (sts) {
f282b18d 9964 case RMS$_FNF: case RMS$_DNF:
a5f75d66 9965 set_errno(ENOENT); break;
f282b18d
CB		 9966 case RMS$_DIR:
9967 set_errno(ENOTDIR); break;
a5f75d66
AD		 9968 case RMS$_DEV:
9969 set_errno(ENODEV); break;
9970 case RMS$_SYN:
9971 set_errno(EINVAL); break;
9972 case RMS$_PRV:
9973 set_errno(EACCES); break;
9974 default:
9975 set_errno(EVMSERR);
9976 }
9977 return 0;
9978 }
9979
9980 fab_out = fab_in;
9981 fab_out.fab$w_ifi = 0;
9982 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
9983 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
9984 fab_out.fab$l_fop = FAB$M_SQO;
9985 fab_out.fab$l_fna = vmsout;
9986 fab_out.fab$b_fns = strlen(vmsout);
9987 fab_out.fab$l_dna = nam.nam$l_name;
9988 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
a3e9d8c9 9989
9990 if (preserve_dates == 0) { /* Act like DCL COPY */
f7ddb74a 9991 nam.nam$b_nop |= NAM$M_SYNCHK;
a3e9d8c9 9992 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
9993 if (!((sts = sys$parse(&fab_out)) & 1)) {
9994 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
9995 set_vaxc_errno(sts);
9996 return 0;
9997 }
9998 fab_out.fab$l_xab = (void *) &xabdat;
9999 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10000 }
10001 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10002 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10003 preserve_dates =0; /* bitmask from this point forward */
10004
10005 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a5f75d66
AD		 10006 if (!((sts = sys$create(&fab_out)) & 1)) {
10007 set_vaxc_errno(sts);
10008 switch (sts) {
f282b18d 10009 case RMS$_DNF:
a5f75d66 10010 set_errno(ENOENT); break;
f282b18d
CB		 10011 case RMS$_DIR:
10012 set_errno(ENOTDIR); break;
a5f75d66
AD		 10013 case RMS$_DEV:
10014 set_errno(ENODEV); break;
10015 case RMS$_SYN:
10016 set_errno(EINVAL); break;
10017 case RMS$_PRV:
10018 set_errno(EACCES); break;
10019 default:
10020 set_errno(EVMSERR);
10021 }
10022 return 0;
10023 }
10024 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
a3e9d8c9 10025 if (preserve_dates & 2) {
10026 /* sys$close() will process xabrdt, not xabdat */
10027 xabrdt = cc$rms_xabrdt;
b7ae7a0d 10028#ifndef __GNUC__
a3e9d8c9 10029 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
b7ae7a0d 10030#else
10031 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10032 * is unsigned long[2], while DECC & VAXC use a struct */
10033 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10034#endif
a3e9d8c9 10035 fab_out.fab$l_xab = (void *) &xabrdt;
10036 }
a5f75d66
AD		 10037
10038 rab_in = cc$rms_rab;
10039 rab_in.rab$l_fab = &fab_in;
10040 rab_in.rab$l_rop = RAB$M_BIO;
10041 rab_in.rab$l_ubf = ubf;
10042 rab_in.rab$w_usz = sizeof ubf;
10043 if (!((sts = sys$connect(&rab_in)) & 1)) {
10044 sys$close(&fab_in); sys$close(&fab_out);
10045 set_errno(EVMSERR); set_vaxc_errno(sts);
10046 return 0;
10047 }
10048
10049 rab_out = cc$rms_rab;
10050 rab_out.rab$l_fab = &fab_out;
10051 rab_out.rab$l_rbf = ubf;
10052 if (!((sts = sys$connect(&rab_out)) & 1)) {
10053 sys$close(&fab_in); sys$close(&fab_out);
10054 set_errno(EVMSERR); set_vaxc_errno(sts);
10055 return 0;
10056 }
10057
10058 while ((sts = sys$read(&rab_in))) { /* always true */
10059 if (sts == RMS$_EOF) break;
10060 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10061 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10062 sys$close(&fab_in); sys$close(&fab_out);
10063 set_errno(EVMSERR); set_vaxc_errno(sts);
10064 return 0;
10065 }
10066 }
10067
10068 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10069 sys$close(&fab_in); sys$close(&fab_out);
10070 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10071 if (!(sts & 1)) {
10072 set_errno(EVMSERR); set_vaxc_errno(sts);
10073 return 0;
10074 }
10075
10076 return 1;
10077
10078} /* end of rmscopy() */
a480973c
JM		 10079#else
10080/* ODS-5 support version */
10081int
10082Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10083{
10084 char *vmsin, * vmsout, *esa, *esa_out,
10085 *rsa, *ubf;
10086 unsigned long int i, sts, sts2;
10087 struct FAB fab_in, fab_out;
10088 struct RAB rab_in, rab_out;
10089 struct NAML nam;
10090 struct NAML nam_out;
10091 struct XABDAT xabdat;
10092 struct XABFHC xabfhc;
10093 struct XABRDT xabrdt;
10094 struct XABSUM xabsum;
10095
10096 Newx(vmsin, VMS_MAXRSS, char);
10097 Newx(vmsout, VMS_MAXRSS, char);
10098 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10099 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10100 Safefree(vmsin);
10101 Safefree(vmsout);
10102 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10103 return 0;
10104 }
10105
10106 Newx(esa, VMS_MAXRSS, char);
10107 nam = cc$rms_naml;
10108 fab_in = cc$rms_fab;
10109 fab_in.fab$l_fna = (char *) -1;
10110 fab_in.fab$b_fns = 0;
10111 nam.naml$l_long_filename = vmsin;
10112 nam.naml$l_long_filename_size = strlen(vmsin);
10113 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10114 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10115 fab_in.fab$l_fop = FAB$M_SQO;
10116 fab_in.fab$l_naml = &nam;
10117 fab_in.fab$l_xab = (void *) &xabdat;
10118
10119 Newx(rsa, VMS_MAXRSS, char);
10120 nam.naml$l_rsa = NULL;
10121 nam.naml$b_rss = 0;
10122 nam.naml$l_long_result = rsa;
10123 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10124 nam.naml$l_esa = NULL;
10125 nam.naml$b_ess = 0;
10126 nam.naml$l_long_expand = esa;
10127 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10128 nam.naml$b_esl = nam.naml$b_rsl = 0;
10129 nam.naml$l_long_expand_size = 0;
10130 nam.naml$l_long_result_size = 0;
10131#ifdef NAM$M_NO_SHORT_UPCASE
10132 if (decc_efs_case_preserve)
10133 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10134#endif
10135
10136 xabdat = cc$rms_xabdat; /* To get creation date */
10137 xabdat.xab$l_nxt = (void *) &xabfhc;
10138
10139 xabfhc = cc$rms_xabfhc; /* To get record length */
10140 xabfhc.xab$l_nxt = (void *) &xabsum;
10141
10142 xabsum = cc$rms_xabsum; /* To get key and area information */
10143
10144 if (!((sts = sys$open(&fab_in)) & 1)) {
10145 Safefree(vmsin);
10146 Safefree(vmsout);
10147 Safefree(esa);
10148 Safefree(rsa);
10149 set_vaxc_errno(sts);
10150 switch (sts) {
10151 case RMS$_FNF: case RMS$_DNF:
10152 set_errno(ENOENT); break;
10153 case RMS$_DIR:
10154 set_errno(ENOTDIR); break;
10155 case RMS$_DEV:
10156 set_errno(ENODEV); break;
10157 case RMS$_SYN:
10158 set_errno(EINVAL); break;
10159 case RMS$_PRV:
10160 set_errno(EACCES); break;
10161 default:
10162 set_errno(EVMSERR);
10163 }
10164 return 0;
10165 }
10166
10167 nam_out = nam;
10168 fab_out = fab_in;
10169 fab_out.fab$w_ifi = 0;
10170 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10171 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10172 fab_out.fab$l_fop = FAB$M_SQO;
10173 fab_out.fab$l_naml = &nam_out;
10174 fab_out.fab$l_fna = (char *) -1;
10175 fab_out.fab$b_fns = 0;
10176 nam_out.naml$l_long_filename = vmsout;
10177 nam_out.naml$l_long_filename_size = strlen(vmsout);
10178 fab_out.fab$l_dna = (char *) -1;
10179 fab_out.fab$b_dns = 0;
10180 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10181 nam_out.naml$l_long_defname_size =
10182 nam.naml$l_long_name ?
10183 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10184
10185 Newx(esa_out, VMS_MAXRSS, char);
10186 nam_out.naml$l_rsa = NULL;
10187 nam_out.naml$b_rss = 0;
10188 nam_out.naml$l_long_result = NULL;
10189 nam_out.naml$l_long_result_alloc = 0;
10190 nam_out.naml$l_esa = NULL;
10191 nam_out.naml$b_ess = 0;
10192 nam_out.naml$l_long_expand = esa_out;
10193 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10194
10195 if (preserve_dates == 0) { /* Act like DCL COPY */
10196 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10197 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10198 if (!((sts = sys$parse(&fab_out)) & 1)) {
10199 Safefree(vmsin);
10200 Safefree(vmsout);
10201 Safefree(esa);
10202 Safefree(rsa);
10203 Safefree(esa_out);
10204 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10205 set_vaxc_errno(sts);
10206 return 0;
10207 }
10208 fab_out.fab$l_xab = (void *) &xabdat;
10209 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10210 }
10211 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10212 preserve_dates =0; /* bitmask from this point forward */
10213
10214 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10215 if (!((sts = sys$create(&fab_out)) & 1)) {
10216 Safefree(vmsin);
10217 Safefree(vmsout);
10218 Safefree(esa);
10219 Safefree(rsa);
10220 Safefree(esa_out);
10221 set_vaxc_errno(sts);
10222 switch (sts) {
10223 case RMS$_DNF:
10224 set_errno(ENOENT); break;
10225 case RMS$_DIR:
10226 set_errno(ENOTDIR); break;
10227 case RMS$_DEV:
10228 set_errno(ENODEV); break;
10229 case RMS$_SYN:
10230 set_errno(EINVAL); break;
10231 case RMS$_PRV:
10232 set_errno(EACCES); break;
10233 default:
10234 set_errno(EVMSERR);
10235 }
10236 return 0;
10237 }
10238 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10239 if (preserve_dates & 2) {
10240 /* sys$close() will process xabrdt, not xabdat */
10241 xabrdt = cc$rms_xabrdt;
10242#ifndef __GNUC__
10243 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10244#else
10245 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10246 * is unsigned long[2], while DECC & VAXC use a struct */
10247 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10248#endif
10249 fab_out.fab$l_xab = (void *) &xabrdt;
10250 }
10251
10252 Newx(ubf, 32256, char);
10253 rab_in = cc$rms_rab;
10254 rab_in.rab$l_fab = &fab_in;
10255 rab_in.rab$l_rop = RAB$M_BIO;
10256 rab_in.rab$l_ubf = ubf;
10257 rab_in.rab$w_usz = 32256;
10258 if (!((sts = sys$connect(&rab_in)) & 1)) {
10259 sys$close(&fab_in); sys$close(&fab_out);
10260 Safefree(vmsin);
10261 Safefree(vmsout);
10262 Safefree(esa);
10263 Safefree(ubf);
10264 Safefree(rsa);
10265 Safefree(esa_out);
10266 set_errno(EVMSERR); set_vaxc_errno(sts);
10267 return 0;
10268 }
10269
10270 rab_out = cc$rms_rab;
10271 rab_out.rab$l_fab = &fab_out;
10272 rab_out.rab$l_rbf = ubf;
10273 if (!((sts = sys$connect(&rab_out)) & 1)) {
10274 sys$close(&fab_in); sys$close(&fab_out);
10275 Safefree(vmsin);
10276 Safefree(vmsout);
10277 Safefree(esa);
10278 Safefree(ubf);
10279 Safefree(rsa);
10280 Safefree(esa_out);
10281 set_errno(EVMSERR); set_vaxc_errno(sts);
10282 return 0;
10283 }
10284
10285 while ((sts = sys$read(&rab_in))) { /* always true */
10286 if (sts == RMS$_EOF) break;
10287 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10288 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10289 sys$close(&fab_in); sys$close(&fab_out);
10290 Safefree(vmsin);
10291 Safefree(vmsout);
10292 Safefree(esa);
10293 Safefree(ubf);
10294 Safefree(rsa);
10295 Safefree(esa_out);
10296 set_errno(EVMSERR); set_vaxc_errno(sts);
10297 return 0;
10298 }
10299 }
10300
10301
10302 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10303 sys$close(&fab_in); sys$close(&fab_out);
10304 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10305 if (!(sts & 1)) {
10306 Safefree(vmsin);
10307 Safefree(vmsout);
10308 Safefree(esa);
10309 Safefree(ubf);
10310 Safefree(rsa);
10311 Safefree(esa_out);
10312 set_errno(EVMSERR); set_vaxc_errno(sts);
10313 return 0;
10314 }
10315
10316 Safefree(vmsin);
10317 Safefree(vmsout);
10318 Safefree(esa);
10319 Safefree(ubf);
10320 Safefree(rsa);
10321 Safefree(esa_out);
10322 return 1;
10323
10324} /* end of rmscopy() */
10325#endif
a5f75d66
AD		 10326/*}}}*/
10327
10328
748a9306
LW		 10329/*** The following glue provides 'hooks' to make some of the routines
10330 * from this file available from Perl. These routines are sufficiently
10331 * basic, and are required sufficiently early in the build process,
10332 * that's it's nice to have them available to miniperl as well as the
10333 * full Perl, so they're set up here instead of in an extension. The
10334 * Perl code which handles importation of these names into a given
10335 * package lives in [.VMS]Filespec.pm in @INC.
10336 */
10337
10338void
5c84aa53 10339rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 10340{
10341 dXSARGS;
bbce6d69 10342 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 10343 STRLEN n_a;
01b8edb6 10344
bbce6d69 10345 if (!items || items > 2)
5c84aa53 10346 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 10347 fspec = SvPV(ST(0),n_a);
bbce6d69 10348 if (!fspec || !*fspec) XSRETURN_UNDEF;
2d8e6c8d 10349 if (items == 2) defspec = SvPV(ST(1),n_a);
b7ae7a0d 10350
bbce6d69 10351 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10352 ST(0) = sv_newmortal();
10353 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
740ce14c 10354 XSRETURN(1);
01b8edb6 10355}
10356
10357void
5c84aa53 10358vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10359{
10360 dXSARGS;
10361 char *vmsified;
2d8e6c8d 10362 STRLEN n_a;
748a9306 10363
5c84aa53 10364 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
2d8e6c8d 10365 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10366 ST(0) = sv_newmortal();
10367 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10368 XSRETURN(1);
10369}
10370
10371void
5c84aa53 10372unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10373{
10374 dXSARGS;
10375 char *unixified;
2d8e6c8d 10376 STRLEN n_a;
748a9306 10377
5c84aa53 10378 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
2d8e6c8d 10379 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10380 ST(0) = sv_newmortal();
10381 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10382 XSRETURN(1);
10383}
10384
10385void
5c84aa53 10386fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10387{
10388 dXSARGS;
10389 char *fileified;
2d8e6c8d 10390 STRLEN n_a;
748a9306 10391
5c84aa53 10392 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
2d8e6c8d 10393 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10394 ST(0) = sv_newmortal();
10395 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10396 XSRETURN(1);
10397}
10398
10399void
5c84aa53 10400pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10401{
10402 dXSARGS;
10403 char *pathified;
2d8e6c8d 10404 STRLEN n_a;
748a9306 10405
5c84aa53 10406 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
2d8e6c8d 10407 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10408 ST(0) = sv_newmortal();
10409 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10410 XSRETURN(1);
10411}
10412
10413void
5c84aa53 10414vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 10415{
10416 dXSARGS;
10417 char *vmspath;
2d8e6c8d 10418 STRLEN n_a;
748a9306 10419
5c84aa53 10420 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
2d8e6c8d 10421 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10422 ST(0) = sv_newmortal();
10423 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10424 XSRETURN(1);
10425}
10426
10427void
5c84aa53 10428unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 10429{
10430 dXSARGS;
10431 char *unixpath;
2d8e6c8d 10432 STRLEN n_a;
748a9306 10433
5c84aa53 10434 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
2d8e6c8d 10435 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10436 ST(0) = sv_newmortal();
10437 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10438 XSRETURN(1);
10439}
10440
10441void
5c84aa53 10442candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 10443{
10444 dXSARGS;
a5f75d66
AD		 10445 char fspec[NAM$C_MAXRSS+1], *fsp;
10446 SV *mysv;
10447 IO *io;
2d8e6c8d 10448 STRLEN n_a;
748a9306 10449
5c84aa53 10450 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 10451
10452 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10453 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10454 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 10455 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10456 ST(0) = &PL_sv_no;
a5f75d66
AD		 10457 XSRETURN(1);
10458 }
10459 fsp = fspec;
10460 }
10461 else {
2d8e6c8d 10462 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 10463 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10464 ST(0) = &PL_sv_no;
a5f75d66
AD		 10465 XSRETURN(1);
10466 }
10467 }
10468
54310121 10469 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
a5f75d66
AD		 10470 XSRETURN(1);
10471}
10472
10473void
5c84aa53 10474rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 10475{
10476 dXSARGS;
a480973c 10477 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 10478 int date_flag;
a5f75d66
AD		 10479 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10480 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10481 unsigned long int sts;
10482 SV *mysv;
10483 IO *io;
2d8e6c8d 10484 STRLEN n_a;
a5f75d66 10485
a3e9d8c9 10486 if (items < 2 || items > 3)
5c84aa53 10487 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 10488
10489 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 10490 Newx(inspec, VMS_MAXRSS, char);
a5f75d66 10491 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10492 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 10493 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10494 ST(0) = &PL_sv_no;
a480973c 10495 Safefree(inspec);
a5f75d66
AD		 10496 XSRETURN(1);
10497 }
10498 inp = inspec;
10499 }
10500 else {
2d8e6c8d 10501 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 10502 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10503 ST(0) = &PL_sv_no;
a480973c 10504 Safefree(inspec);
a5f75d66
AD		 10505 XSRETURN(1);
10506 }
10507 }
10508 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 10509 Newx(outspec, VMS_MAXRSS, char);
a5f75d66 10510 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10511 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 10512 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10513 ST(0) = &PL_sv_no;
a480973c
JM		 10514 Safefree(inspec);
10515 Safefree(outspec);
a5f75d66
AD		 10516 XSRETURN(1);
10517 }
10518 outp = outspec;
10519 }
10520 else {
2d8e6c8d 10521 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 10522 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10523 ST(0) = &PL_sv_no;
a480973c
JM		 10524 Safefree(inspec);
10525 Safefree(outspec);
a5f75d66
AD		 10526 XSRETURN(1);
10527 }
10528 }
a3e9d8c9 10529 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 10530
54310121 10531 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
a480973c
JM		 10532 Safefree(inspec);
10533 Safefree(outspec);
748a9306
LW		 10534 XSRETURN(1);
10535}
10536
a480973c
JM		 10537/* The mod2fname is limited to shorter filenames by design, so it should
10538 * not be modified to support longer EFS pathnames
10539 */
4b19af01 10540void
fd8cd3a3 10541mod2fname(pTHX_ CV *cv)
4b19af01
CB		 10542{
10543 dXSARGS;
10544 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10545 workbuff[NAM$C_MAXRSS*1 + 1];
10546 int total_namelen = 3, counter, num_entries;
10547 /* ODS-5 ups this, but we want to be consistent, so... */
10548 int max_name_len = 39;
10549 AV *in_array = (AV *)SvRV(ST(0));
10550
10551 num_entries = av_len(in_array);
10552
10553 /* All the names start with PL_. */
10554 strcpy(ultimate_name, "PL_");
10555
10556 /* Clean up our working buffer */
10557 Zero(work_name, sizeof(work_name), char);
10558
10559 /* Run through the entries and build up a working name */
10560 for(counter = 0; counter <= num_entries; counter++) {
10561 /* If it's not the first name then tack on a __ */
10562 if (counter) {
10563 strcat(work_name, "__");
10564 }
10565 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10566 PL_na));
10567 }
10568
10569 /* Check to see if we actually have to bother...*/
10570 if (strlen(work_name) + 3 <= max_name_len) {
10571 strcat(ultimate_name, work_name);
10572 } else {
10573 /* It's too darned big, so we need to go strip. We use the same */
10574 /* algorithm as xsubpp does. First, strip out doubled __ */
10575 char *source, *dest, last;
10576 dest = workbuff;
10577 last = 0;
10578 for (source = work_name; *source; source++) {
10579 if (last == *source && last == '_') {
10580 continue;
10581 }
10582 *dest++ = *source;
10583 last = *source;
10584 }
10585 /* Go put it back */
10586 strcpy(work_name, workbuff);
10587 /* Is it still too big? */
10588 if (strlen(work_name) + 3 > max_name_len) {
10589 /* Strip duplicate letters */
10590 last = 0;
10591 dest = workbuff;
10592 for (source = work_name; *source; source++) {
10593 if (last == toupper(*source)) {
10594 continue;
10595 }
10596 *dest++ = *source;
10597 last = toupper(*source);
10598 }
10599 strcpy(work_name, workbuff);
10600 }
10601
10602 /* Is it *still* too big? */
10603 if (strlen(work_name) + 3 > max_name_len) {
10604 /* Too bad, we truncate */
10605 work_name[max_name_len - 2] = 0;
10606 }
10607 strcat(ultimate_name, work_name);
10608 }
10609
10610 /* Okay, return it */
10611 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10612 XSRETURN(1);
10613}
10614
748a9306 10615void
96e176bf
CL		 10616hushexit_fromperl(pTHX_ CV *cv)
10617{
10618 dXSARGS;
10619
10620 if (items > 0) {
10621 VMSISH_HUSHED = SvTRUE(ST(0));
10622 }
10623 ST(0) = boolSV(VMSISH_HUSHED);
10624 XSRETURN(1);
10625}
10626
2497a41f
JM		 10627#ifdef HAS_SYMLINK
10628static char *
10629mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10630
10631void
10632vms_realpath_fromperl(pTHX_ CV *cv)
10633{
10634 dXSARGS;
10635 char *fspec, *rslt_spec, *rslt;
10636 STRLEN n_a;
10637
10638 if (!items || items != 1)
10639 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10640
10641 fspec = SvPV(ST(0),n_a);
10642 if (!fspec || !*fspec) XSRETURN_UNDEF;
10643
10644 Newx(rslt_spec, VMS_MAXRSS + 1, char);
10645 rslt = do_vms_realpath(fspec, rslt_spec);
10646 ST(0) = sv_newmortal();
10647 if (rslt != NULL)
10648 sv_usepvn(ST(0),rslt,strlen(rslt));
10649 else
10650 Safefree(rslt_spec);
10651 XSRETURN(1);
10652}
10653#endif
10654
10655#if __CRTL_VER >= 70301000 && !defined(__VAX)
10656int do_vms_case_tolerant(void);
10657
10658void
10659vms_case_tolerant_fromperl(pTHX_ CV *cv)
10660{
10661 dXSARGS;
10662 ST(0) = boolSV(do_vms_case_tolerant());
10663 XSRETURN(1);
10664}
10665#endif
10666
96e176bf
CL		 10667void
10668Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10669 struct interp_intern *dst)
10670{
10671 memcpy(dst,src,sizeof(struct interp_intern));
10672}
10673
10674void
10675Perl_sys_intern_clear(pTHX)
10676{
10677}
10678
10679void
10680Perl_sys_intern_init(pTHX)
10681{
3ff49832
CL		 10682 unsigned int ix = RAND_MAX;
10683 double x;
96e176bf
CL		 10684
10685 VMSISH_HUSHED = 0;
10686
7a7fd8e0
JM		 10687 /* fix me later to track running under GNV */
10688 /* this allows some limited testing */
10689 MY_POSIX_EXIT = decc_filename_unix_report;
10690
96e176bf
CL		 10691 x = (float)ix;
10692 MY_INV_RAND_MAX = 1./x;
ff7adb52 10693}
96e176bf
CL		 10694
10695void
f7ddb74a 10696init_os_extras(void)
748a9306 10697{
a69a6dba 10698 dTHX;
748a9306 10699 char* file = __FILE__;
93948341
CB		 10700 char temp_buff[512];
10701 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10702 no_translate_barewords = TRUE;
10703 } else {
10704 no_translate_barewords = FALSE;
10705 }
748a9306 10706
740ce14c 10707 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 10708 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10709 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10710 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10711 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10712 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10713 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10714 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 10715 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 10716 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 10717 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
f7ddb74a
JM		 10718#ifdef HAS_SYMLINK
10719 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10720#endif
f7ddb74a
JM		 10721#if __CRTL_VER >= 70301000 && !defined(__VAX)
10722 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10723#endif
17f28c40 10724
afd8f436 10725 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 10726
748a9306
LW		 10727 return;
10728}
10729
f7ddb74a
JM		 10730#ifdef HAS_SYMLINK
10731
10732#if __CRTL_VER == 80200000
10733/* This missed getting in to the DECC SDK for 8.2 */
10734char *realpath(const char *file_name, char * resolved_name, ...);
10735#endif
10736
10737/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10738/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10739 * The perl fallback routine to provide realpath() is not as efficient
10740 * on OpenVMS.
10741 */
10742static char *
10743mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10744{
10745 return realpath(filespec, outbuf);
10746}
10747
10748/*}}}*/
10749/* External entry points */
10750char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10751{ return do_vms_realpath(filespec, outbuf); }
10752#else
10753char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10754{ return NULL; }
10755#endif
10756
10757
10758#if __CRTL_VER >= 70301000 && !defined(__VAX)
10759/* case_tolerant */
10760
10761/*{{{int do_vms_case_tolerant(void)*/
10762/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10763 * controlled by a process setting.
10764 */
10765int do_vms_case_tolerant(void)
10766{
10767 return vms_process_case_tolerant;
10768}
10769/*}}}*/
10770/* External entry points */
10771int Perl_vms_case_tolerant(void)
10772{ return do_vms_case_tolerant(); }
10773#else
10774int Perl_vms_case_tolerant(void)
10775{ return vms_process_case_tolerant; }
10776#endif
10777
10778
10779 /* Start of DECC RTL Feature handling */
10780
10781static int sys_trnlnm
10782 (const char * logname,
10783 char * value,
10784 int value_len)
10785{
10786 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10787 const unsigned long attr = LNM$M_CASE_BLIND;
10788 struct dsc$descriptor_s name_dsc;
10789 int status;
10790 unsigned short result;
10791 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10792 {0, 0, 0, 0}};
10793
10794 name_dsc.dsc$w_length = strlen(logname);
10795 name_dsc.dsc$a_pointer = (char *)logname;
10796 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10797 name_dsc.dsc$b_class = DSC$K_CLASS_S;
10798
10799 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10800
10801 if ($VMS_STATUS_SUCCESS(status)) {
10802
10803 /* Null terminate and return the string */
10804 /*--------------------------------------*/
10805 value[result] = 0;
10806 }
10807
10808 return status;
10809}
10810
10811static int sys_crelnm
10812 (const char * logname,
10813 const char * value)
10814{
10815 int ret_val;
10816 const char * proc_table = "LNM$PROCESS_TABLE";
10817 struct dsc$descriptor_s proc_table_dsc;
10818 struct dsc$descriptor_s logname_dsc;
10819 struct itmlst_3 item_list[2];
10820
10821 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10822 proc_table_dsc.dsc$w_length = strlen(proc_table);
10823 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10824 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10825
10826 logname_dsc.dsc$a_pointer = (char *) logname;
10827 logname_dsc.dsc$w_length = strlen(logname);
10828 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10829 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10830
10831 item_list[0].buflen = strlen(value);
10832 item_list[0].itmcode = LNM$_STRING;
10833 item_list[0].bufadr = (char *)value;
10834 item_list[0].retlen = NULL;
10835
10836 item_list[1].buflen = 0;
10837 item_list[1].itmcode = 0;
10838
10839 ret_val = sys$crelnm
10840 (NULL,
10841 (const struct dsc$descriptor_s *)&proc_table_dsc,
10842 (const struct dsc$descriptor_s *)&logname_dsc,
10843 NULL,
10844 (const struct item_list_3 *) item_list);
10845
10846 return ret_val;
10847}
10848
10849
10850/* C RTL Feature settings */
10851
10852static int set_features
10853 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
10854 int (* cli_routine)(void), /* Not documented */
10855 void *image_info) /* Not documented */
10856{
10857 int status;
10858 int s;
10859 int dflt;
10860 char* str;
10861 char val_str[10];
3c841f20 10862#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 10863 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10864 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10865 unsigned long case_perm;
10866 unsigned long case_image;
3c841f20 10867#endif
f7ddb74a 10868
2497a41f
JM		 10869 /* hacks to see if known bugs are still present for testing */
10870
10871 /* Readdir is returning filenames in VMS syntax always */
10872 decc_bug_readdir_efs1 = 1;
10873 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10874 if ($VMS_STATUS_SUCCESS(status)) {
10875 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10876 decc_bug_readdir_efs1 = 1;
10877 else
10878 decc_bug_readdir_efs1 = 0;
10879 }
10880
10881 /* PCP mode requires creating /dev/null special device file */
682e4b71 10882 decc_bug_devnull = 1;
2497a41f
JM		 10883 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10884 if ($VMS_STATUS_SUCCESS(status)) {
10885 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10886 decc_bug_devnull = 1;
682e4b71
JM		 10887 else
10888 decc_bug_devnull = 0;
2497a41f
JM		 10889 }
10890
10891 /* fgetname returning a VMS name in UNIX mode */
10892 decc_bug_fgetname = 1;
10893 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10894 if ($VMS_STATUS_SUCCESS(status)) {
10895 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10896 decc_bug_fgetname = 1;
10897 else
10898 decc_bug_fgetname = 0;
10899 }
10900
10901 /* UNIX directory names with no paths are broken in a lot of places */
10902 decc_dir_barename = 1;
10903 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10904 if ($VMS_STATUS_SUCCESS(status)) {
10905 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10906 decc_dir_barename = 1;
10907 else
10908 decc_dir_barename = 0;
10909 }
10910
f7ddb74a
JM		 10911#if __CRTL_VER >= 70300000 && !defined(__VAX)
10912 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10913 if (s >= 0) {
10914 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10915 if (decc_disable_to_vms_logname_translation < 0)
10916 decc_disable_to_vms_logname_translation = 0;
10917 }
10918
10919 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10920 if (s >= 0) {
10921 decc_efs_case_preserve = decc$feature_get_value(s, 1);
10922 if (decc_efs_case_preserve < 0)
10923 decc_efs_case_preserve = 0;
10924 }
10925
10926 s = decc$feature_get_index("DECC$EFS_CHARSET");
10927 if (s >= 0) {
10928 decc_efs_charset = decc$feature_get_value(s, 1);
10929 if (decc_efs_charset < 0)
10930 decc_efs_charset = 0;
10931 }
10932
10933 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10934 if (s >= 0) {
10935 decc_filename_unix_report = decc$feature_get_value(s, 1);
10936 if (decc_filename_unix_report > 0)
10937 decc_filename_unix_report = 1;
10938 else
10939 decc_filename_unix_report = 0;
10940 }
10941
10942 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10943 if (s >= 0) {
10944 decc_filename_unix_only = decc$feature_get_value(s, 1);
10945 if (decc_filename_unix_only > 0) {
10946 decc_filename_unix_only = 1;
10947 }
10948 else {
10949 decc_filename_unix_only = 0;
10950 }
10951 }
10952
10953 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10954 if (s >= 0) {
10955 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10956 if (decc_filename_unix_no_version < 0)
10957 decc_filename_unix_no_version = 0;
10958 }
10959
10960 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10961 if (s >= 0) {
10962 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10963 if (decc_readdir_dropdotnotype < 0)
10964 decc_readdir_dropdotnotype = 0;
10965 }
10966
10967 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10968 if ($VMS_STATUS_SUCCESS(status)) {
10969 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10970 if (s >= 0) {
10971 dflt = decc$feature_get_value(s, 4);
10972 if (dflt > 0) {
10973 decc_disable_posix_root = decc$feature_get_value(s, 1);
10974 if (decc_disable_posix_root <= 0) {
10975 decc$feature_set_value(s, 1, 1);
10976 decc_disable_posix_root = 1;
10977 }
10978 }
10979 else {
10980 /* Traditionally Perl assumes this is off */
10981 decc_disable_posix_root = 1;
10982 decc$feature_set_value(s, 1, 1);
10983 }
10984 }
10985 }
10986
10987#if __CRTL_VER >= 80200000
10988 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
10989 if (s >= 0) {
10990 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
10991 if (decc_posix_compliant_pathnames < 0)
10992 decc_posix_compliant_pathnames = 0;
10993 if (decc_posix_compliant_pathnames > 4)
10994 decc_posix_compliant_pathnames = 0;
10995 }
10996
10997#endif
10998#else
10999 status = sys_trnlnm
11000 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11001 if ($VMS_STATUS_SUCCESS(status)) {
11002 val_str[0] = _toupper(val_str[0]);
11003 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11004 decc_disable_to_vms_logname_translation = 1;
11005 }
11006 }
11007
11008#ifndef __VAX
11009 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11010 if ($VMS_STATUS_SUCCESS(status)) {
11011 val_str[0] = _toupper(val_str[0]);
11012 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11013 decc_efs_case_preserve = 1;
11014 }
11015 }
11016#endif
11017
11018 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11019 if ($VMS_STATUS_SUCCESS(status)) {
11020 val_str[0] = _toupper(val_str[0]);
11021 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11022 decc_filename_unix_report = 1;
11023 }
11024 }
11025 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11026 if ($VMS_STATUS_SUCCESS(status)) {
11027 val_str[0] = _toupper(val_str[0]);
11028 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11029 decc_filename_unix_only = 1;
11030 decc_filename_unix_report = 1;
11031 }
11032 }
11033 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11034 if ($VMS_STATUS_SUCCESS(status)) {
11035 val_str[0] = _toupper(val_str[0]);
11036 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11037 decc_filename_unix_no_version = 1;
11038 }
11039 }
11040 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11041 if ($VMS_STATUS_SUCCESS(status)) {
11042 val_str[0] = _toupper(val_str[0]);
11043 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11044 decc_readdir_dropdotnotype = 1;
11045 }
11046 }
11047#endif
11048
3c841f20 11049#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 11050
11051 /* Report true case tolerance */
11052 /*----------------------------*/
11053 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11054 if (!$VMS_STATUS_SUCCESS(status))
11055 case_perm = PPROP$K_CASE_BLIND;
11056 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11057 if (!$VMS_STATUS_SUCCESS(status))
11058 case_image = PPROP$K_CASE_BLIND;
11059 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11060 (case_image == PPROP$K_CASE_SENSITIVE))
11061 vms_process_case_tolerant = 0;
11062
11063#endif
11064
11065
11066 /* CRTL can be initialized past this point, but not before. */
11067/* DECC$CRTL_INIT(); */
11068
11069 return SS$_NORMAL;
11070}
11071
11072#ifdef __DECC
11073/* DECC dependent attributes */
11074#if __DECC_VER < 60560002
11075#define relative
11076#define not_executable
11077#else
11078#define relative ,rel
11079#define not_executable ,noexe
11080#endif
11081#pragma nostandard
11082#pragma extern_model save
11083#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11084#endif
11085 const __align (LONGWORD) int spare[8] = {0};
11086/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11087/* NOWRT, LONG */
11088#ifdef __DECC
11089#pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11090 nowrt,noshr relative not_executable
11091#endif
11092const long vms_cc_features = (const long)set_features;
11093
11094/*
11095** Force a reference to LIB$INITIALIZE to ensure it
11096** exists in the image.
11097*/
11098int lib$initialize(void);
11099#ifdef __DECC
11100#pragma extern_model strict_refdef
11101#endif
11102 int lib_init_ref = (int) lib$initialize;
11103
11104#ifdef __DECC
11105#pragma extern_model restore
11106#pragma standard
11107#endif
11108
748a9306 11109/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.