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
regmatch(): make IFMATCH use PUSH_STACK rather than fake recursion
[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>
cfcfe586
JM		 50#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
51#include <efndef.h>
52#define NO_EFN EFN$C_ENF
53#else
54#define NO_EFN 0;
55#endif
a0d0e21e 56
f7ddb74a
JM		 57#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
58int decc$feature_get_index(const char *name);
59char* decc$feature_get_name(int index);
60int decc$feature_get_value(int index, int mode);
61int decc$feature_set_value(int index, int mode, int value);
62#else
63#include <unixlib.h>
64#endif
65
cfcfe586
JM		 66#pragma member_alignment save
67#pragma nomember_alignment longword
68struct item_list_3 {
69 unsigned short len;
70 unsigned short code;
71 void * bufadr;
72 unsigned short * retadr;
73};
74#pragma member_alignment restore
75
76/* More specific prototype than in starlet_c.h makes programming errors
77 more visible.
78 */
79#ifdef sys$getdviw
80#undef sys$getdviw
81#endif
82int sys$getdviw
83 (unsigned long efn,
84 unsigned short chan,
85 const struct dsc$descriptor_s * devnam,
86 const struct item_list_3 * itmlst,
87 void * iosb,
88 void * (astadr)(unsigned long),
89 void * astprm,
90 void * nullarg);
91
7a7fd8e0 92#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 93
94static int set_feature_default(const char *name, int value)
95{
96 int status;
97 int index;
98
99 index = decc$feature_get_index(name);
100
101 status = decc$feature_set_value(index, 1, value);
102 if (index == -1 || (status == -1)) {
103 return -1;
104 }
105
106 status = decc$feature_get_value(index, 1);
107 if (status != value) {
108 return -1;
109 }
110
111return 0;
112}
113#endif
f7ddb74a 114
740ce14c 115/* Older versions of ssdef.h don't have these */
116#ifndef SS$_INVFILFOROP
117# define SS$_INVFILFOROP 3930
118#endif
119#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 120# define SS$_NOSUCHOBJECT 2696
121#endif
122
a15cef0c
CB		 123/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
124#define PERLIO_NOT_STDIO 0
125
2497a41f 126/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 127 * code below needs to get to the underlying CRTL routines. */
128#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 129#include "EXTERN.h"
130#include "perl.h"
748a9306 131#include "XSUB.h"
3eeba6fb
CB		 132/* Anticipating future expansion in lexical warnings . . . */
133#ifndef WARN_INTERNAL
134# define WARN_INTERNAL WARN_MISC
135#endif
a0d0e21e 136
988c775c
JM		 137#ifdef VMS_LONGNAME_SUPPORT
138#include <libfildef.h>
139#endif
140
22d4bb9c
CB		 141#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
142# define RTL_USES_UTC 1
143#endif
144
145
c07a80fd 146/* gcc's header files don't #define direct access macros
147 * corresponding to VAXC's variant structs */
148#ifdef __GNUC__
482b294c 149# define uic$v_format uic$r_uic_form.uic$v_format
150# define uic$v_group uic$r_uic_form.uic$v_group
151# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 152# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
153# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
154# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
155# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
156#endif
157
c645ec3f
GS		 158#if defined(NEED_AN_H_ERRNO)
159dEXT int h_errno;
160#endif
c07a80fd 161
f7ddb74a
JM		 162#ifdef __DECC
163#pragma message disable pragma
164#pragma member_alignment save
165#pragma nomember_alignment longword
166#pragma message save
167#pragma message disable misalgndmem
168#endif
a0d0e21e
LW		 169struct itmlst_3 {
170 unsigned short int buflen;
171 unsigned short int itmcode;
172 void *bufadr;
748a9306 173 unsigned short int *retlen;
a0d0e21e 174};
657054d4
JM		 175
176struct filescan_itmlst_2 {
177 unsigned short length;
178 unsigned short itmcode;
179 char * component;
180};
181
dca5a913
JM		 182struct vs_str_st {
183 unsigned short length;
184 char str[65536];
185};
186
f7ddb74a
JM		 187#ifdef __DECC
188#pragma message restore
189#pragma member_alignment restore
190#endif
a0d0e21e 191
4b19af01
CB		 192#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
193#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
194#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
195#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
196#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
f7ddb74a 197#define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
4b19af01
CB		 198#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
199#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
f7ddb74a 200#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 201#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
202#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
203
f7ddb74a
JM		 204static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
205static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
206static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
207static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
208
0e06870b
CB		 209/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
210#define PERL_LNM_MAX_ALLOWED_INDEX 127
211
2d9f3838
CB		 212/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
213 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
214 * the Perl facility.
215 */
216#define PERL_LNM_MAX_ITER 10
217
2497a41f
JM		 218 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
219#if __CRTL_VER >= 70302000 && !defined(__VAX)
220#define MAX_DCL_SYMBOL (8192)
221#define MAX_DCL_LINE_LENGTH (4096 - 4)
222#else
223#define MAX_DCL_SYMBOL (1024)
224#define MAX_DCL_LINE_LENGTH (1024 - 4)
225#endif
ff7adb52 226
01b8edb6 227static char *__mystrtolower(char *str)
228{
229 if (str) for (; *str; ++str) *str= tolower(*str);
230 return str;
231}
232
f675dbe5
CB		 233static struct dsc$descriptor_s fildevdsc =
234 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
235static struct dsc$descriptor_s crtlenvdsc =
236 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
237static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
238static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
239static struct dsc$descriptor_s **env_tables = defenv;
240static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
241
93948341
CB		 242/* True if we shouldn't treat barewords as logicals during directory */
243/* munching */
244static int no_translate_barewords;
245
22d4bb9c
CB		 246#ifndef RTL_USES_UTC
247static int tz_updated = 1;
248#endif
249
f7ddb74a
JM		 250/* DECC Features that may need to affect how Perl interprets
251 * displays filename information
252 */
253static int decc_disable_to_vms_logname_translation = 1;
254static int decc_disable_posix_root = 1;
255int decc_efs_case_preserve = 0;
256static int decc_efs_charset = 0;
257static int decc_filename_unix_no_version = 0;
258static int decc_filename_unix_only = 0;
259int decc_filename_unix_report = 0;
260int decc_posix_compliant_pathnames = 0;
261int decc_readdir_dropdotnotype = 0;
262static int vms_process_case_tolerant = 1;
263
2497a41f
JM		 264/* bug workarounds if needed */
265int decc_bug_readdir_efs1 = 0;
682e4b71 266int decc_bug_devnull = 1;
2497a41f
JM		 267int decc_bug_fgetname = 0;
268int decc_dir_barename = 0;
269
9c1171d1
JM		 270static int vms_debug_on_exception = 0;
271
f7ddb74a
JM		 272/* Is this a UNIX file specification?
273 * No longer a simple check with EFS file specs
274 * For now, not a full check, but need to
275 * handle POSIX ^UP^ specifications
276 * Fixing to handle ^/ cases would require
277 * changes to many other conversion routines.
278 */
279
657054d4 280static int is_unix_filespec(const char *path)
f7ddb74a
JM		 281{
282int ret_val;
283const char * pch1;
284
285 ret_val = 0;
286 if (strncmp(path,"\"^UP^",5) != 0) {
287 pch1 = strchr(path, '/');
288 if (pch1 != NULL)
289 ret_val = 1;
290 else {
291
292 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
293 if (decc_filename_unix_report || decc_filename_unix_only) {
294 if (strcmp(path,".") == 0)
295 ret_val = 1;
296 }
297 }
298 }
299 return ret_val;
300}
301
657054d4
JM		 302/* This handles the expansion of a '^' prefix to the proper character
303 * in a UNIX file specification.
304 *
305 * The output count variable contains the number of characters added
306 * to the output string.
307 *
308 * The return value is the number of characters read from the input
309 * string
310 */
311static int copy_expand_vms_filename_escape
312 (char *outspec, const char *inspec, int *output_cnt)
313{
314int count;
315int scnt;
316
317 count = 0;
318 *output_cnt = 0;
319 if (*inspec == '^') {
320 inspec++;
321 switch (*inspec) {
322 case '.':
323 /* Non trailing dots should just be passed through */
324 *outspec = *inspec;
325 count++;
326 (*output_cnt)++;
327 break;
328 case '_': /* space */
329 *outspec = ' ';
330 inspec++;
331 count++;
332 (*output_cnt)++;
333 break;
334 case 'U': /* Unicode */
335 inspec++;
336 count++;
337 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
338 if (scnt == 4) {
2f4077ca
JM		 339 unsigned int c1, c2;
340 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
341 outspec[0] == c1 & 0xff;
342 outspec[1] == c2 & 0xff;
657054d4
JM		 343 if (scnt > 1) {
344 (*output_cnt) += 2;
345 count += 4;
346 }
347 }
348 else {
349 /* Error - do best we can to continue */
350 *outspec = 'U';
351 outspec++;
352 (*output_cnt++);
353 *outspec = *inspec;
354 count++;
355 (*output_cnt++);
356 }
357 break;
358 default:
359 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
360 if (scnt == 2) {
361 /* Hex encoded */
2f4077ca
JM		 362 unsigned int c1;
363 scnt = sscanf(inspec, "%2x", &c1);
364 outspec[0] = c1 & 0xff;
657054d4
JM		 365 if (scnt > 0) {
366 (*output_cnt++);
367 count += 2;
368 }
369 }
370 else {
371 *outspec = *inspec;
372 count++;
373 (*output_cnt++);
374 }
375 }
376 }
377 else {
378 *outspec = *inspec;
379 count++;
380 (*output_cnt)++;
381 }
382 return count;
383}
384
385
386int SYS$FILESCAN
387 (const struct dsc$descriptor_s * srcstr,
388 struct filescan_itmlst_2 * valuelist,
389 unsigned long * fldflags,
390 struct dsc$descriptor_s *auxout,
391 unsigned short * retlen);
392
393/* vms_split_path - Verify that the input file specification is a
394 * VMS format file specification, and provide pointers to the components of
395 * it. With EFS format filenames, this is virtually the only way to
396 * parse a VMS path specification into components.
397 *
398 * If the sum of the components do not add up to the length of the
399 * string, then the passed file specification is probably a UNIX style
400 * path.
401 */
402static int vms_split_path
367e4b85 403 (pTHX_ const char * path,
dca5a913 404 char * * volume,
657054d4 405 int * vol_len,
dca5a913 406 char * * root,
657054d4 407 int * root_len,
dca5a913 408 char * * dir,
657054d4 409 int * dir_len,
dca5a913 410 char * * name,
657054d4 411 int * name_len,
dca5a913 412 char * * ext,
657054d4 413 int * ext_len,
dca5a913 414 char * * version,
657054d4
JM		 415 int * ver_len)
416{
417struct dsc$descriptor path_desc;
418int status;
419unsigned long flags;
420int ret_stat;
421struct filescan_itmlst_2 item_list[9];
422const int filespec = 0;
423const int nodespec = 1;
424const int devspec = 2;
425const int rootspec = 3;
426const int dirspec = 4;
427const int namespec = 5;
428const int typespec = 6;
429const int verspec = 7;
430
431 /* Assume the worst for an easy exit */
432 ret_stat = -1;
433 *volume = NULL;
434 *vol_len = 0;
435 *root = NULL;
436 *root_len = 0;
437 *dir = NULL;
438 *dir_len;
439 *name = NULL;
440 *name_len = 0;
441 *ext = NULL;
442 *ext_len = 0;
443 *version = NULL;
444 *ver_len = 0;
445
446 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
447 path_desc.dsc$w_length = strlen(path);
448 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
449 path_desc.dsc$b_class = DSC$K_CLASS_S;
450
451 /* Get the total length, if it is shorter than the string passed
452 * then this was probably not a VMS formatted file specification
453 */
454 item_list[filespec].itmcode = FSCN$_FILESPEC;
455 item_list[filespec].length = 0;
456 item_list[filespec].component = NULL;
457
458 /* If the node is present, then it gets considered as part of the
459 * volume name to hopefully make things simple.
460 */
461 item_list[nodespec].itmcode = FSCN$_NODE;
462 item_list[nodespec].length = 0;
463 item_list[nodespec].component = NULL;
464
465 item_list[devspec].itmcode = FSCN$_DEVICE;
466 item_list[devspec].length = 0;
467 item_list[devspec].component = NULL;
468
469 /* root is a special case, adding it to either the directory or
470 * the device components will probalby complicate things for the
471 * callers of this routine, so leave it separate.
472 */
473 item_list[rootspec].itmcode = FSCN$_ROOT;
474 item_list[rootspec].length = 0;
475 item_list[rootspec].component = NULL;
476
477 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
478 item_list[dirspec].length = 0;
479 item_list[dirspec].component = NULL;
480
481 item_list[namespec].itmcode = FSCN$_NAME;
482 item_list[namespec].length = 0;
483 item_list[namespec].component = NULL;
484
485 item_list[typespec].itmcode = FSCN$_TYPE;
486 item_list[typespec].length = 0;
487 item_list[typespec].component = NULL;
488
489 item_list[verspec].itmcode = FSCN$_VERSION;
490 item_list[verspec].length = 0;
491 item_list[verspec].component = NULL;
492
493 item_list[8].itmcode = 0;
494 item_list[8].length = 0;
495 item_list[8].component = NULL;
496
497 status = SYS$FILESCAN
498 ((const struct dsc$descriptor_s *)&path_desc, item_list,
499 &flags, NULL, NULL);
500 _ckvmssts(status); /* All failure status values indicate a coding error */
501
502 /* If we parsed it successfully these two lengths should be the same */
503 if (path_desc.dsc$w_length != item_list[filespec].length)
504 return ret_stat;
505
506 /* If we got here, then it is a VMS file specification */
507 ret_stat = 0;
508
509 /* set the volume name */
510 if (item_list[nodespec].length > 0) {
511 *volume = item_list[nodespec].component;
512 *vol_len = item_list[nodespec].length + item_list[devspec].length;
513 }
514 else {
515 *volume = item_list[devspec].component;
516 *vol_len = item_list[devspec].length;
517 }
518
519 *root = item_list[rootspec].component;
520 *root_len = item_list[rootspec].length;
521
522 *dir = item_list[dirspec].component;
523 *dir_len = item_list[dirspec].length;
524
525 /* Now fun with versions and EFS file specifications
526 * The parser can not tell the difference when a "." is a version
527 * delimiter or a part of the file specification.
528 */
529 if ((decc_efs_charset) &&
530 (item_list[verspec].length > 0) &&
531 (item_list[verspec].component[0] == '.')) {
532 *name = item_list[namespec].component;
533 *name_len = item_list[namespec].length + item_list[typespec].length;
534 *ext = item_list[verspec].component;
535 *ext_len = item_list[verspec].length;
536 *version = NULL;
537 *ver_len = 0;
538 }
539 else {
540 *name = item_list[namespec].component;
541 *name_len = item_list[namespec].length;
542 *ext = item_list[typespec].component;
543 *ext_len = item_list[typespec].length;
544 *version = item_list[verspec].component;
545 *ver_len = item_list[verspec].length;
546 }
547 return ret_stat;
548}
549
f7ddb74a 550
fa537f88
CB		 551/* my_maxidx
552 * Routine to retrieve the maximum equivalence index for an input
553 * logical name. Some calls to this routine have no knowledge if
554 * the variable is a logical or not. So on error we return a max
555 * index of zero.
556 */
f7ddb74a 557/*{{{int my_maxidx(const char *lnm) */
fa537f88 558static int
f7ddb74a 559my_maxidx(const char *lnm)
fa537f88
CB		 560{
561 int status;
562 int midx;
563 int attr = LNM$M_CASE_BLIND;
564 struct dsc$descriptor lnmdsc;
565 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
566 {0, 0, 0, 0}};
567
568 lnmdsc.dsc$w_length = strlen(lnm);
569 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
570 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 571 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 572
573 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
574 if ((status & 1) == 0)
575 midx = 0;
576
577 return (midx);
578}
579/*}}}*/
580
f675dbe5 581/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 582int
fd8cd3a3 583Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 584 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 585{
f7ddb74a
JM		 586 const char *cp1;
587 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 588 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 589 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 590 int midx;
f675dbe5
CB		 591 unsigned char acmode;
592 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
593 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
594 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
595 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 596 {0, 0, 0, 0}};
f675dbe5 597 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 598#if defined(PERL_IMPLICIT_CONTEXT)
599 pTHX = NULL;
fd8cd3a3
DS		 600 if (PL_curinterp) {
601 aTHX = PERL_GET_INTERP;
cc077a9f 602 } else {
fd8cd3a3 603 aTHX = NULL;
cc077a9f
HM		 604 }
605#endif
748a9306 606
fa537f88 607 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 608 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
609 }
f7ddb74a 610 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 611 *cp2 = _toupper(*cp1);
612 if (cp1 - lnm > LNM$C_NAMLENGTH) {
613 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
614 return 0;
615 }
616 }
617 lnmdsc.dsc$w_length = cp1 - lnm;
618 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 619 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 620 secure = flags & PERL__TRNENV_SECURE;
621 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
622 if (!tabvec || !*tabvec) tabvec = env_tables;
623
624 for (curtab = 0; tabvec[curtab]; curtab++) {
625 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
626 if (!ivenv && !secure) {
627 char *eq, *end;
628 int i;
629 if (!environ) {
630 ivenv = 1;
5c84aa53 631 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 632 continue;
633 }
634 retsts = SS$_NOLOGNAM;
635 for (i = 0; environ[i]; i++) {
636 if ((eq = strchr(environ[i],'=')) &&
299d126a 637 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 638 !strncmp(environ[i],uplnm,eq - environ[i])) {
639 eq++;
640 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
641 if (!eqvlen) continue;
642 retsts = SS$_NORMAL;
643 break;
644 }
645 }
646 if (retsts != SS$_NOLOGNAM) break;
647 }
648 }
649 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
650 !str$case_blind_compare(&tmpdsc,&clisym)) {
651 if (!ivsym && !secure) {
652 unsigned short int deflen = LNM$C_NAMLENGTH;
653 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
654 /* dynamic dsc to accomodate possible long value */
655 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
656 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
657 if (retsts & 1) {
2497a41f 658 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 659 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 660 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 661 /* Special hack--we might be called before the interpreter's */
662 /* fully initialized, in which case either thr or PL_curcop */
663 /* might be bogus. We have to check, since ckWARN needs them */
664 /* both to be valid if running threaded */
cc077a9f 665 if (ckWARN(WARN_MISC)) {
f98bc0c6 666 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 667 }
f675dbe5
CB		 668 }
669 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
670 }
671 _ckvmssts(lib$sfree1_dd(&eqvdsc));
672 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
673 if (retsts == LIB$_NOSUCHSYM) continue;
674 break;
675 }
676 }
677 else if (!ivlnm) {
843027b0 678 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 679 midx = my_maxidx(lnm);
680 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
681 lnmlst[1].bufadr = cp2;
fa537f88
CB		 682 eqvlen = 0;
683 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
684 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
685 if (retsts == SS$_NOLOGNAM) break;
686 /* PPFs have a prefix */
687 if (
fd7385b9 688#if INTSIZE == 4
fa537f88 689 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 690#endif
fa537f88
CB		 691 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
692 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
693 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
694 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
695 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 696 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 697 eqvlen -= 4;
698 }
f7ddb74a
JM		 699 cp2 += eqvlen;
700 *cp2 = '\0';
fa537f88
CB		 701 }
702 if ((retsts == SS$_IVLOGNAM) ||
703 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 704 }
fa537f88 705 else {
fa537f88
CB		 706 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
707 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
708 if (retsts == SS$_NOLOGNAM) continue;
709 eqv[eqvlen] = '\0';
710 }
711 eqvlen = strlen(eqv);
f675dbe5
CB		 712 break;
713 }
c07a80fd 714 }
f675dbe5
CB		 715 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
716 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
717 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
718 retsts == SS$_NOLOGNAM) {
719 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 720 }
f675dbe5
CB		 721 else _ckvmssts(retsts);
722 return 0;
723} /* end of vmstrnenv */
724/*}}}*/
c07a80fd 725
f675dbe5
CB		 726/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
727/* Define as a function so we can access statics. */
4b19af01 728int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 729{
730 return vmstrnenv(lnm,eqv,idx,fildev,
731#ifdef SECURE_INTERNAL_GETENV
732 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
733#else
734 0
735#endif
736 );
737}
738/*}}}*/
a0d0e21e
LW		 739
740/* my_getenv
61bb5906
CB		 741 * Note: Uses Perl temp to store result so char * can be returned to
742 * caller; this pointer will be invalidated at next Perl statement
743 * transition.
a6c40364 744 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 745 * so that it'll work when PL_curinterp is undefined (and we therefore can't
746 * allocate SVs).
a0d0e21e 747 */
f675dbe5 748/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 749char *
5c84aa53 750Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 751{
f7ddb74a 752 const char *cp1;
fa537f88 753 static char *__my_getenv_eqv = NULL;
f7ddb74a 754 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 755 unsigned long int idx = 0;
bc10a425 756 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 757 int midx, flags;
61bb5906 758 SV *tmpsv;
a0d0e21e 759
f7ddb74a 760 midx = my_maxidx(lnm) + 1;
fa537f88 761
6b88bc9c 762 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 763 /* Set up a temporary buffer for the return value; Perl will
764 * clean it up at the next statement transition */
fa537f88 765 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 766 if (!tmpsv) return NULL;
767 eqv = SvPVX(tmpsv);
768 }
fa537f88
CB		 769 else {
770 /* Assume no interpreter ==> single thread */
771 if (__my_getenv_eqv != NULL) {
772 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
773 }
774 else {
a02a5408 775 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 776 }
777 eqv = __my_getenv_eqv;
778 }
779
f7ddb74a 780 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 781 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 782 int len;
61bb5906 783 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 784
785 len = strlen(eqv);
786
787 /* Get rid of "000000/ in rooted filespecs */
788 if (len > 7) {
789 char * zeros;
790 zeros = strstr(eqv, "/000000/");
791 if (zeros != NULL) {
792 int mlen;
793 mlen = len - (zeros - eqv) - 7;
794 memmove(zeros, &zeros[7], mlen);
795 len = len - 7;
796 eqv[len] = '\0';
797 }
798 }
61bb5906 799 return eqv;
748a9306 800 }
a0d0e21e 801 else {
2512681b 802 /* Impose security constraints only if tainting */
bc10a425
CB		 803 if (sys) {
804 /* Impose security constraints only if tainting */
805 secure = PL_curinterp ? PL_tainting : will_taint;
806 saverr = errno; savvmserr = vaxc$errno;
807 }
843027b0
CB		 808 else {
809 secure = 0;
810 }
811
812 flags =
f675dbe5 813#ifdef SECURE_INTERNAL_GETENV
843027b0 814 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 815#else
843027b0 816 0
f675dbe5 817#endif
843027b0
CB		 818 ;
819
820 /* For the getenv interface we combine all the equivalence names
821 * of a search list logical into one value to acquire a maximum
822 * value length of 255*128 (assuming %ENV is using logicals).
823 */
824 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
825
826 /* If the name contains a semicolon-delimited index, parse it
827 * off and make sure we only retrieve the equivalence name for
828 * that index. */
829 if ((cp2 = strchr(lnm,';')) != NULL) {
830 strcpy(uplnm,lnm);
831 uplnm[cp2-lnm] = '\0';
832 idx = strtoul(cp2+1,NULL,0);
833 lnm = uplnm;
834 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
835 }
836
837 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
838
bc10a425
CB		 839 /* Discard NOLOGNAM on internal calls since we're often looking
840 * for an optional name, and this "error" often shows up as the
841 * (bogus) exit status for a die() call later on. */
842 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
843 return success ? eqv : Nullch;
a0d0e21e 844 }
a0d0e21e
LW		 845
846} /* end of my_getenv() */
847/*}}}*/
848
f675dbe5 849
a6c40364
GS		 850/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
851char *
fd8cd3a3 852Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 853{
f7ddb74a
JM		 854 const char *cp1;
855 char *buf, *cp2;
a6c40364 856 unsigned long idx = 0;
843027b0 857 int midx, flags;
fa537f88 858 static char *__my_getenv_len_eqv = NULL;
bc10a425 859 int secure, saverr, savvmserr;
cc077a9f
HM		 860 SV *tmpsv;
861
f7ddb74a 862 midx = my_maxidx(lnm) + 1;
fa537f88 863
cc077a9f
HM		 864 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
865 /* Set up a temporary buffer for the return value; Perl will
866 * clean it up at the next statement transition */
fa537f88 867 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 868 if (!tmpsv) return NULL;
869 buf = SvPVX(tmpsv);
870 }
fa537f88
CB		 871 else {
872 /* Assume no interpreter ==> single thread */
873 if (__my_getenv_len_eqv != NULL) {
874 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
875 }
876 else {
a02a5408 877 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 878 }
879 buf = __my_getenv_len_eqv;
880 }
881
f7ddb74a 882 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 883 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 884 char * zeros;
885
f675dbe5 886 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 887 *len = strlen(buf);
f7ddb74a
JM		 888
889 /* Get rid of "000000/ in rooted filespecs */
890 if (*len > 7) {
891 zeros = strstr(buf, "/000000/");
892 if (zeros != NULL) {
893 int mlen;
894 mlen = *len - (zeros - buf) - 7;
895 memmove(zeros, &zeros[7], mlen);
896 *len = *len - 7;
897 buf[*len] = '\0';
898 }
899 }
a6c40364 900 return buf;
f675dbe5
CB		 901 }
902 else {
bc10a425
CB		 903 if (sys) {
904 /* Impose security constraints only if tainting */
905 secure = PL_curinterp ? PL_tainting : will_taint;
906 saverr = errno; savvmserr = vaxc$errno;
907 }
843027b0
CB		 908 else {
909 secure = 0;
910 }
911
912 flags =
f675dbe5 913#ifdef SECURE_INTERNAL_GETENV
843027b0 914 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 915#else
843027b0 916 0
f675dbe5 917#endif
843027b0
CB		 918 ;
919
920 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
921
922 if ((cp2 = strchr(lnm,';')) != NULL) {
923 strcpy(buf,lnm);
924 buf[cp2-lnm] = '\0';
925 idx = strtoul(cp2+1,NULL,0);
926 lnm = buf;
927 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
928 }
929
930 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
931
f7ddb74a
JM		 932 /* Get rid of "000000/ in rooted filespecs */
933 if (*len > 7) {
934 char * zeros;
935 zeros = strstr(buf, "/000000/");
936 if (zeros != NULL) {
937 int mlen;
938 mlen = *len - (zeros - buf) - 7;
939 memmove(zeros, &zeros[7], mlen);
940 *len = *len - 7;
941 buf[*len] = '\0';
942 }
943 }
944
bc10a425
CB		 945 /* Discard NOLOGNAM on internal calls since we're often looking
946 * for an optional name, and this "error" often shows up as the
947 * (bogus) exit status for a die() call later on. */
948 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
949 return *len ? buf : Nullch;
f675dbe5
CB		 950 }
951
a6c40364 952} /* end of my_getenv_len() */
f675dbe5
CB		 953/*}}}*/
954
fd8cd3a3 955static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 956
957static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 958
740ce14c 959/*{{{ void prime_env_iter() */
960void
961prime_env_iter(void)
962/* Fill the %ENV associative array with all logical names we can
963 * find, in preparation for iterating over it.
964 */
965{
17f28c40 966 static int primed = 0;
3eeba6fb 967 HV *seenhv = NULL, *envhv;
22be8b3c 968 SV *sv = NULL;
f675dbe5 969 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 970 unsigned short int chan;
971#ifndef CLI$M_TRUSTED
972# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
973#endif
f675dbe5
CB		 974 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
975 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
976 long int i;
977 bool have_sym = FALSE, have_lnm = FALSE;
978 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
979 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
980 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
981 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
982 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 983#if defined(PERL_IMPLICIT_CONTEXT)
984 pTHX;
985#endif
3db8f154 986#if defined(USE_ITHREADS)
b2b3adea
HM		 987 static perl_mutex primenv_mutex;
988 MUTEX_INIT(&primenv_mutex);
61bb5906 989#endif
740ce14c 990
fd8cd3a3
DS		 991#if defined(PERL_IMPLICIT_CONTEXT)
992 /* We jump through these hoops because we can be called at */
993 /* platform-specific initialization time, which is before anything is */
994 /* set up--we can't even do a plain dTHX since that relies on the */
995 /* interpreter structure to be initialized */
fd8cd3a3
DS		 996 if (PL_curinterp) {
997 aTHX = PERL_GET_INTERP;
998 } else {
999 aTHX = NULL;
1000 }
1001#endif
fd8cd3a3 1002
3eeba6fb 1003 if (primed || !PL_envgv) return;
61bb5906
CB		 1004 MUTEX_LOCK(&primenv_mutex);
1005 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1006 envhv = GvHVn(PL_envgv);
740ce14c 1007 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1008 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1009 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1010
f675dbe5
CB		 1011 for (i = 0; env_tables[i]; i++) {
1012 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1013 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1014 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1015 }
f675dbe5
CB		 1016 if (have_sym || have_lnm) {
1017 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1018 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1019 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1020 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1021 }
f675dbe5
CB		 1022
1023 for (i--; i >= 0; i--) {
1024 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1025 char *start;
1026 int j;
1027 for (j = 0; environ[j]; j++) {
1028 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1029 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1030 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1031 }
1032 else {
1033 start++;
22be8b3c
CB		 1034 sv = newSVpv(start,0);
1035 SvTAINTED_on(sv);
1036 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1037 }
1038 }
1039 continue;
740ce14c 1040 }
f675dbe5
CB		 1041 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1042 !str$case_blind_compare(&tmpdsc,&clisym)) {
1043 strcpy(cmd,"Show Symbol/Global *");
1044 cmddsc.dsc$w_length = 20;
1045 if (env_tables[i]->dsc$w_length == 12 &&
1046 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1047 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1048 flags = defflags | CLI$M_NOLOGNAM;
1049 }
1050 else {
1051 strcpy(cmd,"Show Logical *");
1052 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1053 strcat(cmd," /Table=");
1054 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1055 cmddsc.dsc$w_length = strlen(cmd);
1056 }
1057 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1058 flags = defflags | CLI$M_NOCLISYM;
1059 }
1060
1061 /* Create a new subprocess to execute each command, to exclude the
1062 * remote possibility that someone could subvert a mbx or file used
1063 * to write multiple commands to a single subprocess.
1064 */
1065 do {
1066 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1067 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1068 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1069 defflags &= ~CLI$M_TRUSTED;
1070 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1071 _ckvmssts(retsts);
a02a5408 1072 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1073 if (seenhv) SvREFCNT_dec(seenhv);
1074 seenhv = newHV();
1075 while (1) {
1076 char *cp1, *cp2, *key;
1077 unsigned long int sts, iosb[2], retlen, keylen;
1078 register U32 hash;
1079
1080 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1081 if (sts & 1) sts = iosb[0] & 0xffff;
1082 if (sts == SS$_ENDOFFILE) {
1083 int wakect = 0;
1084 while (substs == 0) { sys$hiber(); wakect++;}
1085 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1086 _ckvmssts(substs);
1087 break;
1088 }
1089 _ckvmssts(sts);
1090 retlen = iosb[0] >> 16;
1091 if (!retlen) continue; /* blank line */
1092 buf[retlen] = '\0';
1093 if (iosb[1] != subpid) {
1094 if (iosb[1]) {
5c84aa53 1095 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1096 }
1097 continue;
1098 }
3eeba6fb 1099 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1100 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1101
1102 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1103 if (*cp1 == '(' || /* Logical name table name */
1104 *cp1 == '=' /* Next eqv of searchlist */) continue;
1105 if (*cp1 == '"') cp1++;
1106 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1107 key = cp1; keylen = cp2 - cp1;
1108 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1109 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1110 while (*cp2 && *cp2 == '=') cp2++;
1111 while (*cp2 && *cp2 == ' ') cp2++;
1112 if (*cp2 == '"') { /* String translation; may embed "" */
1113 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1114 cp2++; cp1--; /* Skip "" surrounding translation */
1115 }
1116 else { /* Numeric translation */
1117 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1118 cp1--; /* stop on last non-space char */
1119 }
1120 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1121 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1122 continue;
1123 }
5afd6d42 1124 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1125
1126 if (cp1 == cp2 && *cp2 == '.') {
1127 /* A single dot usually means an unprintable character, such as a null
1128 * to indicate a zero-length value. Get the actual value to make sure.
1129 */
1130 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1131 char eqv[MAX_DCL_SYMBOL+1];
ff79d39d
CB		 1132 strncpy(lnm, key, keylen);
1133 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1134 sv = newSVpvn(eqv, strlen(eqv));
1135 }
1136 else {
1137 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1138 }
1139
22be8b3c
CB		 1140 SvTAINTED_on(sv);
1141 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1142 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1143 }
f675dbe5
CB		 1144 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1145 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1146 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1147 char eqv[LNM$C_NAMLENGTH+1];
1148 int trnlen, i;
1149 for (i = 0; ppfs[i]; i++) {
1150 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1151 sv = newSVpv(eqv,trnlen);
1152 SvTAINTED_on(sv);
1153 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1154 }
740ce14c 1155 }
1156 }
f675dbe5
CB		 1157 primed = 1;
1158 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1159 if (buf) Safefree(buf);
1160 if (seenhv) SvREFCNT_dec(seenhv);
1161 MUTEX_UNLOCK(&primenv_mutex);
1162 return;
1163
740ce14c 1164} /* end of prime_env_iter */
1165/*}}}*/
740ce14c 1166
f675dbe5 1167
2c590a56 1168/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1169/* Define or delete an element in the same "environment" as
1170 * vmstrnenv(). If an element is to be deleted, it's removed from
1171 * the first place it's found. If it's to be set, it's set in the
1172 * place designated by the first element of the table vector.
3eeba6fb 1173 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1174 */
f675dbe5 1175int
2c590a56 1176Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1177{
f7ddb74a
JM		 1178 const char *cp1;
1179 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1180 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1181 int nseg = 0, j;
a0d0e21e 1182 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1183 struct itmlst_3 *ile, *ilist;
a0d0e21e 1184 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1185 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1186 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1187 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1188 $DESCRIPTOR(local,"_LOCAL");
1189
ed253963
CB		 1190 if (!lnm) {
1191 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1192 return SS$_IVLOGNAM;
1193 }
1194
f7ddb74a 1195 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1196 *cp2 = _toupper(*cp1);
1197 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1198 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1199 return SS$_IVLOGNAM;
1200 }
1201 }
a0d0e21e 1202 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1203 if (!tabvec || !*tabvec) tabvec = env_tables;
1204
3eeba6fb 1205 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1206 for (curtab = 0; tabvec[curtab]; curtab++) {
1207 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1208 int i;
299d126a 1209 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1210 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1211 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1212 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1213#ifdef HAS_SETENV
0e06870b 1214 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1215 }
1216 }
1217 ivenv = 1; retsts = SS$_NOLOGNAM;
1218#else
3eeba6fb 1219 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1220 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1221 ivenv = 1; retsts = SS$_NOSUCHPGM;
1222 break;
1223 }
1224 }
f675dbe5
CB		 1225#endif
1226 }
1227 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1228 !str$case_blind_compare(&tmpdsc,&clisym)) {
1229 unsigned int symtype;
1230 if (tabvec[curtab]->dsc$w_length == 12 &&
1231 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1232 !str$case_blind_compare(&tmpdsc,&local))
1233 symtype = LIB$K_CLI_LOCAL_SYM;
1234 else symtype = LIB$K_CLI_GLOBAL_SYM;
1235 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1236 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1237 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1238 break;
1239 }
1240 else if (!ivlnm) {
1241 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1242 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1243 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1244 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1245 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1246 }
a0d0e21e
LW		 1247 }
1248 }
f675dbe5
CB		 1249 else { /* we're defining a value */
1250 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1251#ifdef HAS_SETENV
3eeba6fb 1252 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1253#else
3eeba6fb 1254 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1255 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1256 retsts = SS$_NOSUCHPGM;
1257#endif
1258 }
1259 else {
f7ddb74a 1260 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1261 eqvdsc.dsc$w_length = strlen(eqv);
1262 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1263 !str$case_blind_compare(&tmpdsc,&clisym)) {
1264 unsigned int symtype;
1265 if (tabvec[0]->dsc$w_length == 12 &&
1266 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1267 !str$case_blind_compare(&tmpdsc,&local))
1268 symtype = LIB$K_CLI_LOCAL_SYM;
1269 else symtype = LIB$K_CLI_GLOBAL_SYM;
1270 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1271 }
3eeba6fb
CB		 1272 else {
1273 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1274 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1275
1276 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1277 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1278 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1279 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1280 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1281 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1282 }
1283
a02a5408 1284 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1285 ile = ilist;
1286 if (!ile) {
1287 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1288 return SS$_INSFMEM;
a1dfe751 1289 }
fa537f88
CB		 1290 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1291
1292 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1293 ile->itmcode = LNM$_STRING;
1294 ile->bufadr = c;
1295 if ((j+1) == nseg) {
1296 ile->buflen = strlen(c);
1297 /* in case we are truncating one that's too long */
1298 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1299 }
1300 else {
1301 ile->buflen = LNM$C_NAMLENGTH;
1302 }
1303 }
1304
1305 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1306 Safefree (ilist);
1307 }
1308 else {
1309 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1310 }
3eeba6fb 1311 }
f675dbe5
CB		 1312 }
1313 }
1314 if (!(retsts & 1)) {
1315 switch (retsts) {
1316 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1317 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1318 set_errno(EVMSERR); break;
1319 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1320 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1321 set_errno(EINVAL); break;
1322 case SS$_NOPRIV:
7d2497bf 1323 set_errno(EACCES); break;
f675dbe5
CB		 1324 default:
1325 _ckvmssts(retsts);
1326 set_errno(EVMSERR);
1327 }
1328 set_vaxc_errno(retsts);
1329 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1330 }
3eeba6fb
CB		 1331 else {
1332 /* We reset error values on success because Perl does an hv_fetch()
1333 * before each hv_store(), and if the thing we're setting didn't
1334 * previously exist, we've got a leftover error message. (Of course,
1335 * this fails in the face of
1336 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1337 * in that the error reported in $! isn't spurious,
1338 * but it's right more often than not.)
1339 */
f675dbe5
CB		 1340 set_errno(0); set_vaxc_errno(retsts);
1341 return 0;
1342 }
1343
1344} /* end of vmssetenv() */
1345/*}}}*/
a0d0e21e 1346
2c590a56 1347/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1348/* This has to be a function since there's a prototype for it in proto.h */
1349void
2c590a56 1350Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1351{
bc10a425
CB		 1352 if (lnm && *lnm) {
1353 int len = strlen(lnm);
1354 if (len == 7) {
1355 char uplnm[8];
22d4bb9c
CB		 1356 int i;
1357 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1358 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1359 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1360 return;
1361 }
1362 }
1363#ifndef RTL_USES_UTC
1364 if (len == 6 || len == 2) {
1365 char uplnm[7];
1366 int i;
1367 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1368 uplnm[len] = '\0';
1369 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1370 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1371 }
1372#endif
1373 }
f675dbe5
CB		 1374 (void) vmssetenv(lnm,eqv,NULL);
1375}
a0d0e21e
LW		 1376/*}}}*/
1377
27c67b75 1378/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1379/* vmssetuserlnm
1380 * sets a user-mode logical in the process logical name table
1381 * used for redirection of sys$error
1382 */
1383void
2fbb330f 1384Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1385{
1386 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1387 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1388 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1389 unsigned char acmode = PSL$C_USER;
1390 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1391 {0, 0, 0, 0}};
2fbb330f 1392 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1393 d_name.dsc$w_length = strlen(name);
1394
1395 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1396 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1397
1398 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1399 if (!(iss&1)) lib$signal(iss);
1400}
1401/*}}}*/
c07a80fd 1402
f675dbe5 1403
c07a80fd 1404/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1405/* my_crypt - VMS password hashing
1406 * my_crypt() provides an interface compatible with the Unix crypt()
1407 * C library function, and uses sys$hash_password() to perform VMS
1408 * password hashing. The quadword hashed password value is returned
1409 * as a NUL-terminated 8 character string. my_crypt() does not change
1410 * the case of its string arguments; in order to match the behavior
1411 * of LOGINOUT et al., alphabetic characters in both arguments must
1412 * be upcased by the caller.
2497a41f
JM		 1413 *
1414 * - fix me to call ACM services when available
c07a80fd 1415 */
1416char *
fd8cd3a3 1417Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1418{
1419# ifndef UAI$C_PREFERRED_ALGORITHM
1420# define UAI$C_PREFERRED_ALGORITHM 127
1421# endif
1422 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1423 unsigned short int salt = 0;
1424 unsigned long int sts;
1425 struct const_dsc {
1426 unsigned short int dsc$w_length;
1427 unsigned char dsc$b_type;
1428 unsigned char dsc$b_class;
1429 const char * dsc$a_pointer;
1430 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1431 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1432 struct itmlst_3 uailst[3] = {
1433 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1434 { sizeof salt, UAI$_SALT, &salt, 0},
1435 { 0, 0, NULL, NULL}};
1436 static char hash[9];
1437
1438 usrdsc.dsc$w_length = strlen(usrname);
1439 usrdsc.dsc$a_pointer = usrname;
1440 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1441 switch (sts) {
f282b18d 1442 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1443 set_errno(EACCES);
1444 break;
1445 case RMS$_RNF:
1446 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1447 break;
1448 default:
1449 set_errno(EVMSERR);
1450 }
1451 set_vaxc_errno(sts);
1452 if (sts != RMS$_RNF) return NULL;
1453 }
1454
1455 txtdsc.dsc$w_length = strlen(textpasswd);
1456 txtdsc.dsc$a_pointer = textpasswd;
1457 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1458 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1459 }
1460
1461 return (char *) hash;
1462
1463} /* end of my_crypt() */
1464/*}}}*/
1465
1466
2fbb330f 1467static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
b8ffc8df
RGS		 1468static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1469static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
a0d0e21e 1470
2497a41f
JM		 1471/* fixup barenames that are directories for internal use.
1472 * There have been problems with the consistent handling of UNIX
1473 * style directory names when routines are presented with a name that
1474 * has no directory delimitors at all. So this routine will eventually
1475 * fix the issue.
1476 */
1477static char * fixup_bare_dirnames(const char * name)
1478{
1479 if (decc_disable_to_vms_logname_translation) {
1480/* fix me */
1481 }
1482 return NULL;
1483}
1484
1485/* mp_do_kill_file
1486 * A little hack to get around a bug in some implemenation of remove()
1487 * that do not know how to delete a directory
1488 *
1489 * Delete any file to which user has control access, regardless of whether
1490 * delete access is explicitly allowed.
1491 * Limitations: User must have write access to parent directory.
1492 * Does not block signals or ASTs; if interrupted in midstream
1493 * may leave file with an altered ACL.
1494 * HANDLE WITH CARE!
1495 */
1496/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1497static int
1498mp_do_kill_file(pTHX_ const char *name, int dirflag)
1499{
1500 char *vmsname, *rspec;
1501 char *remove_name;
1502 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1503 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1504 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1505 struct myacedef {
1506 unsigned char myace$b_length;
1507 unsigned char myace$b_type;
1508 unsigned short int myace$w_flags;
1509 unsigned long int myace$l_access;
1510 unsigned long int myace$l_ident;
1511 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1512 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1513 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1514 struct itmlst_3
1515 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1516 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1517 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1518 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1519 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1520 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1521
1522 /* Expand the input spec using RMS, since the CRTL remove() and
1523 * system services won't do this by themselves, so we may miss
1524 * a file "hiding" behind a logical name or search list. */
c5375c28
JM		 1525 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1526 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1527
2f4077ca 1528 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
c5375c28 1529 PerlMem_free(vmsname);
2497a41f
JM		 1530 return -1;
1531 }
1532
1533 if (decc_posix_compliant_pathnames) {
1534 /* In POSIX mode, we prefer to remove the UNIX name */
1535 rspec = vmsname;
1536 remove_name = (char *)name;
1537 }
1538 else {
c5375c28
JM		 1539 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1540 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
2f4077ca 1541 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
c5375c28
JM		 1542 PerlMem_free(rspec);
1543 PerlMem_free(vmsname);
2497a41f
JM		 1544 return -1;
1545 }
c5375c28 1546 PerlMem_free(vmsname);
2497a41f
JM		 1547 remove_name = rspec;
1548 }
1549
1550#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1551 if (dirflag != 0) {
1552 if (decc_dir_barename && decc_posix_compliant_pathnames) {
c5375c28
JM		 1553 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1554 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1555
7ded3206 1556 do_pathify_dirspec(name, remove_name, 0);
2497a41f
JM		 1557 if (!rmdir(remove_name)) {
1558
c5375c28
JM		 1559 PerlMem_free(remove_name);
1560 PerlMem_free(rspec);
2497a41f
JM		 1561 return 0; /* Can we just get rid of it? */
1562 }
1563 }
1564 else {
1565 if (!rmdir(remove_name)) {
c5375c28 1566 PerlMem_free(rspec);
2497a41f
JM		 1567 return 0; /* Can we just get rid of it? */
1568 }
1569 }
1570 }
1571 else
1572#endif
1573 if (!remove(remove_name)) {
c5375c28 1574 PerlMem_free(rspec);
2497a41f
JM		 1575 return 0; /* Can we just get rid of it? */
1576 }
1577
1578 /* If not, can changing protections help? */
1579 if (vaxc$errno != RMS$_PRV) {
c5375c28 1580 PerlMem_free(rspec);
2497a41f
JM		 1581 return -1;
1582 }
1583
1584 /* No, so we get our own UIC to use as a rights identifier,
1585 * and the insert an ACE at the head of the ACL which allows us
1586 * to delete the file.
1587 */
1588 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1589 fildsc.dsc$w_length = strlen(rspec);
1590 fildsc.dsc$a_pointer = rspec;
1591 cxt = 0;
1592 newace.myace$l_ident = oldace.myace$l_ident;
1593 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1594 switch (aclsts) {
1595 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1596 set_errno(ENOENT); break;
1597 case RMS$_DIR:
1598 set_errno(ENOTDIR); break;
1599 case RMS$_DEV:
1600 set_errno(ENODEV); break;
1601 case RMS$_SYN: case SS$_INVFILFOROP:
1602 set_errno(EINVAL); break;
1603 case RMS$_PRV:
1604 set_errno(EACCES); break;
1605 default:
1606 _ckvmssts(aclsts);
1607 }
1608 set_vaxc_errno(aclsts);
c5375c28 1609 PerlMem_free(rspec);
2497a41f
JM		 1610 return -1;
1611 }
1612 /* Grab any existing ACEs with this identifier in case we fail */
1613 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1614 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1615 || fndsts == SS$_NOMOREACE ) {
1616 /* Add the new ACE . . . */
1617 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1618 goto yourroom;
1619
1620#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1621 if (dirflag != 0)
1622 if (decc_dir_barename && decc_posix_compliant_pathnames) {
c5375c28
JM		 1623 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1624 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1625
7ded3206 1626 do_pathify_dirspec(name, remove_name, 0);
2497a41f 1627 rmsts = rmdir(remove_name);
c5375c28 1628 PerlMem_free(remove_name);
2497a41f
JM		 1629 }
1630 else {
1631 rmsts = rmdir(remove_name);
1632 }
1633 else
1634#endif
1635 rmsts = remove(remove_name);
1636 if (rmsts) {
1637 /* We blew it - dir with files in it, no write priv for
1638 * parent directory, etc. Put things back the way they were. */
1639 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1640 goto yourroom;
1641 if (fndsts & 1) {
1642 addlst[0].bufadr = &oldace;
1643 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1644 goto yourroom;
1645 }
1646 }
1647 }
1648
1649 yourroom:
1650 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1651 /* We just deleted it, so of course it's not there. Some versions of
1652 * VMS seem to return success on the unlock operation anyhow (after all
1653 * the unlock is successful), but others don't.
1654 */
1655 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1656 if (aclsts & 1) aclsts = fndsts;
1657 if (!(aclsts & 1)) {
1658 set_errno(EVMSERR);
1659 set_vaxc_errno(aclsts);
c5375c28 1660 PerlMem_free(rspec);
2497a41f
JM		 1661 return -1;
1662 }
1663
c5375c28 1664 PerlMem_free(rspec);
2497a41f
JM		 1665 return rmsts;
1666
1667} /* end of kill_file() */
1668/*}}}*/
1669
1670
a0d0e21e
LW		 1671/*{{{int do_rmdir(char *name)*/
1672int
b8ffc8df 1673Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e
LW		 1674{
1675 char dirfile[NAM$C_MAXRSS+1];
1676 int retval;
61bb5906 1677 Stat_t st;
a0d0e21e
LW		 1678
1679 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1680 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
7ded3206 1681 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
a0d0e21e
LW		 1682 return retval;
1683
1684} /* end of do_rmdir */
1685/*}}}*/
1686
1687/* kill_file
1688 * Delete any file to which user has control access, regardless of whether
1689 * delete access is explicitly allowed.
1690 * Limitations: User must have write access to parent directory.
1691 * Does not block signals or ASTs; if interrupted in midstream
1692 * may leave file with an altered ACL.
1693 * HANDLE WITH CARE!
1694 */
1695/*{{{int kill_file(char *name)*/
1696int
b8ffc8df 1697Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1698{
2f4077ca
JM		 1699 char rspec[NAM$C_MAXRSS+1];
1700 char *tspec;
a0d0e21e 1701 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
748a9306 1702 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
a0d0e21e
LW		 1703 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1704 struct myacedef {
748a9306
LW		 1705 unsigned char myace$b_length;
1706 unsigned char myace$b_type;
1707 unsigned short int myace$w_flags;
1708 unsigned long int myace$l_access;
1709 unsigned long int myace$l_ident;
a0d0e21e
LW		 1710 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1711 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1712 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1713 struct itmlst_3
748a9306
LW		 1714 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1715 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1716 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1717 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1718 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1719 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
a0d0e21e 1720
bbce6d69 1721 /* Expand the input spec using RMS, since the CRTL remove() and
1722 * system services won't do this by themselves, so we may miss
1723 * a file "hiding" behind a logical name or search list. */
2f4077ca
JM		 1724 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1725 if (tspec == NULL) return -1;
bbce6d69 1726 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
740ce14c 1727 /* If not, can changing protections help? */
1728 if (vaxc$errno != RMS$_PRV) return -1;
a0d0e21e
LW		 1729
1730 /* No, so we get our own UIC to use as a rights identifier,
1731 * and the insert an ACE at the head of the ACL which allows us
1732 * to delete the file.
1733 */
748a9306 1734 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
bbce6d69 1735 fildsc.dsc$w_length = strlen(rspec);
1736 fildsc.dsc$a_pointer = rspec;
a0d0e21e 1737 cxt = 0;
748a9306 1738 newace.myace$l_ident = oldace.myace$l_ident;
a0d0e21e 1739 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
740ce14c 1740 switch (aclsts) {
f282b18d 1741 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
740ce14c 1742 set_errno(ENOENT); break;
f282b18d
CB		 1743 case RMS$_DIR:
1744 set_errno(ENOTDIR); break;
740ce14c 1745 case RMS$_DEV:
1746 set_errno(ENODEV); break;
f282b18d 1747 case RMS$_SYN: case SS$_INVFILFOROP:
740ce14c 1748 set_errno(EINVAL); break;
1749 case RMS$_PRV:
1750 set_errno(EACCES); break;
1751 default:
1752 _ckvmssts(aclsts);
1753 }
748a9306 1754 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1755 return -1;
1756 }
1757 /* Grab any existing ACEs with this identifier in case we fail */
1758 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
e518068a 1759 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1760 || fndsts == SS$_NOMOREACE ) {
a0d0e21e
LW		 1761 /* Add the new ACE . . . */
1762 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1763 goto yourroom;
748a9306 1764 if ((rmsts = remove(name))) {
a0d0e21e
LW		 1765 /* We blew it - dir with files in it, no write priv for
1766 * parent directory, etc. Put things back the way they were. */
1767 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1768 goto yourroom;
1769 if (fndsts & 1) {
1770 addlst[0].bufadr = &oldace;
1771 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1772 goto yourroom;
1773 }
1774 }
1775 }
1776
1777 yourroom:
b7ae7a0d 1778 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1779 /* We just deleted it, so of course it's not there. Some versions of
1780 * VMS seem to return success on the unlock operation anyhow (after all
1781 * the unlock is successful), but others don't.
1782 */
760ac839 1783 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
b7ae7a0d 1784 if (aclsts & 1) aclsts = fndsts;
a0d0e21e 1785 if (!(aclsts & 1)) {
748a9306
LW		 1786 set_errno(EVMSERR);
1787 set_vaxc_errno(aclsts);
a0d0e21e
LW		 1788 return -1;
1789 }
1790
1791 return rmsts;
1792
1793} /* end of kill_file() */
1794/*}}}*/
1795
8cc95fdb 1796
84902520 1797/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 1798int
b8ffc8df 1799Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 1800{
1801 STRLEN dirlen = strlen(dir);
1802
a2a90019
CB		 1803 /* zero length string sometimes gives ACCVIO */
1804 if (dirlen == 0) return -1;
1805
8cc95fdb 1806 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1807 * null file name/type. However, it's commonplace under Unix,
1808 * so we'll allow it for a gain in portability.
1809 */
1810 if (dir[dirlen-1] == '/') {
1811 char *newdir = savepvn(dir,dirlen-1);
1812 int ret = mkdir(newdir,mode);
1813 Safefree(newdir);
1814 return ret;
1815 }
1816 else return mkdir(dir,mode);
1817} /* end of my_mkdir */
1818/*}}}*/
1819
ee8c7f54
CB		 1820/*{{{int my_chdir(char *)*/
1821int
b8ffc8df 1822Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 1823{
1824 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 1825
1826 /* zero length string sometimes gives ACCVIO */
1827 if (dirlen == 0) return -1;
f7ddb74a
JM		 1828 const char *dir1;
1829
1830 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1831 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1832 * so that existing scripts do not need to be changed.
1833 */
1834 dir1 = dir;
1835 while ((dirlen > 0) && (*dir1 == ' ')) {
1836 dir1++;
1837 dirlen--;
1838 }
ee8c7f54
CB		 1839
1840 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1841 * that implies
1842 * null file name/type. However, it's commonplace under Unix,
1843 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 1844 *
1845 * - Preview- '/' will be valid soon on VMS
ee8c7f54 1846 */
f7ddb74a 1847 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
dca5a913 1848 char *newdir = savepvn(dir1,dirlen-1);
ee8c7f54
CB		 1849 int ret = chdir(newdir);
1850 Safefree(newdir);
1851 return ret;
1852 }
dca5a913 1853 else return chdir(dir1);
ee8c7f54
CB		 1854} /* end of my_chdir */
1855/*}}}*/
8cc95fdb 1856
674d6c38
CB		 1857
1858/*{{{FILE *my_tmpfile()*/
1859FILE *
1860my_tmpfile(void)
1861{
1862 FILE *fp;
1863 char *cp;
674d6c38
CB		 1864
1865 if ((fp = tmpfile())) return fp;
1866
c5375c28
JM		 1867 cp = PerlMem_malloc(L_tmpnam+24);
1868 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1869
2497a41f
JM		 1870 if (decc_filename_unix_only == 0)
1871 strcpy(cp,"Sys$Scratch:");
1872 else
1873 strcpy(cp,"/tmp/");
674d6c38
CB		 1874 tmpnam(cp+strlen(cp));
1875 strcat(cp,".Perltmp");
1876 fp = fopen(cp,"w+","fop=dlt");
c5375c28 1877 PerlMem_free(cp);
674d6c38
CB		 1878 return fp;
1879}
1880/*}}}*/
1881
5c2d7af2
CB		 1882
1883#ifndef HOMEGROWN_POSIX_SIGNALS
1884/*
1885 * The C RTL's sigaction fails to check for invalid signal numbers so we
1886 * help it out a bit. The docs are correct, but the actual routine doesn't
1887 * do what the docs say it will.
1888 */
1889/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1890int
1891Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1892 struct sigaction* oact)
1893{
1894 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1895 SETERRNO(EINVAL, SS$_INVARG);
1896 return -1;
1897 }
1898 return sigaction(sig, act, oact);
1899}
1900/*}}}*/
1901#endif
1902
f2610a60
CL		 1903#ifdef KILL_BY_SIGPRC
1904#include <errnodef.h>
1905
05c058bc
CB		 1906/* We implement our own kill() using the undocumented system service
1907 sys$sigprc for one of two reasons:
1908
1909 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 1910 target process to do a sys$exit, which usually can't be handled
1911 gracefully...certainly not by Perl and the %SIG{} mechanism.
1912
05c058bc
CB		 1913 2.) If the kill() in the CRTL can't be called from a signal
1914 handler without disappearing into the ether, i.e., the signal
1915 it purportedly sends is never trapped. Still true as of VMS 7.3.
1916
1917 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 1918 in the target process rather than calling sys$exit.
1919
1920 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1921 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1922 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1923 with condition codes C$_SIG0+nsig*8, catching the exception on the
1924 target process and resignaling with appropriate arguments.
1925
1926 But we don't have that VMS 7.0+ exception handler, so if you
1927 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1928
1929 Also note that SIGTERM is listed in the docs as being "unimplemented",
1930 yet always seems to be signaled with a VMS condition code of 4 (and
1931 correctly handled for that code). So we hardwire it in.
1932
1933 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1934 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1935 than signalling with an unrecognized (and unhandled by CRTL) code.
1936*/
1937
1938#define _MY_SIG_MAX 17
1939
9c1171d1
JM		 1940static unsigned int
1941Perl_sig_to_vmscondition_int(int sig)
f2610a60 1942{
2e34cc90 1943 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 1944 {
1945 0, /* 0 ZERO */
1946 SS$_HANGUP, /* 1 SIGHUP */
1947 SS$_CONTROLC, /* 2 SIGINT */
1948 SS$_CONTROLY, /* 3 SIGQUIT */
1949 SS$_RADRMOD, /* 4 SIGILL */
1950 SS$_BREAK, /* 5 SIGTRAP */
1951 SS$_OPCCUS, /* 6 SIGABRT */
1952 SS$_COMPAT, /* 7 SIGEMT */
1953#ifdef __VAX
1954 SS$_FLTOVF, /* 8 SIGFPE VAX */
1955#else
1956 SS$_HPARITH, /* 8 SIGFPE AXP */
1957#endif
1958 SS$_ABORT, /* 9 SIGKILL */
1959 SS$_ACCVIO, /* 10 SIGBUS */
1960 SS$_ACCVIO, /* 11 SIGSEGV */
1961 SS$_BADPARAM, /* 12 SIGSYS */
1962 SS$_NOMBX, /* 13 SIGPIPE */
1963 SS$_ASTFLT, /* 14 SIGALRM */
1964 4, /* 15 SIGTERM */
1965 0, /* 16 SIGUSR1 */
1966 0 /* 17 SIGUSR2 */
1967 };
1968
1969#if __VMS_VER >= 60200000
1970 static int initted = 0;
1971 if (!initted) {
1972 initted = 1;
1973 sig_code[16] = C$_SIGUSR1;
1974 sig_code[17] = C$_SIGUSR2;
1975 }
1976#endif
1977
2e34cc90
CL		 1978 if (sig < _SIG_MIN) return 0;
1979 if (sig > _MY_SIG_MAX) return 0;
1980 return sig_code[sig];
1981}
1982
9c1171d1
JM		 1983unsigned int
1984Perl_sig_to_vmscondition(int sig)
1985{
1986#ifdef SS$_DEBUG
1987 if (vms_debug_on_exception != 0)
1988 lib$signal(SS$_DEBUG);
1989#endif
1990 return Perl_sig_to_vmscondition_int(sig);
1991}
1992
1993
2e34cc90
CL		 1994int
1995Perl_my_kill(int pid, int sig)
1996{
218fdd94 1997 dTHX;
2e34cc90
CL		 1998 int iss;
1999 unsigned int code;
2000 int sys$sigprc(unsigned int *pidadr,
2001 struct dsc$descriptor_s *prcname,
2002 unsigned int code);
2003
7a7fd8e0
JM		 2004 /* sig 0 means validate the PID */
2005 /*------------------------------*/
2006 if (sig == 0) {
2007 const unsigned long int jpicode = JPI$_PID;
2008 pid_t ret_pid;
2009 int status;
2010 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2011 if ($VMS_STATUS_SUCCESS(status))
2012 return 0;
2013 switch (status) {
2014 case SS$_NOSUCHNODE:
2015 case SS$_UNREACHABLE:
2016 case SS$_NONEXPR:
2017 errno = ESRCH;
2018 break;
2019 case SS$_NOPRIV:
2020 errno = EPERM;
2021 break;
2022 default:
2023 errno = EVMSERR;
2024 }
2025 vaxc$errno=status;
2026 return -1;
2027 }
2028
9c1171d1 2029 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2030
7a7fd8e0
JM		 2031 if (!code) {
2032 SETERRNO(EINVAL, SS$_BADPARAM);
2033 return -1;
2034 }
2035
2036 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2037 * signals are to be sent to multiple processes.
2038 * pid = 0 - all processes in group except ones that the system exempts
2039 * pid = -1 - all processes except ones that the system exempts
2040 * pid = -n - all processes in group (abs(n)) except ...
2041 * For now, just report as not supported.
2042 */
2043
2044 if (pid <= 0) {
2045 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2046 return -1;
2047 }
2048
2e34cc90 2049 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2050 if (iss&1) return 0;
2051
2052 switch (iss) {
2053 case SS$_NOPRIV:
2054 set_errno(EPERM); break;
2055 case SS$_NONEXPR:
2056 case SS$_NOSUCHNODE:
2057 case SS$_UNREACHABLE:
2058 set_errno(ESRCH); break;
2059 case SS$_INSFMEM:
2060 set_errno(ENOMEM); break;
2061 default:
2062 _ckvmssts(iss);
2063 set_errno(EVMSERR);
2064 }
2065 set_vaxc_errno(iss);
2066
2067 return -1;
2068}
2069#endif
2070
2fbb330f
JM		 2071/* Routine to convert a VMS status code to a UNIX status code.
2072** More tricky than it appears because of conflicting conventions with
2073** existing code.
2074**
2075** VMS status codes are a bit mask, with the least significant bit set for
2076** success.
2077**
2078** Special UNIX status of EVMSERR indicates that no translation is currently
2079** available, and programs should check the VMS status code.
2080**
2081** Programs compiled with _POSIX_EXIT have a special encoding that requires
2082** decoding.
2083*/
2084
2085#ifndef C_FACILITY_NO
2086#define C_FACILITY_NO 0x350000
2087#endif
2088#ifndef DCL_IVVERB
2089#define DCL_IVVERB 0x38090
2090#endif
2091
7a7fd8e0 2092int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2093{
2094int facility;
2095int fac_sp;
2096int msg_no;
2097int msg_status;
2098int unix_status;
2099
2100 /* Assume the best or the worst */
2101 if (vms_status & STS$M_SUCCESS)
2102 unix_status = 0;
2103 else
2104 unix_status = EVMSERR;
2105
2106 msg_status = vms_status & ~STS$M_CONTROL;
2107
2108 facility = vms_status & STS$M_FAC_NO;
2109 fac_sp = vms_status & STS$M_FAC_SP;
2110 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2111
0968cdad 2112 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2113 switch(msg_no) {
2114 case SS$_NORMAL:
2115 unix_status = 0;
2116 break;
2117 case SS$_ACCVIO:
2118 unix_status = EFAULT;
2119 break;
7a7fd8e0
JM		 2120 case SS$_DEVOFFLINE:
2121 unix_status = EBUSY;
2122 break;
2123 case SS$_CLEARED:
2124 unix_status = ENOTCONN;
2125 break;
2126 case SS$_IVCHAN:
2fbb330f
JM		 2127 case SS$_IVLOGNAM:
2128 case SS$_BADPARAM:
2129 case SS$_IVLOGTAB:
2130 case SS$_NOLOGNAM:
2131 case SS$_NOLOGTAB:
2132 case SS$_INVFILFOROP:
2133 case SS$_INVARG:
2134 case SS$_NOSUCHID:
2135 case SS$_IVIDENT:
2136 unix_status = EINVAL;
2137 break;
7a7fd8e0
JM		 2138 case SS$_UNSUPPORTED:
2139 unix_status = ENOTSUP;
2140 break;
2fbb330f
JM		 2141 case SS$_FILACCERR:
2142 case SS$_NOGRPPRV:
2143 case SS$_NOSYSPRV:
2144 unix_status = EACCES;
2145 break;
2146 case SS$_DEVICEFULL:
2147 unix_status = ENOSPC;
2148 break;
2149 case SS$_NOSUCHDEV:
2150 unix_status = ENODEV;
2151 break;
2152 case SS$_NOSUCHFILE:
2153 case SS$_NOSUCHOBJECT:
2154 unix_status = ENOENT;
2155 break;
fb38d079
JM		 2156 case SS$_ABORT: /* Fatal case */
2157 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2158 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2159 unix_status = EINTR;
2160 break;
2161 case SS$_BUFFEROVF:
2162 unix_status = E2BIG;
2163 break;
2164 case SS$_INSFMEM:
2165 unix_status = ENOMEM;
2166 break;
2167 case SS$_NOPRIV:
2168 unix_status = EPERM;
2169 break;
2170 case SS$_NOSUCHNODE:
2171 case SS$_UNREACHABLE:
2172 unix_status = ESRCH;
2173 break;
2174 case SS$_NONEXPR:
2175 unix_status = ECHILD;
2176 break;
2177 default:
2178 if ((facility == 0) && (msg_no < 8)) {
2179 /* These are not real VMS status codes so assume that they are
2180 ** already UNIX status codes
2181 */
2182 unix_status = msg_no;
2183 break;
2184 }
2185 }
2186 }
2187 else {
2188 /* Translate a POSIX exit code to a UNIX exit code */
2189 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2190 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2191 }
2192 else {
7a7fd8e0
JM		 2193
2194 /* Documented traditional behavior for handling VMS child exits */
2195 /*--------------------------------------------------------------*/
2196 if (child_flag != 0) {
2197
2198 /* Success / Informational return 0 */
2199 /*----------------------------------*/
2200 if (msg_no & STS$K_SUCCESS)
2201 return 0;
2202
2203 /* Warning returns 1 */
2204 /*-------------------*/
2205 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2206 return 1;
2207
2208 /* Everything else pass through the severity bits */
2209 /*------------------------------------------------*/
2210 return (msg_no & STS$M_SEVERITY);
2211 }
2212
2213 /* Normal VMS status to ERRNO mapping attempt */
2214 /*--------------------------------------------*/
2fbb330f
JM		 2215 switch(msg_status) {
2216 /* case RMS$_EOF: */ /* End of File */
2217 case RMS$_FNF: /* File Not Found */
2218 case RMS$_DNF: /* Dir Not Found */
2219 unix_status = ENOENT;
2220 break;
2221 case RMS$_RNF: /* Record Not Found */
2222 unix_status = ESRCH;
2223 break;
2224 case RMS$_DIR:
2225 unix_status = ENOTDIR;
2226 break;
2227 case RMS$_DEV:
2228 unix_status = ENODEV;
2229 break;
7a7fd8e0
JM		 2230 case RMS$_IFI:
2231 case RMS$_FAC:
2232 case RMS$_ISI:
2233 unix_status = EBADF;
2234 break;
2235 case RMS$_FEX:
2236 unix_status = EEXIST;
2237 break;
2fbb330f
JM		 2238 case RMS$_SYN:
2239 case RMS$_FNM:
2240 case LIB$_INVSTRDES:
2241 case LIB$_INVARG:
2242 case LIB$_NOSUCHSYM:
2243 case LIB$_INVSYMNAM:
2244 case DCL_IVVERB:
2245 unix_status = EINVAL;
2246 break;
2247 case CLI$_BUFOVF:
2248 case RMS$_RTB:
2249 case CLI$_TKNOVF:
2250 case CLI$_RSLOVF:
2251 unix_status = E2BIG;
2252 break;
2253 case RMS$_PRV: /* No privilege */
2254 case RMS$_ACC: /* ACP file access failed */
2255 case RMS$_WLK: /* Device write locked */
2256 unix_status = EACCES;
2257 break;
2258 /* case RMS$_NMF: */ /* No more files */
2259 }
2260 }
2261 }
2262
2263 return unix_status;
2264}
2265
7a7fd8e0
JM		 2266/* Try to guess at what VMS error status should go with a UNIX errno
2267 * value. This is hard to do as there could be many possible VMS
2268 * error statuses that caused the errno value to be set.
2269 */
2270
2271int Perl_unix_status_to_vms(int unix_status)
2272{
2273int test_unix_status;
2274
2275 /* Trivial cases first */
2276 /*---------------------*/
2277 if (unix_status == EVMSERR)
2278 return vaxc$errno;
2279
2280 /* Is vaxc$errno sane? */
2281 /*---------------------*/
2282 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2283 if (test_unix_status == unix_status)
2284 return vaxc$errno;
2285
2286 /* If way out of range, must be VMS code already */
2287 /*-----------------------------------------------*/
2288 if (unix_status > EVMSERR)
2289 return unix_status;
2290
2291 /* If out of range, punt */
2292 /*-----------------------*/
2293 if (unix_status > __ERRNO_MAX)
2294 return SS$_ABORT;
2295
2296
2297 /* Ok, now we have to do it the hard way. */
2298 /*----------------------------------------*/
2299 switch(unix_status) {
2300 case 0: return SS$_NORMAL;
2301 case EPERM: return SS$_NOPRIV;
2302 case ENOENT: return SS$_NOSUCHOBJECT;
2303 case ESRCH: return SS$_UNREACHABLE;
2304 case EINTR: return SS$_ABORT;
2305 /* case EIO: */
2306 /* case ENXIO: */
2307 case E2BIG: return SS$_BUFFEROVF;
2308 /* case ENOEXEC */
2309 case EBADF: return RMS$_IFI;
2310 case ECHILD: return SS$_NONEXPR;
2311 /* case EAGAIN */
2312 case ENOMEM: return SS$_INSFMEM;
2313 case EACCES: return SS$_FILACCERR;
2314 case EFAULT: return SS$_ACCVIO;
2315 /* case ENOTBLK */
0968cdad 2316 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2317 case EEXIST: return RMS$_FEX;
2318 /* case EXDEV */
2319 case ENODEV: return SS$_NOSUCHDEV;
2320 case ENOTDIR: return RMS$_DIR;
2321 /* case EISDIR */
2322 case EINVAL: return SS$_INVARG;
2323 /* case ENFILE */
2324 /* case EMFILE */
2325 /* case ENOTTY */
2326 /* case ETXTBSY */
2327 /* case EFBIG */
2328 case ENOSPC: return SS$_DEVICEFULL;
2329 case ESPIPE: return LIB$_INVARG;
2330 /* case EROFS: */
2331 /* case EMLINK: */
2332 /* case EPIPE: */
2333 /* case EDOM */
2334 case ERANGE: return LIB$_INVARG;
2335 /* case EWOULDBLOCK */
2336 /* case EINPROGRESS */
2337 /* case EALREADY */
2338 /* case ENOTSOCK */
2339 /* case EDESTADDRREQ */
2340 /* case EMSGSIZE */
2341 /* case EPROTOTYPE */
2342 /* case ENOPROTOOPT */
2343 /* case EPROTONOSUPPORT */
2344 /* case ESOCKTNOSUPPORT */
2345 /* case EOPNOTSUPP */
2346 /* case EPFNOSUPPORT */
2347 /* case EAFNOSUPPORT */
2348 /* case EADDRINUSE */
2349 /* case EADDRNOTAVAIL */
2350 /* case ENETDOWN */
2351 /* case ENETUNREACH */
2352 /* case ENETRESET */
2353 /* case ECONNABORTED */
2354 /* case ECONNRESET */
2355 /* case ENOBUFS */
2356 /* case EISCONN */
2357 case ENOTCONN: return SS$_CLEARED;
2358 /* case ESHUTDOWN */
2359 /* case ETOOMANYREFS */
2360 /* case ETIMEDOUT */
2361 /* case ECONNREFUSED */
2362 /* case ELOOP */
2363 /* case ENAMETOOLONG */
2364 /* case EHOSTDOWN */
2365 /* case EHOSTUNREACH */
2366 /* case ENOTEMPTY */
2367 /* case EPROCLIM */
2368 /* case EUSERS */
2369 /* case EDQUOT */
2370 /* case ENOMSG */
2371 /* case EIDRM */
2372 /* case EALIGN */
2373 /* case ESTALE */
2374 /* case EREMOTE */
2375 /* case ENOLCK */
2376 /* case ENOSYS */
2377 /* case EFTYPE */
2378 /* case ECANCELED */
2379 /* case EFAIL */
2380 /* case EINPROG */
2381 case ENOTSUP:
2382 return SS$_UNSUPPORTED;
2383 /* case EDEADLK */
2384 /* case ENWAIT */
2385 /* case EILSEQ */
2386 /* case EBADCAT */
2387 /* case EBADMSG */
2388 /* case EABANDONED */
2389 default:
2390 return SS$_ABORT; /* punt */
2391 }
2392
2393 return SS$_ABORT; /* Should not get here */
2394}
2fbb330f
JM		 2395
2396
22d4bb9c
CB		 2397/* default piping mailbox size */
2398#define PERL_BUFSIZ 512
2399
674d6c38 2400
a0d0e21e 2401static void
fd8cd3a3 2402create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2403{
22d4bb9c
CB		 2404 unsigned long int mbxbufsiz;
2405 static unsigned long int syssize = 0;
2406 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2407 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2408 int sts;
2409
22d4bb9c
CB		 2410 if (!syssize) {
2411 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2412 /*
22d4bb9c
CB		 2413 * Get the SYSGEN parameter MAXBUF
2414 *
2415 * If the logical 'PERL_MBX_SIZE' is defined
2416 * use the value of the logical instead of PERL_BUFSIZ, but
2417 * keep the size between 128 and MAXBUF.
2418 *
a0d0e21e 2419 */
22d4bb9c
CB		 2420 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2421 }
2422
2423 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2424 mbxbufsiz = atoi(csize);
2425 } else {
2426 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2427 }
22d4bb9c
CB		 2428 if (mbxbufsiz < 128) mbxbufsiz = 128;
2429 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2430
f7ddb74a 2431 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2432
f7ddb74a 2433 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 2434 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2435
2436} /* end of create_mbx() */
2437
22d4bb9c 2438
a0d0e21e 2439/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2440
2441typedef struct _iosb IOSB;
2442typedef struct _iosb* pIOSB;
2443typedef struct _pipe Pipe;
2444typedef struct _pipe* pPipe;
2445typedef struct pipe_details Info;
2446typedef struct pipe_details* pInfo;
2447typedef struct _srqp RQE;
2448typedef struct _srqp* pRQE;
2449typedef struct _tochildbuf CBuf;
2450typedef struct _tochildbuf* pCBuf;
2451
2452struct _iosb {
2453 unsigned short status;
2454 unsigned short count;
2455 unsigned long dvispec;
2456};
2457
2458#pragma member_alignment save
2459#pragma nomember_alignment quadword
2460struct _srqp { /* VMS self-relative queue entry */
2461 unsigned long qptr[2];
2462};
2463#pragma member_alignment restore
2464static RQE RQE_ZERO = {0,0};
2465
2466struct _tochildbuf {
2467 RQE q;
2468 int eof;
2469 unsigned short size;
2470 char *buf;
2471};
2472
2473struct _pipe {
2474 RQE free;
2475 RQE wait;
2476 int fd_out;
2477 unsigned short chan_in;
2478 unsigned short chan_out;
2479 char *buf;
2480 unsigned int bufsize;
2481 IOSB iosb;
2482 IOSB iosb2;
2483 int *pipe_done;
2484 int retry;
2485 int type;
2486 int shut_on_empty;
2487 int need_wake;
2488 pPipe *home;
2489 pInfo info;
2490 pCBuf curr;
2491 pCBuf curr2;
fd8cd3a3
DS		 2492#if defined(PERL_IMPLICIT_CONTEXT)
2493 void *thx; /* Either a thread or an interpreter */
2494 /* pointer, depending on how we're built */
2495#endif
22d4bb9c
CB		 2496};
2497
2498
a0d0e21e
LW		 2499struct pipe_details
2500{
22d4bb9c 2501 pInfo next;
ff7adb52
CL		 2502 PerlIO *fp; /* file pointer to pipe mailbox */
2503 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2504 int pid; /* PID of subprocess */
2505 int mode; /* == 'r' if pipe open for reading */
2506 int done; /* subprocess has completed */
ff7adb52 2507 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2508 int closing; /* my_pclose is closing this pipe */
2509 unsigned long completion; /* termination status of subprocess */
2510 pPipe in; /* pipe in to sub */
2511 pPipe out; /* pipe out of sub */
2512 pPipe err; /* pipe of sub's sys$error */
2513 int in_done; /* true when in pipe finished */
2514 int out_done;
2515 int err_done;
a0d0e21e
LW		 2516};
2517
748a9306
LW		 2518struct exit_control_block
2519{
2520 struct exit_control_block *flink;
2521 unsigned long int (*exit_routine)();
2522 unsigned long int arg_count;
2523 unsigned long int *status_address;
2524 unsigned long int exit_status;
2525};
2526
d85f548a
JH		 2527typedef struct _closed_pipes Xpipe;
2528typedef struct _closed_pipes* pXpipe;
2529
2530struct _closed_pipes {
2531 int pid; /* PID of subprocess */
2532 unsigned long completion; /* termination status of subprocess */
2533};
2534#define NKEEPCLOSED 50
2535static Xpipe closed_list[NKEEPCLOSED];
2536static int closed_index = 0;
2537static int closed_num = 0;
2538
22d4bb9c
CB		 2539#define RETRY_DELAY "0 ::0.20"
2540#define MAX_RETRY 50
a0d0e21e 2541
22d4bb9c
CB		 2542static int pipe_ef = 0; /* first call to safe_popen inits these*/
2543static unsigned long mypid;
2544static unsigned long delaytime[2];
2545
2546static pInfo open_pipes = NULL;
2547static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2548
ff7adb52
CL		 2549#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2550
2551
3eeba6fb 2552
748a9306 2553static unsigned long int
fd8cd3a3 2554pipe_exit_routine(pTHX)
748a9306 2555{
22d4bb9c 2556 pInfo info;
1e422769 2557 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2558 int sts, did_stuff, need_eof, j;
2559
2560 /*
2561 flush any pending i/o
2562 */
2563 info = open_pipes;
2564 while (info) {
2565 if (info->fp) {
2566 if (!info->useFILE)
2567 PerlIO_flush(info->fp); /* first, flush data */
2568 else
2569 fflush((FILE *)info->fp);
2570 }
2571 info = info->next;
2572 }
3eeba6fb
CB		 2573
2574 /*
ff7adb52 2575 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2576 don't hang
2577 */
2578 did_stuff = 0;
2579 info = open_pipes;
748a9306 2580
3eeba6fb 2581 while (info) {
b2b89246 2582 int need_eof;
d4c83939 2583 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2584 if (info->in && !info->in->shut_on_empty) {
d4c83939 2585 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
22d4bb9c 2586 0, 0, 0, 0, 0, 0));
ff7adb52 2587 info->waiting = 1;
22d4bb9c 2588 did_stuff = 1;
748a9306 2589 }
d4c83939 2590 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2591 info = info->next;
2592 }
ff7adb52
CL		 2593
2594 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2595
2596 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2597 int nwait = 0;
2598
2599 info = open_pipes;
2600 while (info) {
d4c83939 2601 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2602 if (info->waiting && info->done)
2603 info->waiting = 0;
2604 nwait += info->waiting;
d4c83939 2605 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2606 info = info->next;
2607 }
2608 if (!nwait) break;
2609 sleep(1);
2610 }
3eeba6fb
CB		 2611
2612 did_stuff = 0;
2613 info = open_pipes;
2614 while (info) {
d4c83939 2615 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2616 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2617 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2618 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2619 did_stuff = 1;
2620 }
d4c83939 2621 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2622 info = info->next;
2623 }
ff7adb52
CL		 2624
2625 /* again, wait for effect */
2626
2627 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2628 int nwait = 0;
2629
2630 info = open_pipes;
2631 while (info) {
d4c83939 2632 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2633 if (info->waiting && info->done)
2634 info->waiting = 0;
2635 nwait += info->waiting;
d4c83939 2636 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2637 info = info->next;
2638 }
2639 if (!nwait) break;
2640 sleep(1);
2641 }
3eeba6fb
CB		 2642
2643 info = open_pipes;
2644 while (info) {
d4c83939 2645 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2646 if (!info->done) { /* We tried to be nice . . . */
2647 sts = sys$delprc(&info->pid,0);
d4c83939 2648 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb 2649 }
d4c83939 2650 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2651 info = info->next;
2652 }
2653
2654 while(open_pipes) {
1e422769 2655 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2656 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 2657 }
2658 return retsts;
2659}
2660
2661static struct exit_control_block pipe_exitblock =
2662 {(struct exit_control_block *) 0,
2663 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2664
22d4bb9c
CB		 2665static void pipe_mbxtofd_ast(pPipe p);
2666static void pipe_tochild1_ast(pPipe p);
2667static void pipe_tochild2_ast(pPipe p);
748a9306 2668
a0d0e21e 2669static void
22d4bb9c 2670popen_completion_ast(pInfo info)
a0d0e21e 2671{
22d4bb9c
CB		 2672 pInfo i = open_pipes;
2673 int iss;
f7ddb74a 2674 int sts;
d85f548a
JH		 2675 pXpipe x;
2676
2677 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2678 closed_list[closed_index].pid = info->pid;
2679 closed_list[closed_index].completion = info->completion;
2680 closed_index++;
2681 if (closed_index == NKEEPCLOSED)
2682 closed_index = 0;
2683 closed_num++;
22d4bb9c
CB		 2684
2685 while (i) {
2686 if (i == info) break;
2687 i = i->next;
2688 }
2689 if (!i) return; /* unlinked, probably freed too */
2690
22d4bb9c
CB		 2691 info->done = TRUE;
2692
2693/*
2694 Writing to subprocess ...
2695 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2696
2697 chan_out may be waiting for "done" flag, or hung waiting
2698 for i/o completion to child...cancel the i/o. This will
2699 put it into "snarf mode" (done but no EOF yet) that discards
2700 input.
2701
2702 Output from subprocess (stdout, stderr) needs to be flushed and
2703 shut down. We try sending an EOF, but if the mbx is full the pipe
2704 routine should still catch the "shut_on_empty" flag, telling it to
2705 use immediate-style reads so that "mbx empty" -> EOF.
2706
2707
2708*/
2709 if (info->in && !info->in_done) { /* only for mode=w */
2710 if (info->in->shut_on_empty && info->in->need_wake) {
2711 info->in->need_wake = FALSE;
fd8cd3a3 2712 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 2713 } else {
fd8cd3a3 2714 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 2715 }
2716 }
2717
2718 if (info->out && !info->out_done) { /* were we also piping output? */
2719 info->out->shut_on_empty = TRUE;
2720 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2721 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 2722 _ckvmssts_noperl(iss);
22d4bb9c
CB		 2723 }
2724
2725 if (info->err && !info->err_done) { /* we were piping stderr */
2726 info->err->shut_on_empty = TRUE;
2727 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2728 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 2729 _ckvmssts_noperl(iss);
a0d0e21e 2730 }
fd8cd3a3 2731 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 2732
a0d0e21e
LW		 2733}
2734
2fbb330f 2735static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 2736static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 2737
22d4bb9c
CB		 2738/*
2739 we actually differ from vmstrnenv since we use this to
2740 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2741 are pointing to the same thing
2742*/
2743
2744static unsigned short
fd8cd3a3 2745popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 2746{
2747 int iss;
2748 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2749 $DESCRIPTOR(d_log,"");
2750 struct _il3 {
2751 unsigned short length;
2752 unsigned short code;
2753 char * buffer_addr;
2754 unsigned short *retlenaddr;
2755 } itmlst[2];
2756 unsigned short l, ifi;
2757
2758 d_log.dsc$a_pointer = logical;
2759 d_log.dsc$w_length = strlen(logical);
2760
2761 itmlst[0].code = LNM$_STRING;
2762 itmlst[0].length = 255;
2763 itmlst[0].buffer_addr = result;
2764 itmlst[0].retlenaddr = &l;
2765
2766 itmlst[1].code = 0;
2767 itmlst[1].length = 0;
2768 itmlst[1].buffer_addr = 0;
2769 itmlst[1].retlenaddr = 0;
2770
2771 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2772 if (iss == SS$_NOLOGNAM) {
2773 iss = SS$_NORMAL;
2774 l = 0;
2775 }
2776 if (!(iss&1)) lib$signal(iss);
2777 result[l] = '\0';
2778/*
2779 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2780 strip it off and return the ifi, if any
2781*/
2782 ifi = 0;
2783 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 2784 memmove(&ifi,result+2,2);
22d4bb9c
CB		 2785 strcpy(result,result+4);
2786 }
2787 return ifi; /* this is the RMS internal file id */
2788}
2789
22d4bb9c
CB		 2790static void pipe_infromchild_ast(pPipe p);
2791
2792/*
2793 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2794 inside an AST routine without worrying about reentrancy and which Perl
2795 memory allocator is being used.
2796
2797 We read data and queue up the buffers, then spit them out one at a
2798 time to the output mailbox when the output mailbox is ready for one.
2799
2800*/
2801#define INITIAL_TOCHILDQUEUE 2
2802
2803static pPipe
fd8cd3a3 2804pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2805{
22d4bb9c
CB		 2806 pPipe p;
2807 pCBuf b;
2808 char mbx1[64], mbx2[64];
2809 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2810 DSC$K_CLASS_S, mbx1},
2811 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2812 DSC$K_CLASS_S, mbx2};
2813 unsigned int dviitm = DVI$_DEVBUFSIZ;
2814 int j, n;
2815
d4c83939
CB		 2816 n = sizeof(Pipe);
2817 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 2818
fd8cd3a3
DS		 2819 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2820 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2821 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2822
2823 p->buf = 0;
2824 p->shut_on_empty = FALSE;
2825 p->need_wake = FALSE;
2826 p->type = 0;
2827 p->retry = 0;
2828 p->iosb.status = SS$_NORMAL;
2829 p->iosb2.status = SS$_NORMAL;
2830 p->free = RQE_ZERO;
2831 p->wait = RQE_ZERO;
2832 p->curr = 0;
2833 p->curr2 = 0;
2834 p->info = 0;
fd8cd3a3
DS		 2835#ifdef PERL_IMPLICIT_CONTEXT
2836 p->thx = aTHX;
2837#endif
22d4bb9c
CB		 2838
2839 n = sizeof(CBuf) + p->bufsize;
2840
2841 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2842 _ckvmssts(lib$get_vm(&n, &b));
2843 b->buf = (char *) b + sizeof(CBuf);
2844 _ckvmssts(lib$insqhi(b, &p->free));
2845 }
2846
2847 pipe_tochild2_ast(p);
2848 pipe_tochild1_ast(p);
2849 strcpy(wmbx, mbx1);
2850 strcpy(rmbx, mbx2);
2851 return p;
2852}
2853
2854/* reads the MBX Perl is writing, and queues */
2855
2856static void
2857pipe_tochild1_ast(pPipe p)
2858{
22d4bb9c
CB		 2859 pCBuf b = p->curr;
2860 int iss = p->iosb.status;
2861 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 2862 int sts;
fd8cd3a3
DS		 2863#ifdef PERL_IMPLICIT_CONTEXT
2864 pTHX = p->thx;
2865#endif
22d4bb9c
CB		 2866
2867 if (p->retry) {
2868 if (eof) {
2869 p->shut_on_empty = TRUE;
2870 b->eof = TRUE;
2871 _ckvmssts(sys$dassgn(p->chan_in));
2872 } else {
2873 _ckvmssts(iss);
2874 }
2875
2876 b->eof = eof;
2877 b->size = p->iosb.count;
f7ddb74a 2878 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 2879 if (p->need_wake) {
2880 p->need_wake = FALSE;
2881 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2882 }
2883 } else {
2884 p->retry = 1; /* initial call */
2885 }
2886
2887 if (eof) { /* flush the free queue, return when done */
2888 int n = sizeof(CBuf) + p->bufsize;
2889 while (1) {
2890 iss = lib$remqti(&p->free, &b);
2891 if (iss == LIB$_QUEWASEMP) return;
2892 _ckvmssts(iss);
2893 _ckvmssts(lib$free_vm(&n, &b));
2894 }
2895 }
2896
2897 iss = lib$remqti(&p->free, &b);
2898 if (iss == LIB$_QUEWASEMP) {
2899 int n = sizeof(CBuf) + p->bufsize;
2900 _ckvmssts(lib$get_vm(&n, &b));
2901 b->buf = (char *) b + sizeof(CBuf);
2902 } else {
2903 _ckvmssts(iss);
2904 }
2905
2906 p->curr = b;
2907 iss = sys$qio(0,p->chan_in,
2908 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2909 &p->iosb,
2910 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2911 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2912 _ckvmssts(iss);
2913}
2914
2915
2916/* writes queued buffers to output, waits for each to complete before
2917 doing the next */
2918
2919static void
2920pipe_tochild2_ast(pPipe p)
2921{
22d4bb9c
CB		 2922 pCBuf b = p->curr2;
2923 int iss = p->iosb2.status;
2924 int n = sizeof(CBuf) + p->bufsize;
2925 int done = (p->info && p->info->done) ||
2926 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 2927#if defined(PERL_IMPLICIT_CONTEXT)
2928 pTHX = p->thx;
2929#endif
22d4bb9c
CB		 2930
2931 do {
2932 if (p->type) { /* type=1 has old buffer, dispose */
2933 if (p->shut_on_empty) {
2934 _ckvmssts(lib$free_vm(&n, &b));
2935 } else {
2936 _ckvmssts(lib$insqhi(b, &p->free));
2937 }
2938 p->type = 0;
2939 }
2940
2941 iss = lib$remqti(&p->wait, &b);
2942 if (iss == LIB$_QUEWASEMP) {
2943 if (p->shut_on_empty) {
2944 if (done) {
2945 _ckvmssts(sys$dassgn(p->chan_out));
2946 *p->pipe_done = TRUE;
2947 _ckvmssts(sys$setef(pipe_ef));
2948 } else {
2949 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2950 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2951 }
2952 return;
2953 }
2954 p->need_wake = TRUE;
2955 return;
2956 }
2957 _ckvmssts(iss);
2958 p->type = 1;
2959 } while (done);
2960
2961
2962 p->curr2 = b;
2963 if (b->eof) {
2964 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2965 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2966 } else {
2967 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2968 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2969 }
2970
2971 return;
2972
2973}
2974
2975
2976static pPipe
fd8cd3a3 2977pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 2978{
22d4bb9c
CB		 2979 pPipe p;
2980 char mbx1[64], mbx2[64];
2981 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2982 DSC$K_CLASS_S, mbx1},
2983 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2984 DSC$K_CLASS_S, mbx2};
2985 unsigned int dviitm = DVI$_DEVBUFSIZ;
2986
d4c83939
CB		 2987 int n = sizeof(Pipe);
2988 _ckvmssts(lib$get_vm(&n, &p));
fd8cd3a3
DS		 2989 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2990 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 2991
2992 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 2993 n = p->bufsize * sizeof(char);
2994 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 2995 p->shut_on_empty = FALSE;
2996 p->info = 0;
2997 p->type = 0;
2998 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 2999#if defined(PERL_IMPLICIT_CONTEXT)
3000 p->thx = aTHX;
3001#endif
22d4bb9c
CB		 3002 pipe_infromchild_ast(p);
3003
3004 strcpy(wmbx, mbx1);
3005 strcpy(rmbx, mbx2);
3006 return p;
3007}
3008
3009static void
3010pipe_infromchild_ast(pPipe p)
3011{
22d4bb9c
CB		 3012 int iss = p->iosb.status;
3013 int eof = (iss == SS$_ENDOFFILE);
3014 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3015 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3016#if defined(PERL_IMPLICIT_CONTEXT)
3017 pTHX = p->thx;
3018#endif
22d4bb9c
CB		 3019
3020 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3021 _ckvmssts(sys$dassgn(p->chan_out));
3022 p->chan_out = 0;
3023 }
3024
3025 /* read completed:
3026 input shutdown if EOF from self (done or shut_on_empty)
3027 output shutdown if closing flag set (my_pclose)
3028 send data/eof from child or eof from self
3029 otherwise, re-read (snarf of data from child)
3030 */
3031
3032 if (p->type == 1) {
3033 p->type = 0;
3034 if (myeof && p->chan_in) { /* input shutdown */
3035 _ckvmssts(sys$dassgn(p->chan_in));
3036 p->chan_in = 0;
3037 }
3038
3039 if (p->chan_out) {
3040 if (myeof || kideof) { /* pass EOF to parent */
3041 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3042 pipe_infromchild_ast, p,
3043 0, 0, 0, 0, 0, 0));
3044 return;
3045 } else if (eof) { /* eat EOF --- fall through to read*/
3046
3047 } else { /* transmit data */
3048 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3049 pipe_infromchild_ast,p,
3050 p->buf, p->iosb.count, 0, 0, 0, 0));
3051 return;
3052 }
3053 }
3054 }
3055
3056 /* everything shut? flag as done */
3057
3058 if (!p->chan_in && !p->chan_out) {
3059 *p->pipe_done = TRUE;
3060 _ckvmssts(sys$setef(pipe_ef));
3061 return;
3062 }
3063
3064 /* write completed (or read, if snarfing from child)
3065 if still have input active,
3066 queue read...immediate mode if shut_on_empty so we get EOF if empty
3067 otherwise,
3068 check if Perl reading, generate EOFs as needed
3069 */
3070
3071 if (p->type == 0) {
3072 p->type = 1;
3073 if (p->chan_in) {
3074 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3075 pipe_infromchild_ast,p,
3076 p->buf, p->bufsize, 0, 0, 0, 0);
3077 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3078 _ckvmssts(iss);
3079 } else { /* send EOFs for extra reads */
3080 p->iosb.status = SS$_ENDOFFILE;
3081 p->iosb.dvispec = 0;
3082 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3083 0, 0, 0,
3084 pipe_infromchild_ast, p, 0, 0, 0, 0));
3085 }
3086 }
3087}
3088
3089static pPipe
fd8cd3a3 3090pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3091{
22d4bb9c
CB		 3092 pPipe p;
3093 char mbx[64];
3094 unsigned long dviitm = DVI$_DEVBUFSIZ;
3095 struct stat s;
3096 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3097 DSC$K_CLASS_S, mbx};
a480973c 3098 int n = sizeof(Pipe);
22d4bb9c
CB		 3099
3100 /* things like terminals and mbx's don't need this filter */
3101 if (fd && fstat(fd,&s) == 0) {
3102 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3103 char device[65];
3104 unsigned short dev_len;
3105 struct dsc$descriptor_s d_dev;
3106 char * cptr;
3107 struct item_list_3 items[3];
3108 int status;
3109 unsigned short dvi_iosb[4];
3110
3111 cptr = getname(fd, out, 1);
3112 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3113 d_dev.dsc$a_pointer = out;
3114 d_dev.dsc$w_length = strlen(out);
3115 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3116 d_dev.dsc$b_class = DSC$K_CLASS_S;
3117
3118 items[0].len = 4;
3119 items[0].code = DVI$_DEVCHAR;
3120 items[0].bufadr = &devchar;
3121 items[0].retadr = NULL;
3122 items[1].len = 64;
3123 items[1].code = DVI$_FULLDEVNAM;
3124 items[1].bufadr = device;
3125 items[1].retadr = &dev_len;
3126 items[2].len = 0;
3127 items[2].code = 0;
3128
3129 status = sys$getdviw
3130 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3131 _ckvmssts(status);
3132 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3133 device[dev_len] = 0;
3134
3135 if (!(devchar & DEV$M_DIR)) {
3136 strcpy(out, device);
3137 return 0;
3138 }
3139 }
22d4bb9c
CB		 3140 }
3141
d4c83939 3142 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3143 p->fd_out = dup(fd);
fd8cd3a3 3144 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 3145 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3146 n = (p->bufsize+1) * sizeof(char);
3147 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3148 p->shut_on_empty = FALSE;
3149 p->retry = 0;
3150 p->info = 0;
3151 strcpy(out, mbx);
3152
3153 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3154 pipe_mbxtofd_ast, p,
3155 p->buf, p->bufsize, 0, 0, 0, 0));
3156
3157 return p;
3158}
3159
3160static void
3161pipe_mbxtofd_ast(pPipe p)
3162{
22d4bb9c
CB		 3163 int iss = p->iosb.status;
3164 int done = p->info->done;
3165 int iss2;
3166 int eof = (iss == SS$_ENDOFFILE);
3167 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3168 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3169#if defined(PERL_IMPLICIT_CONTEXT)
3170 pTHX = p->thx;
3171#endif
22d4bb9c
CB		 3172
3173 if (done && myeof) { /* end piping */
3174 close(p->fd_out);
3175 sys$dassgn(p->chan_in);
3176 *p->pipe_done = TRUE;
3177 _ckvmssts(sys$setef(pipe_ef));
3178 return;
3179 }
3180
3181 if (!err && !eof) { /* good data to send to file */
3182 p->buf[p->iosb.count] = '\n';
3183 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3184 if (iss2 < 0) {
3185 p->retry++;
3186 if (p->retry < MAX_RETRY) {
3187 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3188 return;
3189 }
3190 }
3191 p->retry = 0;
3192 } else if (err) {
3193 _ckvmssts(iss);
3194 }
3195
3196
3197 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3198 pipe_mbxtofd_ast, p,
3199 p->buf, p->bufsize, 0, 0, 0, 0);
3200 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3201 _ckvmssts(iss);
3202}
3203
3204
3205typedef struct _pipeloc PLOC;
3206typedef struct _pipeloc* pPLOC;
3207
3208struct _pipeloc {
3209 pPLOC next;
3210 char dir[NAM$C_MAXRSS+1];
3211};
3212static pPLOC head_PLOC = 0;
3213
5c0ae288 3214void
fd8cd3a3 3215free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3216{
3217 pPLOC p, pnext;
ff7adb52 3218 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3219
ff7adb52 3220 p = *pHead;
5c0ae288
CL		 3221 while (p) {
3222 pnext = p->next;
e0ef6b43 3223 PerlMem_free(p);
5c0ae288
CL		 3224 p = pnext;
3225 }
ff7adb52 3226 *pHead = 0;
5c0ae288 3227}
22d4bb9c
CB		 3228
3229static void
fd8cd3a3 3230store_pipelocs(pTHX)
22d4bb9c
CB		 3231{
3232 int i;
3233 pPLOC p;
ff7adb52 3234 AV *av = 0;
22d4bb9c
CB		 3235 SV *dirsv;
3236 GV *gv;
3237 char *dir, *x;
3238 char *unixdir;
3239 char temp[NAM$C_MAXRSS+1];
3240 STRLEN n_a;
3241
ff7adb52 3242 if (head_PLOC)
218fdd94 3243 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3244
22d4bb9c
CB		 3245/* the . directory from @INC comes last */
3246
e0ef6b43 3247 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3248 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3249 p->next = head_PLOC;
3250 head_PLOC = p;
3251 strcpy(p->dir,"./");
3252
3253/* get the directory from $^X */
3254
c5375c28
JM		 3255 unixdir = PerlMem_malloc(VMS_MAXRSS);
3256 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3257
218fdd94
CL		 3258#ifdef PERL_IMPLICIT_CONTEXT
3259 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3260#else
22d4bb9c 3261 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3262#endif
22d4bb9c
CB		 3263 strcpy(temp, PL_origargv[0]);
3264 x = strrchr(temp,']');
2497a41f
JM		 3265 if (x == NULL) {
3266 x = strrchr(temp,'>');
3267 if (x == NULL) {
3268 /* It could be a UNIX path */
3269 x = strrchr(temp,'/');
3270 }
3271 }
3272 if (x)
3273 x[1] = '\0';
3274 else {
3275 /* Got a bare name, so use default directory */
3276 temp[0] = '.';
3277 temp[1] = '\0';
3278 }
22d4bb9c 3279
c5375c28 3280 if ((tounixpath(temp, unixdir)) != Nullch) {
e0ef6b43 3281 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3282 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3283 p->next = head_PLOC;
3284 head_PLOC = p;
3285 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3286 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3287 }
22d4bb9c
CB		 3288 }
3289
3290/* reverse order of @INC entries, skip "." since entered above */
3291
218fdd94
CL		 3292#ifdef PERL_IMPLICIT_CONTEXT
3293 if (aTHX)
3294#endif
ff7adb52
CL		 3295 if (PL_incgv) av = GvAVn(PL_incgv);
3296
3297 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3298 dirsv = *av_fetch(av,i,TRUE);
3299
3300 if (SvROK(dirsv)) continue;
3301 dir = SvPVx(dirsv,n_a);
3302 if (strcmp(dir,".") == 0) continue;
c5375c28 3303 if ((tounixpath(dir, unixdir)) == Nullch)
22d4bb9c
CB		 3304 continue;
3305
e0ef6b43 3306 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3307 p->next = head_PLOC;
3308 head_PLOC = p;
3309 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3310 p->dir[NAM$C_MAXRSS] = '\0';
3311 }
3312
3313/* most likely spot (ARCHLIB) put first in the list */
3314
3315#ifdef ARCHLIB_EXP
c5375c28 3316 if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
e0ef6b43 3317 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3318 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3319 p->next = head_PLOC;
3320 head_PLOC = p;
3321 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3322 p->dir[NAM$C_MAXRSS] = '\0';
3323 }
3324#endif
c5375c28 3325 PerlMem_free(unixdir);
22d4bb9c
CB		 3326}
3327
a1887106
JM		 3328static I32
3329Perl_cando_by_name_int
3330 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3331#if !defined(PERL_IMPLICIT_CONTEXT)
3332#define cando_by_name_int Perl_cando_by_name_int
3333#else
3334#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3335#endif
22d4bb9c
CB		 3336
3337static char *
fd8cd3a3 3338find_vmspipe(pTHX)
22d4bb9c
CB		 3339{
3340 static int vmspipe_file_status = 0;
3341 static char vmspipe_file[NAM$C_MAXRSS+1];
3342
3343 /* already found? Check and use ... need read+execute permission */
3344
3345 if (vmspipe_file_status == 1) {
a1887106
JM		 3346 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3347 && cando_by_name_int
3348 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3349 return vmspipe_file;
3350 }
3351 vmspipe_file_status = 0;
3352 }
3353
3354 /* scan through stored @INC, $^X */
3355
3356 if (vmspipe_file_status == 0) {
3357 char file[NAM$C_MAXRSS+1];
3358 pPLOC p = head_PLOC;
3359
3360 while (p) {
2f4077ca 3361 char * exp_res;
4d743a9b 3362 int dirlen;
22d4bb9c 3363 strcpy(file, p->dir);
4d743a9b
JM		 3364 dirlen = strlen(file);
3365 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3366 file[NAM$C_MAXRSS] = '\0';
3367 p = p->next;
3368
2f4077ca
JM		 3369 exp_res = do_rmsexpand
3370 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3371 if (!exp_res) continue;
22d4bb9c 3372
a1887106
JM		 3373 if (cando_by_name_int
3374 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3375 && cando_by_name_int
3376 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3377 vmspipe_file_status = 1;
3378 return vmspipe_file;
3379 }
3380 }
3381 vmspipe_file_status = -1; /* failed, use tempfiles */
3382 }
3383
3384 return 0;
3385}
3386
3387static FILE *
fd8cd3a3 3388vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3389{
3390 char file[NAM$C_MAXRSS+1];
3391 FILE *fp;
3392 static int index = 0;
2497a41f
JM		 3393 Stat_t s0, s1;
3394 int cmp_result;
22d4bb9c
CB		 3395
3396 /* create a tempfile */
3397
3398 /* we can't go from W, shr=get to R, shr=get without
3399 an intermediate vulnerable state, so don't bother trying...
3400
3401 and lib$spawn doesn't shr=put, so have to close the write
3402
3403 So... match up the creation date/time and the FID to
3404 make sure we're dealing with the same file
3405
3406 */
3407
3408 index++;
2497a41f
JM		 3409 if (!decc_filename_unix_only) {
3410 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3411 fp = fopen(file,"w");
3412 if (!fp) {
22d4bb9c
CB		 3413 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3414 fp = fopen(file,"w");
3415 if (!fp) {
3416 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3417 fp = fopen(file,"w");
2497a41f
JM		 3418 }
3419 }
3420 }
3421 else {
3422 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3423 fp = fopen(file,"w");
3424 if (!fp) {
3425 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3426 fp = fopen(file,"w");
3427 if (!fp) {
3428 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3429 fp = fopen(file,"w");
3430 }
3431 }
22d4bb9c
CB		 3432 }
3433 if (!fp) return 0; /* we're hosed */
3434
f9ecfa39 3435 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3436 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3437 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3438 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3439 fprintf(fp,"$ perl_on = \"set noon\"\n");
3440 fprintf(fp,"$ perl_exit = \"exit\"\n");
3441 fprintf(fp,"$ perl_del = \"delete\"\n");
3442 fprintf(fp,"$ pif = \"if\"\n");
3443 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3444 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3445 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3446 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3447 fprintf(fp,"$! --- build command line to get max possible length\n");
3448 fprintf(fp,"$c=perl_popen_cmd0\n");
3449 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3450 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3451 fprintf(fp,"$x=perl_popen_cmd3\n");
3452 fprintf(fp,"$c=c+x\n");
22d4bb9c 3453 fprintf(fp,"$ perl_on\n");
f9ecfa39 3454 fprintf(fp,"$ 'c'\n");
22d4bb9c 3455 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3456 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3457 fprintf(fp,"$ perl_exit 'perl_status'\n");
3458 fsync(fileno(fp));
3459
3460 fgetname(fp, file, 1);
2497a41f 3461 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3462 fclose(fp);
3463
2497a41f
JM		 3464 if (decc_filename_unix_only)
3465 do_tounixspec(file, file, 0);
22d4bb9c
CB		 3466 fp = fopen(file,"r","shr=get");
3467 if (!fp) return 0;
2497a41f
JM		 3468 fstat(fileno(fp), (struct stat *)&s1);
3469
682e4b71 3470 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3471 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3472 fclose(fp);
3473 return 0;
3474 }
3475
3476 return fp;
3477}
3478
3479
3480
8fde5078 3481static PerlIO *
2fbb330f 3482safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 3483{
748a9306 3484 static int handler_set_up = FALSE;
55f2b99c 3485 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 3486 /* The use of a GLOBAL table (as was done previously) rendered
3487 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3488 * environment. Hence we've switched to LOCAL symbol table.
3489 */
3490 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 3491 int j, wait = 0, n;
ff7adb52 3492 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 3493 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 3494 FILE *tpipe = 0;
3495 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 3496 pInfo info = NULL;
48b5a746 3497 char cmd_sym_name[20];
22d4bb9c
CB		 3498 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3499 DSC$K_CLASS_S, symbol};
22d4bb9c 3500 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 3501 DSC$K_CLASS_S, 0};
48b5a746
CL		 3502 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3503 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 3504 struct dsc$descriptor_s *vmscmd;
22d4bb9c 3505 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 3506 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 3507 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
a0d0e21e 3508
afd8f436
JH		 3509 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3510
22d4bb9c
CB		 3511 /* once-per-program initialization...
3512 note that the SETAST calls and the dual test of pipe_ef
3513 makes sure that only the FIRST thread through here does
3514 the initialization...all other threads wait until it's
3515 done.
3516
3517 Yeah, uglier than a pthread call, it's got all the stuff inline
3518 rather than in a separate routine.
3519 */
3520
3521 if (!pipe_ef) {
3522 _ckvmssts(sys$setast(0));
3523 if (!pipe_ef) {
3524 unsigned long int pidcode = JPI$_PID;
3525 $DESCRIPTOR(d_delay, RETRY_DELAY);
3526 _ckvmssts(lib$get_ef(&pipe_ef));
3527 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3528 _ckvmssts(sys$bintim(&d_delay, delaytime));
3529 }
3530 if (!handler_set_up) {
3531 _ckvmssts(sys$dclexh(&pipe_exitblock));
3532 handler_set_up = TRUE;
3533 }
3534 _ckvmssts(sys$setast(1));
3535 }
3536
3537 /* see if we can find a VMSPIPE.COM */
3538
3539 tfilebuf[0] = '@';
fd8cd3a3 3540 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 3541 if (vmspipe) {
3542 strcpy(tfilebuf+1,vmspipe);
3543 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 3544 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 3545 if (!tpipe) { /* a fish popular in Boston */
3546 if (ckWARN(WARN_PIPE)) {
f98bc0c6 3547 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB		 3548 }
3549 return Nullfp;
3550 }
3551 fgetname(tpipe,tfilebuf+1,1);
3552 }
3553 vmspipedsc.dsc$a_pointer = tfilebuf;
3554 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 3555
218fdd94 3556 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 3557 if (!(sts & 1)) {
3558 switch (sts) {
3559 case RMS$_FNF: case RMS$_DNF:
3560 set_errno(ENOENT); break;
3561 case RMS$_DIR:
3562 set_errno(ENOTDIR); break;
3563 case RMS$_DEV:
3564 set_errno(ENODEV); break;
3565 case RMS$_PRV:
3566 set_errno(EACCES); break;
3567 case RMS$_SYN:
3568 set_errno(EINVAL); break;
3569 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3570 set_errno(E2BIG); break;
3571 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3572 _ckvmssts(sts); /* fall through */
3573 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3574 set_errno(EVMSERR);
3575 }
3576 set_vaxc_errno(sts);
ff7adb52 3577 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 3578 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 3579 }
ff7adb52 3580 *psts = sts;
a2669cfc
JH		 3581 return Nullfp;
3582 }
d4c83939
CB		 3583 n = sizeof(Info);
3584 _ckvmssts(lib$get_vm(&n, &info));
22d4bb9c 3585
ff7adb52 3586 strcpy(mode,in_mode);
22d4bb9c
CB		 3587 info->mode = *mode;
3588 info->done = FALSE;
3589 info->completion = 0;
3590 info->closing = FALSE;
3591 info->in = 0;
3592 info->out = 0;
3593 info->err = 0;
ff7adb52
CL		 3594 info->fp = Nullfp;
3595 info->useFILE = 0;
3596 info->waiting = 0;
22d4bb9c
CB		 3597 info->in_done = TRUE;
3598 info->out_done = TRUE;
3599 info->err_done = TRUE;
cfcfe586
JM		 3600
3601 in = PerlMem_malloc(VMS_MAXRSS);
3602 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3603 out = PerlMem_malloc(VMS_MAXRSS);
3604 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3605 err = PerlMem_malloc(VMS_MAXRSS);
3606 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3607
0e06870b 3608 in[0] = out[0] = err[0] = '\0';
22d4bb9c 3609
ff7adb52
CL		 3610 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3611 info->useFILE = 1;
3612 strcpy(p,p+1);
3613 }
3614 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3615 wait = 1;
3616 strcpy(p,p+1);
3617 }
3618
22d4bb9c 3619 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 3620
fd8cd3a3 3621 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 3622 if (info->out) {
3623 info->out->pipe_done = &info->out_done;
3624 info->out_done = FALSE;
3625 info->out->info = info;
3626 }
ff7adb52 3627 if (!info->useFILE) {
22d4bb9c 3628 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 3629 } else {
3630 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3631 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3632 }
3633
22d4bb9c
CB		 3634 if (!info->fp && info->out) {
3635 sys$cancel(info->out->chan_out);
3636
3637 while (!info->out_done) {
3638 int done;
3639 _ckvmssts(sys$setast(0));
3640 done = info->out_done;
3641 if (!done) _ckvmssts(sys$clref(pipe_ef));
3642 _ckvmssts(sys$setast(1));
3643 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 3644 }
22d4bb9c 3645
d4c83939
CB		 3646 if (info->out->buf) {
3647 n = info->out->bufsize * sizeof(char);
3648 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3649 }
3650 n = sizeof(Pipe);
3651 _ckvmssts(lib$free_vm(&n, &info->out));
3652 n = sizeof(Info);
3653 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 3654 *psts = RMS$_FNF;
22d4bb9c 3655 return Nullfp;
0e06870b 3656 }
22d4bb9c 3657
fd8cd3a3 3658 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 3659 if (info->err) {
3660 info->err->pipe_done = &info->err_done;
3661 info->err_done = FALSE;
3662 info->err->info = info;
3663 }
a0d0e21e 3664
ff7adb52
CL		 3665 } else if (*mode == 'w') { /* piping to subroutine */
3666
3667 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3668 if (info->out) {
3669 info->out->pipe_done = &info->out_done;
3670 info->out_done = FALSE;
3671 info->out->info = info;
3672 }
3673
3674 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3675 if (info->err) {
3676 info->err->pipe_done = &info->err_done;
3677 info->err_done = FALSE;
3678 info->err->info = info;
3679 }
a0d0e21e 3680
fd8cd3a3 3681 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 3682 if (!info->useFILE) {
a480973c 3683 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 3684 } else {
3685 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3686 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3687 }
3688
22d4bb9c
CB		 3689 if (info->in) {
3690 info->in->pipe_done = &info->in_done;
3691 info->in_done = FALSE;
3692 info->in->info = info;
3693 }
a0d0e21e 3694
22d4bb9c
CB		 3695 /* error cleanup */
3696 if (!info->fp && info->in) {
3697 info->done = TRUE;
3698 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3699 0, 0, 0, 0, 0, 0, 0, 0));
3700
3701 while (!info->in_done) {
3702 int done;
3703 _ckvmssts(sys$setast(0));
3704 done = info->in_done;
3705 if (!done) _ckvmssts(sys$clref(pipe_ef));
3706 _ckvmssts(sys$setast(1));
3707 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3708 }
a0d0e21e 3709
d4c83939
CB		 3710 if (info->in->buf) {
3711 n = info->in->bufsize * sizeof(char);
3712 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3713 }
3714 n = sizeof(Pipe);
3715 _ckvmssts(lib$free_vm(&n, &info->in));
3716 n = sizeof(Info);
3717 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 3718 *psts = RMS$_FNF;
0e06870b 3719 return Nullfp;
22d4bb9c 3720 }
a0d0e21e 3721
22d4bb9c 3722
ff7adb52 3723 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 3724 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 3725 if (info->out) {
3726 info->out->pipe_done = &info->out_done;
3727 info->out_done = FALSE;
3728 info->out->info = info;
3729 }
0e06870b 3730
fd8cd3a3 3731 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 3732 if (info->err) {
3733 info->err->pipe_done = &info->err_done;
3734 info->err_done = FALSE;
3735 info->err->info = info;
3736 }
748a9306 3737 }
22d4bb9c
CB		 3738
3739 symbol[MAX_DCL_SYMBOL] = '\0';
3740
3741 strncpy(symbol, in, MAX_DCL_SYMBOL);
3742 d_symbol.dsc$w_length = strlen(symbol);
3743 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3744
3745 strncpy(symbol, err, MAX_DCL_SYMBOL);
3746 d_symbol.dsc$w_length = strlen(symbol);
3747 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3748
0e06870b
CB		 3749 strncpy(symbol, out, MAX_DCL_SYMBOL);
3750 d_symbol.dsc$w_length = strlen(symbol);
3751 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 3752
cfcfe586
JM		 3753 /* Done with the names for the pipes */
3754 PerlMem_free(err);
3755 PerlMem_free(out);
3756 PerlMem_free(in);
3757
218fdd94 3758 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 3759 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3760 if (*p == '$') p++; /* remove leading $ */
3761 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 3762
3763 for (j = 0; j < 4; j++) {
3764 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3765 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3766
22d4bb9c
CB		 3767 strncpy(symbol, p, MAX_DCL_SYMBOL);
3768 d_symbol.dsc$w_length = strlen(symbol);
3769 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3770
48b5a746
CL		 3771 if (strlen(p) > MAX_DCL_SYMBOL) {
3772 p += MAX_DCL_SYMBOL;
3773 } else {
3774 p += strlen(p);
3775 }
3776 }
22d4bb9c 3777 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 3778 info->next=open_pipes; /* prepend to list */
3779 open_pipes=info;
22d4bb9c 3780 _ckvmssts(sys$setast(1));
55f2b99c
CB		 3781 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3782 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3783 * have SYS$COMMAND if we need it.
3784 */
3785 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 3786 0, &info->pid, &info->completion,
3787 0, popen_completion_ast,info,0,0,0));
3788
3789 /* if we were using a tempfile, close it now */
3790
3791 if (tpipe) fclose(tpipe);
3792
ff7adb52 3793 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 3794 we can get rid of ours */
3795
48b5a746
CL		 3796 for (j = 0; j < 4; j++) {
3797 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3798 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 3799 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 3800 }
22d4bb9c
CB		 3801 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3802 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 3803 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 3804 vms_execfree(vmscmd);
a0d0e21e 3805
218fdd94
CL		 3806#ifdef PERL_IMPLICIT_CONTEXT
3807 if (aTHX)
3808#endif
6b88bc9c 3809 PL_forkprocess = info->pid;
218fdd94 3810
ff7adb52
CL		 3811 if (wait) {
3812 int done = 0;
3813 while (!done) {
3814 _ckvmssts(sys$setast(0));
3815 done = info->done;
3816 if (!done) _ckvmssts(sys$clref(pipe_ef));
3817 _ckvmssts(sys$setast(1));
3818 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3819 }
3820 *psts = info->completion;
2fbb330f
JM		 3821/* Caller thinks it is open and tries to close it. */
3822/* This causes some problems, as it changes the error status */
3823/* my_pclose(info->fp); */
ff7adb52
CL		 3824 } else {
3825 *psts = SS$_NORMAL;
3826 }
a0d0e21e 3827 return info->fp;
1e422769 3828} /* end of safe_popen */
3829
3830
a15cef0c
CB		 3831/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3832PerlIO *
2fbb330f 3833Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 3834{
ff7adb52 3835 int sts;
1e422769 3836 TAINT_ENV();
3837 TAINT_PROPER("popen");
45bc9206 3838 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 3839 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 3840}
1e422769 3841
a0d0e21e
LW		 3842/*}}}*/
3843
a15cef0c
CB		 3844/*{{{ I32 my_pclose(PerlIO *fp)*/
3845I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 3846{
22d4bb9c 3847 pInfo info, last = NULL;
748a9306 3848 unsigned long int retsts;
d4c83939 3849 int done, iss, n;
a0d0e21e
LW		 3850
3851 for (info = open_pipes; info != NULL; last = info, info = info->next)
3852 if (info->fp == fp) break;
3853
1e422769 3854 if (info == NULL) { /* no such pipe open */
3855 set_errno(ECHILD); /* quoth POSIX */
3856 set_vaxc_errno(SS$_NONEXPR);
3857 return -1;
3858 }
748a9306 3859
bbce6d69 3860 /* If we were writing to a subprocess, insure that someone reading from
3861 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 3862 * produce an EOF record in the mailbox.
3863 *
3864 * well, at least sometimes it *does*, so we have to watch out for
3865 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3866 */
ff7adb52
CL		 3867 if (info->fp) {
3868 if (!info->useFILE)
d4c83939 3869 PerlIO_flush(info->fp); /* first, flush data */
ff7adb52
CL		 3870 else
3871 fflush((FILE *)info->fp);
3872 }
22d4bb9c 3873
b08af3f0 3874 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 3875 info->closing = TRUE;
3876 done = info->done && info->in_done && info->out_done && info->err_done;
3877 /* hanging on write to Perl's input? cancel it */
3878 if (info->mode == 'r' && info->out && !info->out_done) {
3879 if (info->out->chan_out) {
3880 _ckvmssts(sys$cancel(info->out->chan_out));
3881 if (!info->out->chan_in) { /* EOF generation, need AST */
3882 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3883 }
3884 }
3885 }
3886 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3887 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3888 0, 0, 0, 0, 0, 0));
b08af3f0 3889 _ckvmssts(sys$setast(1));
ff7adb52
CL		 3890 if (info->fp) {
3891 if (!info->useFILE)
d4c83939 3892 PerlIO_close(info->fp);
ff7adb52
CL		 3893 else
3894 fclose((FILE *)info->fp);
3895 }
22d4bb9c
CB		 3896 /*
3897 we have to wait until subprocess completes, but ALSO wait until all
3898 the i/o completes...otherwise we'll be freeing the "info" structure
3899 that the i/o ASTs could still be using...
3900 */
3901
3902 while (!done) {
3903 _ckvmssts(sys$setast(0));
3904 done = info->done && info->in_done && info->out_done && info->err_done;
3905 if (!done) _ckvmssts(sys$clref(pipe_ef));
3906 _ckvmssts(sys$setast(1));
3907 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3908 }
3909 retsts = info->completion;
a0d0e21e 3910
a0d0e21e 3911 /* remove from list of open pipes */
b08af3f0 3912 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 3913 if (last) last->next = info->next;
3914 else open_pipes = info->next;
b08af3f0 3915 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 3916
3917 /* free buffers and structures */
3918
3919 if (info->in) {
d4c83939
CB		 3920 if (info->in->buf) {
3921 n = info->in->bufsize * sizeof(char);
3922 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3923 }
3924 n = sizeof(Pipe);
3925 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 3926 }
3927 if (info->out) {
d4c83939
CB		 3928 if (info->out->buf) {
3929 n = info->out->bufsize * sizeof(char);
3930 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3931 }
3932 n = sizeof(Pipe);
3933 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 3934 }
3935 if (info->err) {
d4c83939
CB		 3936 if (info->err->buf) {
3937 n = info->err->bufsize * sizeof(char);
3938 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3939 }
3940 n = sizeof(Pipe);
3941 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 3942 }
d4c83939
CB		 3943 n = sizeof(Info);
3944 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 3945
3946 return retsts;
748a9306 3947
a0d0e21e
LW		 3948} /* end of my_pclose() */
3949
119586db 3950#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 3951 /* Roll our own prototype because we want this regardless of whether
3952 * _VMS_WAIT is defined.
3953 */
3954 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3955#endif
3956/* sort-of waitpid; special handling of pipe clean-up for subprocesses
3957 created with popen(); otherwise partially emulate waitpid() unless
3958 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3959 Also check processes not considered by the CRTL waitpid().
3960 */
4fdae800 3961/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3962Pid_t
fd8cd3a3 3963Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 3964{
22d4bb9c
CB		 3965 pInfo info;
3966 int done;
aeb5cf3c 3967 int sts;
d85f548a 3968 int j;
aeb5cf3c
CB		 3969
3970 if (statusp) *statusp = 0;
a0d0e21e
LW		 3971
3972 for (info = open_pipes; info != NULL; info = info->next)
3973 if (info->pid == pid) break;
3974
3975 if (info != NULL) { /* we know about this child */
748a9306 3976 while (!info->done) {
22d4bb9c
CB		 3977 _ckvmssts(sys$setast(0));
3978 done = info->done;
3979 if (!done) _ckvmssts(sys$clref(pipe_ef));
3980 _ckvmssts(sys$setast(1));
3981 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 3982 }
3983
aeb5cf3c 3984 if (statusp) *statusp = info->completion;
a0d0e21e 3985 return pid;
d85f548a
JH		 3986 }
3987
3988 /* child that already terminated? */
aeb5cf3c 3989
d85f548a
JH		 3990 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3991 if (closed_list[j].pid == pid) {
3992 if (statusp) *statusp = closed_list[j].completion;
3993 return pid;
3994 }
a0d0e21e 3995 }
d85f548a
JH		 3996
3997 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 3998
119586db 3999#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4000
4001 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4002 * in 7.2 did we get a version that fills in the VMS completion
4003 * status as Perl has always tried to do.
4004 */
4005
4006 sts = __vms_waitpid( pid, statusp, flags );
4007
4008 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4009 return sts;
4010
4011 /* If the real waitpid tells us the child does not exist, we
4012 * fall through here to implement waiting for a child that
4013 * was created by some means other than exec() (say, spawned
4014 * from DCL) or to wait for a process that is not a subprocess
4015 * of the current process.
4016 */
4017
119586db 4018#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 4019
21bc9d50 4020 {
a0d0e21e 4021 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4022 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4023 unsigned long int pidcode = JPI$_PID, mypid;
4024 unsigned long int interval[2];
aeb5cf3c 4025 unsigned int jpi_iosb[2];
d85f548a 4026 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4027 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4028 { 0, 0, 0, 0}
4029 };
aeb5cf3c
CB		 4030
4031 if (pid <= 0) {
4032 /* Sorry folks, we don't presently implement rooting around for
4033 the first child we can find, and we definitely don't want to
4034 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4035 */
4036 set_errno(ENOTSUP);
4037 return -1;
4038 }
4039
d85f548a
JH		 4040 /* Get the owner of the child so I can warn if it's not mine. If the
4041 * process doesn't exist or I don't have the privs to look at it,
4042 * I can go home early.
aeb5cf3c
CB		 4043 */
4044 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4045 if (sts & 1) sts = jpi_iosb[0];
4046 if (!(sts & 1)) {
4047 switch (sts) {
4048 case SS$_NONEXPR:
4049 set_errno(ECHILD);
4050 break;
4051 case SS$_NOPRIV:
4052 set_errno(EACCES);
4053 break;
4054 default:
4055 _ckvmssts(sts);
4056 }
4057 set_vaxc_errno(sts);
4058 return -1;
4059 }
a0d0e21e 4060
3eeba6fb 4061 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4062 /* remind folks they are asking for non-standard waitpid behavior */
4063 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4064 if (ownerpid != mypid)
f98bc0c6 4065 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4066 "waitpid: process %x is not a child of process %x",
4067 pid,mypid);
748a9306 4068 }
a0d0e21e 4069
d85f548a
JH		 4070 /* simply check on it once a second until it's not there anymore. */
4071
4072 _ckvmssts(sys$bintim(&intdsc,interval));
4073 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4074 _ckvmssts(sys$schdwk(0,0,interval,0));
4075 _ckvmssts(sys$hiber());
d85f548a
JH		 4076 }
4077 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4078
4079 _ckvmssts(sts);
a0d0e21e 4080 return pid;
21bc9d50 4081 }
a0d0e21e 4082} /* end of waitpid() */
a0d0e21e
LW		 4083/*}}}*/
4084/*}}}*/
4085/*}}}*/
4086
4087/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4088char *
4089my_gconvert(double val, int ndig, int trail, char *buf)
4090{
4091 static char __gcvtbuf[DBL_DIG+1];
4092 char *loc;
4093
4094 loc = buf ? buf : __gcvtbuf;
71be2cbc 4095
4096#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4097 if (val < 1) {
4098 sprintf(loc,"%.*g",ndig,val);
4099 return loc;
4100 }
4101#endif
4102
a0d0e21e
LW		 4103 if (val) {
4104 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4105 return gcvt(val,ndig,loc);
4106 }
4107 else {
4108 loc[0] = '0'; loc[1] = '\0';
4109 return loc;
4110 }
4111
4112}
4113/*}}}*/
4114
988c775c 4115#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a480973c
JM		 4116static int rms_free_search_context(struct FAB * fab)
4117{
4118struct NAM * nam;
4119
4120 nam = fab->fab$l_nam;
4121 nam->nam$b_nop |= NAM$M_SYNCHK;
4122 nam->nam$l_rlf = NULL;
4123 fab->fab$b_dns = 0;
4124 return sys$parse(fab, NULL, NULL);
4125}
4126
4127#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4128#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4129#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4130#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4131#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4132#define rms_nam_esll(nam) nam.nam$b_esl
4133#define rms_nam_esl(nam) nam.nam$b_esl
4134#define rms_nam_name(nam) nam.nam$l_name
4135#define rms_nam_namel(nam) nam.nam$l_name
4136#define rms_nam_type(nam) nam.nam$l_type
4137#define rms_nam_typel(nam) nam.nam$l_type
4138#define rms_nam_ver(nam) nam.nam$l_ver
4139#define rms_nam_verl(nam) nam.nam$l_ver
4140#define rms_nam_rsll(nam) nam.nam$b_rsl
4141#define rms_nam_rsl(nam) nam.nam$b_rsl
4142#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4143#define rms_set_fna(fab, nam, name, size) \
a1887106 4144 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4145#define rms_get_fna(fab, nam) fab.fab$l_fna
4146#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4147 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4148#define rms_nam_dns(fab, nam) fab.fab$b_dns
a480973c 4149#define rms_set_esa(fab, nam, name, size) \
a1887106 4150 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4151#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4152 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4153#define rms_set_rsa(nam, name, size) \
a1887106 4154 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4155#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4156 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4157#define rms_nam_name_type_l_size(nam) \
4158 (nam.nam$b_name + nam.nam$b_type)
a480973c
JM		 4159#else
4160static int rms_free_search_context(struct FAB * fab)
4161{
4162struct NAML * nam;
4163
4164 nam = fab->fab$l_naml;
4165 nam->naml$b_nop |= NAM$M_SYNCHK;
4166 nam->naml$l_rlf = NULL;
4167 nam->naml$l_long_defname_size = 0;
988c775c 4168
a480973c
JM		 4169 fab->fab$b_dns = 0;
4170 return sys$parse(fab, NULL, NULL);
4171}
4172
4173#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4174#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4175#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4176#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4177#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4178#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4179#define rms_nam_esl(nam) nam.naml$b_esl
4180#define rms_nam_name(nam) nam.naml$l_name
4181#define rms_nam_namel(nam) nam.naml$l_long_name
4182#define rms_nam_type(nam) nam.naml$l_type
4183#define rms_nam_typel(nam) nam.naml$l_long_type
4184#define rms_nam_ver(nam) nam.naml$l_ver
4185#define rms_nam_verl(nam) nam.naml$l_long_ver
4186#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4187#define rms_nam_rsl(nam) nam.naml$b_rsl
4188#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4189#define rms_set_fna(fab, nam, name, size) \
a1887106 4190 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4191 nam.naml$l_long_filename_size = size; \
a1887106 4192 nam.naml$l_long_filename = name;}
a480973c
JM		 4193#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4194#define rms_set_dna(fab, nam, name, size) \
a1887106 4195 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4196 nam.naml$l_long_defname_size = size; \
a1887106 4197 nam.naml$l_long_defname = name; }
a480973c
JM		 4198#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4199#define rms_set_esa(fab, nam, name, size) \
a1887106 4200 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4201 nam.naml$l_long_expand_alloc = size; \
a1887106 4202 nam.naml$l_long_expand = name; }
a480973c 4203#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4204 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4205 nam.naml$l_long_expand = l_name; \
a1887106 4206 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4207#define rms_set_rsa(nam, name, size) \
a1887106 4208 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4209 nam.naml$l_long_result = name; \
a1887106 4210 nam.naml$l_long_result_alloc = size; }
a480973c 4211#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4212 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4213 nam.naml$l_long_result = l_name; \
a1887106
JM		 4214 nam.naml$l_long_result_alloc = l_size; }
4215#define rms_nam_name_type_l_size(nam) \
4216 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4217#endif
4218
bbce6d69 4219
4220/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4221/* Shortcut for common case of simple calls to $PARSE and $SEARCH
4222 * to expand file specification. Allows for a single default file
4223 * specification and a simple mask of options. If outbuf is non-NULL,
4224 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4225 * the resultant file specification is placed. If outbuf is NULL, the
4226 * resultant file specification is placed into a static buffer.
4227 * The third argument, if non-NULL, is taken to be a default file
4228 * specification string. The fourth argument is unused at present.
4229 * rmesexpand() returns the address of the resultant string if
4230 * successful, and NULL on error.
e886094b
JM		 4231 *
4232 * New functionality for previously unused opts value:
4233 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 4234 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4235 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
bbce6d69 4236 */
b8ffc8df 4237static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
96e4d5b1 4238
bbce6d69 4239static char *
2fbb330f 4240mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
bbce6d69 4241{
a1887106 4242 static char __rmsexpand_retbuf[VMS_MAXRSS];
18a3d61e
JM		 4243 char * vmsfspec, *tmpfspec;
4244 char * esa, *cp, *out = NULL;
c5375c28 4245 char * tbuf;
18a3d61e
JM		 4246 char * esal;
4247 char * outbufl;
4248 struct FAB myfab = cc$rms_fab;
a480973c 4249 rms_setup_nam(mynam);
18a3d61e
JM		 4250 STRLEN speclen;
4251 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4252 int sts;
4253
4254 if (!filespec || !*filespec) {
4255 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4256 return NULL;
4257 }
4258 if (!outbuf) {
4259 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4260 else outbuf = __rmsexpand_retbuf;
4261 }
4262
4263 vmsfspec = NULL;
4264 tmpfspec = NULL;
4265 outbufl = NULL;
a1887106
JM		 4266
4267 isunix = 0;
4268 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4269 isunix = is_unix_filespec(filespec);
4270 if (isunix) {
4271 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4272 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4273 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
c5375c28 4274 PerlMem_free(vmsfspec);
18a3d61e
JM		 4275 if (out)
4276 Safefree(out);
4277 return NULL;
a1887106
JM		 4278 }
4279 filespec = vmsfspec;
18a3d61e 4280
a1887106
JM		 4281 /* Unless we are forcing to VMS format, a UNIX input means
4282 * UNIX output, and that requires long names to be used
4283 */
4284 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
18a3d61e 4285 opts |= PERL_RMSEXPAND_M_LONG;
a1887106 4286 else {
18a3d61e 4287 isunix = 0;
a1887106 4288 }
18a3d61e
JM		 4289 }
4290 }
4291
a480973c
JM		 4292 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4293 rms_bind_fab_nam(myfab, mynam);
18a3d61e
JM		 4294
4295 if (defspec && *defspec) {
4296 int t_isunix;
4297 t_isunix = is_unix_filespec(defspec);
4298 if (t_isunix) {
c5375c28
JM		 4299 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4300 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
18a3d61e 4301 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
c5375c28 4302 PerlMem_free(tmpfspec);
18a3d61e 4303 if (vmsfspec != NULL)
c5375c28 4304 PerlMem_free(vmsfspec);
18a3d61e
JM		 4305 if (out)
4306 Safefree(out);
4307 return NULL;
4308 }
4309 defspec = tmpfspec;
4310 }
a480973c 4311 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
18a3d61e
JM		 4312 }
4313
c5375c28
JM		 4314 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4315 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 4316#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 4317 esal = PerlMem_malloc(VMS_MAXRSS);
c5375c28 4318 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 4319#endif
a1887106 4320 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e
JM		 4321
4322 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4323 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
18a3d61e
JM		 4324 }
4325 else {
a480973c 4326#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c5375c28
JM		 4327 outbufl = PerlMem_malloc(VMS_MAXRSS);
4328 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 4329 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4330#else
4331 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4332#endif
18a3d61e
JM		 4333 }
4334
f7ddb74a
JM		 4335#ifdef NAM$M_NO_SHORT_UPCASE
4336 if (decc_efs_case_preserve)
a480973c 4337 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4338#endif
18a3d61e
JM		 4339
4340 /* First attempt to parse as an existing file */
4341 retsts = sys$parse(&myfab,0,0);
4342 if (!(retsts & STS$K_SUCCESS)) {
4343
4344 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 4345 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
18a3d61e
JM		 4346 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4347 retsts = sys$parse(&myfab,0,0);
4348 if (retsts & STS$K_SUCCESS) goto expanded;
4349 }
4350
4351 /* Still could not parse the file specification */
4352 /*----------------------------------------------*/
a480973c 4353 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 4354 if (out) Safefree(out);
4355 if (tmpfspec != NULL)
c5375c28 4356 PerlMem_free(tmpfspec);
18a3d61e 4357 if (vmsfspec != NULL)
c5375c28
JM		 4358 PerlMem_free(vmsfspec);
4359 if (outbufl != NULL)
4360 PerlMem_free(outbufl);
4361 PerlMem_free(esa);
4362 PerlMem_free(esal);
18a3d61e
JM		 4363 set_vaxc_errno(retsts);
4364 if (retsts == RMS$_PRV) set_errno(EACCES);
4365 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4366 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4367 else set_errno(EVMSERR);
4368 return NULL;
4369 }
4370 retsts = sys$search(&myfab,0,0);
4371 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 4372 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 4373 if (out) Safefree(out);
4374 if (tmpfspec != NULL)
c5375c28 4375 PerlMem_free(tmpfspec);
18a3d61e 4376 if (vmsfspec != NULL)
c5375c28
JM		 4377 PerlMem_free(vmsfspec);
4378 if (outbufl != NULL)
4379 PerlMem_free(outbufl);
4380 PerlMem_free(esa);
4381 PerlMem_free(esal);
18a3d61e
JM		 4382 set_vaxc_errno(retsts);
4383 if (retsts == RMS$_PRV) set_errno(EACCES);
4384 else set_errno(EVMSERR);
4385 return NULL;
4386 }
4387
4388 /* If the input filespec contained any lowercase characters,
4389 * downcase the result for compatibility with Unix-minded code. */
4390 expanded:
4391 if (!decc_efs_case_preserve) {
c5375c28
JM		 4392 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4393 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 4394 }
4395
4396 /* Is a long or a short name expected */
4397 /*------------------------------------*/
4398 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4399 if (rms_nam_rsll(mynam)) {
c5375c28 4400 tbuf = outbuf;
a480973c 4401 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 4402 }
4403 else {
c5375c28 4404 tbuf = esal; /* Not esa */
a480973c 4405 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 4406 }
4407 }
4408 else {
a480973c 4409 if (rms_nam_rsl(mynam)) {
c5375c28 4410 tbuf = outbuf;
a480973c 4411 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 4412 }
4413 else {
c5375c28 4414 tbuf = esa; /* Not esal */
a480973c 4415 speclen = rms_nam_esl(mynam);
18a3d61e
JM		 4416 }
4417 }
4d743a9b
JM		 4418 tbuf[speclen] = '\0';
4419
18a3d61e
JM		 4420 /* Trim off null fields added by $PARSE
4421 * If type > 1 char, must have been specified in original or default spec
4422 * (not true for version; $SEARCH may have added version of existing file).
4423 */
a480973c 4424 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 4425 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 4426 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4427 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 4428 }
4429 else {
a480973c
JM		 4430 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4431 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 4432 }
4433 if (trimver || trimtype) {
4434 if (defspec && *defspec) {
4435 char *defesal = NULL;
c5375c28 4436 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
18a3d61e
JM		 4437 if (defesal != NULL) {
4438 struct FAB deffab = cc$rms_fab;
a480973c 4439 rms_setup_nam(defnam);
18a3d61e 4440
a480973c
JM		 4441 rms_bind_fab_nam(deffab, defnam);
4442
4443 /* Cast ok */
4444 rms_set_fna
4445 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4446
4447 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4448
4d743a9b 4449 rms_clear_nam_nop(defnam);
a480973c 4450 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 4451#ifdef NAM$M_NO_SHORT_UPCASE
4452 if (decc_efs_case_preserve)
a480973c 4453 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e
JM		 4454#endif
4455 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4456 if (trimver) {
a480973c 4457 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 4458 }
4459 if (trimtype) {
a480973c 4460 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 4461 }
4462 }
c5375c28 4463 PerlMem_free(defesal);
18a3d61e
JM		 4464 }
4465 }
4466 if (trimver) {
4467 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 4468 if (*(rms_nam_verl(mynam)) != '\"')
c5375c28 4469 speclen = rms_nam_verl(mynam) - tbuf;
18a3d61e
JM		 4470 }
4471 else {
a480973c 4472 if (*(rms_nam_ver(mynam)) != '\"')
c5375c28 4473 speclen = rms_nam_ver(mynam) - tbuf;
18a3d61e
JM		 4474 }
4475 }
4476 if (trimtype) {
4477 /* If we didn't already trim version, copy down */
4478 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
c5375c28 4479 if (speclen > rms_nam_verl(mynam) - tbuf)
18a3d61e 4480 memmove
a480973c
JM		 4481 (rms_nam_typel(mynam),
4482 rms_nam_verl(mynam),
c5375c28 4483 speclen - (rms_nam_verl(mynam) - tbuf));
a480973c 4484 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 4485 }
4486 else {
c5375c28 4487 if (speclen > rms_nam_ver(mynam) - tbuf)
18a3d61e 4488 memmove
a480973c
JM		 4489 (rms_nam_type(mynam),
4490 rms_nam_ver(mynam),
c5375c28 4491 speclen - (rms_nam_ver(mynam) - tbuf));
a480973c 4492 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 4493 }
4494 }
4495 }
4496
4497 /* Done with these copies of the input files */
4498 /*-------------------------------------------*/
4499 if (vmsfspec != NULL)
c5375c28 4500 PerlMem_free(vmsfspec);
18a3d61e 4501 if (tmpfspec != NULL)
c5375c28 4502 PerlMem_free(tmpfspec);
18a3d61e
JM		 4503
4504 /* If we just had a directory spec on input, $PARSE "helpfully"
4505 * adds an empty name and type for us */
4506 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 4507 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4508 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4509 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 4510 speclen = rms_nam_namel(mynam) - tbuf;
18a3d61e
JM		 4511 }
4512 else {
a480973c
JM		 4513 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4514 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4515 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 4516 speclen = rms_nam_name(mynam) - tbuf;
18a3d61e
JM		 4517 }
4518
4519 /* Posix format specifications must have matching quotes */
4d743a9b
JM		 4520 if (speclen < (VMS_MAXRSS - 1)) {
4521 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4522 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4523 tbuf[speclen] = '\"';
4524 speclen++;
4525 }
18a3d61e
JM		 4526 }
4527 }
c5375c28
JM		 4528 tbuf[speclen] = '\0';
4529 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
18a3d61e
JM		 4530
4531 /* Have we been working with an expanded, but not resultant, spec? */
4532 /* Also, convert back to Unix syntax if necessary. */
4533
a480973c 4534 if (!rms_nam_rsll(mynam)) {
18a3d61e
JM		 4535 if (isunix) {
4536 if (do_tounixspec(esa,outbuf,0) == NULL) {
c5375c28
JM		 4537 if (out) Safefree(out);
4538 PerlMem_free(esal);
4539 PerlMem_free(esa);
4540 if (outbufl != NULL)
4541 PerlMem_free(outbufl);
18a3d61e
JM		 4542 return NULL;
4543 }
4544 }
4545 else strcpy(outbuf,esa);
4546 }
4547 else if (isunix) {
c5375c28
JM		 4548 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4549 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
18a3d61e 4550 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
c5375c28
JM		 4551 if (out) Safefree(out);
4552 PerlMem_free(esa);
4553 PerlMem_free(esal);
4554 PerlMem_free(tmpfspec);
4555 if (outbufl != NULL)
4556 PerlMem_free(outbufl);
18a3d61e
JM		 4557 return NULL;
4558 }
4559 strcpy(outbuf,tmpfspec);
c5375c28 4560 PerlMem_free(tmpfspec);
18a3d61e
JM		 4561 }
4562
a480973c
JM		 4563 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4564 sts = rms_free_search_context(&myfab); /* Free search context */
c5375c28
JM		 4565 PerlMem_free(esa);
4566 PerlMem_free(esal);
4567 if (outbufl != NULL)
4568 PerlMem_free(outbufl);
bbce6d69 4569 return outbuf;
4570}
4571/*}}}*/
4572/* External entry points */
2fbb330f 4573char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 4574{ return do_rmsexpand(spec,buf,0,def,opt); }
2fbb330f 4575char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
bbce6d69 4576{ return do_rmsexpand(spec,buf,1,def,opt); }
4577
4578
a0d0e21e
LW		 4579/*
4580** The following routines are provided to make life easier when
4581** converting among VMS-style and Unix-style directory specifications.
4582** All will take input specifications in either VMS or Unix syntax. On
4583** failure, all return NULL. If successful, the routines listed below
748a9306 4584** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 4585** reformatted spec (and, therefore, subsequent calls to that routine
4586** will clobber the result), while the routines of the same names with
4587** a _ts suffix appended will return a pointer to a mallocd string
4588** containing the appropriately reformatted spec.
4589** In all cases, only explicit syntax is altered; no check is made that
4590** the resulting string is valid or that the directory in question
4591** actually exists.
4592**
4593** fileify_dirspec() - convert a directory spec into the name of the
4594** directory file (i.e. what you can stat() to see if it's a dir).
4595** The style (VMS or Unix) of the result is the same as the style
4596** of the parameter passed in.
4597** pathify_dirspec() - convert a directory spec into a path (i.e.
4598** what you prepend to a filename to indicate what directory it's in).
4599** The style (VMS or Unix) of the result is the same as the style
4600** of the parameter passed in.
4601** tounixpath() - convert a directory spec into a Unix-style path.
4602** tovmspath() - convert a directory spec into a VMS-style path.
4603** tounixspec() - convert any file spec into a Unix-style file spec.
4604** tovmsspec() - convert any file spec into a VMS-style spec.
e518068a 4605**
bd3fa61c 4606** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 4607** Permission is given to distribute this code as part of the Perl
4608** standard distribution under the terms of the GNU General Public
4609** License or the Perl Artistic License. Copies of each may be
4610** found in the Perl standard distribution.
a0d0e21e
LW		 4611 */
4612
a480973c 4613/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
b8ffc8df 4614static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
a0d0e21e 4615{
a480973c 4616 static char __fileify_retbuf[VMS_MAXRSS];
b7ae7a0d 4617 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 4618 char *retspec, *cp1, *cp2, *lastdir;
a480973c 4619 char *trndir, *vmsdir;
2d9f3838 4620 unsigned short int trnlnm_iter_count;
f7ddb74a 4621 int sts;
a0d0e21e 4622
c07a80fd 4623 if (!dir || !*dir) {
4624 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4625 }
a0d0e21e 4626 dirlen = strlen(dir);
a2a90019 4627 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 4628 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 4629 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4630 dir = "/sys$disk";
4631 dirlen = 9;
4632 }
4633 else
4634 dirlen = 1;
61bb5906 4635 }
a480973c
JM		 4636 if (dirlen > (VMS_MAXRSS - 1)) {
4637 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4638 return NULL;
c07a80fd 4639 }
c5375c28
JM		 4640 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4641 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 4642 if (!strpbrk(dir+1,"/]>:") &&
4643 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 4644 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838
CB		 4645 trnlnm_iter_count = 0;
4646 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4647 trnlnm_iter_count++;
4648 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4649 }
b8ffc8df 4650 dirlen = strlen(trndir);
e518068a 4651 }
01b8edb6 4652 else {
4653 strncpy(trndir,dir,dirlen);
4654 trndir[dirlen] = '\0';
01b8edb6 4655 }
b8ffc8df
RGS		 4656
4657 /* At this point we are done with *dir and use *trndir which is a
4658 * copy that can be modified. *dir must not be modified.
4659 */
4660
c07a80fd 4661 /* If we were handed a rooted logical name or spec, treat it like a
4662 * simple directory, so that
4663 * $ Define myroot dev:[dir.]
4664 * ... do_fileify_dirspec("myroot",buf,1) ...
4665 * does something useful.
4666 */
b8ffc8df
RGS		 4667 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4668 trndir[--dirlen] = '\0';
4669 trndir[dirlen-1] = ']';
c07a80fd 4670 }
b8ffc8df
RGS		 4671 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4672 trndir[--dirlen] = '\0';
4673 trndir[dirlen-1] = '>';
46112e17 4674 }
e518068a 4675
b8ffc8df 4676 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 4677 /* If we've got an explicit filename, we can just shuffle the string. */
4678 if (*(cp1+1)) hasfilename = 1;
4679 /* Similarly, we can just back up a level if we've got multiple levels
4680 of explicit directories in a VMS spec which ends with directories. */
4681 else {
b8ffc8df 4682 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 4683 if (*cp2 == '.') {
4684 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 4685/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 4686 *cp2 = *cp1; *cp1 = '\0';
4687 hasfilename = 1;
4688 break;
4689 }
b7ae7a0d 4690 }
4691 if (*cp2 == '[' || *cp2 == '<') break;
4692 }
4693 }
4694 }
4695
c5375c28
JM		 4696 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4697 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 4698 cp1 = strpbrk(trndir,"]:>");
f7ddb74a 4699 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df 4700 if (trndir[0] == '.') {
a480973c 4701 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 4702 PerlMem_free(trndir);
4703 PerlMem_free(vmsdir);
748a9306 4704 return do_fileify_dirspec("[]",buf,ts);
a480973c 4705 }
b8ffc8df 4706 else if (trndir[1] == '.' &&
a480973c 4707 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 4708 PerlMem_free(trndir);
4709 PerlMem_free(vmsdir);
748a9306 4710 return do_fileify_dirspec("[-]",buf,ts);
a480973c 4711 }
748a9306 4712 }
b8ffc8df 4713 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 4714 dirlen -= 1; /* to last element */
b8ffc8df 4715 lastdir = strrchr(trndir,'/');
a0d0e21e 4716 }
b8ffc8df 4717 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 4718 /* If we have "/." or "/..", VMSify it and let the VMS code
4719 * below expand it, rather than repeating the code to handle
4720 * relative components of a filespec here */
4633a7c4
LW		 4721 do {
4722 if (*(cp1+2) == '.') cp1++;
4723 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c
JM		 4724 char * ret_chr;
4725 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
c5375c28
JM		 4726 PerlMem_free(trndir);
4727 PerlMem_free(vmsdir);
a480973c
JM		 4728 return NULL;
4729 }
fc1ce8cc
CB		 4730 if (strchr(vmsdir,'/') != NULL) {
4731 /* If do_tovmsspec() returned it, it must have VMS syntax
4732 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4733 * the time to check this here only so we avoid a recursion
4734 * loop; otherwise, gigo.
4735 */
c5375c28
JM		 4736 PerlMem_free(trndir);
4737 PerlMem_free(vmsdir);
a480973c
JM		 4738 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4739 return NULL;
fc1ce8cc 4740 }
a480973c 4741 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
c5375c28
JM		 4742 PerlMem_free(trndir);
4743 PerlMem_free(vmsdir);
a480973c
JM		 4744 return NULL;
4745 }
4746 ret_chr = do_tounixspec(trndir,buf,ts);
c5375c28
JM		 4747 PerlMem_free(trndir);
4748 PerlMem_free(vmsdir);
a480973c 4749 return ret_chr;
4633a7c4
LW		 4750 }
4751 cp1++;
4752 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 4753 lastdir = strrchr(trndir,'/');
748a9306 4754 }
b8ffc8df 4755 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 4756 char * ret_chr;
61bb5906
CB		 4757 /* Ditto for specs that end in an MFD -- let the VMS code
4758 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 4759
4760 /* This should not happen any more. Allowing the fake /000000
4761 * in a UNIX pathname causes all sorts of problems when trying
4762 * to run in UNIX emulation. So the VMS to UNIX conversions
4763 * now remove the fake /000000 directories.
4764 */
4765
b8ffc8df 4766 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
a480973c 4767 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
c5375c28
JM		 4768 PerlMem_free(trndir);
4769 PerlMem_free(vmsdir);
a480973c
JM		 4770 return NULL;
4771 }
4772 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
c5375c28
JM		 4773 PerlMem_free(trndir);
4774 PerlMem_free(vmsdir);
a480973c
JM		 4775 return NULL;
4776 }
4777 ret_chr = do_tounixspec(trndir,buf,ts);
c5375c28
JM		 4778 PerlMem_free(trndir);
4779 PerlMem_free(vmsdir);
a480973c 4780 return ret_chr;
61bb5906 4781 }
a0d0e21e 4782 else {
f7ddb74a 4783
b8ffc8df
RGS		 4784 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4785 !(lastdir = cp1 = strrchr(trndir,']')) &&
4786 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 4787 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 4788 int ver; char *cp3;
f7ddb74a
JM		 4789
4790 /* For EFS or ODS-5 look for the last dot */
4791 if (decc_efs_charset) {
4792 cp2 = strrchr(cp1,'.');
4793 }
4794 if (vms_process_case_tolerant) {
4795 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4796 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4797 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4798 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4799 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 4800 (ver || *cp3)))))) {
c5375c28
JM		 4801 PerlMem_free(trndir);
4802 PerlMem_free(vmsdir);
f7ddb74a
JM		 4803 set_errno(ENOTDIR);
4804 set_vaxc_errno(RMS$_DIR);
4805 return NULL;
4806 }
4807 }
4808 else {
4809 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4810 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4811 !*(cp2+3) || *(cp2+3) != 'R' ||
4812 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4813 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4814 (ver || *cp3)))))) {
c5375c28
JM		 4815 PerlMem_free(trndir);
4816 PerlMem_free(vmsdir);
f7ddb74a
JM		 4817 set_errno(ENOTDIR);
4818 set_vaxc_errno(RMS$_DIR);
4819 return NULL;
4820 }
a0d0e21e 4821 }
b8ffc8df 4822 dirlen = cp2 - trndir;
a0d0e21e 4823 }
748a9306 4824 }
f7ddb74a
JM		 4825
4826 retlen = dirlen + 6;
748a9306 4827 if (buf) retspec = buf;
a02a5408 4828 else if (ts) Newx(retspec,retlen+1,char);
748a9306 4829 else retspec = __fileify_retbuf;
f7ddb74a
JM		 4830 memcpy(retspec,trndir,dirlen);
4831 retspec[dirlen] = '\0';
4832
a0d0e21e
LW		 4833 /* We've picked up everything up to the directory file name.
4834 Now just add the type and version, and we're set. */
f7ddb74a
JM		 4835 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4836 strcat(retspec,".dir;1");
4837 else
4838 strcat(retspec,".DIR;1");
c5375c28
JM		 4839 PerlMem_free(trndir);
4840 PerlMem_free(vmsdir);
a0d0e21e
LW		 4841 return retspec;
4842 }
4843 else { /* VMS-style directory spec */
a480973c
JM		 4844
4845 char *esa, term, *cp;
01b8edb6 4846 unsigned long int sts, cmplen, haslower = 0;
a480973c
JM		 4847 unsigned int nam_fnb;
4848 char * nam_type;
a0d0e21e 4849 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 4850 rms_setup_nam(savnam);
4851 rms_setup_nam(dirnam);
4852
c5375c28
JM		 4853 esa = PerlMem_malloc(VMS_MAXRSS + 1);
4854 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 4855 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4856 rms_bind_fab_nam(dirfab, dirnam);
4857 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4858 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
f7ddb74a
JM		 4859#ifdef NAM$M_NO_SHORT_UPCASE
4860 if (decc_efs_case_preserve)
a480973c 4861 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4862#endif
01b8edb6 4863
b8ffc8df 4864 for (cp = trndir; *cp; cp++)
01b8edb6 4865 if (islower(*cp)) { haslower = 1; break; }
a480973c 4866 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
f7ddb74a 4867 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 4868 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4869 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 4870 }
4871 if (!sts) {
c5375c28
JM		 4872 PerlMem_free(esa);
4873 PerlMem_free(trndir);
4874 PerlMem_free(vmsdir);
748a9306
LW		 4875 set_errno(EVMSERR);
4876 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 4877 return NULL;
4878 }
e518068a 4879 }
4880 else {
4881 savnam = dirnam;
a480973c
JM		 4882 /* Does the file really exist? */
4883 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 4884 /* Yes; fake the fnb bits so we'll check type below */
a480973c 4885 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 4886 }
752635ea
CB		 4887 else { /* No; just work with potential name */
4888 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4889 else {
2623a4a6
JM		 4890 int fab_sts;
4891 fab_sts = dirfab.fab$l_sts;
4892 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 4893 PerlMem_free(esa);
4894 PerlMem_free(trndir);
4895 PerlMem_free(vmsdir);
2623a4a6 4896 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 4897 return NULL;
4898 }
e518068a 4899 }
a0d0e21e 4900 }
a480973c 4901 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
748a9306
LW		 4902 cp1 = strchr(esa,']');
4903 if (!cp1) cp1 = strchr(esa,'>');
4904 if (cp1) { /* Should always be true */
a480973c
JM		 4905 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4906 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
748a9306
LW		 4907 }
4908 }
a480973c 4909 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 4910 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 4911 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4912 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 4913 /* Something other than .DIR[;1]. Bzzt. */
a480973c 4914 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 4915 PerlMem_free(esa);
4916 PerlMem_free(trndir);
4917 PerlMem_free(vmsdir);
748a9306
LW		 4918 set_errno(ENOTDIR);
4919 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 4920 return NULL;
4921 }
748a9306 4922 }
a480973c
JM		 4923 esa[rms_nam_esll(dirnam)] = '\0';
4924 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306
LW		 4925 /* They provided at least the name; we added the type, if necessary, */
4926 if (buf) retspec = buf; /* in sys$parse() */
a480973c 4927 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
748a9306
LW		 4928 else retspec = __fileify_retbuf;
4929 strcpy(retspec,esa);
a480973c 4930 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 4931 PerlMem_free(trndir);
4932 PerlMem_free(esa);
4933 PerlMem_free(vmsdir);
748a9306
LW		 4934 return retspec;
4935 }
c07a80fd 4936 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4937 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4938 *cp1 = '\0';
a480973c 4939 rms_nam_esll(dirnam) -= 9;
c07a80fd 4940 }
748a9306 4941 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
752635ea 4942 if (cp1 == NULL) { /* should never happen */
a480973c 4943 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 4944 PerlMem_free(trndir);
4945 PerlMem_free(esa);
4946 PerlMem_free(vmsdir);
752635ea
CB		 4947 return NULL;
4948 }
748a9306
LW		 4949 term = *cp1;
4950 *cp1 = '\0';
4951 retlen = strlen(esa);
f7ddb74a
JM		 4952 cp1 = strrchr(esa,'.');
4953 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 4954 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a
JM		 4955 while (cp1 != NULL) {
4956 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4957 break;
4958 else {
4959 cp1--;
4960 while ((cp1 > esa) && (*cp1 != '.'))
4961 cp1--;
4962 }
4963 if (cp1 == esa)
4964 cp1 = NULL;
4965 }
4966
4967 if ((cp1) != NULL) {
748a9306
LW		 4968 /* There's more than one directory in the path. Just roll back. */
4969 *cp1 = term;
4970 if (buf) retspec = buf;
a02a5408 4971 else if (ts) Newx(retspec,retlen+7,char);
748a9306
LW		 4972 else retspec = __fileify_retbuf;
4973 strcpy(retspec,esa);
a0d0e21e
LW		 4974 }
4975 else {
a480973c 4976 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 4977 /* Go back and expand rooted logical name */
a480973c 4978 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 4979#ifdef NAM$M_NO_SHORT_UPCASE
4980 if (decc_efs_case_preserve)
a480973c 4981 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 4982#endif
a480973c
JM		 4983 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4984 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 4985 PerlMem_free(esa);
4986 PerlMem_free(trndir);
4987 PerlMem_free(vmsdir);
748a9306
LW		 4988 set_errno(EVMSERR);
4989 set_vaxc_errno(dirfab.fab$l_sts);
4990 return NULL;
4991 }
a480973c 4992 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 4993 if (buf) retspec = buf;
a02a5408 4994 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 4995 else retspec = __fileify_retbuf;
748a9306 4996 cp1 = strstr(esa,"][");
46112e17 4997 if (!cp1) cp1 = strstr(esa,"]<");
748a9306
LW		 4998 dirlen = cp1 - esa;
4999 memcpy(retspec,esa,dirlen);
5000 if (!strncmp(cp1+2,"000000]",7)) {
5001 retspec[dirlen-1] = '\0';
657054d4 5002 /* fix-me Not full ODS-5, just extra dots in directories for now */
f7ddb74a
JM		 5003 cp1 = retspec + dirlen - 1;
5004 while (cp1 > retspec)
5005 {
5006 if (*cp1 == '[')
5007 break;
5008 if (*cp1 == '.') {
5009 if (*(cp1-1) != '^')
5010 break;
5011 }
5012 cp1--;
5013 }
4633a7c4
LW		 5014 if (*cp1 == '.') *cp1 = ']';
5015 else {
5016 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 5017 memmove(cp1+1,"000000]",7);
4633a7c4 5018 }
748a9306
LW		 5019 }
5020 else {
18a3d61e 5021 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
748a9306
LW		 5022 retspec[retlen] = '\0';
5023 /* Convert last '.' to ']' */
f7ddb74a
JM		 5024 cp1 = retspec+retlen-1;
5025 while (*cp != '[') {
5026 cp1--;
5027 if (*cp1 == '.') {
5028 /* Do not trip on extra dots in ODS-5 directories */
5029 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5030 break;
5031 }
5032 }
4633a7c4
LW		 5033 if (*cp1 == '.') *cp1 = ']';
5034 else {
5035 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 5036 memmove(cp1+1,"000000]",7);
4633a7c4 5037 }
748a9306 5038 }
a0d0e21e 5039 }
748a9306 5040 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 5041 if (buf) retspec = buf;
a02a5408 5042 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e
LW		 5043 else retspec = __fileify_retbuf;
5044 cp1 = esa;
5045 cp2 = retspec;
bbdb6c9a 5046 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 5047 strcpy(cp2,":[000000]");
5048 cp1 += 2;
5049 strcpy(cp2+9,cp1);
5050 }
748a9306 5051 }
a480973c 5052 sts = rms_free_search_context(&dirfab);
748a9306 5053 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 5054 type and version, and we're done. */
5055 strcat(retspec,".DIR;1");
01b8edb6 5056
5057 /* $PARSE may have upcased filespec, so convert output to lower
5058 * case if input contained any lowercase characters. */
f7ddb74a 5059 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
c5375c28
JM		 5060 PerlMem_free(trndir);
5061 PerlMem_free(esa);
5062 PerlMem_free(vmsdir);
a0d0e21e
LW		 5063 return retspec;
5064 }
5065} /* end of do_fileify_dirspec() */
5066/*}}}*/
5067/* External entry points */
b8ffc8df 5068char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
a0d0e21e 5069{ return do_fileify_dirspec(dir,buf,0); }
b8ffc8df 5070char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
a0d0e21e
LW		 5071{ return do_fileify_dirspec(dir,buf,1); }
5072
5073/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
b8ffc8df 5074static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
a0d0e21e 5075{
a480973c 5076 static char __pathify_retbuf[VMS_MAXRSS];
a0d0e21e 5077 unsigned long int retlen;
a480973c 5078 char *retpath, *cp1, *cp2, *trndir;
2d9f3838 5079 unsigned short int trnlnm_iter_count;
baf3cf9c 5080 STRLEN trnlen;
f7ddb74a 5081 int sts;
a0d0e21e 5082
c07a80fd 5083 if (!dir || !*dir) {
5084 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5085 }
5086
c5375c28
JM		 5087 trndir = PerlMem_malloc(VMS_MAXRSS);
5088 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 5089 if (*dir) strcpy(trndir,dir);
a480973c 5090 else getcwd(trndir,VMS_MAXRSS - 1);
c07a80fd 5091
2d9f3838 5092 trnlnm_iter_count = 0;
93948341
CB		 5093 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5094 && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 5095 trnlnm_iter_count++;
5096 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
baf3cf9c 5097 trnlen = strlen(trndir);
a0d0e21e 5098
c07a80fd 5099 /* Trap simple rooted lnms, and return lnm:[000000] */
5100 if (!strcmp(trndir+trnlen-2,".]")) {
5101 if (buf) retpath = buf;
a02a5408 5102 else if (ts) Newx(retpath,strlen(dir)+10,char);
c07a80fd 5103 else retpath = __pathify_retbuf;
5104 strcpy(retpath,dir);
5105 strcat(retpath,":[000000]");
c5375c28 5106 PerlMem_free(trndir);
c07a80fd 5107 return retpath;
5108 }
5109 }
748a9306 5110
b8ffc8df
RGS		 5111 /* At this point we do not work with *dir, but the copy in
5112 * *trndir that is modifiable.
5113 */
5114
5115 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5116 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5117 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5118 retlen = 2 + (*(trndir+1) != '\0');
748a9306 5119 else {
b8ffc8df
RGS		 5120 if ( !(cp1 = strrchr(trndir,'/')) &&
5121 !(cp1 = strrchr(trndir,']')) &&
5122 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
f86702cc 5123 if ((cp2 = strchr(cp1,'.')) != NULL &&
5124 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5125 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5126 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5127 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 5128 int ver; char *cp3;
f7ddb74a
JM		 5129
5130 /* For EFS or ODS-5 look for the last dot */
5131 if (decc_efs_charset) {
5132 cp2 = strrchr(cp1,'.');
5133 }
5134 if (vms_process_case_tolerant) {
5135 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5136 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5137 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5138 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5139 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 5140 (ver || *cp3)))))) {
c5375c28 5141 PerlMem_free(trndir);
f7ddb74a
JM		 5142 set_errno(ENOTDIR);
5143 set_vaxc_errno(RMS$_DIR);
5144 return NULL;
5145 }
5146 }
5147 else {
5148 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5149 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5150 !*(cp2+3) || *(cp2+3) != 'R' ||
5151 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5152 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5153 (ver || *cp3)))))) {
c5375c28 5154 PerlMem_free(trndir);
f7ddb74a
JM		 5155 set_errno(ENOTDIR);
5156 set_vaxc_errno(RMS$_DIR);
5157 return NULL;
5158 }
5159 }
b8ffc8df 5160 retlen = cp2 - trndir + 1;
a0d0e21e 5161 }
748a9306 5162 else { /* No file type present. Treat the filename as a directory. */
b8ffc8df 5163 retlen = strlen(trndir) + 1;
a0d0e21e
LW		 5164 }
5165 }
a0d0e21e 5166 if (buf) retpath = buf;
a02a5408 5167 else if (ts) Newx(retpath,retlen+1,char);
a0d0e21e 5168 else retpath = __pathify_retbuf;
b8ffc8df 5169 strncpy(retpath, trndir, retlen-1);
a0d0e21e
LW		 5170 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5171 retpath[retlen-1] = '/'; /* with '/', add it. */
5172 retpath[retlen] = '\0';
5173 }
5174 else retpath[retlen-1] = '\0';
5175 }
5176 else { /* VMS-style directory spec */
a480973c 5177 char *esa, *cp;
01b8edb6 5178 unsigned long int sts, cmplen, haslower;
a0d0e21e 5179 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 5180 int dirlen;
5181 rms_setup_nam(savnam);
5182 rms_setup_nam(dirnam);
a0d0e21e 5183
b7ae7a0d 5184 /* If we've got an explicit filename, we can just shuffle the string. */
b8ffc8df
RGS		 5185 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5186 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
b7ae7a0d 5187 if ((cp2 = strchr(cp1,'.')) != NULL) {
5188 int ver; char *cp3;
f7ddb74a
JM		 5189 if (vms_process_case_tolerant) {
5190 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5191 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5192 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5193 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5194 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 5195 (ver || *cp3)))))) {
c5375c28 5196 PerlMem_free(trndir);
f7ddb74a
JM		 5197 set_errno(ENOTDIR);
5198 set_vaxc_errno(RMS$_DIR);
5199 return NULL;
5200 }
5201 }
5202 else {
5203 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5204 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5205 !*(cp2+3) || *(cp2+3) != 'R' ||
5206 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5207 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5208 (ver || *cp3)))))) {
c5375c28 5209 PerlMem_free(trndir);
f7ddb74a
JM		 5210 set_errno(ENOTDIR);
5211 set_vaxc_errno(RMS$_DIR);
5212 return NULL;
5213 }
5214 }
b7ae7a0d 5215 }
5216 else { /* No file type, so just draw name into directory part */
5217 for (cp2 = cp1; *cp2; cp2++) ;
5218 }
5219 *cp2 = *cp1;
5220 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5221 *cp1 = '.';
5222 /* We've now got a VMS 'path'; fall through */
5223 }
a480973c
JM		 5224
5225 dirlen = strlen(trndir);
5226 if (trndir[dirlen-1] == ']' ||
5227 trndir[dirlen-1] == '>' ||
5228 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
748a9306 5229 if (buf) retpath = buf;
f7ddb74a 5230 else if (ts) Newx(retpath,strlen(trndir)+1,char);
748a9306 5231 else retpath = __pathify_retbuf;
b8ffc8df 5232 strcpy(retpath,trndir);
c5375c28 5233 PerlMem_free(trndir);
748a9306 5234 return retpath;
a480973c
JM		 5235 }
5236 rms_set_fna(dirfab, dirnam, trndir, dirlen);
c5375c28
JM		 5237 esa = PerlMem_malloc(VMS_MAXRSS);
5238 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 5239 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5240 rms_bind_fab_nam(dirfab, dirnam);
5241 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
f7ddb74a
JM		 5242#ifdef NAM$M_NO_SHORT_UPCASE
5243 if (decc_efs_case_preserve)
a480973c 5244 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5245#endif
01b8edb6 5246
b8ffc8df 5247 for (cp = trndir; *cp; cp++)
01b8edb6 5248 if (islower(*cp)) { haslower = 1; break; }
5249
a480973c 5250 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
f7ddb74a 5251 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 5252 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5253 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 5254 }
5255 if (!sts) {
c5375c28
JM		 5256 PerlMem_free(trndir);
5257 PerlMem_free(esa);
748a9306
LW		 5258 set_errno(EVMSERR);
5259 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 5260 return NULL;
5261 }
a0d0e21e 5262 }
e518068a 5263 else {
5264 savnam = dirnam;
a480973c
JM		 5265 /* Does the file really exist? */
5266 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
e518068a 5267 if (dirfab.fab$l_sts != RMS$_FNF) {
f7ddb74a 5268 int sts1;
a480973c 5269 sts1 = rms_free_search_context(&dirfab);
c5375c28
JM		 5270 PerlMem_free(trndir);
5271 PerlMem_free(esa);
e518068a 5272 set_errno(EVMSERR);
5273 set_vaxc_errno(dirfab.fab$l_sts);
5274 return NULL;
5275 }
5276 dirnam = savnam; /* No; just work with potential name */
5277 }
5278 }
a480973c 5279 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 5280 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 5281 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5282 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
f7ddb74a 5283 int sts2;
a0d0e21e 5284 /* Something other than .DIR[;1]. Bzzt. */
a480973c 5285 sts2 = rms_free_search_context(&dirfab);
c5375c28
JM		 5286 PerlMem_free(trndir);
5287 PerlMem_free(esa);
748a9306
LW		 5288 set_errno(ENOTDIR);
5289 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 5290 return NULL;
5291 }
a0d0e21e 5292 }
748a9306
LW		 5293 /* OK, the type was fine. Now pull any file name into the
5294 directory path. */
a480973c 5295 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
a0d0e21e 5296 else {
748a9306 5297 cp1 = strrchr(esa,'>');
a480973c 5298 *(rms_nam_typel(dirnam)) = '>';
a0d0e21e 5299 }
748a9306 5300 *cp1 = '.';
a480973c
JM		 5301 *(rms_nam_typel(dirnam) + 1) = '\0';
5302 retlen = (rms_nam_typel(dirnam)) - esa + 2;
a0d0e21e 5303 if (buf) retpath = buf;
a02a5408 5304 else if (ts) Newx(retpath,retlen,char);
a0d0e21e
LW		 5305 else retpath = __pathify_retbuf;
5306 strcpy(retpath,esa);
c5375c28 5307 PerlMem_free(esa);
a480973c 5308 sts = rms_free_search_context(&dirfab);
01b8edb6 5309 /* $PARSE may have upcased filespec, so convert output to lower
5310 * case if input contained any lowercase characters. */
f7ddb74a 5311 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
a0d0e21e
LW		 5312 }
5313
c5375c28 5314 PerlMem_free(trndir);
a0d0e21e
LW		 5315 return retpath;
5316} /* end of do_pathify_dirspec() */
5317/*}}}*/
5318/* External entry points */
b8ffc8df 5319char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
a0d0e21e 5320{ return do_pathify_dirspec(dir,buf,0); }
b8ffc8df 5321char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
a0d0e21e
LW		 5322{ return do_pathify_dirspec(dir,buf,1); }
5323
2497a41f 5324/*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
b8ffc8df 5325static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
a0d0e21e 5326{
a480973c 5327 static char __tounixspec_retbuf[VMS_MAXRSS];
2f4077ca 5328 char *dirend, *rslt, *cp1, *cp3, *tmp;
b8ffc8df 5329 const char *cp2;
a480973c 5330 int devlen, dirlen, retlen = VMS_MAXRSS;
0f20d7df 5331 int expand = 1; /* guarantee room for leading and trailing slashes */
2d9f3838 5332 unsigned short int trnlnm_iter_count;
f7ddb74a 5333 int cmp_rslt;
a0d0e21e 5334
748a9306 5335 if (spec == NULL) return NULL;
4d743a9b 5336 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
a0d0e21e 5337 if (buf) rslt = buf;
e518068a 5338 else if (ts) {
4d743a9b 5339 Newx(rslt, VMS_MAXRSS, char);
e518068a 5340 }
a0d0e21e 5341 else rslt = __tounixspec_retbuf;
f7ddb74a 5342
2497a41f
JM		 5343 /* New VMS specific format needs translation
5344 * glob passes filenames with trailing '\n' and expects this preserved.
5345 */
5346 if (decc_posix_compliant_pathnames) {
5347 if (strncmp(spec, "\"^UP^", 5) == 0) {
5348 char * uspec;
5349 char *tunix;
5350 int tunix_len;
5351 int nl_flag;
5352
c5375c28
JM		 5353 tunix = PerlMem_malloc(VMS_MAXRSS);
5354 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
2497a41f
JM		 5355 strcpy(tunix, spec);
5356 tunix_len = strlen(tunix);
5357 nl_flag = 0;
5358 if (tunix[tunix_len - 1] == '\n') {
5359 tunix[tunix_len - 1] = '\"';
5360 tunix[tunix_len] = '\0';
5361 tunix_len--;
5362 nl_flag = 1;
5363 }
5364 uspec = decc$translate_vms(tunix);
367e4b85 5365 PerlMem_free(tunix);
2497a41f
JM		 5366 if ((int)uspec > 0) {
5367 strcpy(rslt,uspec);
5368 if (nl_flag) {
5369 strcat(rslt,"\n");
5370 }
5371 else {
5372 /* If we can not translate it, makemaker wants as-is */
5373 strcpy(rslt, spec);
5374 }
5375 return rslt;
5376 }
5377 }
5378 }
5379
f7ddb74a
JM		 5380 cmp_rslt = 0; /* Presume VMS */
5381 cp1 = strchr(spec, '/');
5382 if (cp1 == NULL)
5383 cmp_rslt = 0;
5384
5385 /* Look for EFS ^/ */
5386 if (decc_efs_charset) {
5387 while (cp1 != NULL) {
5388 cp2 = cp1 - 1;
5389 if (*cp2 != '^') {
5390 /* Found illegal VMS, assume UNIX */
5391 cmp_rslt = 1;
5392 break;
5393 }
5394 cp1++;
5395 cp1 = strchr(cp1, '/');
5396 }
5397 }
5398
5399 /* Look for "." and ".." */
5400 if (decc_filename_unix_report) {
5401 if (spec[0] == '.') {
5402 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5403 cmp_rslt = 1;
5404 }
5405 else {
5406 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5407 cmp_rslt = 1;
5408 }
5409 }
5410 }
5411 }
5412 /* This is already UNIX or at least nothing VMS understands */
5413 if (cmp_rslt) {
a0d0e21e
LW		 5414 strcpy(rslt,spec);
5415 return rslt;
5416 }
5417
5418 cp1 = rslt;
5419 cp2 = spec;
5420 dirend = strrchr(spec,']');
5421 if (dirend == NULL) dirend = strrchr(spec,'>');
5422 if (dirend == NULL) dirend = strchr(spec,':');
5423 if (dirend == NULL) {
5424 strcpy(rslt,spec);
5425 return rslt;
5426 }
f7ddb74a
JM		 5427
5428 /* Special case 1 - sys$posix_root = / */
5429#if __CRTL_VER >= 70000000
5430 if (!decc_disable_posix_root) {
5431 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5432 *cp1 = '/';
5433 cp1++;
5434 cp2 = cp2 + 15;
5435 }
5436 }
5437#endif
5438
5439 /* Special case 2 - Convert NLA0: to /dev/null */
5440#if __CRTL_VER < 70000000
5441 cmp_rslt = strncmp(spec,"NLA0:", 5);
5442 if (cmp_rslt != 0)
5443 cmp_rslt = strncmp(spec,"nla0:", 5);
5444#else
5445 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5446#endif
5447 if (cmp_rslt == 0) {
5448 strcpy(rslt, "/dev/null");
5449 cp1 = cp1 + 9;
5450 cp2 = cp2 + 5;
5451 if (spec[6] != '\0') {
5452 cp1[9] == '/';
5453 cp1++;
5454 cp2++;
5455 }
5456 }
5457
5458 /* Also handle special case "SYS$SCRATCH:" */
5459#if __CRTL_VER < 70000000
5460 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5461 if (cmp_rslt != 0)
5462 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5463#else
5464 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5465#endif
c5375c28
JM		 5466 tmp = PerlMem_malloc(VMS_MAXRSS);
5467 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 5468 if (cmp_rslt == 0) {
5469 int islnm;
5470
5471 islnm = my_trnlnm(tmp, "TMP", 0);
5472 if (!islnm) {
5473 strcpy(rslt, "/tmp");
5474 cp1 = cp1 + 4;
5475 cp2 = cp2 + 12;
5476 if (spec[12] != '\0') {
5477 cp1[4] == '/';
5478 cp1++;
5479 cp2++;
5480 }
5481 }
5482 }
5483
a5f75d66 5484 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 5485 *(cp1++) = '/';
5486 }
5487 else { /* the VMS spec begins with directories */
5488 cp2++;
a5f75d66 5489 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 5490 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
367e4b85 5491 PerlMem_free(tmp);
a5f75d66
AD		 5492 return rslt;
5493 }
f7ddb74a 5494 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 5495 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
a0d0e21e 5496 if (ts) Safefree(rslt);
367e4b85 5497 PerlMem_free(tmp);
a0d0e21e
LW		 5498 return NULL;
5499 }
2d9f3838 5500 trnlnm_iter_count = 0;
a0d0e21e
LW		 5501 do {
5502 cp3 = tmp;
5503 while (*cp3 != ':' && *cp3) cp3++;
5504 *(cp3++) = '\0';
5505 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 5506 trnlnm_iter_count++;
5507 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 5508 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 5509 if (ts && !buf &&
e518068a 5510 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 5511 retlen = devlen + dirlen;
f86702cc 5512 Renew(rslt,retlen+1+2*expand,char);
5513 cp1 = rslt;
5514 }
5515 cp3 = tmp;
5516 *(cp1++) = '/';
5517 while (*cp3) {
5518 *(cp1++) = *(cp3++);
2f4077ca 5519 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
367e4b85 5520 PerlMem_free(tmp);
2f4077ca
JM		 5521 return NULL; /* No room */
5522 }
a0d0e21e 5523 }
f86702cc 5524 *(cp1++) = '/';
5525 }
f7ddb74a
JM		 5526 if ((*cp2 == '^')) {
5527 /* EFS file escape, pass the next character as is */
5528 /* Fix me: HEX encoding for UNICODE not implemented */
5529 cp2++;
5530 }
f86702cc 5531 else if ( *cp2 == '.') {
5532 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5533 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5534 cp2 += 3;
5535 }
5536 else cp2++;
a0d0e21e 5537 }
a0d0e21e 5538 }
367e4b85 5539 PerlMem_free(tmp);
a0d0e21e 5540 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 5541 if ((*cp2 == '^')) {
5542 /* EFS file escape, pass the next character as is */
5543 /* Fix me: HEX encoding for UNICODE not implemented */
5544 cp2++;
5545 *(cp1++) = *cp2;
5546 }
a0d0e21e
LW		 5547 if (*cp2 == ':') {
5548 *(cp1++) = '/';
5549 if (*(cp2+1) == '[') cp2++;
5550 }
f86702cc 5551 else if (*cp2 == ']' || *cp2 == '>') {
5552 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5553 }
f7ddb74a 5554 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 5555 *(cp1++) = '/';
e518068a 5556 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5557 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5558 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5559 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5560 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5561 }
f86702cc 5562 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5563 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5564 cp2 += 2;
5565 }
a0d0e21e
LW		 5566 }
5567 else if (*cp2 == '-') {
5568 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5569 while (*cp2 == '-') {
5570 cp2++;
5571 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5572 }
5573 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5574 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 5575 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 5576 return NULL;
5577 }
a0d0e21e
LW		 5578 }
5579 else *(cp1++) = *cp2;
5580 }
5581 else *(cp1++) = *cp2;
5582 }
5583 while (*cp2) *(cp1++) = *(cp2++);
5584 *cp1 = '\0';
5585
f7ddb74a
JM		 5586 /* This still leaves /000000/ when working with a
5587 * VMS device root or concealed root.
5588 */
5589 {
5590 int ulen;
5591 char * zeros;
5592
5593 ulen = strlen(rslt);
5594
5595 /* Get rid of "000000/ in rooted filespecs */
5596 if (ulen > 7) {
5597 zeros = strstr(rslt, "/000000/");
5598 if (zeros != NULL) {
5599 int mlen;
5600 mlen = ulen - (zeros - rslt) - 7;
5601 memmove(zeros, &zeros[7], mlen);
5602 ulen = ulen - 7;
5603 rslt[ulen] = '\0';
5604 }
5605 }
5606 }
5607
a0d0e21e
LW		 5608 return rslt;
5609
5610} /* end of do_tounixspec() */
5611/*}}}*/
5612/* External entry points */
b8ffc8df
RGS		 5613char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5614char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
a0d0e21e 5615
2497a41f
JM		 5616#if __CRTL_VER >= 80200000 && !defined(__VAX)
5617
5618static int posix_to_vmsspec
5619 (char *vmspath, int vmspath_len, const char *unixpath) {
5620int sts;
5621struct FAB myfab = cc$rms_fab;
5622struct NAML mynam = cc$rms_naml;
5623struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5624 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5625char *esa;
5626char *vms_delim;
5627int dir_flag;
5628int unixlen;
5629
5630 /* If not a posix spec already, convert it */
5631 dir_flag = 0;
5632 unixlen = strlen(unixpath);
5633 if (unixlen == 0) {
5634 vmspath[0] = '\0';
5635 return SS$_NORMAL;
5636 }
5637 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5638 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5639 }
5640 else {
5641 /* This is already a VMS specification, no conversion */
5642 unixlen--;
5643 strncpy(vmspath,unixpath, vmspath_len);
5644 }
5645 vmspath[vmspath_len] = 0;
5646 if (unixpath[unixlen - 1] == '/')
5647 dir_flag = 1;
c5375c28
JM		 5648 esa = PerlMem_malloc(VMS_MAXRSS);
5649 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 5650 myfab.fab$l_fna = vmspath;
5651 myfab.fab$b_fns = strlen(vmspath);
5652 myfab.fab$l_naml = &mynam;
5653 mynam.naml$l_esa = NULL;
5654 mynam.naml$b_ess = 0;
5655 mynam.naml$l_long_expand = esa;
a480973c 5656 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
2497a41f
JM		 5657 mynam.naml$l_rsa = NULL;
5658 mynam.naml$b_rss = 0;
5659 if (decc_efs_case_preserve)
5660 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5661 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5662
5663 /* Set up the remaining naml fields */
5664 sts = sys$parse(&myfab);
5665
5666 /* It failed! Try again as a UNIX filespec */
5667 if (!(sts & 1)) {
367e4b85 5668 PerlMem_free(esa);
2497a41f
JM		 5669 return sts;
5670 }
5671
5672 /* get the Device ID and the FID */
5673 sts = sys$search(&myfab);
5674 /* on any failure, returned the POSIX ^UP^ filespec */
5675 if (!(sts & 1)) {
367e4b85 5676 PerlMem_free(esa);
2497a41f
JM		 5677 return sts;
5678 }
5679 specdsc.dsc$a_pointer = vmspath;
5680 specdsc.dsc$w_length = vmspath_len;
5681
5682 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5683 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5684 sts = lib$fid_to_name
5685 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5686
5687 /* on any failure, returned the POSIX ^UP^ filespec */
5688 if (!(sts & 1)) {
5689 /* This can happen if user does not have permission to read directories */
5690 if (strncmp(unixpath,"\"^UP^",5) != 0)
5691 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5692 else
5693 strcpy(vmspath, unixpath);
5694 }
5695 else {
5696 vmspath[specdsc.dsc$w_length] = 0;
5697
5698 /* Are we expecting a directory? */
5699 if (dir_flag != 0) {
5700 int i;
5701 char *eptr;
5702
5703 eptr = NULL;
5704
5705 i = specdsc.dsc$w_length - 1;
5706 while (i > 0) {
5707 int zercnt;
5708 zercnt = 0;
5709 /* Version must be '1' */
5710 if (vmspath[i--] != '1')
5711 break;
5712 /* Version delimiter is one of ".;" */
5713 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5714 break;
5715 i--;
5716 if (vmspath[i--] != 'R')
5717 break;
5718 if (vmspath[i--] != 'I')
5719 break;
5720 if (vmspath[i--] != 'D')
5721 break;
5722 if (vmspath[i--] != '.')
5723 break;
5724 eptr = &vmspath[i+1];
5725 while (i > 0) {
5726 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5727 if (vmspath[i-1] != '^') {
5728 if (zercnt != 6) {
5729 *eptr = vmspath[i];
5730 eptr[1] = '\0';
5731 vmspath[i] = '.';
5732 break;
5733 }
5734 else {
5735 /* Get rid of 6 imaginary zero directory filename */
5736 vmspath[i+1] = '\0';
5737 }
5738 }
5739 }
5740 if (vmspath[i] == '0')
5741 zercnt++;
5742 else
5743 zercnt = 10;
5744 i--;
5745 }
5746 break;
5747 }
5748 }
5749 }
367e4b85 5750 PerlMem_free(esa);
2497a41f
JM		 5751 return sts;
5752}
5753
5754/* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5755static int posix_to_vmsspec_hardway
5756 (char *vmspath, int vmspath_len, const char *unixpath) {
5757
5758char *esa;
5759const char *unixptr;
5760char *vmsptr;
5761const char *lastslash;
5762const char *lastdot;
5763int unixlen;
5764int vmslen;
5765int dir_start;
5766int dir_dot;
5767int quoted;
5768
5769
5770 unixptr = unixpath;
5771 dir_dot = 0;
5772
5773 /* Ignore leading "/" characters */
5774 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5775 unixptr++;
5776 }
5777 unixlen = strlen(unixptr);
5778
5779 /* Do nothing with blank paths */
5780 if (unixlen == 0) {
5781 vmspath[0] = '\0';
5782 return SS$_NORMAL;
5783 }
5784
5785 lastslash = strrchr(unixptr,'/');
5786 lastdot = strrchr(unixptr,'.');
5787
5788
5789 /* last dot is last dot or past end of string */
5790 if (lastdot == NULL)
5791 lastdot = unixptr + unixlen;
5792
5793 /* if no directories, set last slash to beginning of string */
5794 if (lastslash == NULL) {
5795 lastslash = unixptr;
5796 }
5797 else {
5798 /* Watch out for trailing "." after last slash, still a directory */
5799 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5800 lastslash = unixptr + unixlen;
5801 }
5802
5803 /* Watch out for traiing ".." after last slash, still a directory */
5804 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5805 lastslash = unixptr + unixlen;
5806 }
5807
5808 /* dots in directories are aways escaped */
5809 if (lastdot < lastslash)
5810 lastdot = unixptr + unixlen;
5811 }
5812
5813 /* if (unixptr < lastslash) then we are in a directory */
5814
5815 dir_start = 0;
5816 quoted = 0;
5817
5818 vmsptr = vmspath;
5819 vmslen = 0;
5820
5821 /* This could have a "^UP^ on the front */
5822 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5823 quoted = 1;
5824 unixptr+= 5;
5825 }
5826
5827 /* Start with the UNIX path */
5828 if (*unixptr != '/') {
5829 /* relative paths */
5830 if (lastslash > unixptr) {
5831 int dotdir_seen;
5832
5833 /* skip leading ./ */
5834 dotdir_seen = 0;
5835 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5836 dotdir_seen = 1;
5837 unixptr++;
5838 unixptr++;
5839 }
5840
5841 /* Are we still in a directory? */
5842 if (unixptr <= lastslash) {
5843 *vmsptr++ = '[';
5844 vmslen = 1;
5845 dir_start = 1;
5846
5847 /* if not backing up, then it is relative forward. */
5848 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5849 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5850 *vmsptr++ = '.';
5851 vmslen++;
5852 dir_dot = 1;
5853 }
5854 }
5855 else {
5856 if (dotdir_seen) {
5857 /* Perl wants an empty directory here to tell the difference
5858 * between a DCL commmand and a filename
5859 */
5860 *vmsptr++ = '[';
5861 *vmsptr++ = ']';
5862 vmslen = 2;
5863 }
5864 }
5865 }
5866 else {
5867 /* Handle two special files . and .. */
5868 if (unixptr[0] == '.') {
5869 if (unixptr[1] == '\0') {
5870 *vmsptr++ = '[';
5871 *vmsptr++ = ']';
5872 vmslen += 2;
5873 *vmsptr++ = '\0';
5874 return SS$_NORMAL;
5875 }
5876 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5877 *vmsptr++ = '[';
5878 *vmsptr++ = '-';
5879 *vmsptr++ = ']';
5880 vmslen += 3;
5881 *vmsptr++ = '\0';
5882 return SS$_NORMAL;
5883 }
5884 }
5885 }
5886 }
5887 else { /* Absolute PATH handling */
5888 int sts;
5889 char * nextslash;
5890 int seg_len;
5891 /* Need to find out where root is */
5892
5893 /* In theory, this procedure should never get an absolute POSIX pathname
5894 * that can not be found on the POSIX root.
5895 * In practice, that can not be relied on, and things will show up
5896 * here that are a VMS device name or concealed logical name instead.
5897 * So to make things work, this procedure must be tolerant.
5898 */
c5375c28
JM		 5899 esa = PerlMem_malloc(vmspath_len);
5900 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 5901
5902 sts = SS$_NORMAL;
5903 nextslash = strchr(&unixptr[1],'/');
5904 seg_len = 0;
5905 if (nextslash != NULL) {
5906 seg_len = nextslash - &unixptr[1];
5907 strncpy(vmspath, unixptr, seg_len + 1);
5908 vmspath[seg_len+1] = 0;
5909 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5910 }
5911
5912 if (sts & 1) {
5913 /* This is verified to be a real path */
5914
5915 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5916 strcpy(vmspath, esa);
5917 vmslen = strlen(vmspath);
5918 vmsptr = vmspath + vmslen;
5919 unixptr++;
5920 if (unixptr < lastslash) {
5921 char * rptr;
5922 vmsptr--;
5923 *vmsptr++ = '.';
5924 dir_start = 1;
5925 dir_dot = 1;
5926 if (vmslen > 7) {
5927 int cmp;
5928 rptr = vmsptr - 7;
5929 cmp = strcmp(rptr,"000000.");
5930 if (cmp == 0) {
5931 vmslen -= 7;
5932 vmsptr -= 7;
5933 vmsptr[1] = '\0';
5934 } /* removing 6 zeros */
5935 } /* vmslen < 7, no 6 zeros possible */
5936 } /* Not in a directory */
5937 } /* end of verified real path handling */
5938 else {
5939 int add_6zero;
5940 int islnm;
5941
5942 /* Ok, we have a device or a concealed root that is not in POSIX
5943 * or we have garbage. Make the best of it.
5944 */
5945
5946 /* Posix to VMS destroyed this, so copy it again */
5947 strncpy(vmspath, &unixptr[1], seg_len);
5948 vmspath[seg_len] = 0;
5949 vmslen = seg_len;
5950 vmsptr = &vmsptr[vmslen];
5951 islnm = 0;
5952
5953 /* Now do we need to add the fake 6 zero directory to it? */
5954 add_6zero = 1;
5955 if ((*lastslash == '/') && (nextslash < lastslash)) {
5956 /* No there is another directory */
5957 add_6zero = 0;
5958 }
5959 else {
5960 int trnend;
5961
5962 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206
CB		 5963 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5964 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 5965
5966 /* if this was a logical name, ']' or '>' must be present */
5967 /* if not a logical name, then assume a device and hope. */
5968 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5969
5970 /* if log name and trailing '.' then rooted - treat as device */
5971 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5972
5973 /* Fix me, if not a logical name, a device lookup should be
5974 * done to see if the device is file structured. If the device
5975 * is not file structured, the 6 zeros should not be put on.
5976 *
5977 * As it is, perl is occasionally looking for dev:[000000]tty.
5978 * which looks a little strange.
5979 */
5980
5981 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5982 /* No real directory present */
5983 add_6zero = 1;
5984 }
5985 }
5986
5987 /* Put the device delimiter on */
5988 *vmsptr++ = ':';
5989 vmslen++;
5990 unixptr = nextslash;
5991 unixptr++;
5992
5993 /* Start directory if needed */
5994 if (!islnm || add_6zero) {
5995 *vmsptr++ = '[';
5996 vmslen++;
5997 dir_start = 1;
5998 }
5999
6000 /* add fake 000000] if needed */
6001 if (add_6zero) {
6002 *vmsptr++ = '0';
6003 *vmsptr++ = '0';
6004 *vmsptr++ = '0';
6005 *vmsptr++ = '0';
6006 *vmsptr++ = '0';
6007 *vmsptr++ = '0';
6008 *vmsptr++ = ']';
6009 vmslen += 7;
6010 dir_start = 0;
6011 }
6012
6013 } /* non-POSIX translation */
367e4b85 6014 PerlMem_free(esa);
2497a41f
JM		 6015 } /* End of relative/absolute path handling */
6016
6017 while ((*unixptr) && (vmslen < vmspath_len)){
6018 int dash_flag;
6019
6020 dash_flag = 0;
6021
6022 if (dir_start != 0) {
6023
6024 /* First characters in a directory are handled special */
6025 while ((*unixptr == '/') ||
6026 ((*unixptr == '.') &&
6027 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6028 int loop_flag;
6029
6030 loop_flag = 0;
6031
6032 /* Skip redundant / in specification */
6033 while ((*unixptr == '/') && (dir_start != 0)) {
6034 loop_flag = 1;
6035 unixptr++;
6036 if (unixptr == lastslash)
6037 break;
6038 }
6039 if (unixptr == lastslash)
6040 break;
6041
6042 /* Skip redundant ./ characters */
6043 while ((*unixptr == '.') &&
6044 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6045 loop_flag = 1;
6046 unixptr++;
6047 if (unixptr == lastslash)
6048 break;
6049 if (*unixptr == '/')
6050 unixptr++;
6051 }
6052 if (unixptr == lastslash)
6053 break;
6054
6055 /* Skip redundant ../ characters */
6056 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6057 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6058 /* Set the backing up flag */
6059 loop_flag = 1;
6060 dir_dot = 0;
6061 dash_flag = 1;
6062 *vmsptr++ = '-';
6063 vmslen++;
6064 unixptr++; /* first . */
6065 unixptr++; /* second . */
6066 if (unixptr == lastslash)
6067 break;
6068 if (*unixptr == '/') /* The slash */
6069 unixptr++;
6070 }
6071 if (unixptr == lastslash)
6072 break;
6073
6074 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6075 /* Not needed when VMS is pretending to be UNIX. */
6076
6077 /* Is this loop stuck because of too many dots? */
6078 if (loop_flag == 0) {
6079 /* Exit the loop and pass the rest through */
6080 break;
6081 }
6082 }
6083
6084 /* Are we done with directories yet? */
6085 if (unixptr >= lastslash) {
6086
6087 /* Watch out for trailing dots */
6088 if (dir_dot != 0) {
6089 vmslen --;
6090 vmsptr--;
6091 }
6092 *vmsptr++ = ']';
6093 vmslen++;
6094 dash_flag = 0;
6095 dir_start = 0;
6096 if (*unixptr == '/')
6097 unixptr++;
6098 }
6099 else {
6100 /* Have we stopped backing up? */
6101 if (dash_flag) {
6102 *vmsptr++ = '.';
6103 vmslen++;
6104 dash_flag = 0;
6105 /* dir_start continues to be = 1 */
6106 }
6107 if (*unixptr == '-') {
6108 *vmsptr++ = '^';
6109 *vmsptr++ = *unixptr++;
6110 vmslen += 2;
6111 dir_start = 0;
6112
6113 /* Now are we done with directories yet? */
6114 if (unixptr >= lastslash) {
6115
6116 /* Watch out for trailing dots */
6117 if (dir_dot != 0) {
6118 vmslen --;
6119 vmsptr--;
6120 }
6121
6122 *vmsptr++ = ']';
6123 vmslen++;
6124 dash_flag = 0;
6125 dir_start = 0;
6126 }
6127 }
6128 }
6129 }
6130
6131 /* All done? */
6132 if (*unixptr == '\0')
6133 break;
6134
6135 /* Normal characters - More EFS work probably needed */
6136 dir_start = 0;
6137 dir_dot = 0;
6138
6139 switch(*unixptr) {
6140 case '/':
6141 /* remove multiple / */
6142 while (unixptr[1] == '/') {
6143 unixptr++;
6144 }
6145 if (unixptr == lastslash) {
6146 /* Watch out for trailing dots */
6147 if (dir_dot != 0) {
6148 vmslen --;
6149 vmsptr--;
6150 }
6151 *vmsptr++ = ']';
6152 }
6153 else {
6154 dir_start = 1;
6155 *vmsptr++ = '.';
6156 dir_dot = 1;
6157
6158 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6159 /* Not needed when VMS is pretending to be UNIX. */
6160
6161 }
6162 dash_flag = 0;
6163 if (*unixptr != '\0')
6164 unixptr++;
6165 vmslen++;
6166 break;
6167 case '?':
6168 *vmsptr++ = '%';
6169 vmslen++;
6170 unixptr++;
6171 break;
6172 case ' ':
6173 *vmsptr++ = '^';
6174 *vmsptr++ = '_';
6175 vmslen += 2;
6176 unixptr++;
6177 break;
6178 case '.':
6179 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6180 *vmsptr++ = '^';
6181 *vmsptr++ = '.';
6182 vmslen += 2;
6183 unixptr++;
6184
6185 /* trailing dot ==> '^..' on VMS */
6186 if (*unixptr == '\0') {
6187 *vmsptr++ = '.';
6188 vmslen++;
6189 }
6190 *vmsptr++ = *unixptr++;
6191 vmslen ++;
6192 }
6193 if (quoted && (unixptr[1] == '\0')) {
6194 unixptr++;
6195 break;
6196 }
6197 *vmsptr++ = '^';
6198 *vmsptr++ = *unixptr++;
6199 vmslen += 2;
6200 break;
6201 case '~':
6202 case ';':
6203 case '\\':
6204 *vmsptr++ = '^';
6205 *vmsptr++ = *unixptr++;
6206 vmslen += 2;
6207 break;
6208 default:
6209 if (*unixptr != '\0') {
6210 *vmsptr++ = *unixptr++;
6211 vmslen++;
6212 }
6213 break;
6214 }
6215 }
6216
6217 /* Make sure directory is closed */
6218 if (unixptr == lastslash) {
6219 char *vmsptr2;
6220 vmsptr2 = vmsptr - 1;
6221
6222 if (*vmsptr2 != ']') {
6223 *vmsptr2--;
6224
6225 /* directories do not end in a dot bracket */
6226 if (*vmsptr2 == '.') {
6227 vmsptr2--;
6228
6229 /* ^. is allowed */
6230 if (*vmsptr2 != '^') {
6231 vmsptr--; /* back up over the dot */
6232 }
6233 }
6234 *vmsptr++ = ']';
6235 }
6236 }
6237 else {
6238 char *vmsptr2;
6239 /* Add a trailing dot if a file with no extension */
6240 vmsptr2 = vmsptr - 1;
6241 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6242 (*lastdot != '.')) {
6243 *vmsptr++ = '.';
6244 vmslen++;
6245 }
6246 }
6247
6248 *vmsptr = '\0';
6249 return SS$_NORMAL;
6250}
6251#endif
6252
a0d0e21e 6253/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
b8ffc8df 6254static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
a480973c 6255 static char __tovmsspec_retbuf[VMS_MAXRSS];
e518068a 6256 char *rslt, *dirend;
f7ddb74a
JM		 6257 char *lastdot;
6258 char *vms_delim;
b8ffc8df
RGS		 6259 register char *cp1;
6260 const char *cp2;
e518068a 6261 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 6262 int rslt_len;
6263 int no_type_seen;
a0d0e21e 6264
748a9306 6265 if (path == NULL) return NULL;
4d743a9b 6266 rslt_len = VMS_MAXRSS-1;
a0d0e21e 6267 if (buf) rslt = buf;
a480973c 6268 else if (ts) Newx(rslt, VMS_MAXRSS, char);
a0d0e21e 6269 else rslt = __tovmsspec_retbuf;
748a9306 6270 if (strpbrk(path,"]:>") ||
a0d0e21e 6271 (dirend = strrchr(path,'/')) == NULL) {
748a9306
LW		 6272 if (path[0] == '.') {
6273 if (path[1] == '\0') strcpy(rslt,"[]");
6274 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6275 else strcpy(rslt,path); /* probably garbage */
6276 }
6277 else strcpy(rslt,path);
a0d0e21e
LW		 6278 return rslt;
6279 }
f7ddb74a 6280
2497a41f
JM		 6281 /* Posix specifications are now a native VMS format */
6282 /*--------------------------------------------------*/
6283#if __CRTL_VER >= 80200000 && !defined(__VAX)
6284 if (decc_posix_compliant_pathnames) {
6285 if (strncmp(path,"\"^UP^",5) == 0) {
6286 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6287 return rslt;
6288 }
6289 }
6290#endif
6291
f7ddb74a
JM		 6292 vms_delim = strpbrk(path,"]:>");
6293
2497a41f
JM		 6294 if ((vms_delim != NULL) ||
6295 ((dirend = strrchr(path,'/')) == NULL)) {
6296
6297 /* VMS special characters found! */
6298
6299 if (path[0] == '.') {
6300 if (path[1] == '\0') strcpy(rslt,"[]");
6301 else if (path[1] == '.' && path[2] == '\0')
6302 strcpy(rslt,"[-]");
6303
6304 /* Dot preceeding a device or directory ? */
6305 else {
6306 /* If not in POSIX mode, pass it through and hope it works */
6307#if __CRTL_VER >= 80200000 && !defined(__VAX)
6308 if (!decc_posix_compliant_pathnames)
6309 strcpy(rslt,path); /* probably garbage */
6310 else
6311 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6312#else
6313 strcpy(rslt,path); /* probably garbage */
6314#endif
6315 }
6316 }
6317 else {
6318
6319 /* If no VMS characters and in POSIX mode, convert it!
6320 * This is the easiest way to get directory specifications
6321 * handled correctly in POSIX mode
6322 */
6323#if __CRTL_VER >= 80200000 && !defined(__VAX)
6324 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6325 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6326 else {
6327 /* No unix path separators - presume VMS already */
6328 strcpy(rslt,path);
6329 }
6330#else
6331 strcpy(rslt,path); /* probably garbage */
6332#endif
6333 }
6334 return rslt;
6335 }
6336
6337/* If POSIX mode active, handle the conversion */
6338#if __CRTL_VER >= 80200000 && !defined(__VAX)
6339 if (decc_posix_compliant_pathnames) {
6340 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6341 return rslt;
6342 }
6343#endif
f7ddb74a 6344
f86702cc 6345 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 6346 if (!*(dirend+2)) dirend +=2;
6347 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
f86702cc 6348 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 6349 }
f7ddb74a 6350
a0d0e21e
LW		 6351 cp1 = rslt;
6352 cp2 = path;
f7ddb74a 6353 lastdot = strrchr(cp2,'.');
a0d0e21e 6354 if (*cp2 == '/') {
a480973c 6355 char *trndev;
e518068a 6356 int islnm, rooted;
6357 STRLEN trnend;
6358
b7ae7a0d 6359 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 6360 if (!*(cp2+1)) {
f7ddb74a
JM		 6361 if (decc_disable_posix_root) {
6362 strcpy(rslt,"sys$disk:[000000]");
6363 }
6364 else {
6365 strcpy(rslt,"sys$posix_root:[000000]");
6366 }
61bb5906
CB		 6367 return rslt;
6368 }
a0d0e21e 6369 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 6370 *cp1 = '\0';
c5375c28
JM		 6371 trndev = PerlMem_malloc(VMS_MAXRSS);
6372 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 6373 islnm = my_trnlnm(rslt,trndev,0);
f7ddb74a
JM		 6374
6375 /* DECC special handling */
6376 if (!islnm) {
6377 if (strcmp(rslt,"bin") == 0) {
6378 strcpy(rslt,"sys$system");
6379 cp1 = rslt + 10;
6380 *cp1 = 0;
6381 islnm = my_trnlnm(rslt,trndev,0);
6382 }
6383 else if (strcmp(rslt,"tmp") == 0) {
6384 strcpy(rslt,"sys$scratch");
6385 cp1 = rslt + 11;
6386 *cp1 = 0;
6387 islnm = my_trnlnm(rslt,trndev,0);
6388 }
6389 else if (!decc_disable_posix_root) {
6390 strcpy(rslt, "sys$posix_root");
6391 cp1 = rslt + 13;
6392 *cp1 = 0;
6393 cp2 = path;
6394 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6395 islnm = my_trnlnm(rslt,trndev,0);
6396 }
6397 else if (strcmp(rslt,"dev") == 0) {
6398 if (strncmp(cp2,"/null", 5) == 0) {
6399 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6400 strcpy(rslt,"NLA0");
6401 cp1 = rslt + 4;
6402 *cp1 = 0;
6403 cp2 = cp2 + 5;
6404 islnm = my_trnlnm(rslt,trndev,0);
6405 }
6406 }
6407 }
6408 }
6409
e518068a 6410 trnend = islnm ? strlen(trndev) - 1 : 0;
6411 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6412 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6413 /* If the first element of the path is a logical name, determine
6414 * whether it has to be translated so we can add more directories. */
6415 if (!islnm || rooted) {
6416 *(cp1++) = ':';
6417 *(cp1++) = '[';
6418 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6419 else cp2++;
6420 }
6421 else {
6422 if (cp2 != dirend) {
e518068a 6423 strcpy(rslt,trndev);
6424 cp1 = rslt + trnend;
755b3d5d
JM		 6425 if (*cp2 != 0) {
6426 *(cp1++) = '.';
6427 cp2++;
6428 }
e518068a 6429 }
6430 else {
f7ddb74a
JM		 6431 if (decc_disable_posix_root) {
6432 *(cp1++) = ':';
6433 hasdir = 0;
6434 }
e518068a 6435 }
6436 }
367e4b85 6437 PerlMem_free(trndev);
748a9306 6438 }
a0d0e21e
LW		 6439 else {
6440 *(cp1++) = '[';
748a9306
LW		 6441 if (*cp2 == '.') {
6442 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6443 cp2 += 2; /* skip over "./" - it's redundant */
6444 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6445 }
6446 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6447 *(cp1++) = '-'; /* "../" --> "-" */
6448 cp2 += 3;
6449 }
f86702cc 6450 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6451 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6452 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6453 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6454 cp2 += 4;
6455 }
f7ddb74a
JM		 6456 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6457 /* Escape the extra dots in EFS file specifications */
6458 *(cp1++) = '^';
6459 }
748a9306
LW		 6460 if (cp2 > dirend) cp2 = dirend;
6461 }
6462 else *(cp1++) = '.';
6463 }
6464 for (; cp2 < dirend; cp2++) {
6465 if (*cp2 == '/') {
01b8edb6 6466 if (*(cp2-1) == '/') continue;
748a9306
LW		 6467 if (*(cp1-1) != '.') *(cp1++) = '.';
6468 infront = 0;
6469 }
6470 else if (!infront && *cp2 == '.') {
01b8edb6 6471 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6472 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 6473 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6474 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 6475 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 6476 else { /* back up over previous directory name */
6477 cp1--;
6478 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6479 if (*(cp1-1) == '[') {
6480 memcpy(cp1,"000000.",7);
6481 cp1 += 7;
6482 }
748a9306
LW		 6483 }
6484 cp2 += 2;
01b8edb6 6485 if (cp2 == dirend) break;
748a9306 6486 }
f86702cc 6487 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6488 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6489 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6490 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6491 if (!*(cp2+3)) {
6492 *(cp1++) = '.'; /* Simulate trailing '/' */
6493 cp2 += 2; /* for loop will incr this to == dirend */
6494 }
6495 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6496 }
f7ddb74a
JM		 6497 else {
6498 if (decc_efs_charset == 0)
6499 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6500 else {
6501 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6502 *(cp1++) = '.';
6503 }
6504 }
748a9306
LW		 6505 }
6506 else {
e518068a 6507 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 6508 if (*cp2 == '.') {
6509 if (decc_efs_charset == 0)
6510 *(cp1++) = '_';
6511 else {
6512 *(cp1++) = '^';
6513 *(cp1++) = '.';
6514 }
6515 }
748a9306
LW		 6516 else *(cp1++) = *cp2;
6517 infront = 1;
6518 }
a0d0e21e 6519 }
748a9306 6520 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 6521 if (hasdir) *(cp1++) = ']';
748a9306 6522 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 6523 /* fixme for ODS5 */
6524 no_type_seen = 0;
6525 if (cp2 > lastdot)
6526 no_type_seen = 1;
6527 while (*cp2) {
6528 switch(*cp2) {
6529 case '?':
6530 *(cp1++) = '%';
6531 cp2++;
6532 case ' ':
6533 *(cp1)++ = '^';
6534 *(cp1)++ = '_';
6535 cp2++;
6536 break;
6537 case '.':
6538 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6539 decc_readdir_dropdotnotype) {
6540 *(cp1)++ = '^';
6541 *(cp1)++ = '.';
6542 cp2++;
6543
6544 /* trailing dot ==> '^..' on VMS */
6545 if (*cp2 == '\0') {
6546 *(cp1++) = '.';
6547 no_type_seen = 0;
6548 }
6549 }
6550 else {
6551 *(cp1++) = *(cp2++);
6552 no_type_seen = 0;
6553 }
6554 break;
6555 case '\"':
6556 case '~':
6557 case '`':
6558 case '!':
6559 case '#':
6560 case '%':
6561 case '^':
6562 case '&':
6563 case '(':
6564 case ')':
6565 case '=':
6566 case '+':
6567 case '\'':
6568 case '@':
6569 case '[':
6570 case ']':
6571 case '{':
6572 case '}':
6573 case ':':
6574 case '\\':
6575 case '|':
6576 case '<':
6577 case '>':
6578 *(cp1++) = '^';
6579 *(cp1++) = *(cp2++);
6580 break;
6581 case ';':
6582 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
657054d4 6583 * which is wrong. UNIX notation should be ".dir." unless
f7ddb74a
JM		 6584 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6585 * changing this behavior could break more things at this time.
2497a41f
JM		 6586 * efs character set effectively does not allow "." to be a version
6587 * delimiter as a further complication about changing this.
f7ddb74a
JM		 6588 */
6589 if (decc_filename_unix_report != 0) {
6590 *(cp1++) = '^';
6591 }
6592 *(cp1++) = *(cp2++);
6593 break;
6594 default:
6595 *(cp1++) = *(cp2++);
6596 }
6597 }
6598 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6599 char *lcp1;
6600 lcp1 = cp1;
6601 lcp1--;
6602 /* Fix me for "^]", but that requires making sure that you do
6603 * not back up past the start of the filename
6604 */
6605 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6606 *cp1++ = '.';
6607 }
a0d0e21e
LW		 6608 *cp1 = '\0';
6609
6610 return rslt;
6611
6612} /* end of do_tovmsspec() */
6613/*}}}*/
6614/* External entry points */
2fbb330f
JM		 6615char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6616char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
a0d0e21e
LW		 6617
6618/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
b8ffc8df 6619static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
a480973c 6620 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 6621 int vmslen;
a480973c 6622 char *pathified, *vmsified, *cp;
a0d0e21e 6623
748a9306 6624 if (path == NULL) return NULL;
c5375c28
JM		 6625 pathified = PerlMem_malloc(VMS_MAXRSS);
6626 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 6627 if (do_pathify_dirspec(path,pathified,0) == NULL) {
c5375c28 6628 PerlMem_free(pathified);
a480973c
JM		 6629 return NULL;
6630 }
c5375c28
JM		 6631
6632 vmsified = NULL;
6633 if (buf == NULL)
6634 Newx(vmsified, VMS_MAXRSS, char);
6635 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6636 PerlMem_free(pathified);
6637 if (vmsified) Safefree(vmsified);
a480973c
JM		 6638 return NULL;
6639 }
c5375c28 6640 PerlMem_free(pathified);
a480973c 6641 if (buf) {
a480973c
JM		 6642 return buf;
6643 }
a0d0e21e
LW		 6644 else if (ts) {
6645 vmslen = strlen(vmsified);
a02a5408 6646 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 6647 memcpy(cp,vmsified,vmslen);
6648 cp[vmslen] = '\0';
a480973c 6649 Safefree(vmsified);
a0d0e21e
LW		 6650 return cp;
6651 }
6652 else {
6653 strcpy(__tovmspath_retbuf,vmsified);
a480973c 6654 Safefree(vmsified);
a0d0e21e
LW		 6655 return __tovmspath_retbuf;
6656 }
6657
6658} /* end of do_tovmspath() */
6659/*}}}*/
6660/* External entry points */
b8ffc8df
RGS		 6661char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6662char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
a0d0e21e
LW		 6663
6664
6665/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
b8ffc8df 6666static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
a480973c 6667 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 6668 int unixlen;
a480973c 6669 char *pathified, *unixified, *cp;
a0d0e21e 6670
748a9306 6671 if (path == NULL) return NULL;
c5375c28
JM		 6672 pathified = PerlMem_malloc(VMS_MAXRSS);
6673 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 6674 if (do_pathify_dirspec(path,pathified,0) == NULL) {
c5375c28 6675 PerlMem_free(pathified);
a480973c
JM		 6676 return NULL;
6677 }
c5375c28
JM		 6678
6679 unixified = NULL;
6680 if (buf == NULL) {
6681 Newx(unixified, VMS_MAXRSS, char);
6682 }
a480973c 6683 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
c5375c28
JM		 6684 PerlMem_free(pathified);
6685 if (unixified) Safefree(unixified);
a480973c
JM		 6686 return NULL;
6687 }
c5375c28 6688 PerlMem_free(pathified);
a480973c 6689 if (buf) {
a480973c
JM		 6690 return buf;
6691 }
a0d0e21e
LW		 6692 else if (ts) {
6693 unixlen = strlen(unixified);
a02a5408 6694 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 6695 memcpy(cp,unixified,unixlen);
6696 cp[unixlen] = '\0';
a480973c 6697 Safefree(unixified);
a0d0e21e
LW		 6698 return cp;
6699 }
6700 else {
6701 strcpy(__tounixpath_retbuf,unixified);
a480973c 6702 Safefree(unixified);
a0d0e21e
LW		 6703 return __tounixpath_retbuf;
6704 }
6705
6706} /* end of do_tounixpath() */
6707/*}}}*/
6708/* External entry points */
b8ffc8df
RGS		 6709char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6710char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
a0d0e21e
LW		 6711
6712/*
6713 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6714 *
6715 *****************************************************************************
6716 * *
6717 * Copyright (C) 1989-1994 by *
6718 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6719 * *
6720 * Permission is hereby granted for the reproduction of this software, *
6721 * on condition that this copyright notice is included in the reproduction, *
6722 * and that such reproduction is not for purposes of profit or material *
6723 * gain. *
6724 * *
6725 * 27-Aug-1994 Modified for inclusion in perl5 *
bd3fa61c 6726 * by Charles Bailey bailey@newman.upenn.edu *
a0d0e21e
LW		 6727 *****************************************************************************
6728 */
6729
6730/*
6731 * getredirection() is intended to aid in porting C programs
6732 * to VMS (Vax-11 C). The native VMS environment does not support
6733 * '>' and '<' I/O redirection, or command line wild card expansion,
6734 * or a command line pipe mechanism using the '|' AND background
6735 * command execution '&'. All of these capabilities are provided to any
6736 * C program which calls this procedure as the first thing in the
6737 * main program.
6738 * The piping mechanism will probably work with almost any 'filter' type
6739 * of program. With suitable modification, it may useful for other
6740 * portability problems as well.
6741 *
6742 * Author: Mark Pizzolato mark@infocomm.com
6743 */
6744struct list_item
6745 {
6746 struct list_item *next;
6747 char *value;
6748 };
6749
6750static void add_item(struct list_item **head,
6751 struct list_item **tail,
6752 char *value,
6753 int *count);
6754
4b19af01
CB		 6755static void mp_expand_wild_cards(pTHX_ char *item,
6756 struct list_item **head,
6757 struct list_item **tail,
6758 int *count);
a0d0e21e 6759
8df869cb 6760static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 6761
fd8cd3a3 6762static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 6763
6764/*{{{ void getredirection(int *ac, char ***av)*/
84902520 6765static void
4b19af01 6766mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 6767/*
6768 * Process vms redirection arg's. Exit if any error is seen.
6769 * If getredirection() processes an argument, it is erased
6770 * from the vector. getredirection() returns a new argc and argv value.
6771 * In the event that a background command is requested (by a trailing "&"),
6772 * this routine creates a background subprocess, and simply exits the program.
6773 *
6774 * Warning: do not try to simplify the code for vms. The code
6775 * presupposes that getredirection() is called before any data is
6776 * read from stdin or written to stdout.
6777 *
6778 * Normal usage is as follows:
6779 *
6780 * main(argc, argv)
6781 * int argc;
6782 * char *argv[];
6783 * {
6784 * getredirection(&argc, &argv);
6785 * }
6786 */
6787{
6788 int argc = *ac; /* Argument Count */
6789 char **argv = *av; /* Argument Vector */
6790 char *ap; /* Argument pointer */
6791 int j; /* argv[] index */
6792 int item_count = 0; /* Count of Items in List */
6793 struct list_item *list_head = 0; /* First Item in List */
6794 struct list_item *list_tail; /* Last Item in List */
6795 char *in = NULL; /* Input File Name */
6796 char *out = NULL; /* Output File Name */
6797 char *outmode = "w"; /* Mode to Open Output File */
6798 char *err = NULL; /* Error File Name */
6799 char *errmode = "w"; /* Mode to Open Error File */
6800 int cmargc = 0; /* Piped Command Arg Count */
6801 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 6802
6803 /*
6804 * First handle the case where the last thing on the line ends with
6805 * a '&'. This indicates the desire for the command to be run in a
6806 * subprocess, so we satisfy that desire.
6807 */
6808 ap = argv[argc-1];
6809 if (0 == strcmp("&", ap))
8c3eed29 6810 exit(background_process(aTHX_ --argc, argv));
e518068a 6811 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 6812 {
6813 ap[strlen(ap)-1] = '\0';
8c3eed29 6814 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 6815 }
6816 /*
6817 * Now we handle the general redirection cases that involve '>', '>>',
6818 * '<', and pipes '|'.
6819 */
6820 for (j = 0; j < argc; ++j)
6821 {
6822 if (0 == strcmp("<", argv[j]))
6823 {
6824 if (j+1 >= argc)
6825 {
fd71b04b 6826 fprintf(stderr,"No input file after < on command line");
748a9306 6827 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6828 }
6829 in = argv[++j];
6830 continue;
6831 }
6832 if ('<' == *(ap = argv[j]))
6833 {
6834 in = 1 + ap;
6835 continue;
6836 }
6837 if (0 == strcmp(">", ap))
6838 {
6839 if (j+1 >= argc)
6840 {
fd71b04b 6841 fprintf(stderr,"No output file after > on command line");
748a9306 6842 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6843 }
6844 out = argv[++j];
6845 continue;
6846 }
6847 if ('>' == *ap)
6848 {
6849 if ('>' == ap[1])
6850 {
6851 outmode = "a";
6852 if ('\0' == ap[2])
6853 out = argv[++j];
6854 else
6855 out = 2 + ap;
6856 }
6857 else
6858 out = 1 + ap;
6859 if (j >= argc)
6860 {
fd71b04b 6861 fprintf(stderr,"No output file after > or >> on command line");
748a9306 6862 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6863 }
6864 continue;
6865 }
6866 if (('2' == *ap) && ('>' == ap[1]))
6867 {
6868 if ('>' == ap[2])
6869 {
6870 errmode = "a";
6871 if ('\0' == ap[3])
6872 err = argv[++j];
6873 else
6874 err = 3 + ap;
6875 }
6876 else
6877 if ('\0' == ap[2])
6878 err = argv[++j];
6879 else
748a9306 6880 err = 2 + ap;
a0d0e21e
LW		 6881 if (j >= argc)
6882 {
fd71b04b 6883 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 6884 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6885 }
6886 continue;
6887 }
6888 if (0 == strcmp("|", argv[j]))
6889 {
6890 if (j+1 >= argc)
6891 {
fd71b04b 6892 fprintf(stderr,"No command into which to pipe on command line");
748a9306 6893 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 6894 }
6895 cmargc = argc-(j+1);
6896 cmargv = &argv[j+1];
6897 argc = j;
6898 continue;
6899 }
6900 if ('|' == *(ap = argv[j]))
6901 {
6902 ++argv[j];
6903 cmargc = argc-j;
6904 cmargv = &argv[j];
6905 argc = j;
6906 continue;
6907 }
6908 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6909 }
6910 /*
6911 * Allocate and fill in the new argument vector, Some Unix's terminate
6912 * the list with an extra null pointer.
6913 */
e0ef6b43 6914 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 6915 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 6916 *av = argv;
6917 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6918 argv[j] = list_head->value;
6919 *ac = item_count;
6920 if (cmargv != NULL)
6921 {
6922 if (out != NULL)
6923 {
fd71b04b 6924 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 6925 exit(LIB$_INVARGORD);
a0d0e21e 6926 }
fd8cd3a3 6927 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 6928 }
6929
6930 /* Check for input from a pipe (mailbox) */
6931
a5f75d66 6932 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 6933 {
6934 char mbxname[L_tmpnam];
6935 long int bufsize;
6936 long int dvi_item = DVI$_DEVBUFSIZ;
6937 $DESCRIPTOR(mbxnam, "");
6938 $DESCRIPTOR(mbxdevnam, "");
6939
6940 /* Input from a pipe, reopen it in binary mode to disable */
6941 /* carriage control processing. */
6942
fd71b04b 6943 fgetname(stdin, mbxname);
a0d0e21e
LW		 6944 mbxnam.dsc$a_pointer = mbxname;
6945 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6946 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6947 mbxdevnam.dsc$a_pointer = mbxname;
6948 mbxdevnam.dsc$w_length = sizeof(mbxname);
6949 dvi_item = DVI$_DEVNAM;
6950 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6951 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 6952 set_errno(0);
6953 set_vaxc_errno(1);
a0d0e21e
LW		 6954 freopen(mbxname, "rb", stdin);
6955 if (errno != 0)
6956 {
fd71b04b 6957 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 6958 exit(vaxc$errno);
a0d0e21e
LW		 6959 }
6960 }
6961 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6962 {
fd71b04b 6963 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 6964 exit(vaxc$errno);
a0d0e21e
LW		 6965 }
6966 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6967 {
fd71b04b 6968 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 6969 exit(vaxc$errno);
a0d0e21e 6970 }
fd8cd3a3 6971 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 6972
748a9306 6973 if (err != NULL) {
71d7ec5d 6974 if (strcmp(err,"&1") == 0) {
a15cef0c 6975 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 6976 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 6977 } else {
748a9306
LW		 6978 FILE *tmperr;
6979 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6980 {
fd71b04b 6981 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 6982 exit(vaxc$errno);
6983 }
6984 fclose(tmperr);
a15cef0c 6985 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 6986 {
6987 exit(vaxc$errno);
6988 }
fd8cd3a3 6989 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 6990 }
71d7ec5d 6991 }
a0d0e21e 6992#ifdef ARGPROC_DEBUG
740ce14c 6993 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 6994 for (j = 0; j < *ac; ++j)
740ce14c 6995 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 6996#endif
b7ae7a0d 6997 /* Clear errors we may have hit expanding wildcards, so they don't
6998 show up in Perl's $! later */
6999 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 7000} /* end of getredirection() */
7001/*}}}*/
7002
7003static void add_item(struct list_item **head,
7004 struct list_item **tail,
7005 char *value,
7006 int *count)
7007{
7008 if (*head == 0)
7009 {
e0ef6b43 7010 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 7011 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 7012 *tail = *head;
7013 }
7014 else {
e0ef6b43 7015 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 7016 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 7017 *tail = (*tail)->next;
7018 }
7019 (*tail)->value = value;
7020 ++(*count);
7021}
7022
4b19af01 7023static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 7024 struct list_item **head,
7025 struct list_item **tail,
7026 int *count)
7027{
7028int expcount = 0;
748a9306 7029unsigned long int context = 0;
a0d0e21e 7030int isunix = 0;
773da73d 7031int item_len = 0;
a0d0e21e
LW		 7032char *had_version;
7033char *had_device;
7034int had_directory;
f675dbe5 7035char *devdir,*cp;
a480973c 7036char *vmsspec;
a0d0e21e 7037$DESCRIPTOR(filespec, "");
748a9306 7038$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 7039$DESCRIPTOR(resultspec, "");
a480973c
JM		 7040unsigned long int lff_flags = 0;
7041int sts;
dca5a913 7042int rms_sts;
a480973c
JM		 7043
7044#ifdef VMS_LONGNAME_SUPPORT
7045 lff_flags = LIB$M_FIL_LONG_NAMES;
7046#endif
a0d0e21e 7047
f675dbe5
CB		 7048 for (cp = item; *cp; cp++) {
7049 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7050 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7051 }
7052 if (!*cp || isspace(*cp))
a0d0e21e
LW		 7053 {
7054 add_item(head, tail, item, count);
7055 return;
7056 }
773da73d
JH		 7057 else
7058 {
7059 /* "double quoted" wild card expressions pass as is */
7060 /* From DCL that means using e.g.: */
7061 /* perl program """perl.*""" */
7062 item_len = strlen(item);
7063 if ( '"' == *item && '"' == item[item_len-1] )
7064 {
7065 item++;
7066 item[item_len-2] = '\0';
7067 add_item(head, tail, item, count);
7068 return;
7069 }
7070 }
a0d0e21e
LW		 7071 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7072 resultspec.dsc$b_class = DSC$K_CLASS_D;
7073 resultspec.dsc$a_pointer = NULL;
c5375c28
JM		 7074 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7075 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 7076 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
a0d0e21e
LW		 7077 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7078 if (!isunix || !filespec.dsc$a_pointer)
7079 filespec.dsc$a_pointer = item;
7080 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7081 /*
7082 * Only return version specs, if the caller specified a version
7083 */
7084 had_version = strchr(item, ';');
7085 /*
7086 * Only return device and directory specs, if the caller specifed either.
7087 */
7088 had_device = strchr(item, ':');
7089 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7090
a480973c
JM		 7091 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7092 (&filespec, &resultspec, &context,
dca5a913 7093 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 7094 {
7095 char *string;
7096 char *c;
7097
c5375c28
JM		 7098 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7099 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 7100 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7101 string[resultspec.dsc$w_length] = '\0';
7102 if (NULL == had_version)
f7ddb74a 7103 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 7104 if ((!had_directory) && (had_device == NULL))
7105 {
7106 if (NULL == (devdir = strrchr(string, ']')))
7107 devdir = strrchr(string, '>');
7108 strcpy(string, devdir + 1);
7109 }
7110 /*
7111 * Be consistent with what the C RTL has already done to the rest of
7112 * the argv items and lowercase all of these names.
7113 */
f7ddb74a
JM		 7114 if (!decc_efs_case_preserve) {
7115 for (c = string; *c; ++c)
a0d0e21e
LW		 7116 if (isupper(*c))
7117 *c = tolower(*c);
f7ddb74a 7118 }
f86702cc 7119 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 7120 add_item(head, tail, string, count);
7121 ++expcount;
a480973c 7122 }
367e4b85 7123 PerlMem_free(vmsspec);
c07a80fd 7124 if (sts != RMS$_NMF)
7125 {
7126 set_vaxc_errno(sts);
7127 switch (sts)
7128 {
f282b18d 7129 case RMS$_FNF: case RMS$_DNF:
c07a80fd 7130 set_errno(ENOENT); break;
f282b18d
CB		 7131 case RMS$_DIR:
7132 set_errno(ENOTDIR); break;
c07a80fd 7133 case RMS$_DEV:
7134 set_errno(ENODEV); break;
f282b18d 7135 case RMS$_FNM: case RMS$_SYN:
c07a80fd 7136 set_errno(EINVAL); break;
7137 case RMS$_PRV:
7138 set_errno(EACCES); break;
7139 default:
b7ae7a0d 7140 _ckvmssts_noperl(sts);
c07a80fd 7141 }
7142 }
a0d0e21e
LW		 7143 if (expcount == 0)
7144 add_item(head, tail, item, count);
b7ae7a0d 7145 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7146 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 7147}
7148
7149static int child_st[2];/* Event Flag set when child process completes */
7150
748a9306 7151static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 7152
748a9306 7153static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 7154{
7155short iosb[4];
7156
7157 if (0 == child_st[0])
7158 {
7159#ifdef ARGPROC_DEBUG
740ce14c 7160 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 7161#endif
7162 fflush(stdout); /* Have to flush pipe for binary data to */
7163 /* terminate properly -- <tp@mccall.com> */
7164 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7165 sys$dassgn(child_chan);
7166 fclose(stdout);
7167 sys$synch(0, child_st);
7168 }
7169 return(1);
7170}
7171
7172static void sig_child(int chan)
7173{
7174#ifdef ARGPROC_DEBUG
740ce14c 7175 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 7176#endif
7177 if (child_st[0] == 0)
7178 child_st[0] = 1;
7179}
7180
748a9306 7181static struct exit_control_block exit_block =
a0d0e21e
LW		 7182 {
7183 0,
7184 exit_handler,
7185 1,
7186 &exit_block.exit_status,
7187 0
7188 };
7189
ff7adb52
CL		 7190static void
7191pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 7192{
ff7adb52 7193 PerlIO *fp;
218fdd94 7194 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 7195 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7196 int sts, j, l, ismcr, quote, tquote = 0;
7197
218fdd94
CL		 7198 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7199 vms_execfree(vmscmd);
ff7adb52
CL		 7200
7201 j = l = 0;
7202 p = subcmd;
7203 q = cmargv[0];
7204 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7205 && toupper(*(q+2)) == 'R' && !*(q+3);
7206
7207 while (q && l < MAX_DCL_LINE_LENGTH) {
7208 if (!*q) {
7209 if (j > 0 && quote) {
7210 *p++ = '"';
7211 l++;
7212 }
7213 q = cmargv[++j];
7214 if (q) {
7215 if (ismcr && j > 1) quote = 1;
7216 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7217 *p++ = ' ';
7218 l++;
7219 if (quote || tquote) {
7220 *p++ = '"';
7221 l++;
7222 }
988c775c 7223 }
ff7adb52
CL		 7224 } else {
7225 if ((quote||tquote) && *q == '"') {
7226 *p++ = '"';
7227 l++;
988c775c 7228 }
ff7adb52
CL		 7229 *p++ = *q++;
7230 l++;
7231 }
7232 }
7233 *p = '\0';
a0d0e21e 7234
218fdd94 7235 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
ff7adb52
CL		 7236 if (fp == Nullfp) {
7237 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 7238 }
a0d0e21e
LW		 7239}
7240
8df869cb 7241static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 7242{
a480973c 7243char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 7244$DESCRIPTOR(value, "");
7245static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7246static $DESCRIPTOR(null, "NLA0:");
7247static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7248char pidstring[80];
7249$DESCRIPTOR(pidstr, "");
7250int pid;
748a9306 7251unsigned long int flags = 17, one = 1, retsts;
a480973c 7252int len;
a0d0e21e
LW		 7253
7254 strcat(command, argv[0]);
a480973c
JM		 7255 len = strlen(command);
7256 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e
LW		 7257 {
7258 strcat(command, " \"");
7259 strcat(command, *(++argv));
7260 strcat(command, "\"");
a480973c 7261 len = strlen(command);
a0d0e21e
LW		 7262 }
7263 value.dsc$a_pointer = command;
7264 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 7265 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 7266 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7267 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 7268 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 7269 }
7270 else {
b7ae7a0d 7271 _ckvmssts_noperl(retsts);
748a9306 7272 }
a0d0e21e 7273#ifdef ARGPROC_DEBUG
740ce14c 7274 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 7275#endif
7276 sprintf(pidstring, "%08X", pid);
740ce14c 7277 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 7278 pidstr.dsc$a_pointer = pidstring;
7279 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7280 lib$set_symbol(&pidsymbol, &pidstr);
7281 return(SS$_NORMAL);
7282}
7283/*}}}*/
7284/***** End of code taken from Mark Pizzolato's argproc.c package *****/
7285
84902520
TB		 7286
7287/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 7288/* Older VAXC header files lack these constants */
7289#ifndef JPI$_RIGHTS_SIZE
7290# define JPI$_RIGHTS_SIZE 817
7291#endif
7292#ifndef KGB$M_SUBSYSTEM
7293# define KGB$M_SUBSYSTEM 0x8
7294#endif
a480973c 7295
e0ef6b43
CB		 7296/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7297
84902520
TB		 7298/*{{{void vms_image_init(int *, char ***)*/
7299void
7300vms_image_init(int *argcp, char ***argvp)
7301{
f675dbe5
CB		 7302 char eqv[LNM$C_NAMLENGTH+1] = "";
7303 unsigned int len, tabct = 8, tabidx = 0;
7304 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 7305 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7306 unsigned short int dummy, rlen;
f675dbe5 7307 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 7308#if defined(PERL_IMPLICIT_CONTEXT)
7309 pTHX = NULL;
7310#endif
61bb5906
CB		 7311 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7312 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7313 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7314 { 0, 0, 0, 0} };
84902520 7315
2e34cc90 7316#ifdef KILL_BY_SIGPRC
f7ddb74a 7317 Perl_csighandler_init();
2e34cc90
CL		 7318#endif
7319
fd8cd3a3
DS		 7320 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7321 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 7322 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7323 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 7324 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 7325 will_taint = TRUE;
84902520
TB		 7326 break;
7327 }
7328 }
61bb5906 7329 /* Rights identifiers might trigger tainting as well. */
f675dbe5 7330 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 7331 while (rlen < rsz) {
7332 /* We didn't get all the identifiers on the first pass. Allocate a
7333 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7334 * were needed to hold all identifiers at time of last call; we'll
7335 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 7336 * If it gave us less than it wanted to despite ample buffer space,
7337 * something's broken. Is your system missing a system identifier?
61bb5906 7338 */
22d4bb9c
CB		 7339 if (rsz <= jpilist[1].buflen) {
7340 /* Perl_croak accvios when used this early in startup. */
7341 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7342 rsz, (unsigned long) jpilist[1].buflen,
7343 "Check your rights database for corruption.\n");
7344 exit(SS$_ABORT);
7345 }
e0ef6b43
CB		 7346 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7347 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 7348 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 7349 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 7350 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7351 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 7352 }
7353 mask = jpilist[1].bufadr;
7354 /* Check attribute flags for each identifier (2nd longword); protected
7355 * subsystem identifiers trigger tainting.
7356 */
7357 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7358 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 7359 will_taint = TRUE;
61bb5906
CB		 7360 break;
7361 }
7362 }
367e4b85 7363 if (mask != rlst) PerlMem_free(mask);
61bb5906 7364 }
f7ddb74a
JM		 7365
7366 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7367 * logical, some versions of the CRTL will add a phanthom /000000/
7368 * directory. This needs to be removed.
7369 */
7370 if (decc_filename_unix_report) {
7371 char * zeros;
7372 int ulen;
7373 ulen = strlen(argvp[0][0]);
7374 if (ulen > 7) {
7375 zeros = strstr(argvp[0][0], "/000000/");
7376 if (zeros != NULL) {
7377 int mlen;
7378 mlen = ulen - (zeros - argvp[0][0]) - 7;
7379 memmove(zeros, &zeros[7], mlen);
7380 ulen = ulen - 7;
7381 argvp[0][0][ulen] = '\0';
7382 }
7383 }
7384 /* It also may have a trailing dot that needs to be removed otherwise
7385 * it will be converted to VMS mode incorrectly.
7386 */
7387 ulen--;
7388 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7389 argvp[0][0][ulen] = '\0';
7390 }
7391
61bb5906 7392 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 7393 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 7394 * hasn't been allocated when vms_image_init() is called.
7395 */
f675dbe5 7396 if (will_taint) {
ec618cdf
CB		 7397 char **newargv, **oldargv;
7398 oldargv = *argvp;
e0ef6b43 7399 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 7400 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 7401 newargv[0] = oldargv[0];
c5375c28
JM		 7402 newargv[1] = PerlMem_malloc(3 * sizeof(char));
7403 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 7404 strcpy(newargv[1], "-T");
7405 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7406 (*argcp)++;
7407 newargv[*argcp] = NULL;
61bb5906
CB		 7408 /* We orphan the old argv, since we don't know where it's come from,
7409 * so we don't know how to free it.
7410 */
ec618cdf 7411 *argvp = newargv;
61bb5906 7412 }
f675dbe5
CB		 7413 else { /* Did user explicitly request tainting? */
7414 int i;
7415 char *cp, **av = *argvp;
7416 for (i = 1; i < *argcp; i++) {
7417 if (*av[i] != '-') break;
7418 for (cp = av[i]+1; *cp; cp++) {
7419 if (*cp == 'T') { will_taint = 1; break; }
7420 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7421 strchr("DFIiMmx",*cp)) break;
7422 }
7423 if (will_taint) break;
7424 }
7425 }
7426
7427 for (tabidx = 0;
7428 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7429 tabidx++) {
c5375c28
JM		 7430 if (!tabidx) {
7431 tabvec = (struct dsc$descriptor_s **)
7432 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7433 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7434 }
f675dbe5
CB		 7435 else if (tabidx >= tabct) {
7436 tabct += 8;
e0ef6b43 7437 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 7438 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 7439 }
e0ef6b43 7440 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 7441 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5
CB		 7442 tabvec[tabidx]->dsc$w_length = 0;
7443 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7444 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7445 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 7446 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 7447 }
7448 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7449
84902520 7450 getredirection(argcp,argvp);
3bc25146
CB		 7451#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7452 {
7453# include <reentrancy.h>
f7ddb74a 7454 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 7455 }
7456#endif
84902520
TB		 7457 return;
7458}
7459/*}}}*/
7460
7461
a0d0e21e
LW		 7462/* trim_unixpath()
7463 * Trim Unix-style prefix off filespec, so it looks like what a shell
7464 * glob expansion would return (i.e. from specified prefix on, not
7465 * full path). Note that returned filespec is Unix-style, regardless
7466 * of whether input filespec was VMS-style or Unix-style.
7467 *
a3e9d8c9 7468 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 7469 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7470 * vector of options; at present, only bit 0 is used, and if set tells
7471 * trim unixpath to try the current default directory as a prefix when
7472 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 7473 *
7474 * Returns !=0 on success, with trimmed filespec replacing contents of
7475 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 7476 */
f86702cc 7477/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 7478int
2fbb330f 7479Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 7480{
a480973c 7481 char *unixified, *unixwild,
f86702cc 7482 *template, *base, *end, *cp1, *cp2;
7483 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 7484
c5375c28
JM		 7485 unixwild = PerlMem_malloc(VMS_MAXRSS);
7486 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
a3e9d8c9 7487 if (!wildspec || !fspec) return 0;
2fbb330f 7488 template = unixwild;
a3e9d8c9 7489 if (strpbrk(wildspec,"]>:") != NULL) {
a480973c 7490 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
367e4b85 7491 PerlMem_free(unixwild);
a480973c
JM		 7492 return 0;
7493 }
a3e9d8c9 7494 }
2fbb330f 7495 else {
a480973c
JM		 7496 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7497 unixwild[VMS_MAXRSS-1] = 0;
2fbb330f 7498 }
c5375c28
JM		 7499 unixified = PerlMem_malloc(VMS_MAXRSS);
7500 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
a0d0e21e 7501 if (strpbrk(fspec,"]>:") != NULL) {
a480973c 7502 if (do_tounixspec(fspec,unixified,0) == NULL) {
367e4b85
JM		 7503 PerlMem_free(unixwild);
7504 PerlMem_free(unixified);
a480973c
JM		 7505 return 0;
7506 }
a0d0e21e 7507 else base = unixified;
a3e9d8c9 7508 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7509 * check to see that final result fits into (isn't longer than) fspec */
7510 reslen = strlen(fspec);
a0d0e21e
LW		 7511 }
7512 else base = fspec;
a3e9d8c9 7513
7514 /* No prefix or absolute path on wildcard, so nothing to remove */
7515 if (!*template || *template == '/') {
367e4b85 7516 PerlMem_free(unixwild);
a480973c 7517 if (base == fspec) {
367e4b85 7518 PerlMem_free(unixified);
a480973c
JM		 7519 return 1;
7520 }
a3e9d8c9 7521 tmplen = strlen(unixified);
a480973c 7522 if (tmplen > reslen) {
367e4b85 7523 PerlMem_free(unixified);
a480973c
JM		 7524 return 0; /* not enough space */
7525 }
a3e9d8c9 7526 /* Copy unixified resultant, including trailing NUL */
7527 memmove(fspec,unixified,tmplen+1);
367e4b85 7528 PerlMem_free(unixified);
a3e9d8c9 7529 return 1;
7530 }
a0d0e21e 7531
f86702cc 7532 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7533 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7534 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7535 for (cp1 = end ;cp1 >= base; cp1--)
7536 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7537 { cp1++; break; }
7538 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 7539 PerlMem_free(unixified);
7540 PerlMem_free(unixwild);
a3e9d8c9 7541 return 1;
7542 }
f86702cc 7543 else {
a480973c 7544 char *tpl, *lcres;
f86702cc 7545 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7546 int ells = 1, totells, segdirs, match;
a480973c 7547 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 7548 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7549
7550 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7551 totells = ells;
7552 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
367e4b85 7553 tpl = PerlMem_malloc(VMS_MAXRSS);
c5375c28 7554 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
f86702cc 7555 if (ellipsis == template && opts & 1) {
7556 /* Template begins with an ellipsis. Since we can't tell how many
7557 * directory names at the front of the resultant to keep for an
7558 * arbitrary starting point, we arbitrarily choose the current
7559 * default directory as a starting point. If it's there as a prefix,
7560 * clip it off. If not, fall through and act as if the leading
7561 * ellipsis weren't there (i.e. return shortest possible path that
7562 * could match template).
7563 */
a480973c 7564 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 7565 PerlMem_free(tpl);
7566 PerlMem_free(unixified);
7567 PerlMem_free(unixwild);
a480973c
JM		 7568 return 0;
7569 }
f7ddb74a
JM		 7570 if (!decc_efs_case_preserve) {
7571 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7572 if (_tolower(*cp1) != _tolower(*cp2)) break;
7573 }
f86702cc 7574 segdirs = dirs - totells; /* Min # of dirs we must have left */
7575 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7576 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 7577 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 7578 PerlMem_free(tpl);
7579 PerlMem_free(unixified);
7580 PerlMem_free(unixwild);
f86702cc 7581 return 1;
a3e9d8c9 7582 }
a3e9d8c9 7583 }
f86702cc 7584 /* First off, back up over constant elements at end of path */
7585 if (dirs) {
7586 for (front = end ; front >= base; front--)
7587 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 7588 }
c5375c28
JM		 7589 lcres = PerlMem_malloc(VMS_MAXRSS);
7590 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 7591 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7592 cp1++,cp2++) {
7593 if (!decc_efs_case_preserve) {
7594 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7595 }
7596 else {
7597 *cp2 = *cp1;
7598 }
7599 }
7600 if (cp1 != '\0') {
367e4b85
JM		 7601 PerlMem_free(tpl);
7602 PerlMem_free(unixified);
7603 PerlMem_free(unixwild);
c5375c28 7604 PerlMem_free(lcres);
a480973c 7605 return 0; /* Path too long. */
f7ddb74a 7606 }
f86702cc 7607 lcend = cp2;
7608 *cp2 = '\0'; /* Pick up with memcpy later */
7609 lcfront = lcres + (front - base);
7610 /* Now skip over each ellipsis and try to match the path in front of it. */
7611 while (ells--) {
7612 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7613 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7614 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7615 if (cp1 < template) break; /* template started with an ellipsis */
7616 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7617 ellipsis = cp1; continue;
7618 }
a480973c 7619 wilddsc.dsc$a_pointer = tpl;
f86702cc 7620 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7621 nextell = cp1;
7622 for (segdirs = 0, cp2 = tpl;
a480973c 7623 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 7624 cp1++, cp2++) {
7625 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 7626 else {
7627 if (!decc_efs_case_preserve) {
7628 *cp2 = _tolower(*cp1); /* else lowercase for match */
7629 }
7630 else {
7631 *cp2 = *cp1; /* else preserve case for match */
7632 }
7633 }
f86702cc 7634 if (*cp2 == '/') segdirs++;
7635 }
a480973c 7636 if (cp1 != ellipsis - 1) {
367e4b85
JM		 7637 PerlMem_free(tpl);
7638 PerlMem_free(unixified);
7639 PerlMem_free(unixwild);
7640 PerlMem_free(lcres);
a480973c
JM		 7641 return 0; /* Path too long */
7642 }
f86702cc 7643 /* Back up at least as many dirs as in template before matching */
7644 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7645 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7646 for (match = 0; cp1 > lcres;) {
7647 resdsc.dsc$a_pointer = cp1;
7648 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7649 match++;
7650 if (match == 1) lcfront = cp1;
7651 }
7652 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7653 }
a480973c 7654 if (!match) {
367e4b85
JM		 7655 PerlMem_free(tpl);
7656 PerlMem_free(unixified);
7657 PerlMem_free(unixwild);
7658 PerlMem_free(lcres);
a480973c
JM		 7659 return 0; /* Can't find prefix ??? */
7660 }
f86702cc 7661 if (match > 1 && opts & 1) {
7662 /* This ... wildcard could cover more than one set of dirs (i.e.
7663 * a set of similar dir names is repeated). If the template
7664 * contains more than 1 ..., upstream elements could resolve the
7665 * ambiguity, but it's not worth a full backtracking setup here.
7666 * As a quick heuristic, clip off the current default directory
7667 * if it's present to find the trimmed spec, else use the
7668 * shortest string that this ... could cover.
7669 */
7670 char def[NAM$C_MAXRSS+1], *st;
7671
a480973c
JM		 7672 if (getcwd(def, sizeof def,0) == NULL) {
7673 Safefree(unixified);
7674 Safefree(unixwild);
7675 Safefree(lcres);
7676 Safefree(tpl);
7677 return 0;
7678 }
f7ddb74a
JM		 7679 if (!decc_efs_case_preserve) {
7680 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7681 if (_tolower(*cp1) != _tolower(*cp2)) break;
7682 }
f86702cc 7683 segdirs = dirs - totells; /* Min # of dirs we must have left */
7684 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7685 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 7686 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 7687 PerlMem_free(tpl);
7688 PerlMem_free(unixified);
7689 PerlMem_free(unixwild);
7690 PerlMem_free(lcres);
f86702cc 7691 return 1;
7692 }
7693 /* Nope -- stick with lcfront from above and keep going. */
7694 }
7695 }
18a3d61e 7696 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 7697 PerlMem_free(tpl);
7698 PerlMem_free(unixified);
7699 PerlMem_free(unixwild);
7700 PerlMem_free(lcres);
a3e9d8c9 7701 return 1;
f86702cc 7702 ellipsis = nextell;
a0d0e21e 7703 }
a0d0e21e
LW		 7704
7705} /* end of trim_unixpath() */
7706/*}}}*/
7707
a0d0e21e
LW		 7708
7709/*
7710 * VMS readdir() routines.
7711 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 7712 *
bd3fa61c 7713 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 7714 * Minor modifications to original routines.
7715 */
7716
a9852f7c
CB		 7717/* readdir may have been redefined by reentr.h, so make sure we get
7718 * the local version for what we do here.
7719 */
7720#ifdef readdir
7721# undef readdir
7722#endif
7723#if !defined(PERL_IMPLICIT_CONTEXT)
7724# define readdir Perl_readdir
7725#else
7726# define readdir(a) Perl_readdir(aTHX_ a)
7727#endif
7728
a0d0e21e
LW		 7729 /* Number of elements in vms_versions array */
7730#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7731
7732/*
7733 * Open a directory, return a handle for later use.
7734 */
7735/*{{{ DIR *opendir(char*name) */
ddcbaa1c 7736DIR *
b8ffc8df 7737Perl_opendir(pTHX_ const char *name)
a0d0e21e 7738{
ddcbaa1c 7739 DIR *dd;
657054d4 7740 char *dir;
61bb5906 7741 Stat_t sb;
657054d4 7742 int unix_flag;
61bb5906 7743
657054d4
JM		 7744 unix_flag = 0;
7745 if (decc_efs_charset) {
7746 unix_flag = is_unix_filespec(name);
7747 }
7748
7749 Newx(dir, VMS_MAXRSS, char);
a0d0e21e 7750 if (do_tovmspath(name,dir,0) == NULL) {
657054d4 7751 Safefree(dir);
61bb5906 7752 return NULL;
a0d0e21e 7753 }
ada67d10
CB		 7754 /* Check access before stat; otherwise stat does not
7755 * accurately report whether it's a directory.
7756 */
a1887106 7757 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 7758 /* cando_by_name has already set errno */
657054d4 7759 Safefree(dir);
ada67d10
CB		 7760 return NULL;
7761 }
61bb5906
CB		 7762 if (flex_stat(dir,&sb) == -1) return NULL;
7763 if (!S_ISDIR(sb.st_mode)) {
657054d4 7764 Safefree(dir);
61bb5906
CB		 7765 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7766 return NULL;
7767 }
61bb5906 7768 /* Get memory for the handle, and the pattern. */
ddcbaa1c 7769 Newx(dd,1,DIR);
a02a5408 7770 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 7771
7772 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 7773 sprintf(dd->pattern, "%s*.*",dir);
657054d4 7774 Safefree(dir);
a0d0e21e
LW		 7775 dd->context = 0;
7776 dd->count = 0;
657054d4
JM		 7777 dd->flags = 0;
7778 if (unix_flag)
7779 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
a0d0e21e
LW		 7780 dd->pat.dsc$a_pointer = dd->pattern;
7781 dd->pat.dsc$w_length = strlen(dd->pattern);
7782 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7783 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 7784#if defined(USE_ITHREADS)
a02a5408 7785 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 7786 MUTEX_INIT( (perl_mutex *) dd->mutex );
7787#else
7788 dd->mutex = NULL;
7789#endif
a0d0e21e
LW		 7790
7791 return dd;
7792} /* end of opendir() */
7793/*}}}*/
7794
7795/*
7796 * Set the flag to indicate we want versions or not.
7797 */
7798/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7799void
ddcbaa1c 7800vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 7801{
657054d4
JM		 7802 if (flag)
7803 dd->flags |= PERL_VMSDIR_M_VERSIONS;
7804 else
7805 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 7806}
7807/*}}}*/
7808
7809/*
7810 * Free up an opened directory.
7811 */
7812/*{{{ void closedir(DIR *dd)*/
7813void
ddcbaa1c 7814Perl_closedir(DIR *dd)
a0d0e21e 7815{
f7ddb74a
JM		 7816 int sts;
7817
7818 sts = lib$find_file_end(&dd->context);
a0d0e21e 7819 Safefree(dd->pattern);
3bc25146 7820#if defined(USE_ITHREADS)
a9852f7c
CB		 7821 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7822 Safefree(dd->mutex);
7823#endif
f7ddb74a 7824 Safefree(dd);
a0d0e21e
LW		 7825}
7826/*}}}*/
7827
7828/*
7829 * Collect all the version numbers for the current file.
7830 */
7831static void
ddcbaa1c 7832collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 7833{
7834 struct dsc$descriptor_s pat;
7835 struct dsc$descriptor_s res;
ddcbaa1c 7836 struct dirent *e;
657054d4 7837 char *p, *text, *buff;
a0d0e21e
LW		 7838 int i;
7839 unsigned long context, tmpsts;
7840
7841 /* Convenient shorthand. */
7842 e = &dd->entry;
7843
7844 /* Add the version wildcard, ignoring the "*.*" put on before */
7845 i = strlen(dd->pattern);
a02a5408 7846 Newx(text,i + e->d_namlen + 3,char);
f7ddb74a
JM		 7847 strcpy(text, dd->pattern);
7848 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 7849
7850 /* Set up the pattern descriptor. */
7851 pat.dsc$a_pointer = text;
7852 pat.dsc$w_length = i + e->d_namlen - 1;
7853 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7854 pat.dsc$b_class = DSC$K_CLASS_S;
7855
7856 /* Set up result descriptor. */
657054d4 7857 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 7858 res.dsc$a_pointer = buff;
657054d4 7859 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 7860 res.dsc$b_dtype = DSC$K_DTYPE_T;
7861 res.dsc$b_class = DSC$K_CLASS_S;
7862
7863 /* Read files, collecting versions. */
7864 for (context = 0, e->vms_verscount = 0;
7865 e->vms_verscount < VERSIZE(e);
7866 e->vms_verscount++) {
657054d4
JM		 7867 unsigned long rsts;
7868 unsigned long flags = 0;
7869
7870#ifdef VMS_LONGNAME_SUPPORT
988c775c 7871 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 7872#endif
7873 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 7874 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 7875 _ckvmssts(tmpsts);
657054d4 7876 buff[VMS_MAXRSS - 1] = '\0';
748a9306 7877 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 7878 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7879 else
7880 e->vms_versions[e->vms_verscount] = -1;
7881 }
7882
748a9306 7883 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 7884 Safefree(text);
657054d4 7885 Safefree(buff);
a0d0e21e
LW		 7886
7887} /* end of collectversions() */
7888
7889/*
7890 * Read the next entry from the directory.
7891 */
7892/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 7893struct dirent *
7894Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 7895{
7896 struct dsc$descriptor_s res;
657054d4 7897 char *p, *buff;
a0d0e21e 7898 unsigned long int tmpsts;
657054d4
JM		 7899 unsigned long rsts;
7900 unsigned long flags = 0;
dca5a913 7901 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 7902 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 7903
7904 /* Set up result descriptor, and get next file. */
657054d4 7905 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 7906 res.dsc$a_pointer = buff;
657054d4 7907 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 7908 res.dsc$b_dtype = DSC$K_DTYPE_T;
7909 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 7910
7911#ifdef VMS_LONGNAME_SUPPORT
988c775c 7912 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 7913#endif
7914
7915 tmpsts = lib$find_file
7916 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
4633a7c4
LW		 7917 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7918 if (!(tmpsts & 1)) {
7919 set_vaxc_errno(tmpsts);
7920 switch (tmpsts) {
7921 case RMS$_PRV:
c07a80fd 7922 set_errno(EACCES); break;
4633a7c4 7923 case RMS$_DEV:
c07a80fd 7924 set_errno(ENODEV); break;
4633a7c4 7925 case RMS$_DIR:
f282b18d
CB		 7926 set_errno(ENOTDIR); break;
7927 case RMS$_FNF: case RMS$_DNF:
c07a80fd 7928 set_errno(ENOENT); break;
4633a7c4
LW		 7929 default:
7930 set_errno(EVMSERR);
7931 }
657054d4 7932 Safefree(buff);
4633a7c4
LW		 7933 return NULL;
7934 }
7935 dd->count++;
a0d0e21e 7936 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
f7ddb74a 7937 if (!decc_efs_case_preserve) {
657054d4 7938 buff[VMS_MAXRSS - 1] = '\0';
f7ddb74a 7939 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a
JM		 7940 }
7941 else {
7942 /* we don't want to force to lowercase, just null terminate */
7943 buff[res.dsc$w_length] = '\0';
7944 }
f675dbe5 7945 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
a0d0e21e
LW		 7946 *p = '\0';
7947
7948 /* Skip any directory component and just copy the name. */
657054d4 7949 sts = vms_split_path
367e4b85 7950 (aTHX_ buff,
657054d4
JM		 7951 &v_spec,
7952 &v_len,
7953 &r_spec,
7954 &r_len,
7955 &d_spec,
7956 &d_len,
7957 &n_spec,
7958 &n_len,
7959 &e_spec,
7960 &e_len,
7961 &vs_spec,
7962 &vs_len);
7963
dca5a913
JM		 7964 /* Drop NULL extensions on UNIX file specification */
7965 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
7966 (e_len == 1) && decc_readdir_dropdotnotype)) {
7967 e_len = 0;
7968 e_spec[0] = '\0';
7969 }
7970
657054d4
JM		 7971 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
7972 dd->entry.d_name[n_len + e_len] = '\0';
7973 dd->entry.d_namlen = strlen(dd->entry.d_name);
a0d0e21e 7974
657054d4
JM		 7975 /* Convert the filename to UNIX format if needed */
7976 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
7977
7978 /* Translate the encoded characters. */
7979 /* Fixme: unicode handling could result in embedded 0 characters */
7980 if (strchr(dd->entry.d_name, '^') != NULL) {
7981 char new_name[256];
7982 char * q;
7983 int cnt;
7984 p = dd->entry.d_name;
7985 q = new_name;
7986 while (*p != 0) {
dca5a913
JM		 7987 int x, y;
7988 x = copy_expand_vms_filename_escape(q, p, &y);
7989 p += x;
7990 q += y;
7991 /* fix-me */
7992 /* if y > 1, then this is a wide file specification */
7993 /* Wide file specifications need to be passed in Perl */
7994 /* counted strings apparently with a unicode flag */
657054d4
JM		 7995 }
7996 *q = 0;
7997 strcpy(dd->entry.d_name, new_name);
7998 }
657054d4 7999 }
a0d0e21e 8000
a0d0e21e 8001 dd->entry.vms_verscount = 0;
657054d4
JM		 8002 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8003 Safefree(buff);
a0d0e21e
LW		 8004 return &dd->entry;
8005
8006} /* end of readdir() */
8007/*}}}*/
8008
8009/*
a9852f7c
CB		 8010 * Read the next entry from the directory -- thread-safe version.
8011 */
8012/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8013int
ddcbaa1c 8014Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 8015{
8016 int retval;
8017
8018 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8019
7ded3206 8020 entry = readdir(dd);
a9852f7c
CB		 8021 *result = entry;
8022 retval = ( *result == NULL ? errno : 0 );
8023
8024 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8025
8026 return retval;
8027
8028} /* end of readdir_r() */
8029/*}}}*/
8030
8031/*
a0d0e21e
LW		 8032 * Return something that can be used in a seekdir later.
8033 */
8034/*{{{ long telldir(DIR *dd)*/
8035long
ddcbaa1c 8036Perl_telldir(DIR *dd)
a0d0e21e
LW		 8037{
8038 return dd->count;
8039}
8040/*}}}*/
8041
8042/*
8043 * Return to a spot where we used to be. Brute force.
8044 */
8045/*{{{ void seekdir(DIR *dd,long count)*/
8046void
ddcbaa1c 8047Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 8048{
657054d4 8049 int old_flags;
a0d0e21e
LW		 8050
8051 /* If we haven't done anything yet... */
8052 if (dd->count == 0)
8053 return;
8054
8055 /* Remember some state, and clear it. */
657054d4
JM		 8056 old_flags = dd->flags;
8057 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 8058 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 8059 dd->context = 0;
8060
8061 /* The increment is in readdir(). */
8062 for (dd->count = 0; dd->count < count; )
f7ddb74a 8063 readdir(dd);
a0d0e21e 8064
657054d4 8065 dd->flags = old_flags;
a0d0e21e
LW		 8066
8067} /* end of seekdir() */
8068/*}}}*/
8069
8070/* VMS subprocess management
8071 *
8072 * my_vfork() - just a vfork(), after setting a flag to record that
8073 * the current script is trying a Unix-style fork/exec.
8074 *
8075 * vms_do_aexec() and vms_do_exec() are called in response to the
8076 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 8077 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 8078 * execvp (for those who really want to try this under VMS).
8079 * Otherwise, they do exactly what the perl docs say exec should
8080 * do - terminate the current script and invoke a new command
8081 * (See below for notes on command syntax.)
8082 *
8083 * do_aspawn() and do_spawn() implement the VMS side of the perl
8084 * 'system' function.
8085 *
8086 * Note on command arguments to perl 'exec' and 'system': When handled
8087 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8088 * are concatenated to form a DCL command string. If the first arg
8089 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 8090 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 8091 * the first token of the command is taken as the filespec of an image
8092 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 8093 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 8094 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 8095 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 8096 * but I hope it will form a happy medium between what VMS folks expect
8097 * from lib$spawn and what Unix folks expect from exec.
8098 */
8099
8100static int vfork_called;
8101
8102/*{{{int my_vfork()*/
8103int
8104my_vfork()
8105{
748a9306 8106 vfork_called++;
a0d0e21e
LW		 8107 return vfork();
8108}
8109/*}}}*/
8110
4633a7c4 8111
a0d0e21e 8112static void
218fdd94
CL		 8113vms_execfree(struct dsc$descriptor_s *vmscmd)
8114{
8115 if (vmscmd) {
8116 if (vmscmd->dsc$a_pointer) {
c5375c28 8117 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 8118 }
c5375c28 8119 PerlMem_free(vmscmd);
4633a7c4
LW		 8120 }
8121}
8122
8123static char *
fd8cd3a3 8124setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 8125{
4633a7c4 8126 char *junk, *tmps = Nullch;
a0d0e21e
LW		 8127 register size_t cmdlen = 0;
8128 size_t rlen;
8129 register SV **idx;
2d8e6c8d 8130 STRLEN n_a;
a0d0e21e
LW		 8131
8132 idx = mark;
4633a7c4
LW		 8133 if (really) {
8134 tmps = SvPV(really,rlen);
8135 if (*tmps) {
8136 cmdlen += rlen + 1;
8137 idx++;
8138 }
a0d0e21e
LW		 8139 }
8140
8141 for (idx++; idx <= sp; idx++) {
8142 if (*idx) {
8143 junk = SvPVx(*idx,rlen);
8144 cmdlen += rlen ? rlen + 1 : 0;
8145 }
8146 }
c5375c28 8147 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 8148
4633a7c4 8149 if (tmps && *tmps) {
6b88bc9c 8150 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 8151 mark++;
8152 }
6b88bc9c 8153 else *PL_Cmd = '\0';
a0d0e21e
LW		 8154 while (++mark <= sp) {
8155 if (*mark) {
3eeba6fb
CB		 8156 char *s = SvPVx(*mark,n_a);
8157 if (!*s) continue;
8158 if (*PL_Cmd) strcat(PL_Cmd," ");
8159 strcat(PL_Cmd,s);
a0d0e21e
LW		 8160 }
8161 }
6b88bc9c 8162 return PL_Cmd;
a0d0e21e
LW		 8163
8164} /* end of setup_argstr() */
8165
4633a7c4 8166
a0d0e21e 8167static unsigned long int
2fbb330f 8168setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 8169 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 8170{
aa779de1 8171 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
e886094b
JM		 8172 char image_name[NAM$C_MAXRSS+1];
8173 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 8174 $DESCRIPTOR(defdsc,".EXE");
8012a33e 8175 $DESCRIPTOR(defdsc2,".");
a0d0e21e 8176 $DESCRIPTOR(resdsc,resspec);
218fdd94 8177 struct dsc$descriptor_s *vmscmd;
a0d0e21e 8178 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 8179 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1 8180 register char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 8181 char * cmd;
8182 int cmdlen;
aa779de1 8183 register int isdcl;
a0d0e21e 8184
c5375c28
JM		 8185 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8186 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 8187
8188 /* Make a copy for modification */
8189 cmdlen = strlen(incmd);
c5375c28
JM		 8190 cmd = PerlMem_malloc(cmdlen+1);
8191 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 8192 strncpy(cmd, incmd, cmdlen);
8193 cmd[cmdlen] = 0;
e886094b
JM		 8194 image_name[0] = 0;
8195 image_argv[0] = 0;
2fbb330f 8196
218fdd94
CL		 8197 vmscmd->dsc$a_pointer = NULL;
8198 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8199 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8200 vmscmd->dsc$w_length = 0;
8201 if (pvmscmd) *pvmscmd = vmscmd;
8202
ff7adb52
CL		 8203 if (suggest_quote) *suggest_quote = 0;
8204
2fbb330f 8205 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 8206 PerlMem_free(cmd);
a2669cfc 8207 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 8208 }
8209
a0d0e21e 8210 s = cmd;
2fbb330f 8211
a0d0e21e 8212 while (*s && isspace(*s)) s++;
aa779de1
CB		 8213
8214 if (*s == '@' || *s == '$') {
8215 vmsspec[0] = *s; rest = s + 1;
8216 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8217 }
8218 else { cp = vmsspec; rest = s; }
8219 if (*rest == '.' || *rest == '/') {
8220 char *cp2;
8221 for (cp2 = resspec;
8222 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8223 rest++, cp2++) *cp2 = *rest;
8224 *cp2 = '\0';
8225 if (do_tovmsspec(resspec,cp,0)) {
8226 s = vmsspec;
8227 if (*rest) {
8228 for (cp2 = vmsspec + strlen(vmsspec);
8229 *rest && cp2 - vmsspec < sizeof vmsspec;
8230 rest++, cp2++) *cp2 = *rest;
8231 *cp2 = '\0';
a0d0e21e
LW		 8232 }
8233 }
8234 }
aa779de1
CB		 8235 /* Intuit whether verb (first word of cmd) is a DCL command:
8236 * - if first nonspace char is '@', it's a DCL indirection
8237 * otherwise
8238 * - if verb contains a filespec separator, it's not a DCL command
8239 * - if it doesn't, caller tells us whether to default to a DCL
8240 * command, or to a local image unless told it's DCL (by leading '$')
8241 */
ff7adb52
CL		 8242 if (*s == '@') {
8243 isdcl = 1;
8244 if (suggest_quote) *suggest_quote = 1;
8245 } else {
aa779de1
CB		 8246 register char *filespec = strpbrk(s,":<[.;");
8247 rest = wordbreak = strpbrk(s," \"\t/");
8248 if (!wordbreak) wordbreak = s + strlen(s);
8249 if (*s == '$') check_img = 0;
8250 if (filespec && (filespec < wordbreak)) isdcl = 0;
8251 else isdcl = !check_img;
8252 }
8253
3eeba6fb 8254 if (!isdcl) {
dca5a913 8255 int rsts;
aa779de1
CB		 8256 imgdsc.dsc$a_pointer = s;
8257 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 8258 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e
CB		 8259 if (!(retsts&1)) {
8260 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 8261 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 8262 if (!(retsts & 1) && *s == '$') {
8263 _ckvmssts(lib$find_file_end(&cxt));
8264 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 8265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f
JM		 8266 if (!(retsts&1)) {
8267 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 8268 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 8269 }
8270 }
aa779de1 8271 }
8012a33e
CB		 8272 _ckvmssts(lib$find_file_end(&cxt));
8273
aa779de1 8274 if (retsts & 1) {
8012a33e 8275 FILE *fp;
a0d0e21e
LW		 8276 s = resspec;
8277 while (*s && !isspace(*s)) s++;
8278 *s = '\0';
8012a33e
CB		 8279
8280 /* check that it's really not DCL with no file extension */
e886094b 8281 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 8282 if (fp) {
2497a41f
JM		 8283 char b[256] = {0,0,0,0};
8284 read(fileno(fp), b, 256);
8012a33e 8285 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 8286 if (isdcl) {
e886094b
JM		 8287 int shebang_len;
8288
2497a41f 8289 /* Check for script */
e886094b
JM		 8290 shebang_len = 0;
8291 if ((b[0] == '#') && (b[1] == '!'))
8292 shebang_len = 2;
8293#ifdef ALTERNATE_SHEBANG
8294 else {
8295 shebang_len = strlen(ALTERNATE_SHEBANG);
8296 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8297 char * perlstr;
8298 perlstr = strstr("perl",b);
8299 if (perlstr == NULL)
8300 shebang_len = 0;
8301 }
8302 else
8303 shebang_len = 0;
8304 }
8305#endif
8306
8307 if (shebang_len > 0) {
8308 int i;
8309 int j;
8310 char tmpspec[NAM$C_MAXRSS + 1];
8311
8312 i = shebang_len;
8313 /* Image is following after white space */
8314 /*--------------------------------------*/
8315 while (isprint(b[i]) && isspace(b[i]))
8316 i++;
8317
8318 j = 0;
8319 while (isprint(b[i]) && !isspace(b[i])) {
8320 tmpspec[j++] = b[i++];
8321 if (j >= NAM$C_MAXRSS)
8322 break;
8323 }
8324 tmpspec[j] = '\0';
8325
8326 /* There may be some default parameters to the image */
8327 /*---------------------------------------------------*/
8328 j = 0;
8329 while (isprint(b[i])) {
8330 image_argv[j++] = b[i++];
8331 if (j >= NAM$C_MAXRSS)
8332 break;
8333 }
8334 while ((j > 0) && !isprint(image_argv[j-1]))
8335 j--;
8336 image_argv[j] = 0;
8337
2497a41f 8338 /* It will need to be converted to VMS format and validated */
e886094b
JM		 8339 if (tmpspec[0] != '\0') {
8340 char * iname;
8341
8342 /* Try to find the exact program requested to be run */
8343 /*---------------------------------------------------*/
8344 iname = do_rmsexpand
8345 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8346 if (iname != NULL) {
a1887106
JM		 8347 if (cando_by_name_int
8348 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 8349 /* MCR prefix needed */
8350 isdcl = 0;
8351 }
8352 else {
8353 /* Try again with a null type */
8354 /*----------------------------*/
8355 iname = do_rmsexpand
8356 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8357 if (iname != NULL) {
a1887106
JM		 8358 if (cando_by_name_int
8359 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 8360 /* MCR prefix needed */
8361 isdcl = 0;
8362 }
8363 }
8364 }
8365
8366 /* Did we find the image to run the script? */
8367 /*------------------------------------------*/
8368 if (isdcl) {
8369 char *tchr;
8370
8371 /* Assume DCL or foreign command exists */
8372 /*--------------------------------------*/
8373 tchr = strrchr(tmpspec, '/');
8374 if (tchr != NULL) {
8375 tchr++;
8376 }
8377 else {
8378 tchr = tmpspec;
8379 }
8380 strcpy(image_name, tchr);
8381 }
8382 }
8383 }
2497a41f
JM		 8384 }
8385 }
8012a33e
CB		 8386 fclose(fp);
8387 }
8388 if (check_img && isdcl) return RMS$_FNF;
8389
3eeba6fb 8390 if (cando_by_name(S_IXUSR,0,resspec)) {
c5375c28
JM		 8391 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8392 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8012a33e 8393 if (!isdcl) {
218fdd94 8394 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
e886094b
JM		 8395 if (image_name[0] != 0) {
8396 strcat(vmscmd->dsc$a_pointer, image_name);
8397 strcat(vmscmd->dsc$a_pointer, " ");
8398 }
8399 } else if (image_name[0] != 0) {
8400 strcpy(vmscmd->dsc$a_pointer, image_name);
8401 strcat(vmscmd->dsc$a_pointer, " ");
8012a33e 8402 } else {
218fdd94 8403 strcpy(vmscmd->dsc$a_pointer,"@");
8012a33e 8404 }
e886094b
JM		 8405 if (suggest_quote) *suggest_quote = 1;
8406
8407 /* If there is an image name, use original command */
8408 if (image_name[0] == 0)
8409 strcat(vmscmd->dsc$a_pointer,resspec);
8410 else {
8411 rest = cmd;
8412 while (*rest && isspace(*rest)) rest++;
8413 }
8414
8415 if (image_argv[0] != 0) {
8416 strcat(vmscmd->dsc$a_pointer,image_argv);
8417 strcat(vmscmd->dsc$a_pointer, " ");
8418 }
8419 if (rest) {
8420 int rest_len;
8421 int vmscmd_len;
8422
8423 rest_len = strlen(rest);
8424 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8425 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8426 strcat(vmscmd->dsc$a_pointer,rest);
8427 else
8428 retsts = CLI$_BUFOVF;
8429 }
218fdd94 8430 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 8431 PerlMem_free(cmd);
218fdd94 8432 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 8433 }
c5375c28
JM		 8434 else
8435 retsts = RMS$_PRV;
a0d0e21e
LW		 8436 }
8437 }
3eeba6fb 8438 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 8439 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 8440
b011c7bd 8441 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
c5375c28 8442 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
b011c7bd 8443 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
c5375c28
JM		 8444
8445 PerlMem_free(cmd);
2fbb330f 8446
ff7adb52
CL		 8447 /* check if it's a symbol (for quoting purposes) */
8448 if (suggest_quote && !*suggest_quote) {
8449 int iss;
8450 char equiv[LNM$C_NAMLENGTH];
8451 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8452 eqvdsc.dsc$a_pointer = equiv;
8453
218fdd94 8454 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 8455 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8456 }
3eeba6fb
CB		 8457 if (!(retsts & 1)) {
8458 /* just hand off status values likely to be due to user error */
8459 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8460 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8461 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8462 else { _ckvmssts(retsts); }
8463 }
a0d0e21e 8464
218fdd94 8465 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 8466
a0d0e21e
LW		 8467} /* end of setup_cmddsc() */
8468
a3e9d8c9 8469
a0d0e21e
LW		 8470/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8471bool
fd8cd3a3 8472Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 8473{
c5375c28
JM		 8474bool exec_sts;
8475char * cmd;
8476
a0d0e21e
LW		 8477 if (sp > mark) {
8478 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 8479 vfork_called--;
8480 if (vfork_called < 0) {
5c84aa53 8481 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 8482 vfork_called = 0;
8483 }
8484 else return do_aexec(really,mark,sp);
a0d0e21e 8485 }
4633a7c4 8486 /* no vfork - act VMSish */
c5375c28
JM		 8487 cmd = setup_argstr(aTHX_ really,mark,sp);
8488 exec_sts = vms_do_exec(cmd);
8489 Safefree(cmd); /* Clean up from setup_argstr() */
8490 return exec_sts;
a0d0e21e
LW		 8491 }
8492
8493 return FALSE;
8494} /* end of vms_do_aexec() */
8495/*}}}*/
8496
8497/* {{{bool vms_do_exec(char *cmd) */
8498bool
2fbb330f 8499Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 8500{
218fdd94 8501 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 8502
8503 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 8504 vfork_called--;
8505 if (vfork_called < 0) {
5c84aa53 8506 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 8507 vfork_called = 0;
8508 }
8509 else return do_exec(cmd);
a0d0e21e 8510 }
748a9306
LW		 8511
8512 { /* no vfork - act VMSish */
748a9306 8513 unsigned long int retsts;
a0d0e21e 8514
1e422769 8515 TAINT_ENV();
8516 TAINT_PROPER("exec");
218fdd94
CL		 8517 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8518 retsts = lib$do_command(vmscmd);
a0d0e21e 8519
09b7f37c 8520 switch (retsts) {
f282b18d 8521 case RMS$_FNF: case RMS$_DNF:
09b7f37c 8522 set_errno(ENOENT); break;
f282b18d 8523 case RMS$_DIR:
09b7f37c 8524 set_errno(ENOTDIR); break;
f282b18d
CB		 8525 case RMS$_DEV:
8526 set_errno(ENODEV); break;
09b7f37c
CB		 8527 case RMS$_PRV:
8528 set_errno(EACCES); break;
8529 case RMS$_SYN:
8530 set_errno(EINVAL); break;
a2669cfc 8531 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 8532 set_errno(E2BIG); break;
8533 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8534 _ckvmssts(retsts); /* fall through */
8535 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8536 set_errno(EVMSERR);
8537 }
748a9306 8538 set_vaxc_errno(retsts);
3eeba6fb 8539 if (ckWARN(WARN_EXEC)) {
f98bc0c6 8540 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 8541 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 8542 }
218fdd94 8543 vms_execfree(vmscmd);
a0d0e21e
LW		 8544 }
8545
8546 return FALSE;
8547
8548} /* end of vms_do_exec() */
8549/*}}}*/
8550
2fbb330f 8551unsigned long int Perl_do_spawn(pTHX_ const char *);
a0d0e21e 8552
61bb5906 8553/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
a0d0e21e 8554unsigned long int
fd8cd3a3 8555Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
a0d0e21e 8556{
c5375c28
JM		 8557unsigned long int sts;
8558char * cmd;
a0d0e21e 8559
c5375c28
JM		 8560 if (sp > mark) {
8561 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8562 sts = do_spawn(cmd);
8563 /* pp_sys will clean up cmd */
8564 return sts;
8565 }
a0d0e21e
LW		 8566 return SS$_ABORT;
8567} /* end of do_aspawn() */
8568/*}}}*/
8569
8570/* {{{unsigned long int do_spawn(char *cmd) */
8571unsigned long int
2fbb330f 8572Perl_do_spawn(pTHX_ const char *cmd)
a0d0e21e 8573{
209030df 8574 unsigned long int sts, substs;
a0d0e21e 8575
c5375c28
JM		 8576 /* The caller of this routine expects to Safefree(PL_Cmd) */
8577 Newx(PL_Cmd,10,char);
8578
1e422769 8579 TAINT_ENV();
8580 TAINT_PROPER("spawn");
748a9306 8581 if (!cmd || !*cmd) {
09b7f37c 8582 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 8583 if (!(sts & 1)) {
8584 switch (sts) {
209030df
JH		 8585 case RMS$_FNF: case RMS$_DNF:
8586 set_errno(ENOENT); break;
8587 case RMS$_DIR:
8588 set_errno(ENOTDIR); break;
8589 case RMS$_DEV:
8590 set_errno(ENODEV); break;
8591 case RMS$_PRV:
8592 set_errno(EACCES); break;
8593 case RMS$_SYN:
8594 set_errno(EINVAL); break;
8595 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8596 set_errno(E2BIG); break;
8597 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8598 _ckvmssts(sts); /* fall through */
8599 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8600 set_errno(EVMSERR);
c8795d8b
JH		 8601 }
8602 set_vaxc_errno(sts);
8603 if (ckWARN(WARN_EXEC)) {
f98bc0c6 8604 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 8605 Strerror(errno));
8606 }
09b7f37c 8607 }
c8795d8b 8608 sts = substs;
48023aa8
CL		 8609 }
8610 else {
2fbb330f
JM		 8611 PerlIO * fp;
8612 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8613 if (fp != NULL)
8614 my_pclose(fp);
48023aa8 8615 }
48023aa8 8616 return sts;
a0d0e21e
LW		 8617} /* end of do_spawn() */
8618/*}}}*/
8619
bc10a425
CB		 8620
8621static unsigned int *sockflags, sockflagsize;
8622
8623/*
8624 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8625 * routines found in some versions of the CRTL can't deal with sockets.
8626 * We don't shim the other file open routines since a socket isn't
8627 * likely to be opened by a name.
8628 */
275feba9
CB		 8629/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8630FILE *my_fdopen(int fd, const char *mode)
bc10a425 8631{
f7ddb74a 8632 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 8633
8634 if (fp) {
8635 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 8636 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 8637 if (!sockflagsize || fdoff > sockflagsize) {
8638 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 8639 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 8640 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8641 sockflagsize = fdoff + 2;
8642 }
2497a41f 8643 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 8644 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8645 }
8646 return fp;
8647
8648}
8649/*}}}*/
8650
8651
8652/*
8653 * Clear the corresponding bit when the (possibly) socket stream is closed.
8654 * There still a small hole: we miss an implicit close which might occur
8655 * via freopen(). >> Todo
8656 */
8657/*{{{ int my_fclose(FILE *fp)*/
8658int my_fclose(FILE *fp) {
8659 if (fp) {
8660 unsigned int fd = fileno(fp);
8661 unsigned int fdoff = fd / sizeof(unsigned int);
8662
8663 if (sockflagsize && fdoff <= sockflagsize)
8664 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8665 }
8666 return fclose(fp);
8667}
8668/*}}}*/
8669
8670
a0d0e21e
LW		 8671/*
8672 * A simple fwrite replacement which outputs itmsz*nitm chars without
8673 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 8674 * We are using fputs, which depends on a terminating null. We may
8675 * well be writing binary data, so we need to accommodate not only
8676 * data with nulls sprinkled in the middle but also data with no null
8677 * byte at the end.
a0d0e21e 8678 */
a15cef0c 8679/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 8680int
a15cef0c 8681my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 8682{
22d4bb9c 8683 register char *cp, *end, *cpd, *data;
bc10a425
CB		 8684 register unsigned int fd = fileno(dest);
8685 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 8686 int retval;
bc10a425
CB		 8687 int bufsize = itmsz * nitm + 1;
8688
8689 if (fdoff < sockflagsize &&
8690 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8691 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8692 return nitm;
8693 }
22d4bb9c 8694
bc10a425 8695 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 8696 memcpy( data, src, itmsz*nitm );
8697 data[itmsz*nitm] = '\0';
a0d0e21e 8698
22d4bb9c
CB		 8699 end = data + itmsz * nitm;
8700 retval = (int) nitm; /* on success return # items written */
a0d0e21e 8701
22d4bb9c
CB		 8702 cpd = data;
8703 while (cpd <= end) {
8704 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8705 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 8706 if (cp < end)
22d4bb9c
CB		 8707 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8708 cpd = cp + 1;
a0d0e21e
LW		 8709 }
8710
bc10a425 8711 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 8712 return retval;
a0d0e21e
LW		 8713
8714} /* end of my_fwrite() */
8715/*}}}*/
8716
d27fe803
JH		 8717/*{{{ int my_flush(FILE *fp)*/
8718int
fd8cd3a3 8719Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 8720{
8721 int res;
93948341 8722 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 8723#ifdef VMS_DO_SOCKETS
61bb5906 8724 Stat_t s;
d27fe803
JH		 8725 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8726#endif
8727 res = fsync(fileno(fp));
8728 }
22d4bb9c
CB		 8729/*
8730 * If the flush succeeded but set end-of-file, we need to clear
8731 * the error because our caller may check ferror(). BTW, this
8732 * probably means we just flushed an empty file.
8733 */
8734 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8735
d27fe803
JH		 8736 return res;
8737}
8738/*}}}*/
8739
748a9306
LW		 8740/*
8741 * Here are replacements for the following Unix routines in the VMS environment:
8742 * getpwuid Get information for a particular UIC or UID
8743 * getpwnam Get information for a named user
8744 * getpwent Get information for each user in the rights database
8745 * setpwent Reset search to the start of the rights database
8746 * endpwent Finish searching for users in the rights database
8747 *
8748 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8749 * (defined in pwd.h), which contains the following fields:-
8750 * struct passwd {
8751 * char *pw_name; Username (in lower case)
8752 * char *pw_passwd; Hashed password
8753 * unsigned int pw_uid; UIC
8754 * unsigned int pw_gid; UIC group number
8755 * char *pw_unixdir; Default device/directory (VMS-style)
8756 * char *pw_gecos; Owner name
8757 * char *pw_dir; Default device/directory (Unix-style)
8758 * char *pw_shell; Default CLI name (eg. DCL)
8759 * };
8760 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8761 *
8762 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8763 * not the UIC member number (eg. what's returned by getuid()),
8764 * getpwuid() can accept either as input (if uid is specified, the caller's
8765 * UIC group is used), though it won't recognise gid=0.
8766 *
8767 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8768 * information about other users in your group or in other groups, respectively.
8769 * If the required privilege is not available, then these routines fill only
8770 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8771 * string).
8772 *
8773 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8774 */
8775
8776/* sizes of various UAF record fields */
8777#define UAI$S_USERNAME 12
8778#define UAI$S_IDENT 31
8779#define UAI$S_OWNER 31
8780#define UAI$S_DEFDEV 31
8781#define UAI$S_DEFDIR 63
8782#define UAI$S_DEFCLI 31
8783#define UAI$S_PWD 8
8784
8785#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8786 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8787 (uic).uic$v_group != UIC$K_WILD_GROUP)
8788
4633a7c4
LW		 8789static char __empty[]= "";
8790static struct passwd __passwd_empty=
748a9306
LW		 8791 {(char *) __empty, (char *) __empty, 0, 0,
8792 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8793static int contxt= 0;
8794static struct passwd __pwdcache;
8795static char __pw_namecache[UAI$S_IDENT+1];
8796
748a9306
LW		 8797/*
8798 * This routine does most of the work extracting the user information.
8799 */
fd8cd3a3 8800static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 8801{
748a9306
LW		 8802 static struct {
8803 unsigned char length;
8804 char pw_gecos[UAI$S_OWNER+1];
8805 } owner;
8806 static union uicdef uic;
8807 static struct {
8808 unsigned char length;
8809 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8810 } defdev;
8811 static struct {
8812 unsigned char length;
8813 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8814 } defdir;
8815 static struct {
8816 unsigned char length;
8817 char pw_shell[UAI$S_DEFCLI+1];
8818 } defcli;
8819 static char pw_passwd[UAI$S_PWD+1];
8820
8821 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8822 struct dsc$descriptor_s name_desc;
c07a80fd 8823 unsigned long int sts;
748a9306 8824
4633a7c4 8825 static struct itmlst_3 itmlst[]= {
748a9306
LW		 8826 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8827 {sizeof(uic), UAI$_UIC, &uic, &luic},
8828 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8829 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8830 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8831 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8832 {0, 0, NULL, NULL}};
8833
8834 name_desc.dsc$w_length= strlen(name);
8835 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8836 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 8837 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 8838
8839/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 8840 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8841 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8842 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8843 }
8844 else { _ckvmssts(sts); }
8845 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 8846
8847 if ((int) owner.length < lowner) lowner= (int) owner.length;
8848 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8849 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8850 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8851 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8852 owner.pw_gecos[lowner]= '\0';
8853 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8854 defcli.pw_shell[ldefcli]= '\0';
8855 if (valid_uic(uic)) {
8856 pwd->pw_uid= uic.uic$l_uic;
8857 pwd->pw_gid= uic.uic$v_group;
8858 }
8859 else
5c84aa53 8860 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 8861 pwd->pw_passwd= pw_passwd;
8862 pwd->pw_gecos= owner.pw_gecos;
8863 pwd->pw_dir= defdev.pw_dir;
8864 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8865 pwd->pw_shell= defcli.pw_shell;
8866 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8867 int ldir;
8868 ldir= strlen(pwd->pw_unixdir) - 1;
8869 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8870 }
8871 else
8872 strcpy(pwd->pw_unixdir, pwd->pw_dir);
f7ddb74a
JM		 8873 if (!decc_efs_case_preserve)
8874 __mystrtolower(pwd->pw_unixdir);
c07a80fd 8875 return 1;
a0d0e21e 8876}
748a9306
LW		 8877
8878/*
8879 * Get information for a named user.
8880*/
8881/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 8882struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 8883{
8884 struct dsc$descriptor_s name_desc;
8885 union uicdef uic;
aa689395 8886 unsigned long int status, sts;
748a9306
LW		 8887
8888 __pwdcache = __passwd_empty;
fd8cd3a3 8889 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 8890 /* We still may be able to determine pw_uid and pw_gid */
8891 name_desc.dsc$w_length= strlen(name);
8892 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8893 name_desc.dsc$b_class= DSC$K_CLASS_S;
8894 name_desc.dsc$a_pointer= (char *) name;
aa689395 8895 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 8896 __pwdcache.pw_uid= uic.uic$l_uic;
8897 __pwdcache.pw_gid= uic.uic$v_group;
8898 }
c07a80fd 8899 else {
aa689395 8900 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8901 set_vaxc_errno(sts);
8902 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 8903 return NULL;
8904 }
aa689395 8905 else { _ckvmssts(sts); }
c07a80fd 8906 }
748a9306 8907 }
748a9306
LW		 8908 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8909 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8910 __pwdcache.pw_name= __pw_namecache;
8911 return &__pwdcache;
8912} /* end of my_getpwnam() */
a0d0e21e
LW		 8913/*}}}*/
8914
748a9306
LW		 8915/*
8916 * Get information for a particular UIC or UID.
8917 * Called by my_getpwent with uid=-1 to list all users.
8918*/
8919/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 8920struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 8921{
748a9306
LW		 8922 const $DESCRIPTOR(name_desc,__pw_namecache);
8923 unsigned short lname;
8924 union uicdef uic;
8925 unsigned long int status;
8926
8927 if (uid == (unsigned int) -1) {
8928 do {
8929 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8930 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 8931 set_vaxc_errno(status);
8932 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 8933 my_endpwent();
8934 return NULL;
8935 }
8936 else { _ckvmssts(status); }
8937 } while (!valid_uic (uic));
8938 }
8939 else {
8940 uic.uic$l_uic= uid;
c07a80fd 8941 if (!uic.uic$v_group)
76e3520e 8942 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 8943 if (valid_uic(uic))
8944 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8945 else status = SS$_IVIDENT;
c07a80fd 8946 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8947 status == RMS$_PRV) {
8948 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8949 return NULL;
8950 }
8951 else { _ckvmssts(status); }
748a9306
LW		 8952 }
8953 __pw_namecache[lname]= '\0';
01b8edb6 8954 __mystrtolower(__pw_namecache);
748a9306
LW		 8955
8956 __pwdcache = __passwd_empty;
8957 __pwdcache.pw_name = __pw_namecache;
8958
8959/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8960 The identifier's value is usually the UIC, but it doesn't have to be,
8961 so if we can, we let fillpasswd update this. */
8962 __pwdcache.pw_uid = uic.uic$l_uic;
8963 __pwdcache.pw_gid = uic.uic$v_group;
8964
fd8cd3a3 8965 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 8966 return &__pwdcache;
a0d0e21e 8967
748a9306
LW		 8968} /* end of my_getpwuid() */
8969/*}}}*/
8970
8971/*
8972 * Get information for next user.
8973*/
8974/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 8975struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 8976{
8977 return (my_getpwuid((unsigned int) -1));
8978}
8979/*}}}*/
a0d0e21e 8980
748a9306
LW		 8981/*
8982 * Finish searching rights database for users.
8983*/
8984/*{{{void my_endpwent()*/
fd8cd3a3 8985void Perl_my_endpwent(pTHX)
748a9306
LW		 8986{
8987 if (contxt) {
8988 _ckvmssts(sys$finish_rdb(&contxt));
8989 contxt= 0;
8990 }
a0d0e21e
LW		 8991}
8992/*}}}*/
748a9306 8993
61bb5906
CB		 8994#ifdef HOMEGROWN_POSIX_SIGNALS
8995 /* Signal handling routines, pulled into the core from POSIX.xs.
8996 *
8997 * We need these for threads, so they've been rolled into the core,
8998 * rather than left in POSIX.xs.
8999 *
9000 * (DRS, Oct 23, 1997)
9001 */
5b411029 9002
61bb5906
CB		 9003 /* sigset_t is atomic under VMS, so these routines are easy */
9004/*{{{int my_sigemptyset(sigset_t *) */
5b411029 9005int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 9006 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9007 *set = 0; return 0;
5b411029 9008}
61bb5906
CB		 9009/*}}}*/
9010
9011
9012/*{{{int my_sigfillset(sigset_t *)*/
5b411029 9013int my_sigfillset(sigset_t *set) {
61bb5906
CB		 9014 int i;
9015 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9016 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9017 return 0;
5b411029 9018}
61bb5906
CB		 9019/*}}}*/
9020
9021
9022/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 9023int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 9024 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9025 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9026 *set |= (1 << (sig - 1));
9027 return 0;
5b411029 9028}
61bb5906
CB		 9029/*}}}*/
9030
9031
9032/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 9033int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 9034 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9035 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9036 *set &= ~(1 << (sig - 1));
9037 return 0;
5b411029 9038}
61bb5906
CB		 9039/*}}}*/
9040
9041
9042/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 9043int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 9044 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9045 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 9046 return *set & (1 << (sig - 1));
5b411029 9047}
61bb5906 9048/*}}}*/
5b411029 9049
5b411029 9050
61bb5906
CB		 9051/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9052int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9053 sigset_t tempmask;
9054
9055 /* If set and oset are both null, then things are badly wrong. Bail out. */
9056 if ((oset == NULL) && (set == NULL)) {
9057 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 9058 return -1;
9059 }
5b411029 9060
61bb5906
CB		 9061 /* If set's null, then we're just handling a fetch. */
9062 if (set == NULL) {
9063 tempmask = sigblock(0);
9064 }
9065 else {
9066 switch (how) {
9067 case SIG_SETMASK:
9068 tempmask = sigsetmask(*set);
9069 break;
9070 case SIG_BLOCK:
9071 tempmask = sigblock(*set);
9072 break;
9073 case SIG_UNBLOCK:
9074 tempmask = sigblock(0);
9075 sigsetmask(*oset & ~tempmask);
9076 break;
9077 default:
9078 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9079 return -1;
9080 }
9081 }
9082
9083 /* Did they pass us an oset? If so, stick our holding mask into it */
9084 if (oset)
9085 *oset = tempmask;
5b411029 9086
61bb5906 9087 return 0;
5b411029 9088}
61bb5906
CB		 9089/*}}}*/
9090#endif /* HOMEGROWN_POSIX_SIGNALS */
9091
5b411029 9092
ff0cee69 9093/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9094 * my_utime(), and flex_stat(), all of which operate on UTC unless
9095 * VMSISH_TIMES is true.
9096 */
9097/* method used to handle UTC conversions:
9098 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 9099 */
ff0cee69 9100static int gmtime_emulation_type;
9101/* number of secs to add to UTC POSIX-style time to get local time */
9102static long int utc_offset_secs;
e518068a 9103
ff0cee69 9104/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9105 * in vmsish.h. #undef them here so we can call the CRTL routines
9106 * directly.
e518068a 9107 */
9108#undef gmtime
ff0cee69 9109#undef localtime
9110#undef time
9111
61bb5906 9112
a44ceb8e
CB		 9113/*
9114 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9115 * qualifier with the extern prefix pragma. This provisional
9116 * hack circumvents this prefix pragma problem in previous
9117 * precompilers.
9118 */
9119#if defined(__VMS_VER) && __VMS_VER >= 70000000
9120# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9121# pragma __extern_prefix save
9122# pragma __extern_prefix "" /* set to empty to prevent prefixing */
9123# define gmtime decc$__utctz_gmtime
9124# define localtime decc$__utctz_localtime
9125# define time decc$__utc_time
9126# pragma __extern_prefix restore
9127
9128 struct tm *gmtime(), *localtime();
9129
9130# endif
9131#endif
9132
9133
61bb5906
CB		 9134static time_t toutc_dst(time_t loc) {
9135 struct tm *rsltmp;
9136
9137 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9138 loc -= utc_offset_secs;
9139 if (rsltmp->tm_isdst) loc -= 3600;
9140 return loc;
9141}
32da55ab 9142#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 9143 ((gmtime_emulation_type || my_time(NULL)), \
9144 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9145 ((secs) - utc_offset_secs))))
9146
9147static time_t toloc_dst(time_t utc) {
9148 struct tm *rsltmp;
9149
9150 utc += utc_offset_secs;
9151 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9152 if (rsltmp->tm_isdst) utc += 3600;
9153 return utc;
9154}
32da55ab 9155#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 9156 ((gmtime_emulation_type || my_time(NULL)), \
9157 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9158 ((secs) + utc_offset_secs))))
9159
22d4bb9c
CB		 9160#ifndef RTL_USES_UTC
9161/*
9162
9163 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9164 DST starts on 1st sun of april at 02:00 std time
9165 ends on last sun of october at 02:00 dst time
9166 see the UCX management command reference, SET CONFIG TIMEZONE
9167 for formatting info.
9168
9169 No, it's not as general as it should be, but then again, NOTHING
9170 will handle UK times in a sensible way.
9171*/
9172
9173
9174/*
9175 parse the DST start/end info:
9176 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9177*/
9178
9179static char *
9180tz_parse_startend(char *s, struct tm *w, int *past)
9181{
9182 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9183 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9184 time_t g;
9185
9186 if (!s) return 0;
9187 if (!w) return 0;
9188 if (!past) return 0;
9189
9190 ly = 0;
9191 if (w->tm_year % 4 == 0) ly = 1;
9192 if (w->tm_year % 100 == 0) ly = 0;
9193 if (w->tm_year+1900 % 400 == 0) ly = 1;
9194 if (ly) dinm[1]++;
9195
9196 dozjd = isdigit(*s);
9197 if (*s == 'J' || *s == 'j' || dozjd) {
9198 if (!dozjd && !isdigit(*++s)) return 0;
9199 d = *s++ - '0';
9200 if (isdigit(*s)) {
9201 d = d*10 + *s++ - '0';
9202 if (isdigit(*s)) {
9203 d = d*10 + *s++ - '0';
9204 }
9205 }
9206 if (d == 0) return 0;
9207 if (d > 366) return 0;
9208 d--;
9209 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9210 g = d * 86400;
9211 dozjd = 1;
9212 } else if (*s == 'M' || *s == 'm') {
9213 if (!isdigit(*++s)) return 0;
9214 m = *s++ - '0';
9215 if (isdigit(*s)) m = 10*m + *s++ - '0';
9216 if (*s != '.') return 0;
9217 if (!isdigit(*++s)) return 0;
9218 n = *s++ - '0';
9219 if (n < 1 || n > 5) return 0;
9220 if (*s != '.') return 0;
9221 if (!isdigit(*++s)) return 0;
9222 d = *s++ - '0';
9223 if (d > 6) return 0;
9224 }
9225
9226 if (*s == '/') {
9227 if (!isdigit(*++s)) return 0;
9228 hour = *s++ - '0';
9229 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9230 if (*s == ':') {
9231 if (!isdigit(*++s)) return 0;
9232 min = *s++ - '0';
9233 if (isdigit(*s)) min = 10*min + *s++ - '0';
9234 if (*s == ':') {
9235 if (!isdigit(*++s)) return 0;
9236 sec = *s++ - '0';
9237 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9238 }
9239 }
9240 } else {
9241 hour = 2;
9242 min = 0;
9243 sec = 0;
9244 }
9245
9246 if (dozjd) {
9247 if (w->tm_yday < d) goto before;
9248 if (w->tm_yday > d) goto after;
9249 } else {
9250 if (w->tm_mon+1 < m) goto before;
9251 if (w->tm_mon+1 > m) goto after;
9252
9253 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9254 k = d - j; /* mday of first d */
9255 if (k <= 0) k += 7;
9256 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9257 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9258 if (w->tm_mday < k) goto before;
9259 if (w->tm_mday > k) goto after;
9260 }
9261
9262 if (w->tm_hour < hour) goto before;
9263 if (w->tm_hour > hour) goto after;
9264 if (w->tm_min < min) goto before;
9265 if (w->tm_min > min) goto after;
9266 if (w->tm_sec < sec) goto before;
9267 goto after;
9268
9269before:
9270 *past = 0;
9271 return s;
9272after:
9273 *past = 1;
9274 return s;
9275}
9276
9277
9278
9279
9280/* parse the offset: (+|-)hh[:mm[:ss]] */
9281
9282static char *
9283tz_parse_offset(char *s, int *offset)
9284{
9285 int hour = 0, min = 0, sec = 0;
9286 int neg = 0;
9287 if (!s) return 0;
9288 if (!offset) return 0;
9289
9290 if (*s == '-') {neg++; s++;}
9291 if (*s == '+') s++;
9292 if (!isdigit(*s)) return 0;
9293 hour = *s++ - '0';
9294 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9295 if (hour > 24) return 0;
9296 if (*s == ':') {
9297 if (!isdigit(*++s)) return 0;
9298 min = *s++ - '0';
9299 if (isdigit(*s)) min = min*10 + (*s++ - '0');
9300 if (min > 59) return 0;
9301 if (*s == ':') {
9302 if (!isdigit(*++s)) return 0;
9303 sec = *s++ - '0';
9304 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9305 if (sec > 59) return 0;
9306 }
9307 }
9308
9309 *offset = (hour*60+min)*60 + sec;
9310 if (neg) *offset = -*offset;
9311 return s;
9312}
9313
9314/*
9315 input time is w, whatever type of time the CRTL localtime() uses.
9316 sets dst, the zone, and the gmtoff (seconds)
9317
9318 caches the value of TZ and UCX$TZ env variables; note that
9319 my_setenv looks for these and sets a flag if they're changed
9320 for efficiency.
9321
9322 We have to watch out for the "australian" case (dst starts in
9323 october, ends in april)...flagged by "reverse" and checked by
9324 scanning through the months of the previous year.
9325
9326*/
9327
9328static int
fd8cd3a3 9329tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 9330{
9331 time_t when;
9332 struct tm *w2;
9333 char *s,*s2;
9334 char *dstzone, *tz, *s_start, *s_end;
9335 int std_off, dst_off, isdst;
9336 int y, dststart, dstend;
9337 static char envtz[1025]; /* longer than any logical, symbol, ... */
9338 static char ucxtz[1025];
9339 static char reversed = 0;
9340
9341 if (!w) return 0;
9342
9343 if (tz_updated) {
9344 tz_updated = 0;
9345 reversed = -1; /* flag need to check */
9346 envtz[0] = ucxtz[0] = '\0';
9347 tz = my_getenv("TZ",0);
9348 if (tz) strcpy(envtz, tz);
9349 tz = my_getenv("UCX$TZ",0);
9350 if (tz) strcpy(ucxtz, tz);
9351 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9352 }
9353 tz = envtz;
9354 if (!*tz) tz = ucxtz;
9355
9356 s = tz;
9357 while (isalpha(*s)) s++;
9358 s = tz_parse_offset(s, &std_off);
9359 if (!s) return 0;
9360 if (!*s) { /* no DST, hurray we're done! */
9361 isdst = 0;
9362 goto done;
9363 }
9364
9365 dstzone = s;
9366 while (isalpha(*s)) s++;
9367 s2 = tz_parse_offset(s, &dst_off);
9368 if (s2) {
9369 s = s2;
9370 } else {
9371 dst_off = std_off - 3600;
9372 }
9373
9374 if (!*s) { /* default dst start/end?? */
9375 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9376 s = strchr(ucxtz,',');
9377 }
9378 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9379 }
9380 if (*s != ',') return 0;
9381
9382 when = *w;
9383 when = _toutc(when); /* convert to utc */
9384 when = when - std_off; /* convert to pseudolocal time*/
9385
9386 w2 = localtime(&when);
9387 y = w2->tm_year;
9388 s_start = s+1;
9389 s = tz_parse_startend(s_start,w2,&dststart);
9390 if (!s) return 0;
9391 if (*s != ',') return 0;
9392
9393 when = *w;
9394 when = _toutc(when); /* convert to utc */
9395 when = when - dst_off; /* convert to pseudolocal time*/
9396 w2 = localtime(&when);
9397 if (w2->tm_year != y) { /* spans a year, just check one time */
9398 when += dst_off - std_off;
9399 w2 = localtime(&when);
9400 }
9401 s_end = s+1;
9402 s = tz_parse_startend(s_end,w2,&dstend);
9403 if (!s) return 0;
9404
9405 if (reversed == -1) { /* need to check if start later than end */
9406 int j, ds, de;
9407
9408 when = *w;
9409 if (when < 2*365*86400) {
9410 when += 2*365*86400;
9411 } else {
9412 when -= 365*86400;
9413 }
9414 w2 =localtime(&when);
9415 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9416
9417 for (j = 0; j < 12; j++) {
9418 w2 =localtime(&when);
f7ddb74a
JM		 9419 tz_parse_startend(s_start,w2,&ds);
9420 tz_parse_startend(s_end,w2,&de);
22d4bb9c
CB		 9421 if (ds != de) break;
9422 when += 30*86400;
9423 }
9424 reversed = 0;
9425 if (de && !ds) reversed = 1;
9426 }
9427
9428 isdst = dststart && !dstend;
9429 if (reversed) isdst = dststart || !dstend;
9430
9431done:
9432 if (dst) *dst = isdst;
9433 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9434 if (isdst) tz = dstzone;
9435 if (zone) {
9436 while(isalpha(*tz)) *zone++ = *tz++;
9437 *zone = '\0';
9438 }
9439 return 1;
9440}
9441
9442#endif /* !RTL_USES_UTC */
61bb5906 9443
ff0cee69 9444/* my_time(), my_localtime(), my_gmtime()
61bb5906 9445 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 9446 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 9447 * Note: We need to use these functions even when the CRTL has working
9448 * UTC support, since they also handle C<use vmsish qw(times);>
9449 *
ff0cee69 9450 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 9451 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 9452 */
9453
9454/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 9455time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 9456{
e518068a 9457 time_t when;
61bb5906 9458 struct tm *tm_p;
e518068a 9459
9460 if (gmtime_emulation_type == 0) {
61bb5906
CB		 9461 int dstnow;
9462 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9463 /* results of calls to gmtime() and localtime() */
9464 /* for same &base */
ff0cee69 9465
e518068a 9466 gmtime_emulation_type++;
ff0cee69 9467 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 9468 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 9469
e518068a 9470 gmtime_emulation_type++;
f675dbe5 9471 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 9472 gmtime_emulation_type++;
22d4bb9c 9473 utc_offset_secs = 0;
5c84aa53 9474 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 9475 }
9476 else { utc_offset_secs = atol(off); }
e518068a 9477 }
ff0cee69 9478 else { /* We've got a working gmtime() */
9479 struct tm gmt, local;
e518068a 9480
ff0cee69 9481 gmt = *tm_p;
9482 tm_p = localtime(&base);
9483 local = *tm_p;
9484 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9485 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9486 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9487 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9488 }
e518068a 9489 }
ff0cee69 9490
9491 when = time(NULL);
61bb5906
CB		 9492# ifdef VMSISH_TIME
9493# ifdef RTL_USES_UTC
9494 if (VMSISH_TIME) when = _toloc(when);
9495# else
9496 if (!VMSISH_TIME) when = _toutc(when);
9497# endif
9498# endif
ff0cee69 9499 if (timep != NULL) *timep = when;
9500 return when;
9501
9502} /* end of my_time() */
9503/*}}}*/
9504
9505
9506/*{{{struct tm *my_gmtime(const time_t *timep)*/
9507struct tm *
fd8cd3a3 9508Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 9509{
9510 char *p;
9511 time_t when;
61bb5906 9512 struct tm *rsltmp;
ff0cee69 9513
68dc0745 9514 if (timep == NULL) {
9515 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9516 return NULL;
9517 }
9518 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 9519
9520 when = *timep;
9521# ifdef VMSISH_TIME
61bb5906
CB		 9522 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9523# endif
9524# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9525 return gmtime(&when);
9526# else
ff0cee69 9527 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 9528 rsltmp = localtime(&when);
9529 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9530 return rsltmp;
9531#endif
e518068a 9532} /* end of my_gmtime() */
e518068a 9533/*}}}*/
9534
9535
ff0cee69 9536/*{{{struct tm *my_localtime(const time_t *timep)*/
9537struct tm *
fd8cd3a3 9538Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 9539{
22d4bb9c 9540 time_t when, whenutc;
61bb5906 9541 struct tm *rsltmp;
22d4bb9c 9542 int dst, offset;
ff0cee69 9543
68dc0745 9544 if (timep == NULL) {
9545 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9546 return NULL;
9547 }
9548 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 9549 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 9550
9551 when = *timep;
61bb5906 9552# ifdef RTL_USES_UTC
ff0cee69 9553# ifdef VMSISH_TIME
61bb5906 9554 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 9555# endif
61bb5906 9556 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 9557 return localtime(&when);
22d4bb9c
CB		 9558
9559# else /* !RTL_USES_UTC */
9560 whenutc = when;
61bb5906 9561# ifdef VMSISH_TIME
22d4bb9c
CB		 9562 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9563 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 9564# endif
22d4bb9c
CB		 9565 dst = -1;
9566#ifndef RTL_USES_UTC
32af7c23 9567 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 9568 when = whenutc - offset; /* pseudolocal time*/
9569 }
61bb5906
CB		 9570# endif
9571 /* CRTL localtime() wants local time as input, so does no tz correction */
9572 rsltmp = localtime(&when);
22d4bb9c 9573 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 9574 return rsltmp;
22d4bb9c 9575# endif
ff0cee69 9576
9577} /* end of my_localtime() */
9578/*}}}*/
9579
9580/* Reset definitions for later calls */
9581#define gmtime(t) my_gmtime(t)
9582#define localtime(t) my_localtime(t)
9583#define time(t) my_time(t)
9584
9585
941b3de1
CB		 9586/* my_utime - update modification/access time of a file
9587 *
9588 * VMS 7.3 and later implementation
9589 * Only the UTC translation is home-grown. The rest is handled by the
9590 * CRTL utime(), which will take into account the relevant feature
9591 * logicals and ODS-5 volume characteristics for true access times.
9592 *
9593 * pre VMS 7.3 implementation:
9594 * The calling sequence is identical to POSIX utime(), but under
9595 * VMS with ODS-2, only the modification time is changed; ODS-2 does
9596 * not maintain access times. Restrictions differ from the POSIX
ff0cee69 9597 * definition in that the time can be changed as long as the
9598 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9599 * no separate checks are made to insure that the caller is the
9600 * owner of the file or has special privs enabled.
9601 * Code here is based on Joe Meadows' FILE utility.
941b3de1 9602 *
ff0cee69 9603 */
9604
9605/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9606 * to VMS epoch (01-JAN-1858 00:00:00.00)
9607 * in 100 ns intervals.
9608 */
9609static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9610
94a11853
CB		 9611/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9612int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 9613{
941b3de1
CB		 9614#if __CRTL_VER >= 70300000
9615 struct utimbuf utc_utimes, *utc_utimesp;
9616
9617 if (utimes != NULL) {
9618 utc_utimes.actime = utimes->actime;
9619 utc_utimes.modtime = utimes->modtime;
9620# ifdef VMSISH_TIME
9621 /* If input was local; convert to UTC for sys svc */
9622 if (VMSISH_TIME) {
9623 utc_utimes.actime = _toutc(utimes->actime);
9624 utc_utimes.modtime = _toutc(utimes->modtime);
9625 }
9626# endif
9627 utc_utimesp = &utc_utimes;
9628 }
9629 else {
9630 utc_utimesp = NULL;
9631 }
9632
9633 return utime(file, utc_utimesp);
9634
9635#else /* __CRTL_VER < 70300000 */
9636
ff0cee69 9637 register int i;
f7ddb74a 9638 int sts;
ff0cee69 9639 long int bintime[2], len = 2, lowbit, unixtime,
9640 secscale = 10000000; /* seconds --> 100 ns intervals */
9641 unsigned long int chan, iosb[2], retsts;
9642 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9643 struct FAB myfab = cc$rms_fab;
9644 struct NAM mynam = cc$rms_nam;
9645#if defined (__DECC) && defined (__VAX)
9646 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9647 * at least through VMS V6.1, which causes a type-conversion warning.
9648 */
9649# pragma message save
9650# pragma message disable cvtdiftypes
9651#endif
9652 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9653 struct fibdef myfib;
9654#if defined (__DECC) && defined (__VAX)
9655 /* This should be right after the declaration of myatr, but due
9656 * to a bug in VAX DEC C, this takes effect a statement early.
9657 */
9658# pragma message restore
9659#endif
f7ddb74a 9660 /* cast ok for read only parameter */
ff0cee69 9661 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9662 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9663 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
704c2eb3 9664
ff0cee69 9665 if (file == NULL || *file == '\0') {
941b3de1 9666 SETERRNO(ENOENT, LIB$_INVARG);
ff0cee69 9667 return -1;
9668 }
704c2eb3
JM		 9669
9670 /* Convert to VMS format ensuring that it will fit in 255 characters */
941b3de1
CB		 9671 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
9672 SETERRNO(ENOENT, LIB$_INVARG);
9673 return -1;
9674 }
ff0cee69 9675 if (utimes != NULL) {
9676 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9677 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9678 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9679 * as input, we force the sign bit to be clear by shifting unixtime right
9680 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9681 */
9682 lowbit = (utimes->modtime & 1) ? secscale : 0;
9683 unixtime = (long int) utimes->modtime;
61bb5906
CB		 9684# ifdef VMSISH_TIME
9685 /* If input was UTC; convert to local for sys svc */
9686 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 9687# endif
1a6334fb 9688 unixtime >>= 1; secscale <<= 1;
ff0cee69 9689 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9690 if (!(retsts & 1)) {
941b3de1 9691 SETERRNO(EVMSERR, retsts);
ff0cee69 9692 return -1;
9693 }
9694 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9695 if (!(retsts & 1)) {
941b3de1 9696 SETERRNO(EVMSERR, retsts);
ff0cee69 9697 return -1;
9698 }
9699 }
9700 else {
9701 /* Just get the current time in VMS format directly */
9702 retsts = sys$gettim(bintime);
9703 if (!(retsts & 1)) {
941b3de1 9704 SETERRNO(EVMSERR, retsts);
ff0cee69 9705 return -1;
9706 }
9707 }
9708
9709 myfab.fab$l_fna = vmsspec;
9710 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9711 myfab.fab$l_nam = &mynam;
9712 mynam.nam$l_esa = esa;
9713 mynam.nam$b_ess = (unsigned char) sizeof esa;
9714 mynam.nam$l_rsa = rsa;
9715 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 9716 if (decc_efs_case_preserve)
9717 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 9718
9719 /* Look for the file to be affected, letting RMS parse the file
9720 * specification for us as well. I have set errno using only
9721 * values documented in the utime() man page for VMS POSIX.
9722 */
9723 retsts = sys$parse(&myfab,0,0);
9724 if (!(retsts & 1)) {
9725 set_vaxc_errno(retsts);
9726 if (retsts == RMS$_PRV) set_errno(EACCES);
9727 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9728 else set_errno(EVMSERR);
9729 return -1;
9730 }
9731 retsts = sys$search(&myfab,0,0);
9732 if (!(retsts & 1)) {
752635ea 9733 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9734 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9735 set_vaxc_errno(retsts);
9736 if (retsts == RMS$_PRV) set_errno(EACCES);
9737 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9738 else set_errno(EVMSERR);
9739 return -1;
9740 }
9741
9742 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 9743 /* cast ok for read only parameter */
ff0cee69 9744 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9745
9746 retsts = sys$assign(&devdsc,&chan,0,0);
9747 if (!(retsts & 1)) {
752635ea 9748 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9749 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9750 set_vaxc_errno(retsts);
9751 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9752 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9753 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9754 else set_errno(EVMSERR);
9755 return -1;
9756 }
9757
9758 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9759 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9760
9761 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 9762#if defined(__DECC) || defined(__DECCXX)
ff0cee69 9763 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9764 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9765 /* This prevents the revision time of the file being reset to the current
9766 * time as a result of our IO$_MODIFY $QIO. */
9767 myfib.fib$l_acctl = FIB$M_NORECORD;
9768#else
9769 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9770 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9771 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9772#endif
9773 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 9774 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 9775 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 9776 _ckvmssts(sys$dassgn(chan));
9777 if (retsts & 1) retsts = iosb[0];
9778 if (!(retsts & 1)) {
9779 set_vaxc_errno(retsts);
9780 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9781 else set_errno(EVMSERR);
9782 return -1;
9783 }
9784
9785 return 0;
941b3de1
CB		 9786
9787#endif /* #if __CRTL_VER >= 70300000 */
9788
ff0cee69 9789} /* end of my_utime() */
9790/*}}}*/
9791
748a9306 9792/*
2497a41f 9793 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 9794 * basic stat, but gets it right when asked to stat
9795 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9796 */
9797
2497a41f 9798#ifndef _USE_STD_STAT
748a9306
LW		 9799/* encode_dev packs a VMS device name string into an integer to allow
9800 * simple comparisons. This can be used, for example, to check whether two
9801 * files are located on the same device, by comparing their encoded device
9802 * names. Even a string comparison would not do, because stat() reuses the
9803 * device name buffer for each call; so without encode_dev, it would be
9804 * necessary to save the buffer and use strcmp (this would mean a number of
9805 * changes to the standard Perl code, to say nothing of what a Perl script
9806 * would have to do.
9807 *
9808 * The device lock id, if it exists, should be unique (unless perhaps compared
9809 * with lock ids transferred from other nodes). We have a lock id if the disk is
9810 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9811 * device names. Thus we use the lock id in preference, and only if that isn't
9812 * available, do we try to pack the device name into an integer (flagged by
9813 * the sign bit (LOCKID_MASK) being set).
9814 *
e518068a 9815 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 9816 * name and its encoded form, but it seems very unlikely that we will find
9817 * two files on different disks that share the same encoded device names,
9818 * and even more remote that they will share the same file id (if the test
9819 * is to check for the same file).
9820 *
9821 * A better method might be to use sys$device_scan on the first call, and to
9822 * search for the device, returning an index into the cached array.
9823 * The number returned would be more intelligable.
9824 * This is probably not worth it, and anyway would take quite a bit longer
9825 * on the first call.
9826 */
9827#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 9828static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 9829{
9830 int i;
9831 unsigned long int f;
aa689395 9832 mydev_t enc;
748a9306
LW		 9833 char c;
9834 const char *q;
9835
9836 if (!dev || !dev[0]) return 0;
9837
9838#if LOCKID_MASK
9839 {
9840 struct dsc$descriptor_s dev_desc;
9841 unsigned long int status, lockid, item = DVI$_LOCKID;
9842
9843 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9844 can try that first. */
9845 dev_desc.dsc$w_length = strlen (dev);
9846 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9847 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 9848 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
748a9306
LW		 9849 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9850 if (lockid) return (lockid & ~LOCKID_MASK);
9851 }
a0d0e21e 9852#endif
748a9306
LW		 9853
9854 /* Otherwise we try to encode the device name */
9855 enc = 0;
9856 f = 1;
9857 i = 0;
9858 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 9859 if (*q == ':')
9860 break;
748a9306
LW		 9861 if (isdigit (*q))
9862 c= (*q) - '0';
9863 else if (isalpha (toupper (*q)))
9864 c= toupper (*q) - 'A' + (char)10;
9865 else
9866 continue; /* Skip '$'s */
9867 i++;
9868 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9869 if (i>1) f *= 36;
9870 enc += f * (unsigned long int) c;
9871 }
9872 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9873
9874} /* end of encode_dev() */
cfcfe586
JM		 9875#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9876 device_no = encode_dev(aTHX_ devname)
9877#else
9878#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9879 device_no = new_dev_no
2497a41f 9880#endif
748a9306 9881
748a9306
LW		 9882static int
9883is_null_device(name)
9884 const char *name;
9885{
2497a41f 9886 if (decc_bug_devnull != 0) {
682e4b71 9887 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 9888 return 1;
9889 }
748a9306
LW		 9890 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9891 The underscore prefix, controller letter, and unit number are
9892 independently optional; for our purposes, the colon punctuation
9893 is not. The colon can be trailed by optional directory and/or
9894 filename, but two consecutive colons indicates a nodename rather
9895 than a device. [pr] */
9896 if (*name == '_') ++name;
9897 if (tolower(*name++) != 'n') return 0;
9898 if (tolower(*name++) != 'l') return 0;
9899 if (tolower(*name) == 'a') ++name;
9900 if (*name == '0') ++name;
9901 return (*name++ == ':') && (*name != ':');
9902}
9903
c07a80fd 9904
a1887106
JM		 9905static I32
9906Perl_cando_by_name_int
9907 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306
LW		 9908{
9909 static char usrname[L_cuserid];
9910 static struct dsc$descriptor_s usrdsc =
9911 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
657054d4
JM		 9912 char vmsname[NAM$C_MAXRSS+1];
9913 char *fileified;
597c27e2 9914 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 9915 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 9916 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9917 union prvdef curprv;
597c27e2
CB		 9918 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9919 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
9920 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 9921 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9922 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9923 {0,0,0,0}};
9924 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 9925 {0,0,0,0}};
ada67d10 9926 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
748a9306
LW		 9927
9928 if (!fname || !*fname) return FALSE;
01b8edb6 9929 /* Make sure we expand logical names, since sys$check_access doesn't */
a1887106
JM		 9930
9931 fileified = NULL;
9932 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
9933 fileified = PerlMem_malloc(VMS_MAXRSS);
9934 if (!strpbrk(fname,"/]>:")) {
9935 strcpy(fileified,fname);
9936 trnlnm_iter_count = 0;
9937 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 9938 trnlnm_iter_count++;
9939 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 9940 }
9941 fname = fileified;
2d9f3838 9942 }
a1887106
JM		 9943 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
9944 PerlMem_free(fileified);
9945 return FALSE;
9946 }
9947 retlen = namdsc.dsc$w_length = strlen(vmsname);
9948 namdsc.dsc$a_pointer = vmsname;
9949 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
a5f75d66 9950 vmsname[retlen-1] == ':') {
a1887106
JM		 9951 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9952 namdsc.dsc$w_length = strlen(fileified);
9953 namdsc.dsc$a_pointer = fileified;
9954 }
9955 }
9956 else {
9957 retlen = namdsc.dsc$w_length = strlen(fname);
9958 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
a5f75d66
AD		 9959 }
9960
748a9306 9961 switch (bit) {
f282b18d 9962 case S_IXUSR: case S_IXGRP: case S_IXOTH:
597c27e2
CB		 9963 access = ARM$M_EXECUTE;
9964 flags = CHP$M_READ;
9965 break;
f282b18d 9966 case S_IRUSR: case S_IRGRP: case S_IROTH:
597c27e2
CB		 9967 access = ARM$M_READ;
9968 flags = CHP$M_READ | CHP$M_USEREADALL;
9969 break;
f282b18d 9970 case S_IWUSR: case S_IWGRP: case S_IWOTH:
597c27e2
CB		 9971 access = ARM$M_WRITE;
9972 flags = CHP$M_READ | CHP$M_WRITE;
9973 break;
f282b18d 9974 case S_IDUSR: case S_IDGRP: case S_IDOTH:
597c27e2
CB		 9975 access = ARM$M_DELETE;
9976 flags = CHP$M_READ | CHP$M_WRITE;
9977 break;
748a9306 9978 default:
a1887106
JM		 9979 if (fileified != NULL)
9980 PerlMem_free(fileified);
748a9306
LW		 9981 return FALSE;
9982 }
9983
ada67d10
CB		 9984 /* Before we call $check_access, create a user profile with the current
9985 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 9986 * UAF and might give false positives or negatives. This only works on
9987 * VMS versions v6.0 and later since that's when sys$create_user_profile
9988 * became available.
ada67d10
CB		 9989 */
9990
9991 /* get current process privs and username */
9992 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9993 _ckvmssts(iosb[0]);
9994
baf3cf9c
CB		 9995#if defined(__VMS_VER) && __VMS_VER >= 60000000
9996
ada67d10
CB		 9997 /* find out the space required for the profile */
9998 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9999 &usrprodsc.dsc$w_length,0));
10000
10001 /* allocate space for the profile and get it filled in */
c5375c28
JM		 10002 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10003 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
ada67d10
CB		 10004 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10005 &usrprodsc.dsc$w_length,0));
10006
10007 /* use the profile to check access to the file; free profile & analyze results */
10008 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
c5375c28 10009 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 10010 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c
CB		 10011
10012#else
10013
10014 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10015
10016#endif
10017
bbce6d69 10018 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 10019 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 10020 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 10021 set_vaxc_errno(retsts);
10022 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10023 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10024 else set_errno(ENOENT);
a1887106
JM		 10025 if (fileified != NULL)
10026 PerlMem_free(fileified);
a3e9d8c9 10027 return FALSE;
10028 }
ada67d10 10029 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 10030 if (fileified != NULL)
10031 PerlMem_free(fileified);
3a385817
GS		 10032 return TRUE;
10033 }
748a9306
LW		 10034 _ckvmssts(retsts);
10035
a1887106
JM		 10036 if (fileified != NULL)
10037 PerlMem_free(fileified);
748a9306
LW		 10038 return FALSE; /* Should never get here */
10039
a1887106
JM		 10040}
10041
10042/* Do the permissions allow some operation? Assumes PL_statcache already set. */
10043/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10044 * subset of the applicable information.
10045 */
10046bool
10047Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10048{
10049 return cando_by_name_int
10050 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10051} /* end of cando() */
10052/*}}}*/
10053
10054
10055/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10056I32
10057Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10058{
10059 return cando_by_name_int(bit, effective, fname, 0);
10060
748a9306
LW		 10061} /* end of cando_by_name() */
10062/*}}}*/
10063
10064
61bb5906 10065/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 10066int
fd8cd3a3 10067Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 10068{
b7ae7a0d 10069 if (!fstat(fd,(stat_t *) statbufp)) {
75796008 10070 char *cptr;
988c775c
JM		 10071 char *vms_filename;
10072 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10073 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 10074
988c775c
JM		 10075 /* Save name for cando by name in VMS format */
10076 cptr = getname(fd, vms_filename, 1);
75796008 10077
988c775c
JM		 10078 /* This should not happen, but just in case */
10079 if (cptr == NULL) {
10080 statbufp->st_devnam[0] = 0;
10081 }
10082 else {
10083 /* Make sure that the saved name fits in 255 characters */
10084 cptr = do_rmsexpand
10085 (vms_filename,
10086 statbufp->st_devnam,
10087 0,
10088 NULL,
a1887106 10089 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN);
75796008 10090 if (cptr == NULL)
988c775c 10091 statbufp->st_devnam[0] = 0;
75796008 10092 }
988c775c 10093 PerlMem_free(vms_filename);
682e4b71
JM		 10094
10095 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 10096 VMS_DEVICE_ENCODE
10097 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 10098
61bb5906
CB		 10099# ifdef RTL_USES_UTC
10100# ifdef VMSISH_TIME
10101 if (VMSISH_TIME) {
10102 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10103 statbufp->st_atime = _toloc(statbufp->st_atime);
10104 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10105 }
10106# endif
10107# else
ff0cee69 10108# ifdef VMSISH_TIME
10109 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10110# else
10111 if (1) {
10112# endif
61bb5906
CB		 10113 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10114 statbufp->st_atime = _toutc(statbufp->st_atime);
10115 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 10116 }
61bb5906 10117#endif
b7ae7a0d 10118 return 0;
10119 }
10120 return -1;
748a9306
LW		 10121
10122} /* end of flex_fstat() */
10123/*}}}*/
10124
2497a41f
JM		 10125#if !defined(__VAX) && __CRTL_VER >= 80200000
10126#ifdef lstat
10127#undef lstat
10128#endif
10129#else
10130#ifdef lstat
10131#undef lstat
10132#endif
10133#define lstat(_x, _y) stat(_x, _y)
10134#endif
10135
7ded3206
CB		 10136#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10137
2497a41f
JM		 10138static int
10139Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 10140{
988c775c
JM		 10141 char fileified[VMS_MAXRSS];
10142 char temp_fspec[VMS_MAXRSS];
10143 char *save_spec;
bbce6d69 10144 int retval = -1;
9543c6b6 10145 int saved_errno, saved_vaxc_errno;
748a9306 10146
e956e27a 10147 if (!fspec) return retval;
9543c6b6 10148 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
cc077a9f 10149 strcpy(temp_fspec, fspec);
988c775c 10150
2497a41f
JM		 10151 if (decc_bug_devnull != 0) {
10152 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10153 memset(statbufp,0,sizeof *statbufp);
cfcfe586 10154 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 10155 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10156 statbufp->st_uid = 0x00010001;
10157 statbufp->st_gid = 0x0001;
10158 time((time_t *)&statbufp->st_mtime);
10159 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10160 return 0;
10161 }
748a9306
LW		 10162 }
10163
bbce6d69 10164 /* Try for a directory name first. If fspec contains a filename without
61bb5906 10165 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 10166 * and sea:[wine.dark]water. exist, we prefer the directory here.
10167 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10168 * not sea:[wine.dark]., if the latter exists. If the intended target is
10169 * the file with null type, specify this by calling flex_stat() with
10170 * a '.' at the end of fspec.
2497a41f
JM		 10171 *
10172 * If we are in Posix filespec mode, accept the filename as is.
bbce6d69 10173 */
2497a41f
JM		 10174#if __CRTL_VER >= 80200000 && !defined(__VAX)
10175 if (decc_posix_compliant_pathnames == 0) {
10176#endif
cc077a9f 10177 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
2497a41f
JM		 10178 if (lstat_flag == 0)
10179 retval = stat(fileified,(stat_t *) statbufp);
10180 else
10181 retval = lstat(fileified,(stat_t *) statbufp);
988c775c 10182 save_spec = fileified;
748a9306 10183 }
2497a41f
JM		 10184 if (retval) {
10185 if (lstat_flag == 0)
10186 retval = stat(temp_fspec,(stat_t *) statbufp);
10187 else
10188 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 10189 save_spec = temp_fspec;
2497a41f
JM		 10190 }
10191#if __CRTL_VER >= 80200000 && !defined(__VAX)
10192 } else {
10193 if (lstat_flag == 0)
10194 retval = stat(temp_fspec,(stat_t *) statbufp);
10195 else
10196 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 10197 save_spec = temp_fspec;
2497a41f
JM		 10198 }
10199#endif
ff0cee69 10200 if (!retval) {
988c775c
JM		 10201 char * cptr;
10202 cptr = do_rmsexpand
10203 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS);
10204 if (cptr == NULL)
10205 statbufp->st_devnam[0] = 0;
10206
682e4b71 10207 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 10208 VMS_DEVICE_ENCODE
10209 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 10210# ifdef RTL_USES_UTC
10211# ifdef VMSISH_TIME
10212 if (VMSISH_TIME) {
10213 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10214 statbufp->st_atime = _toloc(statbufp->st_atime);
10215 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10216 }
10217# endif
10218# else
ff0cee69 10219# ifdef VMSISH_TIME
10220 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10221# else
10222 if (1) {
10223# endif
61bb5906
CB		 10224 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10225 statbufp->st_atime = _toutc(statbufp->st_atime);
10226 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 10227 }
61bb5906 10228# endif
ff0cee69 10229 }
9543c6b6
CB		 10230 /* If we were successful, leave errno where we found it */
10231 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
748a9306
LW		 10232 return retval;
10233
2497a41f
JM		 10234} /* end of flex_stat_int() */
10235
10236
10237/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10238int
10239Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10240{
7ded3206 10241 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 10242}
10243/*}}}*/
10244
10245/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10246int
10247Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10248{
7ded3206 10249 return flex_stat_int(fspec, statbufp, 1);
2497a41f 10250}
748a9306
LW		 10251/*}}}*/
10252
b7ae7a0d 10253
c07a80fd 10254/*{{{char *my_getlogin()*/
10255/* VMS cuserid == Unix getlogin, except calling sequence */
10256char *
2fbb330f 10257my_getlogin(void)
c07a80fd 10258{
10259 static char user[L_cuserid];
10260 return cuserid(user);
10261}
10262/*}}}*/
10263
10264
a5f75d66
AD		 10265/* rmscopy - copy a file using VMS RMS routines
10266 *
10267 * Copies contents and attributes of spec_in to spec_out, except owner
10268 * and protection information. Name and type of spec_in are used as
a3e9d8c9 10269 * defaults for spec_out. The third parameter specifies whether rmscopy()
10270 * should try to propagate timestamps from the input file to the output file.
10271 * If it is less than 0, no timestamps are preserved. If it is 0, then
10272 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10273 * propagated to the output file at creation iff the output file specification
10274 * did not contain an explicit name or type, and the revision date is always
10275 * updated at the end of the copy operation. If it is greater than 0, then
10276 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10277 * other than the revision date should be propagated, and bit 1 indicates
10278 * that the revision date should be propagated.
10279 *
10280 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 10281 *
bd3fa61c 10282 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 10283 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 10284 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
10285 * as part of the Perl standard distribution under the terms of the
10286 * GNU General Public License or the Perl Artistic License. Copies
10287 * of each may be found in the Perl standard distribution.
a480973c 10288 */ /* FIXME */
a3e9d8c9 10289/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 10290int
10291Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10292{
10293 char *vmsin, * vmsout, *esa, *esa_out,
10294 *rsa, *ubf;
10295 unsigned long int i, sts, sts2;
a1887106 10296 int dna_len;
a480973c
JM		 10297 struct FAB fab_in, fab_out;
10298 struct RAB rab_in, rab_out;
a1887106
JM		 10299 rms_setup_nam(nam);
10300 rms_setup_nam(nam_out);
a480973c
JM		 10301 struct XABDAT xabdat;
10302 struct XABFHC xabfhc;
10303 struct XABRDT xabrdt;
10304 struct XABSUM xabsum;
10305
c5375c28
JM		 10306 vmsin = PerlMem_malloc(VMS_MAXRSS);
10307 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10308 vmsout = PerlMem_malloc(VMS_MAXRSS);
10309 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 10310 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10311 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
c5375c28
JM		 10312 PerlMem_free(vmsin);
10313 PerlMem_free(vmsout);
a480973c
JM		 10314 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10315 return 0;
10316 }
10317
c5375c28
JM		 10318 esa = PerlMem_malloc(VMS_MAXRSS);
10319 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 10320 fab_in = cc$rms_fab;
a1887106 10321 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 10322 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10323 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10324 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 10325 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 10326 fab_in.fab$l_xab = (void *) &xabdat;
10327
c5375c28
JM		 10328 rsa = PerlMem_malloc(VMS_MAXRSS);
10329 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
a1887106
JM		 10330 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
10331 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
10332 rms_nam_esl(nam) = 0;
10333 rms_nam_rsl(nam) = 0;
10334 rms_nam_esll(nam) = 0;
10335 rms_nam_rsll(nam) = 0;
a480973c
JM		 10336#ifdef NAM$M_NO_SHORT_UPCASE
10337 if (decc_efs_case_preserve)
a1887106 10338 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 10339#endif
10340
10341 xabdat = cc$rms_xabdat; /* To get creation date */
10342 xabdat.xab$l_nxt = (void *) &xabfhc;
10343
10344 xabfhc = cc$rms_xabfhc; /* To get record length */
10345 xabfhc.xab$l_nxt = (void *) &xabsum;
10346
10347 xabsum = cc$rms_xabsum; /* To get key and area information */
10348
10349 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 10350 PerlMem_free(vmsin);
10351 PerlMem_free(vmsout);
10352 PerlMem_free(esa);
10353 PerlMem_free(rsa);
a480973c
JM		 10354 set_vaxc_errno(sts);
10355 switch (sts) {
10356 case RMS$_FNF: case RMS$_DNF:
10357 set_errno(ENOENT); break;
10358 case RMS$_DIR:
10359 set_errno(ENOTDIR); break;
10360 case RMS$_DEV:
10361 set_errno(ENODEV); break;
10362 case RMS$_SYN:
10363 set_errno(EINVAL); break;
10364 case RMS$_PRV:
10365 set_errno(EACCES); break;
10366 default:
10367 set_errno(EVMSERR);
10368 }
10369 return 0;
10370 }
10371
10372 nam_out = nam;
10373 fab_out = fab_in;
10374 fab_out.fab$w_ifi = 0;
10375 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10376 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10377 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 10378 rms_bind_fab_nam(fab_out, nam_out);
10379 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
10380 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
10381 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
c5375c28
JM		 10382 esa_out = PerlMem_malloc(VMS_MAXRSS);
10383 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
a1887106
JM		 10384 rms_set_rsa(nam_out, NULL, 0);
10385 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
a480973c
JM		 10386
10387 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 10388 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 10389 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 10390 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 10391 PerlMem_free(vmsin);
10392 PerlMem_free(vmsout);
10393 PerlMem_free(esa);
10394 PerlMem_free(rsa);
10395 PerlMem_free(esa_out);
a480973c
JM		 10396 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10397 set_vaxc_errno(sts);
10398 return 0;
10399 }
10400 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 10401 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
10402 preserve_dates = 1;
a480973c
JM		 10403 }
10404 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10405 preserve_dates =0; /* bitmask from this point forward */
10406
10407 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 10408 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 10409 PerlMem_free(vmsin);
10410 PerlMem_free(vmsout);
10411 PerlMem_free(esa);
10412 PerlMem_free(rsa);
10413 PerlMem_free(esa_out);
a480973c
JM		 10414 set_vaxc_errno(sts);
10415 switch (sts) {
10416 case RMS$_DNF:
10417 set_errno(ENOENT); break;
10418 case RMS$_DIR:
10419 set_errno(ENOTDIR); break;
10420 case RMS$_DEV:
10421 set_errno(ENODEV); break;
10422 case RMS$_SYN:
10423 set_errno(EINVAL); break;
10424 case RMS$_PRV:
10425 set_errno(EACCES); break;
10426 default:
10427 set_errno(EVMSERR);
10428 }
10429 return 0;
10430 }
10431 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10432 if (preserve_dates & 2) {
10433 /* sys$close() will process xabrdt, not xabdat */
10434 xabrdt = cc$rms_xabrdt;
10435#ifndef __GNUC__
10436 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10437#else
10438 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10439 * is unsigned long[2], while DECC & VAXC use a struct */
10440 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10441#endif
10442 fab_out.fab$l_xab = (void *) &xabrdt;
10443 }
10444
c5375c28
JM		 10445 ubf = PerlMem_malloc(32256);
10446 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 10447 rab_in = cc$rms_rab;
10448 rab_in.rab$l_fab = &fab_in;
10449 rab_in.rab$l_rop = RAB$M_BIO;
10450 rab_in.rab$l_ubf = ubf;
10451 rab_in.rab$w_usz = 32256;
10452 if (!((sts = sys$connect(&rab_in)) & 1)) {
10453 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 10454 PerlMem_free(vmsin);
10455 PerlMem_free(vmsout);
10456 PerlMem_free(esa);
10457 PerlMem_free(ubf);
10458 PerlMem_free(rsa);
10459 PerlMem_free(esa_out);
a480973c
JM		 10460 set_errno(EVMSERR); set_vaxc_errno(sts);
10461 return 0;
10462 }
10463
10464 rab_out = cc$rms_rab;
10465 rab_out.rab$l_fab = &fab_out;
10466 rab_out.rab$l_rbf = ubf;
10467 if (!((sts = sys$connect(&rab_out)) & 1)) {
10468 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 10469 PerlMem_free(vmsin);
10470 PerlMem_free(vmsout);
10471 PerlMem_free(esa);
10472 PerlMem_free(ubf);
10473 PerlMem_free(rsa);
10474 PerlMem_free(esa_out);
a480973c
JM		 10475 set_errno(EVMSERR); set_vaxc_errno(sts);
10476 return 0;
10477 }
10478
10479 while ((sts = sys$read(&rab_in))) { /* always true */
10480 if (sts == RMS$_EOF) break;
10481 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10482 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10483 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 10484 PerlMem_free(vmsin);
10485 PerlMem_free(vmsout);
10486 PerlMem_free(esa);
10487 PerlMem_free(ubf);
10488 PerlMem_free(rsa);
10489 PerlMem_free(esa_out);
a480973c
JM		 10490 set_errno(EVMSERR); set_vaxc_errno(sts);
10491 return 0;
10492 }
10493 }
10494
10495
10496 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10497 sys$close(&fab_in); sys$close(&fab_out);
10498 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10499 if (!(sts & 1)) {
c5375c28
JM		 10500 PerlMem_free(vmsin);
10501 PerlMem_free(vmsout);
10502 PerlMem_free(esa);
10503 PerlMem_free(ubf);
10504 PerlMem_free(rsa);
10505 PerlMem_free(esa_out);
a480973c
JM		 10506 set_errno(EVMSERR); set_vaxc_errno(sts);
10507 return 0;
10508 }
10509
c5375c28
JM		 10510 PerlMem_free(vmsin);
10511 PerlMem_free(vmsout);
10512 PerlMem_free(esa);
10513 PerlMem_free(ubf);
10514 PerlMem_free(rsa);
10515 PerlMem_free(esa_out);
a480973c
JM		 10516 return 1;
10517
10518} /* end of rmscopy() */
a5f75d66
AD		 10519/*}}}*/
10520
10521
748a9306
LW		 10522/*** The following glue provides 'hooks' to make some of the routines
10523 * from this file available from Perl. These routines are sufficiently
10524 * basic, and are required sufficiently early in the build process,
10525 * that's it's nice to have them available to miniperl as well as the
10526 * full Perl, so they're set up here instead of in an extension. The
10527 * Perl code which handles importation of these names into a given
10528 * package lives in [.VMS]Filespec.pm in @INC.
10529 */
10530
10531void
5c84aa53 10532rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 10533{
10534 dXSARGS;
bbce6d69 10535 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 10536 STRLEN n_a;
01b8edb6 10537
bbce6d69 10538 if (!items || items > 2)
5c84aa53 10539 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 10540 fspec = SvPV(ST(0),n_a);
bbce6d69 10541 if (!fspec || !*fspec) XSRETURN_UNDEF;
2d8e6c8d 10542 if (items == 2) defspec = SvPV(ST(1),n_a);
b7ae7a0d 10543
bbce6d69 10544 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10545 ST(0) = sv_newmortal();
10546 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
740ce14c 10547 XSRETURN(1);
01b8edb6 10548}
10549
10550void
5c84aa53 10551vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10552{
10553 dXSARGS;
10554 char *vmsified;
2d8e6c8d 10555 STRLEN n_a;
748a9306 10556
5c84aa53 10557 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
2d8e6c8d 10558 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10559 ST(0) = sv_newmortal();
10560 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10561 XSRETURN(1);
10562}
10563
10564void
5c84aa53 10565unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10566{
10567 dXSARGS;
10568 char *unixified;
2d8e6c8d 10569 STRLEN n_a;
748a9306 10570
5c84aa53 10571 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
2d8e6c8d 10572 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10573 ST(0) = sv_newmortal();
10574 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10575 XSRETURN(1);
10576}
10577
10578void
5c84aa53 10579fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10580{
10581 dXSARGS;
10582 char *fileified;
2d8e6c8d 10583 STRLEN n_a;
748a9306 10584
5c84aa53 10585 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
2d8e6c8d 10586 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10587 ST(0) = sv_newmortal();
10588 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10589 XSRETURN(1);
10590}
10591
10592void
5c84aa53 10593pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 10594{
10595 dXSARGS;
10596 char *pathified;
2d8e6c8d 10597 STRLEN n_a;
748a9306 10598
5c84aa53 10599 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
2d8e6c8d 10600 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10601 ST(0) = sv_newmortal();
10602 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10603 XSRETURN(1);
10604}
10605
10606void
5c84aa53 10607vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 10608{
10609 dXSARGS;
10610 char *vmspath;
2d8e6c8d 10611 STRLEN n_a;
748a9306 10612
5c84aa53 10613 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
2d8e6c8d 10614 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10615 ST(0) = sv_newmortal();
10616 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10617 XSRETURN(1);
10618}
10619
10620void
5c84aa53 10621unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 10622{
10623 dXSARGS;
10624 char *unixpath;
2d8e6c8d 10625 STRLEN n_a;
748a9306 10626
5c84aa53 10627 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
2d8e6c8d 10628 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
748a9306
LW		 10629 ST(0) = sv_newmortal();
10630 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10631 XSRETURN(1);
10632}
10633
10634void
5c84aa53 10635candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 10636{
10637 dXSARGS;
988c775c 10638 char *fspec, *fsp;
a5f75d66
AD		 10639 SV *mysv;
10640 IO *io;
2d8e6c8d 10641 STRLEN n_a;
748a9306 10642
5c84aa53 10643 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 10644
10645 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 10646 Newx(fspec, VMS_MAXRSS, char);
10647 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
a5f75d66 10648 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10649 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 10650 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10651 ST(0) = &PL_sv_no;
988c775c 10652 Safefree(fspec);
a5f75d66
AD		 10653 XSRETURN(1);
10654 }
10655 fsp = fspec;
10656 }
10657 else {
2d8e6c8d 10658 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 10659 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10660 ST(0) = &PL_sv_no;
988c775c 10661 Safefree(fspec);
a5f75d66
AD		 10662 XSRETURN(1);
10663 }
10664 }
10665
54310121 10666 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 10667 Safefree(fspec);
a5f75d66
AD		 10668 XSRETURN(1);
10669}
10670
10671void
5c84aa53 10672rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 10673{
10674 dXSARGS;
a480973c 10675 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 10676 int date_flag;
a5f75d66
AD		 10677 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10678 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10679 unsigned long int sts;
10680 SV *mysv;
10681 IO *io;
2d8e6c8d 10682 STRLEN n_a;
a5f75d66 10683
a3e9d8c9 10684 if (items < 2 || items > 3)
5c84aa53 10685 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 10686
10687 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 10688 Newx(inspec, VMS_MAXRSS, char);
a5f75d66 10689 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10690 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 10691 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10692 ST(0) = &PL_sv_no;
a480973c 10693 Safefree(inspec);
a5f75d66
AD		 10694 XSRETURN(1);
10695 }
10696 inp = inspec;
10697 }
10698 else {
2d8e6c8d 10699 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 10700 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10701 ST(0) = &PL_sv_no;
a480973c 10702 Safefree(inspec);
a5f75d66
AD		 10703 XSRETURN(1);
10704 }
10705 }
10706 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 10707 Newx(outspec, VMS_MAXRSS, char);
a5f75d66 10708 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 10709 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 10710 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10711 ST(0) = &PL_sv_no;
a480973c
JM		 10712 Safefree(inspec);
10713 Safefree(outspec);
a5f75d66
AD		 10714 XSRETURN(1);
10715 }
10716 outp = outspec;
10717 }
10718 else {
2d8e6c8d 10719 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 10720 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 10721 ST(0) = &PL_sv_no;
a480973c
JM		 10722 Safefree(inspec);
10723 Safefree(outspec);
a5f75d66
AD		 10724 XSRETURN(1);
10725 }
10726 }
a3e9d8c9 10727 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 10728
54310121 10729 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
a480973c
JM		 10730 Safefree(inspec);
10731 Safefree(outspec);
748a9306
LW		 10732 XSRETURN(1);
10733}
10734
a480973c
JM		 10735/* The mod2fname is limited to shorter filenames by design, so it should
10736 * not be modified to support longer EFS pathnames
10737 */
4b19af01 10738void
fd8cd3a3 10739mod2fname(pTHX_ CV *cv)
4b19af01
CB		 10740{
10741 dXSARGS;
10742 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10743 workbuff[NAM$C_MAXRSS*1 + 1];
10744 int total_namelen = 3, counter, num_entries;
10745 /* ODS-5 ups this, but we want to be consistent, so... */
10746 int max_name_len = 39;
10747 AV *in_array = (AV *)SvRV(ST(0));
10748
10749 num_entries = av_len(in_array);
10750
10751 /* All the names start with PL_. */
10752 strcpy(ultimate_name, "PL_");
10753
10754 /* Clean up our working buffer */
10755 Zero(work_name, sizeof(work_name), char);
10756
10757 /* Run through the entries and build up a working name */
10758 for(counter = 0; counter <= num_entries; counter++) {
10759 /* If it's not the first name then tack on a __ */
10760 if (counter) {
10761 strcat(work_name, "__");
10762 }
10763 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10764 PL_na));
10765 }
10766
10767 /* Check to see if we actually have to bother...*/
10768 if (strlen(work_name) + 3 <= max_name_len) {
10769 strcat(ultimate_name, work_name);
10770 } else {
10771 /* It's too darned big, so we need to go strip. We use the same */
10772 /* algorithm as xsubpp does. First, strip out doubled __ */
10773 char *source, *dest, last;
10774 dest = workbuff;
10775 last = 0;
10776 for (source = work_name; *source; source++) {
10777 if (last == *source && last == '_') {
10778 continue;
10779 }
10780 *dest++ = *source;
10781 last = *source;
10782 }
10783 /* Go put it back */
10784 strcpy(work_name, workbuff);
10785 /* Is it still too big? */
10786 if (strlen(work_name) + 3 > max_name_len) {
10787 /* Strip duplicate letters */
10788 last = 0;
10789 dest = workbuff;
10790 for (source = work_name; *source; source++) {
10791 if (last == toupper(*source)) {
10792 continue;
10793 }
10794 *dest++ = *source;
10795 last = toupper(*source);
10796 }
10797 strcpy(work_name, workbuff);
10798 }
10799
10800 /* Is it *still* too big? */
10801 if (strlen(work_name) + 3 > max_name_len) {
10802 /* Too bad, we truncate */
10803 work_name[max_name_len - 2] = 0;
10804 }
10805 strcat(ultimate_name, work_name);
10806 }
10807
10808 /* Okay, return it */
10809 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10810 XSRETURN(1);
10811}
10812
748a9306 10813void
96e176bf
CL		 10814hushexit_fromperl(pTHX_ CV *cv)
10815{
10816 dXSARGS;
10817
10818 if (items > 0) {
10819 VMSISH_HUSHED = SvTRUE(ST(0));
10820 }
10821 ST(0) = boolSV(VMSISH_HUSHED);
10822 XSRETURN(1);
10823}
10824
dca5a913
JM		 10825
10826PerlIO *
10827Perl_vms_start_glob
10828 (pTHX_ SV *tmpglob,
10829 IO *io)
10830{
10831 PerlIO *fp;
10832 struct vs_str_st *rslt;
10833 char *vmsspec;
10834 char *rstr;
10835 char *begin, *cp;
10836 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
10837 PerlIO *tmpfp;
10838 STRLEN i;
10839 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10840 struct dsc$descriptor_vs rsdsc;
10841 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
10842 unsigned long hasver = 0, isunix = 0;
10843 unsigned long int lff_flags = 0;
10844 int rms_sts;
10845
10846#ifdef VMS_LONGNAME_SUPPORT
10847 lff_flags = LIB$M_FIL_LONG_NAMES;
10848#endif
10849 /* The Newx macro will not allow me to assign a smaller array
10850 * to the rslt pointer, so we will assign it to the begin char pointer
10851 * and then copy the value into the rslt pointer.
10852 */
10853 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
10854 rslt = (struct vs_str_st *)begin;
10855 rslt->length = 0;
10856 rstr = &rslt->str[0];
10857 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
10858 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
10859 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
10860 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
10861
10862 Newx(vmsspec, VMS_MAXRSS, char);
10863
10864 /* We could find out if there's an explicit dev/dir or version
10865 by peeking into lib$find_file's internal context at
10866 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
10867 but that's unsupported, so I don't want to do it now and
10868 have it bite someone in the future. */
10869 /* Fix-me: vms_split_path() is the only way to do this, the
10870 existing method will fail with many legal EFS or UNIX specifications
10871 */
10872
10873 cp = SvPV(tmpglob,i);
10874
10875 for (; i; i--) {
10876 if (cp[i] == ';') hasver = 1;
10877 if (cp[i] == '.') {
10878 if (sts) hasver = 1;
10879 else sts = 1;
10880 }
10881 if (cp[i] == '/') {
10882 hasdir = isunix = 1;
10883 break;
10884 }
10885 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
10886 hasdir = 1;
10887 break;
10888 }
10889 }
10890 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
10891 Stat_t st;
10892 int stat_sts;
10893 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
10894 if (!stat_sts && S_ISDIR(st.st_mode)) {
10895 wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
10896 ok = (wilddsc.dsc$a_pointer != NULL);
10897 }
10898 else {
10899 wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
10900 ok = (wilddsc.dsc$a_pointer != NULL);
10901 }
10902 if (ok)
10903 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
10904
10905 /* If not extended character set, replace ? with % */
10906 /* With extended character set, ? is a wildcard single character */
10907 if (!decc_efs_case_preserve) {
10908 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
10909 if (*cp == '?') *cp = '%';
10910 }
10911 sts = SS$_NORMAL;
10912 while (ok && $VMS_STATUS_SUCCESS(sts)) {
10913 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10914 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10915
10916 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
10917 &dfltdsc,NULL,&rms_sts,&lff_flags);
10918 if (!$VMS_STATUS_SUCCESS(sts))
10919 break;
10920
10921 /* with varying string, 1st word of buffer contains result length */
10922 rstr[rslt->length] = '\0';
10923
10924 /* Find where all the components are */
10925 v_sts = vms_split_path
367e4b85 10926 (aTHX_ rstr,
dca5a913
JM		 10927 &v_spec,
10928 &v_len,
10929 &r_spec,
10930 &r_len,
10931 &d_spec,
10932 &d_len,
10933 &n_spec,
10934 &n_len,
10935 &e_spec,
10936 &e_len,
10937 &vs_spec,
10938 &vs_len);
10939
10940 /* If no version on input, truncate the version on output */
10941 if (!hasver && (vs_len > 0)) {
10942 *vs_spec = '\0';
10943 vs_len = 0;
10944
10945 /* No version & a null extension on UNIX handling */
10946 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
10947 e_len = 0;
10948 *e_spec = '\0';
10949 }
10950 }
10951
10952 if (!decc_efs_case_preserve) {
10953 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
10954 }
10955
10956 if (hasdir) {
10957 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
10958 begin = rstr;
10959 }
10960 else {
10961 /* Start with the name */
10962 begin = n_spec;
10963 }
10964 strcat(begin,"\n");
10965 ok = (PerlIO_puts(tmpfp,begin) != EOF);
10966 }
10967 if (cxt) (void)lib$find_file_end(&cxt);
10968 if (ok && sts != RMS$_NMF &&
10969 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
10970 if (!ok) {
10971 if (!(sts & 1)) {
10972 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
10973 }
10974 PerlIO_close(tmpfp);
10975 fp = NULL;
10976 }
10977 else {
10978 PerlIO_rewind(tmpfp);
10979 IoTYPE(io) = IoTYPE_RDONLY;
10980 IoIFP(io) = fp = tmpfp;
10981 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
10982 }
10983 }
10984 Safefree(vmsspec);
10985 Safefree(rslt);
10986 return fp;
10987}
10988
2497a41f
JM		 10989#ifdef HAS_SYMLINK
10990static char *
10991mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10992
10993void
10994vms_realpath_fromperl(pTHX_ CV *cv)
10995{
10996 dXSARGS;
10997 char *fspec, *rslt_spec, *rslt;
10998 STRLEN n_a;
10999
11000 if (!items || items != 1)
11001 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11002
11003 fspec = SvPV(ST(0),n_a);
11004 if (!fspec || !*fspec) XSRETURN_UNDEF;
11005
11006 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11007 rslt = do_vms_realpath(fspec, rslt_spec);
11008 ST(0) = sv_newmortal();
11009 if (rslt != NULL)
11010 sv_usepvn(ST(0),rslt,strlen(rslt));
11011 else
11012 Safefree(rslt_spec);
11013 XSRETURN(1);
11014}
11015#endif
11016
11017#if __CRTL_VER >= 70301000 && !defined(__VAX)
11018int do_vms_case_tolerant(void);
11019
11020void
11021vms_case_tolerant_fromperl(pTHX_ CV *cv)
11022{
11023 dXSARGS;
11024 ST(0) = boolSV(do_vms_case_tolerant());
11025 XSRETURN(1);
11026}
11027#endif
11028
96e176bf
CL		 11029void
11030Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11031 struct interp_intern *dst)
11032{
11033 memcpy(dst,src,sizeof(struct interp_intern));
11034}
11035
11036void
11037Perl_sys_intern_clear(pTHX)
11038{
11039}
11040
11041void
11042Perl_sys_intern_init(pTHX)
11043{
3ff49832
CL		 11044 unsigned int ix = RAND_MAX;
11045 double x;
96e176bf
CL		 11046
11047 VMSISH_HUSHED = 0;
11048
7a7fd8e0
JM		 11049 /* fix me later to track running under GNV */
11050 /* this allows some limited testing */
11051 MY_POSIX_EXIT = decc_filename_unix_report;
11052
96e176bf
CL		 11053 x = (float)ix;
11054 MY_INV_RAND_MAX = 1./x;
ff7adb52 11055}
96e176bf
CL		 11056
11057void
f7ddb74a 11058init_os_extras(void)
748a9306 11059{
a69a6dba 11060 dTHX;
748a9306 11061 char* file = __FILE__;
988c775c 11062 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 11063 no_translate_barewords = TRUE;
11064 } else {
11065 no_translate_barewords = FALSE;
11066 }
748a9306 11067
740ce14c 11068 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 11069 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11070 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11071 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11072 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11073 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11074 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11075 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 11076 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 11077 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 11078 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
f7ddb74a
JM		 11079#ifdef HAS_SYMLINK
11080 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11081#endif
f7ddb74a
JM		 11082#if __CRTL_VER >= 70301000 && !defined(__VAX)
11083 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11084#endif
17f28c40 11085
afd8f436 11086 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 11087
748a9306
LW		 11088 return;
11089}
11090
f7ddb74a
JM		 11091#ifdef HAS_SYMLINK
11092
11093#if __CRTL_VER == 80200000
11094/* This missed getting in to the DECC SDK for 8.2 */
11095char *realpath(const char *file_name, char * resolved_name, ...);
11096#endif
11097
11098/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11099/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11100 * The perl fallback routine to provide realpath() is not as efficient
11101 * on OpenVMS.
11102 */
11103static char *
11104mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11105{
11106 return realpath(filespec, outbuf);
11107}
11108
11109/*}}}*/
11110/* External entry points */
11111char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11112{ return do_vms_realpath(filespec, outbuf); }
11113#else
11114char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11115{ return NULL; }
11116#endif
11117
11118
11119#if __CRTL_VER >= 70301000 && !defined(__VAX)
11120/* case_tolerant */
11121
11122/*{{{int do_vms_case_tolerant(void)*/
11123/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11124 * controlled by a process setting.
11125 */
11126int do_vms_case_tolerant(void)
11127{
11128 return vms_process_case_tolerant;
11129}
11130/*}}}*/
11131/* External entry points */
11132int Perl_vms_case_tolerant(void)
11133{ return do_vms_case_tolerant(); }
11134#else
11135int Perl_vms_case_tolerant(void)
11136{ return vms_process_case_tolerant; }
11137#endif
11138
11139
11140 /* Start of DECC RTL Feature handling */
11141
11142static int sys_trnlnm
11143 (const char * logname,
11144 char * value,
11145 int value_len)
11146{
11147 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11148 const unsigned long attr = LNM$M_CASE_BLIND;
11149 struct dsc$descriptor_s name_dsc;
11150 int status;
11151 unsigned short result;
11152 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11153 {0, 0, 0, 0}};
11154
11155 name_dsc.dsc$w_length = strlen(logname);
11156 name_dsc.dsc$a_pointer = (char *)logname;
11157 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11158 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11159
11160 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11161
11162 if ($VMS_STATUS_SUCCESS(status)) {
11163
11164 /* Null terminate and return the string */
11165 /*--------------------------------------*/
11166 value[result] = 0;
11167 }
11168
11169 return status;
11170}
11171
11172static int sys_crelnm
11173 (const char * logname,
11174 const char * value)
11175{
11176 int ret_val;
11177 const char * proc_table = "LNM$PROCESS_TABLE";
11178 struct dsc$descriptor_s proc_table_dsc;
11179 struct dsc$descriptor_s logname_dsc;
11180 struct itmlst_3 item_list[2];
11181
11182 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11183 proc_table_dsc.dsc$w_length = strlen(proc_table);
11184 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11185 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11186
11187 logname_dsc.dsc$a_pointer = (char *) logname;
11188 logname_dsc.dsc$w_length = strlen(logname);
11189 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11190 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11191
11192 item_list[0].buflen = strlen(value);
11193 item_list[0].itmcode = LNM$_STRING;
11194 item_list[0].bufadr = (char *)value;
11195 item_list[0].retlen = NULL;
11196
11197 item_list[1].buflen = 0;
11198 item_list[1].itmcode = 0;
11199
11200 ret_val = sys$crelnm
11201 (NULL,
11202 (const struct dsc$descriptor_s *)&proc_table_dsc,
11203 (const struct dsc$descriptor_s *)&logname_dsc,
11204 NULL,
11205 (const struct item_list_3 *) item_list);
11206
11207 return ret_val;
11208}
11209
11210
11211/* C RTL Feature settings */
11212
11213static int set_features
11214 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11215 int (* cli_routine)(void), /* Not documented */
11216 void *image_info) /* Not documented */
11217{
11218 int status;
11219 int s;
11220 int dflt;
11221 char* str;
11222 char val_str[10];
3c841f20 11223#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 11224 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11225 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11226 unsigned long case_perm;
11227 unsigned long case_image;
3c841f20 11228#endif
f7ddb74a 11229
9c1171d1
JM		 11230 /* Allow an exception to bring Perl into the VMS debugger */
11231 vms_debug_on_exception = 0;
11232 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11233 if ($VMS_STATUS_SUCCESS(status)) {
11234 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11235 vms_debug_on_exception = 1;
11236 else
11237 vms_debug_on_exception = 0;
11238 }
11239
11240
2497a41f
JM		 11241 /* hacks to see if known bugs are still present for testing */
11242
11243 /* Readdir is returning filenames in VMS syntax always */
11244 decc_bug_readdir_efs1 = 1;
11245 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11246 if ($VMS_STATUS_SUCCESS(status)) {
11247 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11248 decc_bug_readdir_efs1 = 1;
11249 else
11250 decc_bug_readdir_efs1 = 0;
11251 }
11252
11253 /* PCP mode requires creating /dev/null special device file */
2623a4a6 11254 decc_bug_devnull = 0;
2497a41f
JM		 11255 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11256 if ($VMS_STATUS_SUCCESS(status)) {
11257 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11258 decc_bug_devnull = 1;
682e4b71
JM		 11259 else
11260 decc_bug_devnull = 0;
2497a41f
JM		 11261 }
11262
11263 /* fgetname returning a VMS name in UNIX mode */
11264 decc_bug_fgetname = 1;
11265 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11266 if ($VMS_STATUS_SUCCESS(status)) {
11267 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11268 decc_bug_fgetname = 1;
11269 else
11270 decc_bug_fgetname = 0;
11271 }
11272
11273 /* UNIX directory names with no paths are broken in a lot of places */
11274 decc_dir_barename = 1;
11275 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11276 if ($VMS_STATUS_SUCCESS(status)) {
11277 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11278 decc_dir_barename = 1;
11279 else
11280 decc_dir_barename = 0;
11281 }
11282
f7ddb74a
JM		 11283#if __CRTL_VER >= 70300000 && !defined(__VAX)
11284 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11285 if (s >= 0) {
11286 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11287 if (decc_disable_to_vms_logname_translation < 0)
11288 decc_disable_to_vms_logname_translation = 0;
11289 }
11290
11291 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11292 if (s >= 0) {
11293 decc_efs_case_preserve = decc$feature_get_value(s, 1);
11294 if (decc_efs_case_preserve < 0)
11295 decc_efs_case_preserve = 0;
11296 }
11297
11298 s = decc$feature_get_index("DECC$EFS_CHARSET");
11299 if (s >= 0) {
11300 decc_efs_charset = decc$feature_get_value(s, 1);
11301 if (decc_efs_charset < 0)
11302 decc_efs_charset = 0;
11303 }
11304
11305 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11306 if (s >= 0) {
11307 decc_filename_unix_report = decc$feature_get_value(s, 1);
11308 if (decc_filename_unix_report > 0)
11309 decc_filename_unix_report = 1;
11310 else
11311 decc_filename_unix_report = 0;
11312 }
11313
11314 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11315 if (s >= 0) {
11316 decc_filename_unix_only = decc$feature_get_value(s, 1);
11317 if (decc_filename_unix_only > 0) {
11318 decc_filename_unix_only = 1;
11319 }
11320 else {
11321 decc_filename_unix_only = 0;
11322 }
11323 }
11324
11325 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11326 if (s >= 0) {
11327 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11328 if (decc_filename_unix_no_version < 0)
11329 decc_filename_unix_no_version = 0;
11330 }
11331
11332 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11333 if (s >= 0) {
11334 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11335 if (decc_readdir_dropdotnotype < 0)
11336 decc_readdir_dropdotnotype = 0;
11337 }
11338
11339 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11340 if ($VMS_STATUS_SUCCESS(status)) {
11341 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11342 if (s >= 0) {
11343 dflt = decc$feature_get_value(s, 4);
11344 if (dflt > 0) {
11345 decc_disable_posix_root = decc$feature_get_value(s, 1);
11346 if (decc_disable_posix_root <= 0) {
11347 decc$feature_set_value(s, 1, 1);
11348 decc_disable_posix_root = 1;
11349 }
11350 }
11351 else {
11352 /* Traditionally Perl assumes this is off */
11353 decc_disable_posix_root = 1;
11354 decc$feature_set_value(s, 1, 1);
11355 }
11356 }
11357 }
11358
11359#if __CRTL_VER >= 80200000
11360 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11361 if (s >= 0) {
11362 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11363 if (decc_posix_compliant_pathnames < 0)
11364 decc_posix_compliant_pathnames = 0;
11365 if (decc_posix_compliant_pathnames > 4)
11366 decc_posix_compliant_pathnames = 0;
11367 }
11368
11369#endif
11370#else
11371 status = sys_trnlnm
11372 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11373 if ($VMS_STATUS_SUCCESS(status)) {
11374 val_str[0] = _toupper(val_str[0]);
11375 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11376 decc_disable_to_vms_logname_translation = 1;
11377 }
11378 }
11379
11380#ifndef __VAX
11381 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11382 if ($VMS_STATUS_SUCCESS(status)) {
11383 val_str[0] = _toupper(val_str[0]);
11384 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11385 decc_efs_case_preserve = 1;
11386 }
11387 }
11388#endif
11389
11390 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11391 if ($VMS_STATUS_SUCCESS(status)) {
11392 val_str[0] = _toupper(val_str[0]);
11393 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11394 decc_filename_unix_report = 1;
11395 }
11396 }
11397 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11398 if ($VMS_STATUS_SUCCESS(status)) {
11399 val_str[0] = _toupper(val_str[0]);
11400 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11401 decc_filename_unix_only = 1;
11402 decc_filename_unix_report = 1;
11403 }
11404 }
11405 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11406 if ($VMS_STATUS_SUCCESS(status)) {
11407 val_str[0] = _toupper(val_str[0]);
11408 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11409 decc_filename_unix_no_version = 1;
11410 }
11411 }
11412 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11413 if ($VMS_STATUS_SUCCESS(status)) {
11414 val_str[0] = _toupper(val_str[0]);
11415 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11416 decc_readdir_dropdotnotype = 1;
11417 }
11418 }
11419#endif
11420
3c841f20 11421#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 11422
11423 /* Report true case tolerance */
11424 /*----------------------------*/
11425 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11426 if (!$VMS_STATUS_SUCCESS(status))
11427 case_perm = PPROP$K_CASE_BLIND;
11428 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11429 if (!$VMS_STATUS_SUCCESS(status))
11430 case_image = PPROP$K_CASE_BLIND;
11431 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11432 (case_image == PPROP$K_CASE_SENSITIVE))
11433 vms_process_case_tolerant = 0;
11434
11435#endif
11436
11437
11438 /* CRTL can be initialized past this point, but not before. */
11439/* DECC$CRTL_INIT(); */
11440
11441 return SS$_NORMAL;
11442}
11443
11444#ifdef __DECC
11445/* DECC dependent attributes */
11446#if __DECC_VER < 60560002
11447#define relative
11448#define not_executable
11449#else
11450#define relative ,rel
11451#define not_executable ,noexe
11452#endif
11453#pragma nostandard
11454#pragma extern_model save
11455#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11456#endif
11457 const __align (LONGWORD) int spare[8] = {0};
11458/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11459/* NOWRT, LONG */
11460#ifdef __DECC
11461#pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11462 nowrt,noshr relative not_executable
11463#endif
11464const long vms_cc_features = (const long)set_features;
11465
11466/*
11467** Force a reference to LIB$INITIALIZE to ensure it
11468** exists in the image.
11469*/
11470int lib$initialize(void);
11471#ifdef __DECC
11472#pragma extern_model strict_refdef
11473#endif
11474 int lib_init_ref = (int) lib$initialize;
11475
11476#ifdef __DECC
11477#pragma extern_model restore
11478#pragma standard
11479#endif
11480
748a9306 11481/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.