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
Upgrade to ExtUtils::MakeMaker 6.42
[perl5.git] / vms / vms.c
CommitLineData
b429d381 1/* vms.c
a0d0e21e 2 *
82dd182c 3 * VMS-specific routines for perl5
748a9306 4 *
82dd182c
CB		 5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
7 *
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
10 *
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
a0d0e21e
LW		 12 */
13
14#include <acedef.h>
15#include <acldef.h>
16#include <armdef.h>
748a9306 17#include <atrdef.h>
a0d0e21e 18#include <chpdef.h>
8fde5078 19#include <clidef.h>
a3e9d8c9 20#include <climsgdef.h>
cd1191f1 21#include <dcdef.h>
a0d0e21e 22#include <descrip.h>
22d4bb9c 23#include <devdef.h>
a0d0e21e 24#include <dvidef.h>
748a9306 25#include <fibdef.h>
a0d0e21e
LW		 26#include <float.h>
27#include <fscndef.h>
28#include <iodef.h>
29#include <jpidef.h>
61bb5906 30#include <kgbdef.h>
f675dbe5 31#include <libclidef.h>
a0d0e21e
LW		 32#include <libdef.h>
33#include <lib$routines.h>
34#include <lnmdef.h>
aeb5cf3c 35#include <msgdef.h>
4fdf8f88 36#include <ossdef.h>
f7ddb74a
JM		 37#if __CRTL_VER >= 70301000 && !defined(__VAX)
38#include <ppropdef.h>
39#endif
748a9306 40#include <prvdef.h>
a0d0e21e
LW		 41#include <psldef.h>
42#include <rms.h>
43#include <shrdef.h>
44#include <ssdef.h>
45#include <starlet.h>
f86702cc 46#include <strdef.h>
47#include <str$routines.h>
a0d0e21e 48#include <syidef.h>
748a9306
LW		 49#include <uaidef.h>
50#include <uicdef.h>
2fbb330f
JM		 51#include <stsdef.h>
52#include <rmsdef.h>
cd1191f1 53#include <smgdef.h>
cfcfe586
JM		 54#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
55#include <efndef.h>
56#define NO_EFN EFN$C_ENF
57#else
58#define NO_EFN 0;
59#endif
a0d0e21e 60
f7ddb74a
JM		 61#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
62int decc$feature_get_index(const char *name);
63char* decc$feature_get_name(int index);
64int decc$feature_get_value(int index, int mode);
65int decc$feature_set_value(int index, int mode, int value);
66#else
67#include <unixlib.h>
68#endif
69
cfcfe586
JM		 70#pragma member_alignment save
71#pragma nomember_alignment longword
72struct item_list_3 {
73 unsigned short len;
74 unsigned short code;
75 void * bufadr;
76 unsigned short * retadr;
77};
78#pragma member_alignment restore
79
80/* More specific prototype than in starlet_c.h makes programming errors
81 more visible.
82 */
83#ifdef sys$getdviw
84#undef sys$getdviw
cfcfe586
JM		 85int sys$getdviw
86 (unsigned long efn,
87 unsigned short chan,
88 const struct dsc$descriptor_s * devnam,
89 const struct item_list_3 * itmlst,
90 void * iosb,
91 void * (astadr)(unsigned long),
92 void * astprm,
93 void * nullarg);
7566800d 94#endif
cfcfe586 95
4fdf8f88
JM		 96#ifdef sys$get_security
97#undef sys$get_security
98int sys$get_security
99 (const struct dsc$descriptor_s * clsnam,
100 const struct dsc$descriptor_s * objnam,
101 const unsigned int *objhan,
102 unsigned int flags,
103 const struct item_list_3 * itmlst,
104 unsigned int * contxt,
105 const unsigned int * acmode);
106#endif
107
108#ifdef sys$set_security
109#undef sys$set_security
110int sys$set_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
114 unsigned int flags,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
118#endif
119
8cb5d3d5
JM		 120#ifdef lib$find_image_symbol
121#undef lib$find_image_symbol
122int lib$find_image_symbol
123 (const struct dsc$descriptor_s * imgname,
124 const struct dsc$descriptor_s * symname,
125 void * symval,
126 const struct dsc$descriptor_s * defspec,
127 unsigned long flag);
4fdf8f88 128#endif
8cb5d3d5 129
4fdf8f88
JM		 130#ifdef lib$rename_file
131#undef lib$rename_file
132int lib$rename_file
133 (const struct dsc$descriptor_s * old_file_dsc,
134 const struct dsc$descriptor_s * new_file_dsc,
135 const struct dsc$descriptor_s * default_file_dsc,
136 const struct dsc$descriptor_s * related_file_dsc,
137 const unsigned long * flags,
138 void * (success)(const struct dsc$descriptor_s * old_dsc,
139 const struct dsc$descriptor_s * new_dsc,
140 const void *),
141 void * (error)(const struct dsc$descriptor_s * old_dsc,
142 const struct dsc$descriptor_s * new_dsc,
143 const int * rms_sts,
144 const int * rms_stv,
145 const int * error_src,
146 const void * usr_arg),
147 int (confirm)(const struct dsc$descriptor_s * old_dsc,
148 const struct dsc$descriptor_s * new_dsc,
149 const void * old_fab,
150 const void * usr_arg),
151 void * user_arg,
152 struct dsc$descriptor_s * old_result_name_dsc,
153 struct dsc$descriptor_s * new_result_name_dsc,
154 unsigned long * file_scan_context);
8cb5d3d5
JM		 155#endif
156
7a7fd8e0 157#if __CRTL_VER >= 70300000 && !defined(__VAX)
f7ddb74a
JM		 158
159static int set_feature_default(const char *name, int value)
160{
161 int status;
162 int index;
163
164 index = decc$feature_get_index(name);
165
166 status = decc$feature_set_value(index, 1, value);
167 if (index == -1 || (status == -1)) {
168 return -1;
169 }
170
171 status = decc$feature_get_value(index, 1);
172 if (status != value) {
173 return -1;
174 }
175
176return 0;
177}
178#endif
f7ddb74a 179
740ce14c 180/* Older versions of ssdef.h don't have these */
181#ifndef SS$_INVFILFOROP
182# define SS$_INVFILFOROP 3930
183#endif
184#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 185# define SS$_NOSUCHOBJECT 2696
186#endif
187
a15cef0c
CB		 188/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
189#define PERLIO_NOT_STDIO 0
190
2497a41f 191/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 192 * code below needs to get to the underlying CRTL routines. */
193#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 194#include "EXTERN.h"
195#include "perl.h"
748a9306 196#include "XSUB.h"
3eeba6fb
CB		 197/* Anticipating future expansion in lexical warnings . . . */
198#ifndef WARN_INTERNAL
199# define WARN_INTERNAL WARN_MISC
200#endif
a0d0e21e 201
988c775c
JM		 202#ifdef VMS_LONGNAME_SUPPORT
203#include <libfildef.h>
204#endif
205
22d4bb9c
CB		 206#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
207# define RTL_USES_UTC 1
208#endif
209
5f1992ed
CB		 210/* Routine to create a decterm for use with the Perl debugger */
211/* No headers, this information was found in the Programming Concepts Manual */
212
8cb5d3d5 213static int (*decw_term_port)
5f1992ed
CB		 214 (const struct dsc$descriptor_s * display,
215 const struct dsc$descriptor_s * setup_file,
216 const struct dsc$descriptor_s * customization,
217 struct dsc$descriptor_s * result_device_name,
218 unsigned short * result_device_name_length,
219 void * controller,
220 void * char_buffer,
8cb5d3d5 221 void * char_change_buffer) = 0;
22d4bb9c 222
c07a80fd 223/* gcc's header files don't #define direct access macros
224 * corresponding to VAXC's variant structs */
225#ifdef __GNUC__
482b294c 226# define uic$v_format uic$r_uic_form.uic$v_format
227# define uic$v_group uic$r_uic_form.uic$v_group
228# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 229# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
230# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
231# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
232# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
233#endif
234
c645ec3f
GS		 235#if defined(NEED_AN_H_ERRNO)
236dEXT int h_errno;
237#endif
c07a80fd 238
f7ddb74a
JM		 239#ifdef __DECC
240#pragma message disable pragma
241#pragma member_alignment save
242#pragma nomember_alignment longword
243#pragma message save
244#pragma message disable misalgndmem
245#endif
a0d0e21e
LW		 246struct itmlst_3 {
247 unsigned short int buflen;
248 unsigned short int itmcode;
249 void *bufadr;
748a9306 250 unsigned short int *retlen;
a0d0e21e 251};
657054d4
JM		 252
253struct filescan_itmlst_2 {
254 unsigned short length;
255 unsigned short itmcode;
256 char * component;
257};
258
dca5a913
JM		 259struct vs_str_st {
260 unsigned short length;
261 char str[65536];
262};
263
f7ddb74a
JM		 264#ifdef __DECC
265#pragma message restore
266#pragma member_alignment restore
267#endif
a0d0e21e 268
360732b5
JM		 269#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
270#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
271#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
272#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
273#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
274#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 275#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 276#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
277#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 278#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 279#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
280#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
281
360732b5
JM		 282static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
283static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
284static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
285static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 286
0e06870b
CB		 287/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
288#define PERL_LNM_MAX_ALLOWED_INDEX 127
289
2d9f3838
CB		 290/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
291 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
292 * the Perl facility.
293 */
294#define PERL_LNM_MAX_ITER 10
295
2497a41f
JM		 296 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
297#if __CRTL_VER >= 70302000 && !defined(__VAX)
298#define MAX_DCL_SYMBOL (8192)
299#define MAX_DCL_LINE_LENGTH (4096 - 4)
300#else
301#define MAX_DCL_SYMBOL (1024)
302#define MAX_DCL_LINE_LENGTH (1024 - 4)
303#endif
ff7adb52 304
01b8edb6 305static char *__mystrtolower(char *str)
306{
307 if (str) for (; *str; ++str) *str= tolower(*str);
308 return str;
309}
310
f675dbe5
CB		 311static struct dsc$descriptor_s fildevdsc =
312 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
313static struct dsc$descriptor_s crtlenvdsc =
314 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
315static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
316static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
317static struct dsc$descriptor_s **env_tables = defenv;
318static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
319
93948341
CB		 320/* True if we shouldn't treat barewords as logicals during directory */
321/* munching */
322static int no_translate_barewords;
323
22d4bb9c
CB		 324#ifndef RTL_USES_UTC
325static int tz_updated = 1;
326#endif
327
f7ddb74a
JM		 328/* DECC Features that may need to affect how Perl interprets
329 * displays filename information
330 */
331static int decc_disable_to_vms_logname_translation = 1;
332static int decc_disable_posix_root = 1;
333int decc_efs_case_preserve = 0;
334static int decc_efs_charset = 0;
335static int decc_filename_unix_no_version = 0;
336static int decc_filename_unix_only = 0;
337int decc_filename_unix_report = 0;
338int decc_posix_compliant_pathnames = 0;
339int decc_readdir_dropdotnotype = 0;
340static int vms_process_case_tolerant = 1;
360732b5
JM		 341int vms_vtf7_filenames = 0;
342int gnv_unix_shell = 0;
e0e5e8d6 343static int vms_unlink_all_versions = 0;
f7ddb74a 344
2497a41f
JM		 345/* bug workarounds if needed */
346int decc_bug_readdir_efs1 = 0;
682e4b71 347int decc_bug_devnull = 1;
2497a41f
JM		 348int decc_bug_fgetname = 0;
349int decc_dir_barename = 0;
350
9c1171d1
JM		 351static int vms_debug_on_exception = 0;
352
f7ddb74a
JM		 353/* Is this a UNIX file specification?
354 * No longer a simple check with EFS file specs
355 * For now, not a full check, but need to
356 * handle POSIX ^UP^ specifications
357 * Fixing to handle ^/ cases would require
358 * changes to many other conversion routines.
359 */
360
657054d4 361static int is_unix_filespec(const char *path)
f7ddb74a
JM		 362{
363int ret_val;
364const char * pch1;
365
366 ret_val = 0;
367 if (strncmp(path,"\"^UP^",5) != 0) {
368 pch1 = strchr(path, '/');
369 if (pch1 != NULL)
370 ret_val = 1;
371 else {
372
373 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
374 if (decc_filename_unix_report || decc_filename_unix_only) {
375 if (strcmp(path,".") == 0)
376 ret_val = 1;
377 }
378 }
379 }
380 return ret_val;
381}
382
360732b5
JM		 383/* This routine converts a UCS-2 character to be VTF-7 encoded.
384 */
385
386static void ucs2_to_vtf7
387 (char *outspec,
388 unsigned long ucs2_char,
389 int * output_cnt)
390{
391unsigned char * ucs_ptr;
392int hex;
393
394 ucs_ptr = (unsigned char *)&ucs2_char;
395
396 outspec[0] = '^';
397 outspec[1] = 'U';
398 hex = (ucs_ptr[1] >> 4) & 0xf;
399 if (hex < 0xA)
400 outspec[2] = hex + '0';
401 else
402 outspec[2] = (hex - 9) + 'A';
403 hex = ucs_ptr[1] & 0xF;
404 if (hex < 0xA)
405 outspec[3] = hex + '0';
406 else {
407 outspec[3] = (hex - 9) + 'A';
408 }
409 hex = (ucs_ptr[0] >> 4) & 0xf;
410 if (hex < 0xA)
411 outspec[4] = hex + '0';
412 else
413 outspec[4] = (hex - 9) + 'A';
414 hex = ucs_ptr[1] & 0xF;
415 if (hex < 0xA)
416 outspec[5] = hex + '0';
417 else {
418 outspec[5] = (hex - 9) + 'A';
419 }
420 *output_cnt = 6;
421}
422
423
424/* This handles the conversion of a UNIX extended character set to a ^
425 * escaped VMS character.
426 * in a UNIX file specification.
427 *
428 * The output count variable contains the number of characters added
429 * to the output string.
430 *
431 * The return value is the number of characters read from the input string
432 */
433static int copy_expand_unix_filename_escape
434 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
435{
436int count;
437int scnt;
438int utf8_flag;
439
440 utf8_flag = 0;
441 if (utf8_fl)
442 utf8_flag = *utf8_fl;
443
444 count = 0;
445 *output_cnt = 0;
446 if (*inspec >= 0x80) {
447 if (utf8_fl && vms_vtf7_filenames) {
448 unsigned long ucs_char;
449
450 ucs_char = 0;
451
452 if ((*inspec & 0xE0) == 0xC0) {
453 /* 2 byte Unicode */
454 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
455 if (ucs_char >= 0x80) {
456 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
457 return 2;
458 }
459 } else if ((*inspec & 0xF0) == 0xE0) {
460 /* 3 byte Unicode */
461 ucs_char = ((inspec[0] & 0xF) << 12) +
462 ((inspec[1] & 0x3f) << 6) +
463 (inspec[2] & 0x3f);
464 if (ucs_char >= 0x800) {
465 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
466 return 3;
467 }
468
469#if 0 /* I do not see longer sequences supported by OpenVMS */
470 /* Maybe some one can fix this later */
471 } else if ((*inspec & 0xF8) == 0xF0) {
472 /* 4 byte Unicode */
473 /* UCS-4 to UCS-2 */
474 } else if ((*inspec & 0xFC) == 0xF8) {
475 /* 5 byte Unicode */
476 /* UCS-4 to UCS-2 */
477 } else if ((*inspec & 0xFE) == 0xFC) {
478 /* 6 byte Unicode */
479 /* UCS-4 to UCS-2 */
480#endif
481 }
482 }
483
38a44b82 484 /* High bit set, but not a Unicode character! */
360732b5
JM		 485
486 /* Non printing DECMCS or ISO Latin-1 character? */
487 if (*inspec <= 0x9F) {
488 int hex;
489 outspec[0] = '^';
490 outspec++;
491 hex = (*inspec >> 4) & 0xF;
492 if (hex < 0xA)
493 outspec[1] = hex + '0';
494 else {
495 outspec[1] = (hex - 9) + 'A';
496 }
497 hex = *inspec & 0xF;
498 if (hex < 0xA)
499 outspec[2] = hex + '0';
500 else {
501 outspec[2] = (hex - 9) + 'A';
502 }
503 *output_cnt = 3;
504 return 1;
505 } else if (*inspec == 0xA0) {
506 outspec[0] = '^';
507 outspec[1] = 'A';
508 outspec[2] = '0';
509 *output_cnt = 3;
510 return 1;
511 } else if (*inspec == 0xFF) {
512 outspec[0] = '^';
513 outspec[1] = 'F';
514 outspec[2] = 'F';
515 *output_cnt = 3;
516 return 1;
517 }
518 *outspec = *inspec;
519 *output_cnt = 1;
520 return 1;
521 }
522
523 /* Is this a macro that needs to be passed through?
524 * Macros start with $( and an alpha character, followed
525 * by a string of alpha numeric characters ending with a )
526 * If this does not match, then encode it as ODS-5.
527 */
528 if ((inspec[0] == '$') && (inspec[1] == '(')) {
529 int tcnt;
530
531 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
532 tcnt = 3;
533 outspec[0] = inspec[0];
534 outspec[1] = inspec[1];
535 outspec[2] = inspec[2];
536
537 while(isalnum(inspec[tcnt]) ||
538 (inspec[2] == '.') || (inspec[2] == '_')) {
539 outspec[tcnt] = inspec[tcnt];
540 tcnt++;
541 }
542 if (inspec[tcnt] == ')') {
543 outspec[tcnt] = inspec[tcnt];
544 tcnt++;
545 *output_cnt = tcnt;
546 return tcnt;
547 }
548 }
549 }
550
551 switch (*inspec) {
552 case 0x7f:
553 outspec[0] = '^';
554 outspec[1] = '7';
555 outspec[2] = 'F';
556 *output_cnt = 3;
557 return 1;
558 break;
559 case '?':
560 if (decc_efs_charset == 0)
561 outspec[0] = '%';
562 else
563 outspec[0] = '?';
564 *output_cnt = 1;
565 return 1;
566 break;
567 case '.':
568 case '~':
569 case '!':
570 case '#':
571 case '&':
572 case '\'':
573 case '`':
574 case '(':
575 case ')':
576 case '+':
577 case '@':
578 case '{':
579 case '}':
580 case ',':
581 case ';':
582 case '[':
583 case ']':
584 case '%':
585 case '^':
adc11f0b
CB		 586 /* Don't escape again if following character is
587 * already something we escape.
588 */
589 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
590 *outspec = *inspec;
591 *output_cnt = 1;
592 return 1;
593 break;
594 }
595 /* But otherwise fall through and escape it. */
360732b5
JM		 596 case '=':
597 /* Assume that this is to be escaped */
598 outspec[0] = '^';
599 outspec[1] = *inspec;
600 *output_cnt = 2;
601 return 1;
602 break;
603 case ' ': /* space */
604 /* Assume that this is to be escaped */
605 outspec[0] = '^';
606 outspec[1] = '_';
607 *output_cnt = 2;
608 return 1;
609 break;
610 default:
611 *outspec = *inspec;
612 *output_cnt = 1;
613 return 1;
614 break;
615 }
616}
617
618
657054d4
JM		 619/* This handles the expansion of a '^' prefix to the proper character
620 * in a UNIX file specification.
621 *
622 * The output count variable contains the number of characters added
623 * to the output string.
624 *
625 * The return value is the number of characters read from the input
626 * string
627 */
628static int copy_expand_vms_filename_escape
629 (char *outspec, const char *inspec, int *output_cnt)
630{
631int count;
632int scnt;
633
634 count = 0;
635 *output_cnt = 0;
636 if (*inspec == '^') {
637 inspec++;
638 switch (*inspec) {
adc11f0b
CB		 639 /* Spaces and non-trailing dots should just be passed through,
640 * but eat the escape character.
641 */
657054d4 642 case '.':
657054d4 643 *outspec = *inspec;
adc11f0b
CB		 644 count += 2;
645 (*output_cnt)++;
657054d4
JM		 646 break;
647 case '_': /* space */
648 *outspec = ' ';
adc11f0b 649 count += 2;
657054d4
JM		 650 (*output_cnt)++;
651 break;
adc11f0b
CB		 652 case '^':
653 /* Hmm. Better leave the escape escaped. */
654 outspec[0] = '^';
655 outspec[1] = '^';
656 count += 2;
657 (*output_cnt) += 2;
658 break;
360732b5 659 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 660 inspec++;
661 count++;
662 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
663 if (scnt == 4) {
2f4077ca
JM		 664 unsigned int c1, c2;
665 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
666 outspec[0] == c1 & 0xff;
667 outspec[1] == c2 & 0xff;
657054d4
JM		 668 if (scnt > 1) {
669 (*output_cnt) += 2;
670 count += 4;
671 }
672 }
673 else {
674 /* Error - do best we can to continue */
675 *outspec = 'U';
676 outspec++;
677 (*output_cnt++);
678 *outspec = *inspec;
679 count++;
680 (*output_cnt++);
681 }
682 break;
683 default:
684 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
685 if (scnt == 2) {
686 /* Hex encoded */
2f4077ca
JM		 687 unsigned int c1;
688 scnt = sscanf(inspec, "%2x", &c1);
689 outspec[0] = c1 & 0xff;
657054d4
JM		 690 if (scnt > 0) {
691 (*output_cnt++);
692 count += 2;
693 }
694 }
695 else {
696 *outspec = *inspec;
697 count++;
698 (*output_cnt++);
699 }
700 }
701 }
702 else {
703 *outspec = *inspec;
704 count++;
705 (*output_cnt)++;
706 }
707 return count;
708}
709
7566800d
CB		 710#ifdef sys$filescan
711#undef sys$filescan
712int sys$filescan
657054d4
JM		 713 (const struct dsc$descriptor_s * srcstr,
714 struct filescan_itmlst_2 * valuelist,
715 unsigned long * fldflags,
716 struct dsc$descriptor_s *auxout,
717 unsigned short * retlen);
7566800d 718#endif
657054d4
JM		 719
720/* vms_split_path - Verify that the input file specification is a
721 * VMS format file specification, and provide pointers to the components of
722 * it. With EFS format filenames, this is virtually the only way to
723 * parse a VMS path specification into components.
724 *
725 * If the sum of the components do not add up to the length of the
726 * string, then the passed file specification is probably a UNIX style
727 * path.
728 */
729static int vms_split_path
360732b5 730 (const char * path,
dca5a913 731 char * * volume,
657054d4 732 int * vol_len,
dca5a913 733 char * * root,
657054d4 734 int * root_len,
dca5a913 735 char * * dir,
657054d4 736 int * dir_len,
dca5a913 737 char * * name,
657054d4 738 int * name_len,
dca5a913 739 char * * ext,
657054d4 740 int * ext_len,
dca5a913 741 char * * version,
657054d4
JM		 742 int * ver_len)
743{
744struct dsc$descriptor path_desc;
745int status;
746unsigned long flags;
747int ret_stat;
748struct filescan_itmlst_2 item_list[9];
749const int filespec = 0;
750const int nodespec = 1;
751const int devspec = 2;
752const int rootspec = 3;
753const int dirspec = 4;
754const int namespec = 5;
755const int typespec = 6;
756const int verspec = 7;
757
758 /* Assume the worst for an easy exit */
759 ret_stat = -1;
760 *volume = NULL;
761 *vol_len = 0;
762 *root = NULL;
763 *root_len = 0;
764 *dir = NULL;
765 *dir_len;
766 *name = NULL;
767 *name_len = 0;
768 *ext = NULL;
769 *ext_len = 0;
770 *version = NULL;
771 *ver_len = 0;
772
773 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
774 path_desc.dsc$w_length = strlen(path);
775 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
776 path_desc.dsc$b_class = DSC$K_CLASS_S;
777
778 /* Get the total length, if it is shorter than the string passed
779 * then this was probably not a VMS formatted file specification
780 */
781 item_list[filespec].itmcode = FSCN$_FILESPEC;
782 item_list[filespec].length = 0;
783 item_list[filespec].component = NULL;
784
785 /* If the node is present, then it gets considered as part of the
786 * volume name to hopefully make things simple.
787 */
788 item_list[nodespec].itmcode = FSCN$_NODE;
789 item_list[nodespec].length = 0;
790 item_list[nodespec].component = NULL;
791
792 item_list[devspec].itmcode = FSCN$_DEVICE;
793 item_list[devspec].length = 0;
794 item_list[devspec].component = NULL;
795
796 /* root is a special case, adding it to either the directory or
797 * the device components will probalby complicate things for the
798 * callers of this routine, so leave it separate.
799 */
800 item_list[rootspec].itmcode = FSCN$_ROOT;
801 item_list[rootspec].length = 0;
802 item_list[rootspec].component = NULL;
803
804 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
805 item_list[dirspec].length = 0;
806 item_list[dirspec].component = NULL;
807
808 item_list[namespec].itmcode = FSCN$_NAME;
809 item_list[namespec].length = 0;
810 item_list[namespec].component = NULL;
811
812 item_list[typespec].itmcode = FSCN$_TYPE;
813 item_list[typespec].length = 0;
814 item_list[typespec].component = NULL;
815
816 item_list[verspec].itmcode = FSCN$_VERSION;
817 item_list[verspec].length = 0;
818 item_list[verspec].component = NULL;
819
820 item_list[8].itmcode = 0;
821 item_list[8].length = 0;
822 item_list[8].component = NULL;
823
7566800d 824 status = sys$filescan
657054d4
JM		 825 ((const struct dsc$descriptor_s *)&path_desc, item_list,
826 &flags, NULL, NULL);
360732b5 827 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 828
829 /* If we parsed it successfully these two lengths should be the same */
830 if (path_desc.dsc$w_length != item_list[filespec].length)
831 return ret_stat;
832
833 /* If we got here, then it is a VMS file specification */
834 ret_stat = 0;
835
836 /* set the volume name */
837 if (item_list[nodespec].length > 0) {
838 *volume = item_list[nodespec].component;
839 *vol_len = item_list[nodespec].length + item_list[devspec].length;
840 }
841 else {
842 *volume = item_list[devspec].component;
843 *vol_len = item_list[devspec].length;
844 }
845
846 *root = item_list[rootspec].component;
847 *root_len = item_list[rootspec].length;
848
849 *dir = item_list[dirspec].component;
850 *dir_len = item_list[dirspec].length;
851
852 /* Now fun with versions and EFS file specifications
853 * The parser can not tell the difference when a "." is a version
854 * delimiter or a part of the file specification.
855 */
856 if ((decc_efs_charset) &&
857 (item_list[verspec].length > 0) &&
858 (item_list[verspec].component[0] == '.')) {
859 *name = item_list[namespec].component;
860 *name_len = item_list[namespec].length + item_list[typespec].length;
861 *ext = item_list[verspec].component;
862 *ext_len = item_list[verspec].length;
863 *version = NULL;
864 *ver_len = 0;
865 }
866 else {
867 *name = item_list[namespec].component;
868 *name_len = item_list[namespec].length;
869 *ext = item_list[typespec].component;
870 *ext_len = item_list[typespec].length;
871 *version = item_list[verspec].component;
872 *ver_len = item_list[verspec].length;
873 }
874 return ret_stat;
875}
876
f7ddb74a 877
fa537f88
CB		 878/* my_maxidx
879 * Routine to retrieve the maximum equivalence index for an input
880 * logical name. Some calls to this routine have no knowledge if
881 * the variable is a logical or not. So on error we return a max
882 * index of zero.
883 */
f7ddb74a 884/*{{{int my_maxidx(const char *lnm) */
fa537f88 885static int
f7ddb74a 886my_maxidx(const char *lnm)
fa537f88
CB		 887{
888 int status;
889 int midx;
890 int attr = LNM$M_CASE_BLIND;
891 struct dsc$descriptor lnmdsc;
892 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
893 {0, 0, 0, 0}};
894
895 lnmdsc.dsc$w_length = strlen(lnm);
896 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
897 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 898 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 899
900 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
901 if ((status & 1) == 0)
902 midx = 0;
903
904 return (midx);
905}
906/*}}}*/
907
f675dbe5 908/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 909int
fd8cd3a3 910Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 911 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 912{
f7ddb74a
JM		 913 const char *cp1;
914 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 915 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 916 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 917 int midx;
f675dbe5
CB		 918 unsigned char acmode;
919 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
920 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
921 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
922 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 923 {0, 0, 0, 0}};
f675dbe5 924 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 925#if defined(PERL_IMPLICIT_CONTEXT)
926 pTHX = NULL;
fd8cd3a3
DS		 927 if (PL_curinterp) {
928 aTHX = PERL_GET_INTERP;
cc077a9f 929 } else {
fd8cd3a3 930 aTHX = NULL;
cc077a9f
HM		 931 }
932#endif
748a9306 933
fa537f88 934 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 935 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
936 }
f7ddb74a 937 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 938 *cp2 = _toupper(*cp1);
939 if (cp1 - lnm > LNM$C_NAMLENGTH) {
940 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
941 return 0;
942 }
943 }
944 lnmdsc.dsc$w_length = cp1 - lnm;
945 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 946 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 947 secure = flags & PERL__TRNENV_SECURE;
948 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
949 if (!tabvec || !*tabvec) tabvec = env_tables;
950
951 for (curtab = 0; tabvec[curtab]; curtab++) {
952 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
953 if (!ivenv && !secure) {
954 char *eq, *end;
955 int i;
956 if (!environ) {
957 ivenv = 1;
5c84aa53 958 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 959 continue;
960 }
961 retsts = SS$_NOLOGNAM;
962 for (i = 0; environ[i]; i++) {
963 if ((eq = strchr(environ[i],'=')) &&
299d126a 964 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 965 !strncmp(environ[i],uplnm,eq - environ[i])) {
966 eq++;
967 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
968 if (!eqvlen) continue;
969 retsts = SS$_NORMAL;
970 break;
971 }
972 }
973 if (retsts != SS$_NOLOGNAM) break;
974 }
975 }
976 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
977 !str$case_blind_compare(&tmpdsc,&clisym)) {
978 if (!ivsym && !secure) {
979 unsigned short int deflen = LNM$C_NAMLENGTH;
980 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
981 /* dynamic dsc to accomodate possible long value */
982 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
983 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
984 if (retsts & 1) {
2497a41f 985 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 986 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 987 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 988 /* Special hack--we might be called before the interpreter's */
989 /* fully initialized, in which case either thr or PL_curcop */
990 /* might be bogus. We have to check, since ckWARN needs them */
991 /* both to be valid if running threaded */
cc077a9f 992 if (ckWARN(WARN_MISC)) {
f98bc0c6 993 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 994 }
f675dbe5
CB		 995 }
996 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
997 }
998 _ckvmssts(lib$sfree1_dd(&eqvdsc));
999 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1000 if (retsts == LIB$_NOSUCHSYM) continue;
1001 break;
1002 }
1003 }
1004 else if (!ivlnm) {
843027b0 1005 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 1006 midx = my_maxidx(lnm);
1007 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1008 lnmlst[1].bufadr = cp2;
fa537f88
CB		 1009 eqvlen = 0;
1010 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1011 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1012 if (retsts == SS$_NOLOGNAM) break;
1013 /* PPFs have a prefix */
1014 if (
fd7385b9 1015#if INTSIZE == 4
fa537f88 1016 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1017#endif
fa537f88
CB		 1018 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1019 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1020 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1021 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1022 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1023 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1024 eqvlen -= 4;
1025 }
f7ddb74a
JM		 1026 cp2 += eqvlen;
1027 *cp2 = '\0';
fa537f88
CB		 1028 }
1029 if ((retsts == SS$_IVLOGNAM) ||
1030 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1031 }
fa537f88 1032 else {
fa537f88
CB		 1033 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1034 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1035 if (retsts == SS$_NOLOGNAM) continue;
1036 eqv[eqvlen] = '\0';
1037 }
1038 eqvlen = strlen(eqv);
f675dbe5
CB		 1039 break;
1040 }
c07a80fd 1041 }
f675dbe5
CB		 1042 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1043 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1044 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1045 retsts == SS$_NOLOGNAM) {
1046 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1047 }
f675dbe5
CB		 1048 else _ckvmssts(retsts);
1049 return 0;
1050} /* end of vmstrnenv */
1051/*}}}*/
c07a80fd 1052
f675dbe5
CB		 1053/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1054/* Define as a function so we can access statics. */
4b19af01 1055int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5
CB		 1056{
1057 return vmstrnenv(lnm,eqv,idx,fildev,
1058#ifdef SECURE_INTERNAL_GETENV
1059 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1060#else
1061 0
1062#endif
1063 );
1064}
1065/*}}}*/
a0d0e21e
LW		 1066
1067/* my_getenv
61bb5906
CB		 1068 * Note: Uses Perl temp to store result so char * can be returned to
1069 * caller; this pointer will be invalidated at next Perl statement
1070 * transition.
a6c40364 1071 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1072 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1073 * allocate SVs).
a0d0e21e 1074 */
f675dbe5 1075/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1076char *
5c84aa53 1077Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1078{
f7ddb74a 1079 const char *cp1;
fa537f88 1080 static char *__my_getenv_eqv = NULL;
f7ddb74a 1081 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1082 unsigned long int idx = 0;
bc10a425 1083 int trnsuccess, success, secure, saverr, savvmserr;
843027b0 1084 int midx, flags;
61bb5906 1085 SV *tmpsv;
a0d0e21e 1086
f7ddb74a 1087 midx = my_maxidx(lnm) + 1;
fa537f88 1088
6b88bc9c 1089 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1090 /* Set up a temporary buffer for the return value; Perl will
1091 * clean it up at the next statement transition */
fa537f88 1092 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1093 if (!tmpsv) return NULL;
1094 eqv = SvPVX(tmpsv);
1095 }
fa537f88
CB		 1096 else {
1097 /* Assume no interpreter ==> single thread */
1098 if (__my_getenv_eqv != NULL) {
1099 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1100 }
1101 else {
a02a5408 1102 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1103 }
1104 eqv = __my_getenv_eqv;
1105 }
1106
f7ddb74a 1107 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1108 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1109 int len;
61bb5906 1110 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1111
1112 len = strlen(eqv);
1113
1114 /* Get rid of "000000/ in rooted filespecs */
1115 if (len > 7) {
1116 char * zeros;
1117 zeros = strstr(eqv, "/000000/");
1118 if (zeros != NULL) {
1119 int mlen;
1120 mlen = len - (zeros - eqv) - 7;
1121 memmove(zeros, &zeros[7], mlen);
1122 len = len - 7;
1123 eqv[len] = '\0';
1124 }
1125 }
61bb5906 1126 return eqv;
748a9306 1127 }
a0d0e21e 1128 else {
2512681b 1129 /* Impose security constraints only if tainting */
bc10a425
CB		 1130 if (sys) {
1131 /* Impose security constraints only if tainting */
1132 secure = PL_curinterp ? PL_tainting : will_taint;
1133 saverr = errno; savvmserr = vaxc$errno;
1134 }
843027b0
CB		 1135 else {
1136 secure = 0;
1137 }
1138
1139 flags =
f675dbe5 1140#ifdef SECURE_INTERNAL_GETENV
843027b0 1141 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1142#else
843027b0 1143 0
f675dbe5 1144#endif
843027b0
CB		 1145 ;
1146
1147 /* For the getenv interface we combine all the equivalence names
1148 * of a search list logical into one value to acquire a maximum
1149 * value length of 255*128 (assuming %ENV is using logicals).
1150 */
1151 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1152
1153 /* If the name contains a semicolon-delimited index, parse it
1154 * off and make sure we only retrieve the equivalence name for
1155 * that index. */
1156 if ((cp2 = strchr(lnm,';')) != NULL) {
1157 strcpy(uplnm,lnm);
1158 uplnm[cp2-lnm] = '\0';
1159 idx = strtoul(cp2+1,NULL,0);
1160 lnm = uplnm;
1161 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1162 }
1163
1164 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1165
bc10a425
CB		 1166 /* Discard NOLOGNAM on internal calls since we're often looking
1167 * for an optional name, and this "error" often shows up as the
1168 * (bogus) exit status for a die() call later on. */
1169 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1170 return success ? eqv : Nullch;
a0d0e21e 1171 }
a0d0e21e
LW		 1172
1173} /* end of my_getenv() */
1174/*}}}*/
1175
f675dbe5 1176
a6c40364
GS		 1177/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1178char *
fd8cd3a3 1179Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1180{
f7ddb74a
JM		 1181 const char *cp1;
1182 char *buf, *cp2;
a6c40364 1183 unsigned long idx = 0;
843027b0 1184 int midx, flags;
fa537f88 1185 static char *__my_getenv_len_eqv = NULL;
bc10a425 1186 int secure, saverr, savvmserr;
cc077a9f
HM		 1187 SV *tmpsv;
1188
f7ddb74a 1189 midx = my_maxidx(lnm) + 1;
fa537f88 1190
cc077a9f
HM		 1191 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1192 /* Set up a temporary buffer for the return value; Perl will
1193 * clean it up at the next statement transition */
fa537f88 1194 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1195 if (!tmpsv) return NULL;
1196 buf = SvPVX(tmpsv);
1197 }
fa537f88
CB		 1198 else {
1199 /* Assume no interpreter ==> single thread */
1200 if (__my_getenv_len_eqv != NULL) {
1201 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1202 }
1203 else {
a02a5408 1204 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1205 }
1206 buf = __my_getenv_len_eqv;
1207 }
1208
f7ddb74a 1209 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1210 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1211 char * zeros;
1212
f675dbe5 1213 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1214 *len = strlen(buf);
f7ddb74a
JM		 1215
1216 /* Get rid of "000000/ in rooted filespecs */
1217 if (*len > 7) {
1218 zeros = strstr(buf, "/000000/");
1219 if (zeros != NULL) {
1220 int mlen;
1221 mlen = *len - (zeros - buf) - 7;
1222 memmove(zeros, &zeros[7], mlen);
1223 *len = *len - 7;
1224 buf[*len] = '\0';
1225 }
1226 }
a6c40364 1227 return buf;
f675dbe5
CB		 1228 }
1229 else {
bc10a425
CB		 1230 if (sys) {
1231 /* Impose security constraints only if tainting */
1232 secure = PL_curinterp ? PL_tainting : will_taint;
1233 saverr = errno; savvmserr = vaxc$errno;
1234 }
843027b0
CB		 1235 else {
1236 secure = 0;
1237 }
1238
1239 flags =
f675dbe5 1240#ifdef SECURE_INTERNAL_GETENV
843027b0 1241 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1242#else
843027b0 1243 0
f675dbe5 1244#endif
843027b0
CB		 1245 ;
1246
1247 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1248
1249 if ((cp2 = strchr(lnm,';')) != NULL) {
1250 strcpy(buf,lnm);
1251 buf[cp2-lnm] = '\0';
1252 idx = strtoul(cp2+1,NULL,0);
1253 lnm = buf;
1254 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1255 }
1256
1257 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1258
f7ddb74a
JM		 1259 /* Get rid of "000000/ in rooted filespecs */
1260 if (*len > 7) {
1261 char * zeros;
1262 zeros = strstr(buf, "/000000/");
1263 if (zeros != NULL) {
1264 int mlen;
1265 mlen = *len - (zeros - buf) - 7;
1266 memmove(zeros, &zeros[7], mlen);
1267 *len = *len - 7;
1268 buf[*len] = '\0';
1269 }
1270 }
1271
bc10a425
CB		 1272 /* Discard NOLOGNAM on internal calls since we're often looking
1273 * for an optional name, and this "error" often shows up as the
1274 * (bogus) exit status for a die() call later on. */
1275 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1276 return *len ? buf : Nullch;
f675dbe5
CB		 1277 }
1278
a6c40364 1279} /* end of my_getenv_len() */
f675dbe5
CB		 1280/*}}}*/
1281
fd8cd3a3 1282static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1283
1284static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1285
740ce14c 1286/*{{{ void prime_env_iter() */
1287void
1288prime_env_iter(void)
1289/* Fill the %ENV associative array with all logical names we can
1290 * find, in preparation for iterating over it.
1291 */
1292{
17f28c40 1293 static int primed = 0;
3eeba6fb 1294 HV *seenhv = NULL, *envhv;
22be8b3c 1295 SV *sv = NULL;
f675dbe5 1296 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
8fde5078
CB		 1297 unsigned short int chan;
1298#ifndef CLI$M_TRUSTED
1299# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1300#endif
f675dbe5
CB		 1301 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1302 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1303 long int i;
1304 bool have_sym = FALSE, have_lnm = FALSE;
1305 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1306 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1307 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1308 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1309 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1310#if defined(PERL_IMPLICIT_CONTEXT)
1311 pTHX;
1312#endif
3db8f154 1313#if defined(USE_ITHREADS)
b2b3adea
HM		 1314 static perl_mutex primenv_mutex;
1315 MUTEX_INIT(&primenv_mutex);
61bb5906 1316#endif
740ce14c 1317
fd8cd3a3
DS		 1318#if defined(PERL_IMPLICIT_CONTEXT)
1319 /* We jump through these hoops because we can be called at */
1320 /* platform-specific initialization time, which is before anything is */
1321 /* set up--we can't even do a plain dTHX since that relies on the */
1322 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1323 if (PL_curinterp) {
1324 aTHX = PERL_GET_INTERP;
1325 } else {
1326 aTHX = NULL;
1327 }
1328#endif
fd8cd3a3 1329
3eeba6fb 1330 if (primed || !PL_envgv) return;
61bb5906
CB		 1331 MUTEX_LOCK(&primenv_mutex);
1332 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1333 envhv = GvHVn(PL_envgv);
740ce14c 1334 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1335 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1336 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1337
f675dbe5
CB		 1338 for (i = 0; env_tables[i]; i++) {
1339 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1340 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1341 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1342 }
f675dbe5
CB		 1343 if (have_sym || have_lnm) {
1344 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1345 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1346 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1347 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1348 }
f675dbe5
CB		 1349
1350 for (i--; i >= 0; i--) {
1351 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1352 char *start;
1353 int j;
1354 for (j = 0; environ[j]; j++) {
1355 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1356 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1357 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1358 }
1359 else {
1360 start++;
22be8b3c
CB		 1361 sv = newSVpv(start,0);
1362 SvTAINTED_on(sv);
1363 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1364 }
1365 }
1366 continue;
740ce14c 1367 }
f675dbe5
CB		 1368 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1369 !str$case_blind_compare(&tmpdsc,&clisym)) {
1370 strcpy(cmd,"Show Symbol/Global *");
1371 cmddsc.dsc$w_length = 20;
1372 if (env_tables[i]->dsc$w_length == 12 &&
1373 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1374 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1375 flags = defflags | CLI$M_NOLOGNAM;
1376 }
1377 else {
1378 strcpy(cmd,"Show Logical *");
1379 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1380 strcat(cmd," /Table=");
1381 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1382 cmddsc.dsc$w_length = strlen(cmd);
1383 }
1384 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1385 flags = defflags | CLI$M_NOCLISYM;
1386 }
1387
1388 /* Create a new subprocess to execute each command, to exclude the
1389 * remote possibility that someone could subvert a mbx or file used
1390 * to write multiple commands to a single subprocess.
1391 */
1392 do {
1393 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1394 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1395 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1396 defflags &= ~CLI$M_TRUSTED;
1397 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1398 _ckvmssts(retsts);
a02a5408 1399 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1400 if (seenhv) SvREFCNT_dec(seenhv);
1401 seenhv = newHV();
1402 while (1) {
1403 char *cp1, *cp2, *key;
1404 unsigned long int sts, iosb[2], retlen, keylen;
1405 register U32 hash;
1406
1407 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1408 if (sts & 1) sts = iosb[0] & 0xffff;
1409 if (sts == SS$_ENDOFFILE) {
1410 int wakect = 0;
1411 while (substs == 0) { sys$hiber(); wakect++;}
1412 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1413 _ckvmssts(substs);
1414 break;
1415 }
1416 _ckvmssts(sts);
1417 retlen = iosb[0] >> 16;
1418 if (!retlen) continue; /* blank line */
1419 buf[retlen] = '\0';
1420 if (iosb[1] != subpid) {
1421 if (iosb[1]) {
5c84aa53 1422 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1423 }
1424 continue;
1425 }
3eeba6fb 1426 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1427 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1428
1429 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1430 if (*cp1 == '(' || /* Logical name table name */
1431 *cp1 == '=' /* Next eqv of searchlist */) continue;
1432 if (*cp1 == '"') cp1++;
1433 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1434 key = cp1; keylen = cp2 - cp1;
1435 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1436 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1437 while (*cp2 && *cp2 == '=') cp2++;
1438 while (*cp2 && *cp2 == ' ') cp2++;
1439 if (*cp2 == '"') { /* String translation; may embed "" */
1440 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1441 cp2++; cp1--; /* Skip "" surrounding translation */
1442 }
1443 else { /* Numeric translation */
1444 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1445 cp1--; /* stop on last non-space char */
1446 }
1447 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1448 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1449 continue;
1450 }
5afd6d42 1451 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1452
1453 if (cp1 == cp2 && *cp2 == '.') {
1454 /* A single dot usually means an unprintable character, such as a null
1455 * to indicate a zero-length value. Get the actual value to make sure.
1456 */
1457 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1458 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1459 int trnlen;
ff79d39d 1460 strncpy(lnm, key, keylen);
0faef845 1461 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1462 sv = newSVpvn(eqv, strlen(eqv));
1463 }
1464 else {
1465 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1466 }
1467
22be8b3c
CB		 1468 SvTAINTED_on(sv);
1469 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1470 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1471 }
f675dbe5
CB		 1472 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1473 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1474 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1475 char eqv[LNM$C_NAMLENGTH+1];
1476 int trnlen, i;
1477 for (i = 0; ppfs[i]; i++) {
1478 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1479 sv = newSVpv(eqv,trnlen);
1480 SvTAINTED_on(sv);
1481 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1482 }
740ce14c 1483 }
1484 }
f675dbe5
CB		 1485 primed = 1;
1486 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1487 if (buf) Safefree(buf);
1488 if (seenhv) SvREFCNT_dec(seenhv);
1489 MUTEX_UNLOCK(&primenv_mutex);
1490 return;
1491
740ce14c 1492} /* end of prime_env_iter */
1493/*}}}*/
740ce14c 1494
f675dbe5 1495
2c590a56 1496/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1497/* Define or delete an element in the same "environment" as
1498 * vmstrnenv(). If an element is to be deleted, it's removed from
1499 * the first place it's found. If it's to be set, it's set in the
1500 * place designated by the first element of the table vector.
3eeba6fb 1501 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1502 */
f675dbe5 1503int
2c590a56 1504Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1505{
f7ddb74a
JM		 1506 const char *cp1;
1507 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1508 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1509 int nseg = 0, j;
a0d0e21e 1510 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1511 struct itmlst_3 *ile, *ilist;
a0d0e21e 1512 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1513 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1514 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1515 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1516 $DESCRIPTOR(local,"_LOCAL");
1517
ed253963
CB		 1518 if (!lnm) {
1519 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1520 return SS$_IVLOGNAM;
1521 }
1522
f7ddb74a 1523 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1524 *cp2 = _toupper(*cp1);
1525 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1526 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1527 return SS$_IVLOGNAM;
1528 }
1529 }
a0d0e21e 1530 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1531 if (!tabvec || !*tabvec) tabvec = env_tables;
1532
3eeba6fb 1533 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1534 for (curtab = 0; tabvec[curtab]; curtab++) {
1535 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1536 int i;
299d126a 1537 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1538 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1539 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1540 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1541#ifdef HAS_SETENV
0e06870b 1542 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1543 }
1544 }
1545 ivenv = 1; retsts = SS$_NOLOGNAM;
1546#else
3eeba6fb 1547 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1548 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1549 ivenv = 1; retsts = SS$_NOSUCHPGM;
1550 break;
1551 }
1552 }
f675dbe5
CB		 1553#endif
1554 }
1555 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1556 !str$case_blind_compare(&tmpdsc,&clisym)) {
1557 unsigned int symtype;
1558 if (tabvec[curtab]->dsc$w_length == 12 &&
1559 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1560 !str$case_blind_compare(&tmpdsc,&local))
1561 symtype = LIB$K_CLI_LOCAL_SYM;
1562 else symtype = LIB$K_CLI_GLOBAL_SYM;
1563 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1564 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1565 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1566 break;
1567 }
1568 else if (!ivlnm) {
1569 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1570 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1571 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1573 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1574 }
a0d0e21e
LW		 1575 }
1576 }
f675dbe5
CB		 1577 else { /* we're defining a value */
1578 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1579#ifdef HAS_SETENV
3eeba6fb 1580 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1581#else
3eeba6fb 1582 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1583 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1584 retsts = SS$_NOSUCHPGM;
1585#endif
1586 }
1587 else {
f7ddb74a 1588 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1589 eqvdsc.dsc$w_length = strlen(eqv);
1590 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1591 !str$case_blind_compare(&tmpdsc,&clisym)) {
1592 unsigned int symtype;
1593 if (tabvec[0]->dsc$w_length == 12 &&
1594 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1595 !str$case_blind_compare(&tmpdsc,&local))
1596 symtype = LIB$K_CLI_LOCAL_SYM;
1597 else symtype = LIB$K_CLI_GLOBAL_SYM;
1598 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1599 }
3eeba6fb
CB		 1600 else {
1601 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1602 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1603
1604 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1605 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1606 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1607 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1608 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1609 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1610 }
1611
a02a5408 1612 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1613 ile = ilist;
1614 if (!ile) {
1615 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1616 return SS$_INSFMEM;
a1dfe751 1617 }
fa537f88
CB		 1618 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1619
1620 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1621 ile->itmcode = LNM$_STRING;
1622 ile->bufadr = c;
1623 if ((j+1) == nseg) {
1624 ile->buflen = strlen(c);
1625 /* in case we are truncating one that's too long */
1626 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1627 }
1628 else {
1629 ile->buflen = LNM$C_NAMLENGTH;
1630 }
1631 }
1632
1633 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1634 Safefree (ilist);
1635 }
1636 else {
1637 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1638 }
3eeba6fb 1639 }
f675dbe5
CB		 1640 }
1641 }
1642 if (!(retsts & 1)) {
1643 switch (retsts) {
1644 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1645 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1646 set_errno(EVMSERR); break;
1647 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1648 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1649 set_errno(EINVAL); break;
1650 case SS$_NOPRIV:
7d2497bf 1651 set_errno(EACCES); break;
f675dbe5
CB		 1652 default:
1653 _ckvmssts(retsts);
1654 set_errno(EVMSERR);
1655 }
1656 set_vaxc_errno(retsts);
1657 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1658 }
3eeba6fb
CB		 1659 else {
1660 /* We reset error values on success because Perl does an hv_fetch()
1661 * before each hv_store(), and if the thing we're setting didn't
1662 * previously exist, we've got a leftover error message. (Of course,
1663 * this fails in the face of
1664 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1665 * in that the error reported in $! isn't spurious,
1666 * but it's right more often than not.)
1667 */
f675dbe5
CB		 1668 set_errno(0); set_vaxc_errno(retsts);
1669 return 0;
1670 }
1671
1672} /* end of vmssetenv() */
1673/*}}}*/
a0d0e21e 1674
2c590a56 1675/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1676/* This has to be a function since there's a prototype for it in proto.h */
1677void
2c590a56 1678Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1679{
bc10a425
CB		 1680 if (lnm && *lnm) {
1681 int len = strlen(lnm);
1682 if (len == 7) {
1683 char uplnm[8];
22d4bb9c
CB		 1684 int i;
1685 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1686 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1687 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1688 return;
1689 }
1690 }
1691#ifndef RTL_USES_UTC
1692 if (len == 6 || len == 2) {
1693 char uplnm[7];
1694 int i;
1695 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1696 uplnm[len] = '\0';
1697 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1698 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
22d4bb9c
CB		 1699 }
1700#endif
1701 }
f675dbe5
CB		 1702 (void) vmssetenv(lnm,eqv,NULL);
1703}
a0d0e21e
LW		 1704/*}}}*/
1705
27c67b75 1706/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1707/* vmssetuserlnm
1708 * sets a user-mode logical in the process logical name table
1709 * used for redirection of sys$error
1710 */
1711void
2fbb330f 1712Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
0e06870b
CB		 1713{
1714 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1715 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1716 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1717 unsigned char acmode = PSL$C_USER;
1718 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1719 {0, 0, 0, 0}};
2fbb330f 1720 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1721 d_name.dsc$w_length = strlen(name);
1722
1723 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1724 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1725
1726 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1727 if (!(iss&1)) lib$signal(iss);
1728}
1729/*}}}*/
c07a80fd 1730
f675dbe5 1731
c07a80fd 1732/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1733/* my_crypt - VMS password hashing
1734 * my_crypt() provides an interface compatible with the Unix crypt()
1735 * C library function, and uses sys$hash_password() to perform VMS
1736 * password hashing. The quadword hashed password value is returned
1737 * as a NUL-terminated 8 character string. my_crypt() does not change
1738 * the case of its string arguments; in order to match the behavior
1739 * of LOGINOUT et al., alphabetic characters in both arguments must
1740 * be upcased by the caller.
2497a41f
JM		 1741 *
1742 * - fix me to call ACM services when available
c07a80fd 1743 */
1744char *
fd8cd3a3 1745Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1746{
1747# ifndef UAI$C_PREFERRED_ALGORITHM
1748# define UAI$C_PREFERRED_ALGORITHM 127
1749# endif
1750 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1751 unsigned short int salt = 0;
1752 unsigned long int sts;
1753 struct const_dsc {
1754 unsigned short int dsc$w_length;
1755 unsigned char dsc$b_type;
1756 unsigned char dsc$b_class;
1757 const char * dsc$a_pointer;
1758 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1759 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1760 struct itmlst_3 uailst[3] = {
1761 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1762 { sizeof salt, UAI$_SALT, &salt, 0},
1763 { 0, 0, NULL, NULL}};
1764 static char hash[9];
1765
1766 usrdsc.dsc$w_length = strlen(usrname);
1767 usrdsc.dsc$a_pointer = usrname;
1768 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1769 switch (sts) {
f282b18d 1770 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1771 set_errno(EACCES);
1772 break;
1773 case RMS$_RNF:
1774 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1775 break;
1776 default:
1777 set_errno(EVMSERR);
1778 }
1779 set_vaxc_errno(sts);
1780 if (sts != RMS$_RNF) return NULL;
1781 }
1782
1783 txtdsc.dsc$w_length = strlen(textpasswd);
1784 txtdsc.dsc$a_pointer = textpasswd;
1785 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1786 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1787 }
1788
1789 return (char *) hash;
1790
1791} /* end of my_crypt() */
1792/*}}}*/
1793
1794
360732b5
JM		 1795static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1796static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1797static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1798
2497a41f
JM		 1799/* fixup barenames that are directories for internal use.
1800 * There have been problems with the consistent handling of UNIX
1801 * style directory names when routines are presented with a name that
1802 * has no directory delimitors at all. So this routine will eventually
1803 * fix the issue.
1804 */
1805static char * fixup_bare_dirnames(const char * name)
1806{
1807 if (decc_disable_to_vms_logname_translation) {
1808/* fix me */
1809 }
1810 return NULL;
1811}
1812
e0e5e8d6
JM		 1813/* 8.3, remove() is now broken on symbolic links */
1814static int rms_erase(const char * vmsname);
1815
1816
2497a41f
JM		 1817/* mp_do_kill_file
1818 * A little hack to get around a bug in some implemenation of remove()
1819 * that do not know how to delete a directory
1820 *
1821 * Delete any file to which user has control access, regardless of whether
1822 * delete access is explicitly allowed.
1823 * Limitations: User must have write access to parent directory.
1824 * Does not block signals or ASTs; if interrupted in midstream
1825 * may leave file with an altered ACL.
1826 * HANDLE WITH CARE!
1827 */
1828/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1829static int
1830mp_do_kill_file(pTHX_ const char *name, int dirflag)
1831{
e0e5e8d6
JM		 1832 char *vmsname;
1833 char *rslt;
2497a41f
JM		 1834 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1835 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1836 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1837 struct myacedef {
1838 unsigned char myace$b_length;
1839 unsigned char myace$b_type;
1840 unsigned short int myace$w_flags;
1841 unsigned long int myace$l_access;
1842 unsigned long int myace$l_ident;
1843 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1844 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1845 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1846 struct itmlst_3
1847 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1848 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1849 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1850 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1851 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1852 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1853
1854 /* Expand the input spec using RMS, since the CRTL remove() and
1855 * system services won't do this by themselves, so we may miss
1856 * a file "hiding" behind a logical name or search list. */
c5375c28
JM		 1857 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1858 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1859
e0e5e8d6
JM		 1860 rslt = do_rmsexpand(name,
1861 vmsname,
1862 0,
1863 NULL,
1864 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1865 NULL,
1866 NULL);
1867 if (rslt == NULL) {
c5375c28 1868 PerlMem_free(vmsname);
2497a41f
JM		 1869 return -1;
1870 }
c5375c28 1871
e0e5e8d6
JM		 1872 /* Erase the file */
1873 rmsts = rms_erase(vmsname);
2497a41f 1874
e0e5e8d6
JM		 1875 /* Did it succeed */
1876 if ($VMS_STATUS_SUCCESS(rmsts)) {
1877 PerlMem_free(vmsname);
1878 return 0;
2497a41f
JM		 1879 }
1880
1881 /* If not, can changing protections help? */
e0e5e8d6
JM		 1882 if (rmsts != RMS$_PRV) {
1883 set_vaxc_errno(rmsts);
1884 PerlMem_free(vmsname);
2497a41f
JM		 1885 return -1;
1886 }
1887
1888 /* No, so we get our own UIC to use as a rights identifier,
1889 * and the insert an ACE at the head of the ACL which allows us
1890 * to delete the file.
1891 */
1892 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1893 fildsc.dsc$w_length = strlen(vmsname);
1894 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1895 cxt = 0;
1896 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1897 rmsts = -1;
2497a41f
JM		 1898 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1899 switch (aclsts) {
1900 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1901 set_errno(ENOENT); break;
1902 case RMS$_DIR:
1903 set_errno(ENOTDIR); break;
1904 case RMS$_DEV:
1905 set_errno(ENODEV); break;
1906 case RMS$_SYN: case SS$_INVFILFOROP:
1907 set_errno(EINVAL); break;
1908 case RMS$_PRV:
1909 set_errno(EACCES); break;
1910 default:
1911 _ckvmssts(aclsts);
1912 }
1913 set_vaxc_errno(aclsts);
e0e5e8d6 1914 PerlMem_free(vmsname);
2497a41f
JM		 1915 return -1;
1916 }
1917 /* Grab any existing ACEs with this identifier in case we fail */
1918 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1919 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1920 || fndsts == SS$_NOMOREACE ) {
1921 /* Add the new ACE . . . */
1922 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1923 goto yourroom;
1924
e0e5e8d6
JM		 1925 rmsts = rms_erase(vmsname);
1926 if ($VMS_STATUS_SUCCESS(rmsts)) {
1927 rmsts = 0;
2497a41f
JM		 1928 }
1929 else {
e0e5e8d6 1930 rmsts = -1;
2497a41f
JM		 1931 /* We blew it - dir with files in it, no write priv for
1932 * parent directory, etc. Put things back the way they were. */
1933 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1934 goto yourroom;
1935 if (fndsts & 1) {
1936 addlst[0].bufadr = &oldace;
1937 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1938 goto yourroom;
1939 }
1940 }
1941 }
1942
1943 yourroom:
1944 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1945 /* We just deleted it, so of course it's not there. Some versions of
1946 * VMS seem to return success on the unlock operation anyhow (after all
1947 * the unlock is successful), but others don't.
1948 */
1949 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1950 if (aclsts & 1) aclsts = fndsts;
1951 if (!(aclsts & 1)) {
1952 set_errno(EVMSERR);
1953 set_vaxc_errno(aclsts);
2497a41f
JM		 1954 }
1955
e0e5e8d6 1956 PerlMem_free(vmsname);
2497a41f
JM		 1957 return rmsts;
1958
1959} /* end of kill_file() */
1960/*}}}*/
1961
1962
a0d0e21e
LW		 1963/*{{{int do_rmdir(char *name)*/
1964int
b8ffc8df 1965Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1966{
e0e5e8d6 1967 char * dirfile;
a0d0e21e 1968 int retval;
61bb5906 1969 Stat_t st;
a0d0e21e 1970
e0e5e8d6
JM		 1971 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1972 if (dirfile == NULL)
1973 _ckvmssts(SS$_INSFMEM);
1974
1975 /* Force to a directory specification */
1976 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1977 PerlMem_free(dirfile);
1978 return -1;
1979 }
dffb32cf 1980 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1981 errno = ENOTDIR;
1982 retval = -1;
1983 }
1984 else
1985 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1986
1987 PerlMem_free(dirfile);
a0d0e21e
LW		 1988 return retval;
1989
1990} /* end of do_rmdir */
1991/*}}}*/
1992
1993/* kill_file
1994 * Delete any file to which user has control access, regardless of whether
1995 * delete access is explicitly allowed.
1996 * Limitations: User must have write access to parent directory.
1997 * Does not block signals or ASTs; if interrupted in midstream
1998 * may leave file with an altered ACL.
1999 * HANDLE WITH CARE!
2000 */
2001/*{{{int kill_file(char *name)*/
2002int
b8ffc8df 2003Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2004{
2f4077ca
JM		 2005 char rspec[NAM$C_MAXRSS+1];
2006 char *tspec;
e0e5e8d6
JM		 2007 Stat_t st;
2008 int rmsts;
a0d0e21e 2009
e0e5e8d6
JM		 2010 /* Remove() is allowed to delete directories, according to the X/Open
2011 * specifications.
4fdf8f88 2012 * This may need special handling to work with the ACL hacks.
a0d0e21e 2013 */
4fdf8f88 2014 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
dffb32cf 2015 rmsts = Perl_do_rmdir(aTHX_ name);
e0e5e8d6 2016 return rmsts;
a0d0e21e
LW		 2017 }
2018
e0e5e8d6 2019 rmsts = mp_do_kill_file(aTHX_ name, 0);
a0d0e21e
LW		 2020
2021 return rmsts;
2022
2023} /* end of kill_file() */
2024/*}}}*/
2025
8cc95fdb 2026
84902520 2027/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2028int
b8ffc8df 2029Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2030{
2031 STRLEN dirlen = strlen(dir);
2032
a2a90019
CB		 2033 /* zero length string sometimes gives ACCVIO */
2034 if (dirlen == 0) return -1;
2035
8cc95fdb 2036 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2037 * null file name/type. However, it's commonplace under Unix,
2038 * so we'll allow it for a gain in portability.
2039 */
2040 if (dir[dirlen-1] == '/') {
2041 char *newdir = savepvn(dir,dirlen-1);
2042 int ret = mkdir(newdir,mode);
2043 Safefree(newdir);
2044 return ret;
2045 }
2046 else return mkdir(dir,mode);
2047} /* end of my_mkdir */
2048/*}}}*/
2049
ee8c7f54
CB		 2050/*{{{int my_chdir(char *)*/
2051int
b8ffc8df 2052Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2053{
2054 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2055
2056 /* zero length string sometimes gives ACCVIO */
2057 if (dirlen == 0) return -1;
f7ddb74a
JM		 2058 const char *dir1;
2059
2060 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2061 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2062 * so that existing scripts do not need to be changed.
2063 */
2064 dir1 = dir;
2065 while ((dirlen > 0) && (*dir1 == ' ')) {
2066 dir1++;
2067 dirlen--;
2068 }
ee8c7f54
CB		 2069
2070 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2071 * that implies
2072 * null file name/type. However, it's commonplace under Unix,
2073 * so we'll allow it for a gain in portability.
f7ddb74a
JM		 2074 *
2075 * - Preview- '/' will be valid soon on VMS
ee8c7f54 2076 */
f7ddb74a 2077 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
dca5a913 2078 char *newdir = savepvn(dir1,dirlen-1);
ee8c7f54
CB		 2079 int ret = chdir(newdir);
2080 Safefree(newdir);
2081 return ret;
2082 }
dca5a913 2083 else return chdir(dir1);
ee8c7f54
CB		 2084} /* end of my_chdir */
2085/*}}}*/
8cc95fdb 2086
674d6c38 2087
f1db9cda
JM		 2088/*{{{int my_chmod(char *, mode_t)*/
2089int
2090Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2091{
2092 STRLEN speclen = strlen(file_spec);
2093
2094 /* zero length string sometimes gives ACCVIO */
2095 if (speclen == 0) return -1;
2096
2097 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2098 * that implies null file name/type. However, it's commonplace under Unix,
2099 * so we'll allow it for a gain in portability.
2100 *
2101 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2102 * in VMS file.dir notation.
2103 */
2104 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2105 char *vms_src, *vms_dir, *rslt;
2106 int ret = -1;
2107 errno = EIO;
2108
2109 /* First convert this to a VMS format specification */
2110 vms_src = PerlMem_malloc(VMS_MAXRSS);
2111 if (vms_src == NULL)
2112 _ckvmssts(SS$_INSFMEM);
2113
2114 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2115 if (rslt == NULL) {
2116 /* If we fail, then not a file specification */
2117 PerlMem_free(vms_src);
2118 errno = EIO;
2119 return -1;
2120 }
2121
2122 /* Now make it a directory spec so chmod is happy */
2123 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2124 if (vms_dir == NULL)
2125 _ckvmssts(SS$_INSFMEM);
2126 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2127 PerlMem_free(vms_src);
2128
2129 /* Now do it */
2130 if (rslt != NULL) {
2131 ret = chmod(vms_dir, mode);
2132 } else {
2133 errno = EIO;
2134 }
2135 PerlMem_free(vms_dir);
2136 return ret;
2137 }
2138 else return chmod(file_spec, mode);
2139} /* end of my_chmod */
2140/*}}}*/
2141
2142
674d6c38
CB		 2143/*{{{FILE *my_tmpfile()*/
2144FILE *
2145my_tmpfile(void)
2146{
2147 FILE *fp;
2148 char *cp;
674d6c38
CB		 2149
2150 if ((fp = tmpfile())) return fp;
2151
c5375c28
JM		 2152 cp = PerlMem_malloc(L_tmpnam+24);
2153 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2154
2497a41f
JM		 2155 if (decc_filename_unix_only == 0)
2156 strcpy(cp,"Sys$Scratch:");
2157 else
2158 strcpy(cp,"/tmp/");
674d6c38
CB		 2159 tmpnam(cp+strlen(cp));
2160 strcat(cp,".Perltmp");
2161 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2162 PerlMem_free(cp);
674d6c38
CB		 2163 return fp;
2164}
2165/*}}}*/
2166
5c2d7af2
CB		 2167
2168#ifndef HOMEGROWN_POSIX_SIGNALS
2169/*
2170 * The C RTL's sigaction fails to check for invalid signal numbers so we
2171 * help it out a bit. The docs are correct, but the actual routine doesn't
2172 * do what the docs say it will.
2173 */
2174/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2175int
2176Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2177 struct sigaction* oact)
2178{
2179 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2180 SETERRNO(EINVAL, SS$_INVARG);
2181 return -1;
2182 }
2183 return sigaction(sig, act, oact);
2184}
2185/*}}}*/
2186#endif
2187
f2610a60
CL		 2188#ifdef KILL_BY_SIGPRC
2189#include <errnodef.h>
2190
05c058bc
CB		 2191/* We implement our own kill() using the undocumented system service
2192 sys$sigprc for one of two reasons:
2193
2194 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2195 target process to do a sys$exit, which usually can't be handled
2196 gracefully...certainly not by Perl and the %SIG{} mechanism.
2197
05c058bc
CB		 2198 2.) If the kill() in the CRTL can't be called from a signal
2199 handler without disappearing into the ether, i.e., the signal
2200 it purportedly sends is never trapped. Still true as of VMS 7.3.
2201
2202 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2203 in the target process rather than calling sys$exit.
2204
2205 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2206 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2207 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2208 with condition codes C$_SIG0+nsig*8, catching the exception on the
2209 target process and resignaling with appropriate arguments.
2210
2211 But we don't have that VMS 7.0+ exception handler, so if you
2212 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2213
2214 Also note that SIGTERM is listed in the docs as being "unimplemented",
2215 yet always seems to be signaled with a VMS condition code of 4 (and
2216 correctly handled for that code). So we hardwire it in.
2217
2218 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2219 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2220 than signalling with an unrecognized (and unhandled by CRTL) code.
2221*/
2222
fe1de8ce 2223#define _MY_SIG_MAX 28
f2610a60 2224
9c1171d1
JM		 2225static unsigned int
2226Perl_sig_to_vmscondition_int(int sig)
f2610a60 2227{
2e34cc90 2228 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2229 {
2230 0, /* 0 ZERO */
2231 SS$_HANGUP, /* 1 SIGHUP */
2232 SS$_CONTROLC, /* 2 SIGINT */
2233 SS$_CONTROLY, /* 3 SIGQUIT */
2234 SS$_RADRMOD, /* 4 SIGILL */
2235 SS$_BREAK, /* 5 SIGTRAP */
2236 SS$_OPCCUS, /* 6 SIGABRT */
2237 SS$_COMPAT, /* 7 SIGEMT */
2238#ifdef __VAX
2239 SS$_FLTOVF, /* 8 SIGFPE VAX */
2240#else
2241 SS$_HPARITH, /* 8 SIGFPE AXP */
2242#endif
2243 SS$_ABORT, /* 9 SIGKILL */
2244 SS$_ACCVIO, /* 10 SIGBUS */
2245 SS$_ACCVIO, /* 11 SIGSEGV */
2246 SS$_BADPARAM, /* 12 SIGSYS */
2247 SS$_NOMBX, /* 13 SIGPIPE */
2248 SS$_ASTFLT, /* 14 SIGALRM */
2249 4, /* 15 SIGTERM */
2250 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2251 0, /* 17 SIGUSR2 */
2252 0, /* 18 */
2253 0, /* 19 */
2254 0, /* 20 SIGCHLD */
2255 0, /* 21 SIGCONT */
2256 0, /* 22 SIGSTOP */
2257 0, /* 23 SIGTSTP */
2258 0, /* 24 SIGTTIN */
2259 0, /* 25 SIGTTOU */
2260 0, /* 26 */
2261 0, /* 27 */
2262 0 /* 28 SIGWINCH */
f2610a60
CL		 2263 };
2264
2265#if __VMS_VER >= 60200000
2266 static int initted = 0;
2267 if (!initted) {
2268 initted = 1;
2269 sig_code[16] = C$_SIGUSR1;
2270 sig_code[17] = C$_SIGUSR2;
fe1de8ce
CB		 2271#if __CRTL_VER >= 70000000
2272 sig_code[20] = C$_SIGCHLD;
2273#endif
2274#if __CRTL_VER >= 70300000
2275 sig_code[28] = C$_SIGWINCH;
2276#endif
f2610a60
CL		 2277 }
2278#endif
2279
2e34cc90
CL		 2280 if (sig < _SIG_MIN) return 0;
2281 if (sig > _MY_SIG_MAX) return 0;
2282 return sig_code[sig];
2283}
2284
9c1171d1
JM		 2285unsigned int
2286Perl_sig_to_vmscondition(int sig)
2287{
2288#ifdef SS$_DEBUG
2289 if (vms_debug_on_exception != 0)
2290 lib$signal(SS$_DEBUG);
2291#endif
2292 return Perl_sig_to_vmscondition_int(sig);
2293}
2294
2295
2e34cc90
CL		 2296int
2297Perl_my_kill(int pid, int sig)
2298{
218fdd94 2299 dTHX;
2e34cc90
CL		 2300 int iss;
2301 unsigned int code;
2302 int sys$sigprc(unsigned int *pidadr,
2303 struct dsc$descriptor_s *prcname,
2304 unsigned int code);
2305
7a7fd8e0
JM		 2306 /* sig 0 means validate the PID */
2307 /*------------------------------*/
2308 if (sig == 0) {
2309 const unsigned long int jpicode = JPI$_PID;
2310 pid_t ret_pid;
2311 int status;
2312 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2313 if ($VMS_STATUS_SUCCESS(status))
2314 return 0;
2315 switch (status) {
2316 case SS$_NOSUCHNODE:
2317 case SS$_UNREACHABLE:
2318 case SS$_NONEXPR:
2319 errno = ESRCH;
2320 break;
2321 case SS$_NOPRIV:
2322 errno = EPERM;
2323 break;
2324 default:
2325 errno = EVMSERR;
2326 }
2327 vaxc$errno=status;
2328 return -1;
2329 }
2330
9c1171d1 2331 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2332
7a7fd8e0
JM		 2333 if (!code) {
2334 SETERRNO(EINVAL, SS$_BADPARAM);
2335 return -1;
2336 }
2337
2338 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2339 * signals are to be sent to multiple processes.
2340 * pid = 0 - all processes in group except ones that the system exempts
2341 * pid = -1 - all processes except ones that the system exempts
2342 * pid = -n - all processes in group (abs(n)) except ...
2343 * For now, just report as not supported.
2344 */
2345
2346 if (pid <= 0) {
2347 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2348 return -1;
2349 }
2350
2e34cc90 2351 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2352 if (iss&1) return 0;
2353
2354 switch (iss) {
2355 case SS$_NOPRIV:
2356 set_errno(EPERM); break;
2357 case SS$_NONEXPR:
2358 case SS$_NOSUCHNODE:
2359 case SS$_UNREACHABLE:
2360 set_errno(ESRCH); break;
2361 case SS$_INSFMEM:
2362 set_errno(ENOMEM); break;
2363 default:
2364 _ckvmssts(iss);
2365 set_errno(EVMSERR);
2366 }
2367 set_vaxc_errno(iss);
2368
2369 return -1;
2370}
2371#endif
2372
2fbb330f
JM		 2373/* Routine to convert a VMS status code to a UNIX status code.
2374** More tricky than it appears because of conflicting conventions with
2375** existing code.
2376**
2377** VMS status codes are a bit mask, with the least significant bit set for
2378** success.
2379**
2380** Special UNIX status of EVMSERR indicates that no translation is currently
2381** available, and programs should check the VMS status code.
2382**
2383** Programs compiled with _POSIX_EXIT have a special encoding that requires
2384** decoding.
2385*/
2386
2387#ifndef C_FACILITY_NO
2388#define C_FACILITY_NO 0x350000
2389#endif
2390#ifndef DCL_IVVERB
2391#define DCL_IVVERB 0x38090
2392#endif
2393
7a7fd8e0 2394int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2395{
2396int facility;
2397int fac_sp;
2398int msg_no;
2399int msg_status;
2400int unix_status;
2401
2402 /* Assume the best or the worst */
2403 if (vms_status & STS$M_SUCCESS)
2404 unix_status = 0;
2405 else
2406 unix_status = EVMSERR;
2407
2408 msg_status = vms_status & ~STS$M_CONTROL;
2409
2410 facility = vms_status & STS$M_FAC_NO;
2411 fac_sp = vms_status & STS$M_FAC_SP;
2412 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2413
0968cdad 2414 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2415 switch(msg_no) {
2416 case SS$_NORMAL:
2417 unix_status = 0;
2418 break;
2419 case SS$_ACCVIO:
2420 unix_status = EFAULT;
2421 break;
7a7fd8e0
JM		 2422 case SS$_DEVOFFLINE:
2423 unix_status = EBUSY;
2424 break;
2425 case SS$_CLEARED:
2426 unix_status = ENOTCONN;
2427 break;
2428 case SS$_IVCHAN:
2fbb330f
JM		 2429 case SS$_IVLOGNAM:
2430 case SS$_BADPARAM:
2431 case SS$_IVLOGTAB:
2432 case SS$_NOLOGNAM:
2433 case SS$_NOLOGTAB:
2434 case SS$_INVFILFOROP:
2435 case SS$_INVARG:
2436 case SS$_NOSUCHID:
2437 case SS$_IVIDENT:
2438 unix_status = EINVAL;
2439 break;
7a7fd8e0
JM		 2440 case SS$_UNSUPPORTED:
2441 unix_status = ENOTSUP;
2442 break;
2fbb330f
JM		 2443 case SS$_FILACCERR:
2444 case SS$_NOGRPPRV:
2445 case SS$_NOSYSPRV:
2446 unix_status = EACCES;
2447 break;
2448 case SS$_DEVICEFULL:
2449 unix_status = ENOSPC;
2450 break;
2451 case SS$_NOSUCHDEV:
2452 unix_status = ENODEV;
2453 break;
2454 case SS$_NOSUCHFILE:
2455 case SS$_NOSUCHOBJECT:
2456 unix_status = ENOENT;
2457 break;
fb38d079
JM		 2458 case SS$_ABORT: /* Fatal case */
2459 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2460 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2461 unix_status = EINTR;
2462 break;
2463 case SS$_BUFFEROVF:
2464 unix_status = E2BIG;
2465 break;
2466 case SS$_INSFMEM:
2467 unix_status = ENOMEM;
2468 break;
2469 case SS$_NOPRIV:
2470 unix_status = EPERM;
2471 break;
2472 case SS$_NOSUCHNODE:
2473 case SS$_UNREACHABLE:
2474 unix_status = ESRCH;
2475 break;
2476 case SS$_NONEXPR:
2477 unix_status = ECHILD;
2478 break;
2479 default:
2480 if ((facility == 0) && (msg_no < 8)) {
2481 /* These are not real VMS status codes so assume that they are
2482 ** already UNIX status codes
2483 */
2484 unix_status = msg_no;
2485 break;
2486 }
2487 }
2488 }
2489 else {
2490 /* Translate a POSIX exit code to a UNIX exit code */
2491 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2492 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2493 }
2494 else {
7a7fd8e0
JM		 2495
2496 /* Documented traditional behavior for handling VMS child exits */
2497 /*--------------------------------------------------------------*/
2498 if (child_flag != 0) {
2499
2500 /* Success / Informational return 0 */
2501 /*----------------------------------*/
2502 if (msg_no & STS$K_SUCCESS)
2503 return 0;
2504
2505 /* Warning returns 1 */
2506 /*-------------------*/
2507 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2508 return 1;
2509
2510 /* Everything else pass through the severity bits */
2511 /*------------------------------------------------*/
2512 return (msg_no & STS$M_SEVERITY);
2513 }
2514
2515 /* Normal VMS status to ERRNO mapping attempt */
2516 /*--------------------------------------------*/
2fbb330f
JM		 2517 switch(msg_status) {
2518 /* case RMS$_EOF: */ /* End of File */
2519 case RMS$_FNF: /* File Not Found */
2520 case RMS$_DNF: /* Dir Not Found */
2521 unix_status = ENOENT;
2522 break;
2523 case RMS$_RNF: /* Record Not Found */
2524 unix_status = ESRCH;
2525 break;
2526 case RMS$_DIR:
2527 unix_status = ENOTDIR;
2528 break;
2529 case RMS$_DEV:
2530 unix_status = ENODEV;
2531 break;
7a7fd8e0
JM		 2532 case RMS$_IFI:
2533 case RMS$_FAC:
2534 case RMS$_ISI:
2535 unix_status = EBADF;
2536 break;
2537 case RMS$_FEX:
2538 unix_status = EEXIST;
2539 break;
2fbb330f
JM		 2540 case RMS$_SYN:
2541 case RMS$_FNM:
2542 case LIB$_INVSTRDES:
2543 case LIB$_INVARG:
2544 case LIB$_NOSUCHSYM:
2545 case LIB$_INVSYMNAM:
2546 case DCL_IVVERB:
2547 unix_status = EINVAL;
2548 break;
2549 case CLI$_BUFOVF:
2550 case RMS$_RTB:
2551 case CLI$_TKNOVF:
2552 case CLI$_RSLOVF:
2553 unix_status = E2BIG;
2554 break;
2555 case RMS$_PRV: /* No privilege */
2556 case RMS$_ACC: /* ACP file access failed */
2557 case RMS$_WLK: /* Device write locked */
2558 unix_status = EACCES;
2559 break;
2560 /* case RMS$_NMF: */ /* No more files */
2561 }
2562 }
2563 }
2564
2565 return unix_status;
2566}
2567
7a7fd8e0
JM		 2568/* Try to guess at what VMS error status should go with a UNIX errno
2569 * value. This is hard to do as there could be many possible VMS
2570 * error statuses that caused the errno value to be set.
2571 */
2572
2573int Perl_unix_status_to_vms(int unix_status)
2574{
2575int test_unix_status;
2576
2577 /* Trivial cases first */
2578 /*---------------------*/
2579 if (unix_status == EVMSERR)
2580 return vaxc$errno;
2581
2582 /* Is vaxc$errno sane? */
2583 /*---------------------*/
2584 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2585 if (test_unix_status == unix_status)
2586 return vaxc$errno;
2587
2588 /* If way out of range, must be VMS code already */
2589 /*-----------------------------------------------*/
2590 if (unix_status > EVMSERR)
2591 return unix_status;
2592
2593 /* If out of range, punt */
2594 /*-----------------------*/
2595 if (unix_status > __ERRNO_MAX)
2596 return SS$_ABORT;
2597
2598
2599 /* Ok, now we have to do it the hard way. */
2600 /*----------------------------------------*/
2601 switch(unix_status) {
2602 case 0: return SS$_NORMAL;
2603 case EPERM: return SS$_NOPRIV;
2604 case ENOENT: return SS$_NOSUCHOBJECT;
2605 case ESRCH: return SS$_UNREACHABLE;
2606 case EINTR: return SS$_ABORT;
2607 /* case EIO: */
2608 /* case ENXIO: */
2609 case E2BIG: return SS$_BUFFEROVF;
2610 /* case ENOEXEC */
2611 case EBADF: return RMS$_IFI;
2612 case ECHILD: return SS$_NONEXPR;
2613 /* case EAGAIN */
2614 case ENOMEM: return SS$_INSFMEM;
2615 case EACCES: return SS$_FILACCERR;
2616 case EFAULT: return SS$_ACCVIO;
2617 /* case ENOTBLK */
0968cdad 2618 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2619 case EEXIST: return RMS$_FEX;
2620 /* case EXDEV */
2621 case ENODEV: return SS$_NOSUCHDEV;
2622 case ENOTDIR: return RMS$_DIR;
2623 /* case EISDIR */
2624 case EINVAL: return SS$_INVARG;
2625 /* case ENFILE */
2626 /* case EMFILE */
2627 /* case ENOTTY */
2628 /* case ETXTBSY */
2629 /* case EFBIG */
2630 case ENOSPC: return SS$_DEVICEFULL;
2631 case ESPIPE: return LIB$_INVARG;
2632 /* case EROFS: */
2633 /* case EMLINK: */
2634 /* case EPIPE: */
2635 /* case EDOM */
2636 case ERANGE: return LIB$_INVARG;
2637 /* case EWOULDBLOCK */
2638 /* case EINPROGRESS */
2639 /* case EALREADY */
2640 /* case ENOTSOCK */
2641 /* case EDESTADDRREQ */
2642 /* case EMSGSIZE */
2643 /* case EPROTOTYPE */
2644 /* case ENOPROTOOPT */
2645 /* case EPROTONOSUPPORT */
2646 /* case ESOCKTNOSUPPORT */
2647 /* case EOPNOTSUPP */
2648 /* case EPFNOSUPPORT */
2649 /* case EAFNOSUPPORT */
2650 /* case EADDRINUSE */
2651 /* case EADDRNOTAVAIL */
2652 /* case ENETDOWN */
2653 /* case ENETUNREACH */
2654 /* case ENETRESET */
2655 /* case ECONNABORTED */
2656 /* case ECONNRESET */
2657 /* case ENOBUFS */
2658 /* case EISCONN */
2659 case ENOTCONN: return SS$_CLEARED;
2660 /* case ESHUTDOWN */
2661 /* case ETOOMANYREFS */
2662 /* case ETIMEDOUT */
2663 /* case ECONNREFUSED */
2664 /* case ELOOP */
2665 /* case ENAMETOOLONG */
2666 /* case EHOSTDOWN */
2667 /* case EHOSTUNREACH */
2668 /* case ENOTEMPTY */
2669 /* case EPROCLIM */
2670 /* case EUSERS */
2671 /* case EDQUOT */
2672 /* case ENOMSG */
2673 /* case EIDRM */
2674 /* case EALIGN */
2675 /* case ESTALE */
2676 /* case EREMOTE */
2677 /* case ENOLCK */
2678 /* case ENOSYS */
2679 /* case EFTYPE */
2680 /* case ECANCELED */
2681 /* case EFAIL */
2682 /* case EINPROG */
2683 case ENOTSUP:
2684 return SS$_UNSUPPORTED;
2685 /* case EDEADLK */
2686 /* case ENWAIT */
2687 /* case EILSEQ */
2688 /* case EBADCAT */
2689 /* case EBADMSG */
2690 /* case EABANDONED */
2691 default:
2692 return SS$_ABORT; /* punt */
2693 }
2694
2695 return SS$_ABORT; /* Should not get here */
2696}
2fbb330f
JM		 2697
2698
22d4bb9c
CB		 2699/* default piping mailbox size */
2700#define PERL_BUFSIZ 512
2701
674d6c38 2702
a0d0e21e 2703static void
fd8cd3a3 2704create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2705{
22d4bb9c
CB		 2706 unsigned long int mbxbufsiz;
2707 static unsigned long int syssize = 0;
2708 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2709 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2710 int sts;
2711
22d4bb9c
CB		 2712 if (!syssize) {
2713 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2714 /*
22d4bb9c
CB		 2715 * Get the SYSGEN parameter MAXBUF
2716 *
2717 * If the logical 'PERL_MBX_SIZE' is defined
2718 * use the value of the logical instead of PERL_BUFSIZ, but
2719 * keep the size between 128 and MAXBUF.
2720 *
a0d0e21e 2721 */
22d4bb9c
CB		 2722 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2723 }
2724
2725 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2726 mbxbufsiz = atoi(csize);
2727 } else {
2728 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2729 }
22d4bb9c
CB		 2730 if (mbxbufsiz < 128) mbxbufsiz = 128;
2731 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2732
f7ddb74a 2733 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2734
f7ddb74a 2735 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
a0d0e21e
LW		 2736 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2737
2738} /* end of create_mbx() */
2739
22d4bb9c 2740
a0d0e21e 2741/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2742
2743typedef struct _iosb IOSB;
2744typedef struct _iosb* pIOSB;
2745typedef struct _pipe Pipe;
2746typedef struct _pipe* pPipe;
2747typedef struct pipe_details Info;
2748typedef struct pipe_details* pInfo;
2749typedef struct _srqp RQE;
2750typedef struct _srqp* pRQE;
2751typedef struct _tochildbuf CBuf;
2752typedef struct _tochildbuf* pCBuf;
2753
2754struct _iosb {
2755 unsigned short status;
2756 unsigned short count;
2757 unsigned long dvispec;
2758};
2759
2760#pragma member_alignment save
2761#pragma nomember_alignment quadword
2762struct _srqp { /* VMS self-relative queue entry */
2763 unsigned long qptr[2];
2764};
2765#pragma member_alignment restore
2766static RQE RQE_ZERO = {0,0};
2767
2768struct _tochildbuf {
2769 RQE q;
2770 int eof;
2771 unsigned short size;
2772 char *buf;
2773};
2774
2775struct _pipe {
2776 RQE free;
2777 RQE wait;
2778 int fd_out;
2779 unsigned short chan_in;
2780 unsigned short chan_out;
2781 char *buf;
2782 unsigned int bufsize;
2783 IOSB iosb;
2784 IOSB iosb2;
2785 int *pipe_done;
2786 int retry;
2787 int type;
2788 int shut_on_empty;
2789 int need_wake;
2790 pPipe *home;
2791 pInfo info;
2792 pCBuf curr;
2793 pCBuf curr2;
fd8cd3a3
DS		 2794#if defined(PERL_IMPLICIT_CONTEXT)
2795 void *thx; /* Either a thread or an interpreter */
2796 /* pointer, depending on how we're built */
2797#endif
22d4bb9c
CB		 2798};
2799
2800
a0d0e21e
LW		 2801struct pipe_details
2802{
22d4bb9c 2803 pInfo next;
ff7adb52
CL		 2804 PerlIO *fp; /* file pointer to pipe mailbox */
2805 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2806 int pid; /* PID of subprocess */
2807 int mode; /* == 'r' if pipe open for reading */
2808 int done; /* subprocess has completed */
ff7adb52 2809 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2810 int closing; /* my_pclose is closing this pipe */
2811 unsigned long completion; /* termination status of subprocess */
2812 pPipe in; /* pipe in to sub */
2813 pPipe out; /* pipe out of sub */
2814 pPipe err; /* pipe of sub's sys$error */
2815 int in_done; /* true when in pipe finished */
2816 int out_done;
2817 int err_done;
cd1191f1
CB		 2818 unsigned short xchan; /* channel to debug xterm */
2819 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2820};
2821
748a9306
LW		 2822struct exit_control_block
2823{
2824 struct exit_control_block *flink;
2825 unsigned long int (*exit_routine)();
2826 unsigned long int arg_count;
2827 unsigned long int *status_address;
2828 unsigned long int exit_status;
2829};
2830
d85f548a
JH		 2831typedef struct _closed_pipes Xpipe;
2832typedef struct _closed_pipes* pXpipe;
2833
2834struct _closed_pipes {
2835 int pid; /* PID of subprocess */
2836 unsigned long completion; /* termination status of subprocess */
2837};
2838#define NKEEPCLOSED 50
2839static Xpipe closed_list[NKEEPCLOSED];
2840static int closed_index = 0;
2841static int closed_num = 0;
2842
22d4bb9c
CB		 2843#define RETRY_DELAY "0 ::0.20"
2844#define MAX_RETRY 50
a0d0e21e 2845
22d4bb9c
CB		 2846static int pipe_ef = 0; /* first call to safe_popen inits these*/
2847static unsigned long mypid;
2848static unsigned long delaytime[2];
2849
2850static pInfo open_pipes = NULL;
2851static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2852
ff7adb52
CL		 2853#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2854
2855
3eeba6fb 2856
748a9306 2857static unsigned long int
fd8cd3a3 2858pipe_exit_routine(pTHX)
748a9306 2859{
22d4bb9c 2860 pInfo info;
1e422769 2861 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
ff7adb52
CL		 2862 int sts, did_stuff, need_eof, j;
2863
5ce486e0
CB		 2864 /*
2865 * Flush any pending i/o, but since we are in process run-down, be
2866 * careful about referencing PerlIO structures that may already have
2867 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2868 */
2869 info = open_pipes;
2870 while (info) {
2871 if (info->fp) {
5ce486e0
CB		 2872 if (!info->useFILE
2873#if defined(USE_ITHREADS)
2874 && my_perl
2875#endif
2876 && PL_perlio_fd_refcnt)
2877 PerlIO_flush(info->fp);
ff7adb52
CL		 2878 else
2879 fflush((FILE *)info->fp);
2880 }
2881 info = info->next;
2882 }
3eeba6fb
CB		 2883
2884 /*
ff7adb52 2885 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2886 don't hang
2887 */
2888 did_stuff = 0;
2889 info = open_pipes;
748a9306 2890
3eeba6fb 2891 while (info) {
b2b89246 2892 int need_eof;
d4c83939 2893 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2894 if (info->in && !info->in->shut_on_empty) {
d4c83939 2895 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
22d4bb9c 2896 0, 0, 0, 0, 0, 0));
ff7adb52 2897 info->waiting = 1;
22d4bb9c 2898 did_stuff = 1;
748a9306 2899 }
d4c83939 2900 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2901 info = info->next;
2902 }
ff7adb52
CL		 2903
2904 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2905
2906 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2907 int nwait = 0;
2908
2909 info = open_pipes;
2910 while (info) {
d4c83939 2911 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2912 if (info->waiting && info->done)
2913 info->waiting = 0;
2914 nwait += info->waiting;
d4c83939 2915 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2916 info = info->next;
2917 }
2918 if (!nwait) break;
2919 sleep(1);
2920 }
3eeba6fb
CB		 2921
2922 did_stuff = 0;
2923 info = open_pipes;
2924 while (info) {
d4c83939 2925 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2926 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2927 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2928 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2929 did_stuff = 1;
2930 }
d4c83939 2931 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2932 info = info->next;
2933 }
ff7adb52
CL		 2934
2935 /* again, wait for effect */
2936
2937 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2938 int nwait = 0;
2939
2940 info = open_pipes;
2941 while (info) {
d4c83939 2942 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2943 if (info->waiting && info->done)
2944 info->waiting = 0;
2945 nwait += info->waiting;
d4c83939 2946 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2947 info = info->next;
2948 }
2949 if (!nwait) break;
2950 sleep(1);
2951 }
3eeba6fb
CB		 2952
2953 info = open_pipes;
2954 while (info) {
d4c83939 2955 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2956 if (!info->done) { /* We tried to be nice . . . */
2957 sts = sys$delprc(&info->pid,0);
d4c83939 2958 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 2959 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 2960 }
d4c83939 2961 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2962 info = info->next;
2963 }
2964
2965 while(open_pipes) {
1e422769 2966 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2967 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 2968 }
2969 return retsts;
2970}
2971
2972static struct exit_control_block pipe_exitblock =
2973 {(struct exit_control_block *) 0,
2974 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2975
22d4bb9c
CB		 2976static void pipe_mbxtofd_ast(pPipe p);
2977static void pipe_tochild1_ast(pPipe p);
2978static void pipe_tochild2_ast(pPipe p);
748a9306 2979
a0d0e21e 2980static void
22d4bb9c 2981popen_completion_ast(pInfo info)
a0d0e21e 2982{
22d4bb9c
CB		 2983 pInfo i = open_pipes;
2984 int iss;
f7ddb74a 2985 int sts;
d85f548a
JH		 2986 pXpipe x;
2987
2988 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2989 closed_list[closed_index].pid = info->pid;
2990 closed_list[closed_index].completion = info->completion;
2991 closed_index++;
2992 if (closed_index == NKEEPCLOSED)
2993 closed_index = 0;
2994 closed_num++;
22d4bb9c
CB		 2995
2996 while (i) {
2997 if (i == info) break;
2998 i = i->next;
2999 }
3000 if (!i) return; /* unlinked, probably freed too */
3001
22d4bb9c
CB		 3002 info->done = TRUE;
3003
3004/*
3005 Writing to subprocess ...
3006 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3007
3008 chan_out may be waiting for "done" flag, or hung waiting
3009 for i/o completion to child...cancel the i/o. This will
3010 put it into "snarf mode" (done but no EOF yet) that discards
3011 input.
3012
3013 Output from subprocess (stdout, stderr) needs to be flushed and
3014 shut down. We try sending an EOF, but if the mbx is full the pipe
3015 routine should still catch the "shut_on_empty" flag, telling it to
3016 use immediate-style reads so that "mbx empty" -> EOF.
3017
3018
3019*/
3020 if (info->in && !info->in_done) { /* only for mode=w */
3021 if (info->in->shut_on_empty && info->in->need_wake) {
3022 info->in->need_wake = FALSE;
fd8cd3a3 3023 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3024 } else {
fd8cd3a3 3025 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3026 }
3027 }
3028
3029 if (info->out && !info->out_done) { /* were we also piping output? */
3030 info->out->shut_on_empty = TRUE;
3031 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3032 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3033 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3034 }
3035
3036 if (info->err && !info->err_done) { /* we were piping stderr */
3037 info->err->shut_on_empty = TRUE;
3038 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3039 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3040 _ckvmssts_noperl(iss);
a0d0e21e 3041 }
fd8cd3a3 3042 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3043
a0d0e21e
LW		 3044}
3045
2fbb330f 3046static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3047static void vms_execfree(struct dsc$descriptor_s *vmscmd);
aa779de1 3048
22d4bb9c
CB		 3049/*
3050 we actually differ from vmstrnenv since we use this to
3051 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3052 are pointing to the same thing
3053*/
3054
3055static unsigned short
fd8cd3a3 3056popen_translate(pTHX_ char *logical, char *result)
22d4bb9c
CB		 3057{
3058 int iss;
3059 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3060 $DESCRIPTOR(d_log,"");
3061 struct _il3 {
3062 unsigned short length;
3063 unsigned short code;
3064 char * buffer_addr;
3065 unsigned short *retlenaddr;
3066 } itmlst[2];
3067 unsigned short l, ifi;
3068
3069 d_log.dsc$a_pointer = logical;
3070 d_log.dsc$w_length = strlen(logical);
3071
3072 itmlst[0].code = LNM$_STRING;
3073 itmlst[0].length = 255;
3074 itmlst[0].buffer_addr = result;
3075 itmlst[0].retlenaddr = &l;
3076
3077 itmlst[1].code = 0;
3078 itmlst[1].length = 0;
3079 itmlst[1].buffer_addr = 0;
3080 itmlst[1].retlenaddr = 0;
3081
3082 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3083 if (iss == SS$_NOLOGNAM) {
3084 iss = SS$_NORMAL;
3085 l = 0;
3086 }
3087 if (!(iss&1)) lib$signal(iss);
3088 result[l] = '\0';
3089/*
3090 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3091 strip it off and return the ifi, if any
3092*/
3093 ifi = 0;
3094 if (result[0] == 0x1b && result[1] == 0x00) {
18a3d61e 3095 memmove(&ifi,result+2,2);
22d4bb9c
CB		 3096 strcpy(result,result+4);
3097 }
3098 return ifi; /* this is the RMS internal file id */
3099}
3100
22d4bb9c
CB		 3101static void pipe_infromchild_ast(pPipe p);
3102
3103/*
3104 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3105 inside an AST routine without worrying about reentrancy and which Perl
3106 memory allocator is being used.
3107
3108 We read data and queue up the buffers, then spit them out one at a
3109 time to the output mailbox when the output mailbox is ready for one.
3110
3111*/
3112#define INITIAL_TOCHILDQUEUE 2
3113
3114static pPipe
fd8cd3a3 3115pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3116{
22d4bb9c
CB		 3117 pPipe p;
3118 pCBuf b;
3119 char mbx1[64], mbx2[64];
3120 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3121 DSC$K_CLASS_S, mbx1},
3122 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3123 DSC$K_CLASS_S, mbx2};
3124 unsigned int dviitm = DVI$_DEVBUFSIZ;
3125 int j, n;
3126
d4c83939
CB		 3127 n = sizeof(Pipe);
3128 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3129
fd8cd3a3
DS		 3130 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3131 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3132 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3133
3134 p->buf = 0;
3135 p->shut_on_empty = FALSE;
3136 p->need_wake = FALSE;
3137 p->type = 0;
3138 p->retry = 0;
3139 p->iosb.status = SS$_NORMAL;
3140 p->iosb2.status = SS$_NORMAL;
3141 p->free = RQE_ZERO;
3142 p->wait = RQE_ZERO;
3143 p->curr = 0;
3144 p->curr2 = 0;
3145 p->info = 0;
fd8cd3a3
DS		 3146#ifdef PERL_IMPLICIT_CONTEXT
3147 p->thx = aTHX;
3148#endif
22d4bb9c
CB		 3149
3150 n = sizeof(CBuf) + p->bufsize;
3151
3152 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3153 _ckvmssts(lib$get_vm(&n, &b));
3154 b->buf = (char *) b + sizeof(CBuf);
3155 _ckvmssts(lib$insqhi(b, &p->free));
3156 }
3157
3158 pipe_tochild2_ast(p);
3159 pipe_tochild1_ast(p);
3160 strcpy(wmbx, mbx1);
3161 strcpy(rmbx, mbx2);
3162 return p;
3163}
3164
3165/* reads the MBX Perl is writing, and queues */
3166
3167static void
3168pipe_tochild1_ast(pPipe p)
3169{
22d4bb9c
CB		 3170 pCBuf b = p->curr;
3171 int iss = p->iosb.status;
3172 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3173 int sts;
fd8cd3a3
DS		 3174#ifdef PERL_IMPLICIT_CONTEXT
3175 pTHX = p->thx;
3176#endif
22d4bb9c
CB		 3177
3178 if (p->retry) {
3179 if (eof) {
3180 p->shut_on_empty = TRUE;
3181 b->eof = TRUE;
3182 _ckvmssts(sys$dassgn(p->chan_in));
3183 } else {
3184 _ckvmssts(iss);
3185 }
3186
3187 b->eof = eof;
3188 b->size = p->iosb.count;
f7ddb74a 3189 _ckvmssts(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3190 if (p->need_wake) {
3191 p->need_wake = FALSE;
3192 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3193 }
3194 } else {
3195 p->retry = 1; /* initial call */
3196 }
3197
3198 if (eof) { /* flush the free queue, return when done */
3199 int n = sizeof(CBuf) + p->bufsize;
3200 while (1) {
3201 iss = lib$remqti(&p->free, &b);
3202 if (iss == LIB$_QUEWASEMP) return;
3203 _ckvmssts(iss);
3204 _ckvmssts(lib$free_vm(&n, &b));
3205 }
3206 }
3207
3208 iss = lib$remqti(&p->free, &b);
3209 if (iss == LIB$_QUEWASEMP) {
3210 int n = sizeof(CBuf) + p->bufsize;
3211 _ckvmssts(lib$get_vm(&n, &b));
3212 b->buf = (char *) b + sizeof(CBuf);
3213 } else {
3214 _ckvmssts(iss);
3215 }
3216
3217 p->curr = b;
3218 iss = sys$qio(0,p->chan_in,
3219 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3220 &p->iosb,
3221 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3222 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3223 _ckvmssts(iss);
3224}
3225
3226
3227/* writes queued buffers to output, waits for each to complete before
3228 doing the next */
3229
3230static void
3231pipe_tochild2_ast(pPipe p)
3232{
22d4bb9c
CB		 3233 pCBuf b = p->curr2;
3234 int iss = p->iosb2.status;
3235 int n = sizeof(CBuf) + p->bufsize;
3236 int done = (p->info && p->info->done) ||
3237 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3238#if defined(PERL_IMPLICIT_CONTEXT)
3239 pTHX = p->thx;
3240#endif
22d4bb9c
CB		 3241
3242 do {
3243 if (p->type) { /* type=1 has old buffer, dispose */
3244 if (p->shut_on_empty) {
3245 _ckvmssts(lib$free_vm(&n, &b));
3246 } else {
3247 _ckvmssts(lib$insqhi(b, &p->free));
3248 }
3249 p->type = 0;
3250 }
3251
3252 iss = lib$remqti(&p->wait, &b);
3253 if (iss == LIB$_QUEWASEMP) {
3254 if (p->shut_on_empty) {
3255 if (done) {
3256 _ckvmssts(sys$dassgn(p->chan_out));
3257 *p->pipe_done = TRUE;
3258 _ckvmssts(sys$setef(pipe_ef));
3259 } else {
3260 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3261 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3262 }
3263 return;
3264 }
3265 p->need_wake = TRUE;
3266 return;
3267 }
3268 _ckvmssts(iss);
3269 p->type = 1;
3270 } while (done);
3271
3272
3273 p->curr2 = b;
3274 if (b->eof) {
3275 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3276 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3277 } else {
3278 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3279 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3280 }
3281
3282 return;
3283
3284}
3285
3286
3287static pPipe
fd8cd3a3 3288pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3289{
22d4bb9c
CB		 3290 pPipe p;
3291 char mbx1[64], mbx2[64];
3292 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3293 DSC$K_CLASS_S, mbx1},
3294 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3295 DSC$K_CLASS_S, mbx2};
3296 unsigned int dviitm = DVI$_DEVBUFSIZ;
3297
d4c83939
CB		 3298 int n = sizeof(Pipe);
3299 _ckvmssts(lib$get_vm(&n, &p));
fd8cd3a3
DS		 3300 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3301 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
22d4bb9c
CB		 3302
3303 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3304 n = p->bufsize * sizeof(char);
3305 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3306 p->shut_on_empty = FALSE;
3307 p->info = 0;
3308 p->type = 0;
3309 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3310#if defined(PERL_IMPLICIT_CONTEXT)
3311 p->thx = aTHX;
3312#endif
22d4bb9c
CB		 3313 pipe_infromchild_ast(p);
3314
3315 strcpy(wmbx, mbx1);
3316 strcpy(rmbx, mbx2);
3317 return p;
3318}
3319
3320static void
3321pipe_infromchild_ast(pPipe p)
3322{
22d4bb9c
CB		 3323 int iss = p->iosb.status;
3324 int eof = (iss == SS$_ENDOFFILE);
3325 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3326 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3327#if defined(PERL_IMPLICIT_CONTEXT)
3328 pTHX = p->thx;
3329#endif
22d4bb9c
CB		 3330
3331 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3332 _ckvmssts(sys$dassgn(p->chan_out));
3333 p->chan_out = 0;
3334 }
3335
3336 /* read completed:
3337 input shutdown if EOF from self (done or shut_on_empty)
3338 output shutdown if closing flag set (my_pclose)
3339 send data/eof from child or eof from self
3340 otherwise, re-read (snarf of data from child)
3341 */
3342
3343 if (p->type == 1) {
3344 p->type = 0;
3345 if (myeof && p->chan_in) { /* input shutdown */
3346 _ckvmssts(sys$dassgn(p->chan_in));
3347 p->chan_in = 0;
3348 }
3349
3350 if (p->chan_out) {
3351 if (myeof || kideof) { /* pass EOF to parent */
3352 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3353 pipe_infromchild_ast, p,
3354 0, 0, 0, 0, 0, 0));
3355 return;
3356 } else if (eof) { /* eat EOF --- fall through to read*/
3357
3358 } else { /* transmit data */
3359 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3360 pipe_infromchild_ast,p,
3361 p->buf, p->iosb.count, 0, 0, 0, 0));
3362 return;
3363 }
3364 }
3365 }
3366
3367 /* everything shut? flag as done */
3368
3369 if (!p->chan_in && !p->chan_out) {
3370 *p->pipe_done = TRUE;
3371 _ckvmssts(sys$setef(pipe_ef));
3372 return;
3373 }
3374
3375 /* write completed (or read, if snarfing from child)
3376 if still have input active,
3377 queue read...immediate mode if shut_on_empty so we get EOF if empty
3378 otherwise,
3379 check if Perl reading, generate EOFs as needed
3380 */
3381
3382 if (p->type == 0) {
3383 p->type = 1;
3384 if (p->chan_in) {
3385 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3386 pipe_infromchild_ast,p,
3387 p->buf, p->bufsize, 0, 0, 0, 0);
3388 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3389 _ckvmssts(iss);
3390 } else { /* send EOFs for extra reads */
3391 p->iosb.status = SS$_ENDOFFILE;
3392 p->iosb.dvispec = 0;
3393 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3394 0, 0, 0,
3395 pipe_infromchild_ast, p, 0, 0, 0, 0));
3396 }
3397 }
3398}
3399
3400static pPipe
fd8cd3a3 3401pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3402{
22d4bb9c
CB		 3403 pPipe p;
3404 char mbx[64];
3405 unsigned long dviitm = DVI$_DEVBUFSIZ;
3406 struct stat s;
3407 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3408 DSC$K_CLASS_S, mbx};
a480973c 3409 int n = sizeof(Pipe);
22d4bb9c
CB		 3410
3411 /* things like terminals and mbx's don't need this filter */
3412 if (fd && fstat(fd,&s) == 0) {
3413 unsigned long dviitm = DVI$_DEVCHAR, devchar;
cfcfe586
JM		 3414 char device[65];
3415 unsigned short dev_len;
3416 struct dsc$descriptor_s d_dev;
3417 char * cptr;
3418 struct item_list_3 items[3];
3419 int status;
3420 unsigned short dvi_iosb[4];
3421
3422 cptr = getname(fd, out, 1);
3423 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3424 d_dev.dsc$a_pointer = out;
3425 d_dev.dsc$w_length = strlen(out);
3426 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3427 d_dev.dsc$b_class = DSC$K_CLASS_S;
3428
3429 items[0].len = 4;
3430 items[0].code = DVI$_DEVCHAR;
3431 items[0].bufadr = &devchar;
3432 items[0].retadr = NULL;
3433 items[1].len = 64;
3434 items[1].code = DVI$_FULLDEVNAM;
3435 items[1].bufadr = device;
3436 items[1].retadr = &dev_len;
3437 items[2].len = 0;
3438 items[2].code = 0;
3439
3440 status = sys$getdviw
3441 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3442 _ckvmssts(status);
3443 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3444 device[dev_len] = 0;
3445
3446 if (!(devchar & DEV$M_DIR)) {
3447 strcpy(out, device);
3448 return 0;
3449 }
3450 }
22d4bb9c
CB		 3451 }
3452
d4c83939 3453 _ckvmssts(lib$get_vm(&n, &p));
22d4bb9c 3454 p->fd_out = dup(fd);
fd8cd3a3 3455 create_mbx(aTHX_ &p->chan_in, &d_mbx);
22d4bb9c 3456 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939
CB		 3457 n = (p->bufsize+1) * sizeof(char);
3458 _ckvmssts(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3459 p->shut_on_empty = FALSE;
3460 p->retry = 0;
3461 p->info = 0;
3462 strcpy(out, mbx);
3463
3464 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3465 pipe_mbxtofd_ast, p,
3466 p->buf, p->bufsize, 0, 0, 0, 0));
3467
3468 return p;
3469}
3470
3471static void
3472pipe_mbxtofd_ast(pPipe p)
3473{
22d4bb9c
CB		 3474 int iss = p->iosb.status;
3475 int done = p->info->done;
3476 int iss2;
3477 int eof = (iss == SS$_ENDOFFILE);
3478 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3479 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3480#if defined(PERL_IMPLICIT_CONTEXT)
3481 pTHX = p->thx;
3482#endif
22d4bb9c
CB		 3483
3484 if (done && myeof) { /* end piping */
3485 close(p->fd_out);
3486 sys$dassgn(p->chan_in);
3487 *p->pipe_done = TRUE;
3488 _ckvmssts(sys$setef(pipe_ef));
3489 return;
3490 }
3491
3492 if (!err && !eof) { /* good data to send to file */
3493 p->buf[p->iosb.count] = '\n';
3494 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3495 if (iss2 < 0) {
3496 p->retry++;
3497 if (p->retry < MAX_RETRY) {
3498 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3499 return;
3500 }
3501 }
3502 p->retry = 0;
3503 } else if (err) {
3504 _ckvmssts(iss);
3505 }
3506
3507
3508 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3509 pipe_mbxtofd_ast, p,
3510 p->buf, p->bufsize, 0, 0, 0, 0);
3511 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3512 _ckvmssts(iss);
3513}
3514
3515
3516typedef struct _pipeloc PLOC;
3517typedef struct _pipeloc* pPLOC;
3518
3519struct _pipeloc {
3520 pPLOC next;
3521 char dir[NAM$C_MAXRSS+1];
3522};
3523static pPLOC head_PLOC = 0;
3524
5c0ae288 3525void
fd8cd3a3 3526free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3527{
3528 pPLOC p, pnext;
ff7adb52 3529 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3530
ff7adb52 3531 p = *pHead;
5c0ae288
CL		 3532 while (p) {
3533 pnext = p->next;
e0ef6b43 3534 PerlMem_free(p);
5c0ae288
CL		 3535 p = pnext;
3536 }
ff7adb52 3537 *pHead = 0;
5c0ae288 3538}
22d4bb9c
CB		 3539
3540static void
fd8cd3a3 3541store_pipelocs(pTHX)
22d4bb9c
CB		 3542{
3543 int i;
3544 pPLOC p;
ff7adb52 3545 AV *av = 0;
22d4bb9c
CB		 3546 SV *dirsv;
3547 GV *gv;
3548 char *dir, *x;
3549 char *unixdir;
3550 char temp[NAM$C_MAXRSS+1];
3551 STRLEN n_a;
3552
ff7adb52 3553 if (head_PLOC)
218fdd94 3554 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3555
22d4bb9c
CB		 3556/* the . directory from @INC comes last */
3557
e0ef6b43 3558 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3559 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3560 p->next = head_PLOC;
3561 head_PLOC = p;
3562 strcpy(p->dir,"./");
3563
3564/* get the directory from $^X */
3565
c5375c28
JM		 3566 unixdir = PerlMem_malloc(VMS_MAXRSS);
3567 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3568
218fdd94
CL		 3569#ifdef PERL_IMPLICIT_CONTEXT
3570 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3571#else
22d4bb9c 3572 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3573#endif
22d4bb9c
CB		 3574 strcpy(temp, PL_origargv[0]);
3575 x = strrchr(temp,']');
2497a41f
JM		 3576 if (x == NULL) {
3577 x = strrchr(temp,'>');
3578 if (x == NULL) {
3579 /* It could be a UNIX path */
3580 x = strrchr(temp,'/');
3581 }
3582 }
3583 if (x)
3584 x[1] = '\0';
3585 else {
3586 /* Got a bare name, so use default directory */
3587 temp[0] = '.';
3588 temp[1] = '\0';
3589 }
22d4bb9c 3590
360732b5 3591 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
e0ef6b43 3592 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3593 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3594 p->next = head_PLOC;
3595 head_PLOC = p;
3596 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3597 p->dir[NAM$C_MAXRSS] = '\0';
c5375c28 3598 }
22d4bb9c
CB		 3599 }
3600
3601/* reverse order of @INC entries, skip "." since entered above */
3602
218fdd94
CL		 3603#ifdef PERL_IMPLICIT_CONTEXT
3604 if (aTHX)
3605#endif
ff7adb52
CL		 3606 if (PL_incgv) av = GvAVn(PL_incgv);
3607
3608 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3609 dirsv = *av_fetch(av,i,TRUE);
3610
3611 if (SvROK(dirsv)) continue;
3612 dir = SvPVx(dirsv,n_a);
3613 if (strcmp(dir,".") == 0) continue;
360732b5 3614 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
22d4bb9c
CB		 3615 continue;
3616
e0ef6b43 3617 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3618 p->next = head_PLOC;
3619 head_PLOC = p;
3620 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3621 p->dir[NAM$C_MAXRSS] = '\0';
3622 }
3623
3624/* most likely spot (ARCHLIB) put first in the list */
3625
3626#ifdef ARCHLIB_EXP
360732b5 3627 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
e0ef6b43 3628 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
c5375c28 3629 if (p == NULL) _ckvmssts(SS$_INSFMEM);
22d4bb9c
CB		 3630 p->next = head_PLOC;
3631 head_PLOC = p;
3632 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3633 p->dir[NAM$C_MAXRSS] = '\0';
3634 }
3635#endif
c5375c28 3636 PerlMem_free(unixdir);
22d4bb9c
CB		 3637}
3638
a1887106
JM		 3639static I32
3640Perl_cando_by_name_int
3641 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3642#if !defined(PERL_IMPLICIT_CONTEXT)
3643#define cando_by_name_int Perl_cando_by_name_int
3644#else
3645#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3646#endif
22d4bb9c
CB		 3647
3648static char *
fd8cd3a3 3649find_vmspipe(pTHX)
22d4bb9c
CB		 3650{
3651 static int vmspipe_file_status = 0;
3652 static char vmspipe_file[NAM$C_MAXRSS+1];
3653
3654 /* already found? Check and use ... need read+execute permission */
3655
3656 if (vmspipe_file_status == 1) {
a1887106
JM		 3657 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3658 && cando_by_name_int
3659 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3660 return vmspipe_file;
3661 }
3662 vmspipe_file_status = 0;
3663 }
3664
3665 /* scan through stored @INC, $^X */
3666
3667 if (vmspipe_file_status == 0) {
3668 char file[NAM$C_MAXRSS+1];
3669 pPLOC p = head_PLOC;
3670
3671 while (p) {
2f4077ca 3672 char * exp_res;
4d743a9b 3673 int dirlen;
22d4bb9c 3674 strcpy(file, p->dir);
4d743a9b
JM		 3675 dirlen = strlen(file);
3676 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
22d4bb9c
CB		 3677 file[NAM$C_MAXRSS] = '\0';
3678 p = p->next;
3679
2f4077ca 3680 exp_res = do_rmsexpand
360732b5 3681 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
2f4077ca 3682 if (!exp_res) continue;
22d4bb9c 3683
a1887106
JM		 3684 if (cando_by_name_int
3685 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3686 && cando_by_name_int
3687 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3688 vmspipe_file_status = 1;
3689 return vmspipe_file;
3690 }
3691 }
3692 vmspipe_file_status = -1; /* failed, use tempfiles */
3693 }
3694
3695 return 0;
3696}
3697
3698static FILE *
fd8cd3a3 3699vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3700{
3701 char file[NAM$C_MAXRSS+1];
3702 FILE *fp;
3703 static int index = 0;
2497a41f
JM		 3704 Stat_t s0, s1;
3705 int cmp_result;
22d4bb9c
CB		 3706
3707 /* create a tempfile */
3708
3709 /* we can't go from W, shr=get to R, shr=get without
3710 an intermediate vulnerable state, so don't bother trying...
3711
3712 and lib$spawn doesn't shr=put, so have to close the write
3713
3714 So... match up the creation date/time and the FID to
3715 make sure we're dealing with the same file
3716
3717 */
3718
3719 index++;
2497a41f
JM		 3720 if (!decc_filename_unix_only) {
3721 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3722 fp = fopen(file,"w");
3723 if (!fp) {
22d4bb9c
CB		 3724 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3725 fp = fopen(file,"w");
3726 if (!fp) {
3727 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3728 fp = fopen(file,"w");
2497a41f
JM		 3729 }
3730 }
3731 }
3732 else {
3733 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3734 fp = fopen(file,"w");
3735 if (!fp) {
3736 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3737 fp = fopen(file,"w");
3738 if (!fp) {
3739 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3740 fp = fopen(file,"w");
3741 }
3742 }
22d4bb9c
CB		 3743 }
3744 if (!fp) return 0; /* we're hosed */
3745
f9ecfa39 3746 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3747 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3748 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3749 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3750 fprintf(fp,"$ perl_on = \"set noon\"\n");
3751 fprintf(fp,"$ perl_exit = \"exit\"\n");
3752 fprintf(fp,"$ perl_del = \"delete\"\n");
3753 fprintf(fp,"$ pif = \"if\"\n");
3754 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3755 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3756 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3757 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3758 fprintf(fp,"$! --- build command line to get max possible length\n");
3759 fprintf(fp,"$c=perl_popen_cmd0\n");
3760 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3761 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3762 fprintf(fp,"$x=perl_popen_cmd3\n");
3763 fprintf(fp,"$c=c+x\n");
22d4bb9c 3764 fprintf(fp,"$ perl_on\n");
f9ecfa39 3765 fprintf(fp,"$ 'c'\n");
22d4bb9c 3766 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3767 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3768 fprintf(fp,"$ perl_exit 'perl_status'\n");
3769 fsync(fileno(fp));
3770
3771 fgetname(fp, file, 1);
2497a41f 3772 fstat(fileno(fp), (struct stat *)&s0);
22d4bb9c
CB		 3773 fclose(fp);
3774
2497a41f 3775 if (decc_filename_unix_only)
360732b5 3776 do_tounixspec(file, file, 0, NULL);
22d4bb9c
CB		 3777 fp = fopen(file,"r","shr=get");
3778 if (!fp) return 0;
2497a41f
JM		 3779 fstat(fileno(fp), (struct stat *)&s1);
3780
682e4b71 3781 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3782 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3783 fclose(fp);
3784 return 0;
3785 }
3786
3787 return fp;
3788}
3789
3790
cd1191f1
CB		 3791static int vms_is_syscommand_xterm(void)
3792{
3793 const static struct dsc$descriptor_s syscommand_dsc =
3794 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3795
3796 const static struct dsc$descriptor_s decwdisplay_dsc =
3797 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3798
3799 struct item_list_3 items[2];
3800 unsigned short dvi_iosb[4];
3801 unsigned long devchar;
3802 unsigned long devclass;
3803 int status;
3804
3805 /* Very simple check to guess if sys$command is a decterm? */
3806 /* First see if the DECW$DISPLAY: device exists */
3807 items[0].len = 4;
3808 items[0].code = DVI$_DEVCHAR;
3809 items[0].bufadr = &devchar;
3810 items[0].retadr = NULL;
3811 items[1].len = 0;
3812 items[1].code = 0;
3813
3814 status = sys$getdviw
3815 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3816
3817 if ($VMS_STATUS_SUCCESS(status)) {
3818 status = dvi_iosb[0];
3819 }
3820
3821 if (!$VMS_STATUS_SUCCESS(status)) {
3822 SETERRNO(EVMSERR, status);
3823 return -1;
3824 }
3825
3826 /* If it does, then for now assume that we are on a workstation */
3827 /* Now verify that SYS$COMMAND is a terminal */
3828 /* for creating the debugger DECTerm */
3829
3830 items[0].len = 4;
3831 items[0].code = DVI$_DEVCLASS;
3832 items[0].bufadr = &devclass;
3833 items[0].retadr = NULL;
3834 items[1].len = 0;
3835 items[1].code = 0;
3836
3837 status = sys$getdviw
3838 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3839
3840 if ($VMS_STATUS_SUCCESS(status)) {
3841 status = dvi_iosb[0];
3842 }
3843
3844 if (!$VMS_STATUS_SUCCESS(status)) {
3845 SETERRNO(EVMSERR, status);
3846 return -1;
3847 }
3848 else {
3849 if (devclass == DC$_TERM) {
3850 return 0;
3851 }
3852 }
3853 return -1;
3854}
3855
3856/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3857static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3858{
3859 int status;
3860 int ret_stat;
3861 char * ret_char;
3862 char device_name[65];
3863 unsigned short device_name_len;
3864 struct dsc$descriptor_s customization_dsc;
3865 struct dsc$descriptor_s device_name_dsc;
3866 const char * cptr;
3867 char * tptr;
3868 char customization[200];
3869 char title[40];
3870 pInfo info = NULL;
3871 char mbx1[64];
3872 unsigned short p_chan;
3873 int n;
3874 unsigned short iosb[4];
3875 struct item_list_3 items[2];
3876 const char * cust_str =
3877 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3878 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3879 DSC$K_CLASS_S, mbx1};
3880
8cb5d3d5
JM		 3881 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3882 /*---------------------------------------*/
d30c1055 3883 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3884
3885
3886 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3887 ret_char = strstr(cmd," xterm ");
3888 if (ret_char == NULL)
3889 return NULL;
3890 cptr = ret_char + 7;
3891 ret_char = strstr(cmd,"tty");
3892 if (ret_char == NULL)
3893 return NULL;
3894 ret_char = strstr(cmd,"sleep");
3895 if (ret_char == NULL)
3896 return NULL;
3897
8cb5d3d5
JM		 3898 if (decw_term_port == 0) {
3899 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3900 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3901 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3902
d30c1055 3903 status = lib$find_image_symbol
8cb5d3d5
JM		 3904 (&filename1_dsc,
3905 &decw_term_port_dsc,
3906 (void *)&decw_term_port,
3907 NULL,
3908 0);
3909
3910 /* Try again with the other image name */
3911 if (!$VMS_STATUS_SUCCESS(status)) {
3912
d30c1055 3913 status = lib$find_image_symbol
8cb5d3d5
JM		 3914 (&filename2_dsc,
3915 &decw_term_port_dsc,
3916 (void *)&decw_term_port,
3917 NULL,
3918 0);
3919
3920 }
3921
3922 }
3923
3924
3925 /* No decw$term_port, give it up */
3926 if (!$VMS_STATUS_SUCCESS(status))
3927 return NULL;
3928
cd1191f1
CB		 3929 /* Are we on a workstation? */
3930 /* to do: capture the rows / columns and pass their properties */
3931 ret_stat = vms_is_syscommand_xterm();
3932 if (ret_stat < 0)
3933 return NULL;
3934
3935 /* Make the title: */
3936 ret_char = strstr(cptr,"-title");
3937 if (ret_char != NULL) {
3938 while ((*cptr != 0) && (*cptr != '\"')) {
3939 cptr++;
3940 }
3941 if (*cptr == '\"')
3942 cptr++;
3943 n = 0;
3944 while ((*cptr != 0) && (*cptr != '\"')) {
3945 title[n] = *cptr;
3946 n++;
3947 if (n == 39) {
3948 title[39] == 0;
3949 break;
3950 }
3951 cptr++;
3952 }
3953 title[n] = 0;
3954 }
3955 else {
3956 /* Default title */
3957 strcpy(title,"Perl Debug DECTerm");
3958 }
3959 sprintf(customization, cust_str, title);
3960
3961 customization_dsc.dsc$a_pointer = customization;
3962 customization_dsc.dsc$w_length = strlen(customization);
3963 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3964 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3965
3966 device_name_dsc.dsc$a_pointer = device_name;
3967 device_name_dsc.dsc$w_length = sizeof device_name -1;
3968 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3969 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3970
3971 device_name_len = 0;
3972
3973 /* Try to create the window */
8cb5d3d5 3974 status = (*decw_term_port)
cd1191f1
CB		 3975 (NULL,
3976 NULL,
3977 &customization_dsc,
3978 &device_name_dsc,
3979 &device_name_len,
3980 NULL,
3981 NULL,
3982 NULL);
3983 if (!$VMS_STATUS_SUCCESS(status)) {
3984 SETERRNO(EVMSERR, status);
3985 return NULL;
3986 }
3987
3988 device_name[device_name_len] = '\0';
3989
3990 /* Need to set this up to look like a pipe for cleanup */
3991 n = sizeof(Info);
3992 status = lib$get_vm(&n, &info);
3993 if (!$VMS_STATUS_SUCCESS(status)) {
3994 SETERRNO(ENOMEM, status);
3995 return NULL;
3996 }
3997
3998 info->mode = *mode;
3999 info->done = FALSE;
4000 info->completion = 0;
4001 info->closing = FALSE;
4002 info->in = 0;
4003 info->out = 0;
4004 info->err = 0;
4005 info->fp = Nullfp;
4006 info->useFILE = 0;
4007 info->waiting = 0;
4008 info->in_done = TRUE;
4009 info->out_done = TRUE;
4010 info->err_done = TRUE;
4011
4012 /* Assign a channel on this so that it will persist, and not login */
4013 /* We stash this channel in the info structure for reference. */
4014 /* The created xterm self destructs when the last channel is removed */
4015 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4016 /* So leave this assigned. */
4017 device_name_dsc.dsc$w_length = device_name_len;
4018 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4019 if (!$VMS_STATUS_SUCCESS(status)) {
4020 SETERRNO(EVMSERR, status);
4021 return NULL;
4022 }
4023 info->xchan_valid = 1;
4024
4025 /* Now create a mailbox to be read by the application */
4026
4027 create_mbx(aTHX_ &p_chan, &d_mbx1);
4028
4029 /* write the name of the created terminal to the mailbox */
4030 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4031 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4032
4033 if (!$VMS_STATUS_SUCCESS(status)) {
4034 SETERRNO(EVMSERR, status);
4035 return NULL;
4036 }
4037
4038 info->fp = PerlIO_open(mbx1, mode);
4039
4040 /* Done with this channel */
4041 sys$dassgn(p_chan);
4042
4043 /* If any errors, then clean up */
4044 if (!info->fp) {
4045 n = sizeof(Info);
4046 _ckvmssts(lib$free_vm(&n, &info));
4047 return NULL;
4048 }
4049
4050 /* All done */
4051 return info->fp;
4052}
22d4bb9c 4053
8fde5078 4054static PerlIO *
2fbb330f 4055safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4056{
748a9306 4057 static int handler_set_up = FALSE;
55f2b99c 4058 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4059 /* The use of a GLOBAL table (as was done previously) rendered
4060 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4061 * environment. Hence we've switched to LOCAL symbol table.
4062 */
4063 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4064 int j, wait = 0, n;
ff7adb52 4065 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4066 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4067 FILE *tpipe = 0;
4068 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4069 pInfo info = NULL;
48b5a746 4070 char cmd_sym_name[20];
22d4bb9c
CB		 4071 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4072 DSC$K_CLASS_S, symbol};
22d4bb9c 4073 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4074 DSC$K_CLASS_S, 0};
48b5a746
CL		 4075 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4076 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4077 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4078 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4079 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4080 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4081
cd1191f1
CB		 4082 /* Check here for Xterm create request. This means looking for
4083 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4084 * is possible to create an xterm.
4085 */
4086 if (*in_mode == 'r') {
4087 PerlIO * xterm_fd;
4088
4089 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4090 if (xterm_fd != Nullfp)
4091 return xterm_fd;
4092 }
cd1191f1 4093
afd8f436
JH		 4094 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4095
22d4bb9c
CB		 4096 /* once-per-program initialization...
4097 note that the SETAST calls and the dual test of pipe_ef
4098 makes sure that only the FIRST thread through here does
4099 the initialization...all other threads wait until it's
4100 done.
4101
4102 Yeah, uglier than a pthread call, it's got all the stuff inline
4103 rather than in a separate routine.
4104 */
4105
4106 if (!pipe_ef) {
4107 _ckvmssts(sys$setast(0));
4108 if (!pipe_ef) {
4109 unsigned long int pidcode = JPI$_PID;
4110 $DESCRIPTOR(d_delay, RETRY_DELAY);
4111 _ckvmssts(lib$get_ef(&pipe_ef));
4112 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4113 _ckvmssts(sys$bintim(&d_delay, delaytime));
4114 }
4115 if (!handler_set_up) {
4116 _ckvmssts(sys$dclexh(&pipe_exitblock));
4117 handler_set_up = TRUE;
4118 }
4119 _ckvmssts(sys$setast(1));
4120 }
4121
4122 /* see if we can find a VMSPIPE.COM */
4123
4124 tfilebuf[0] = '@';
fd8cd3a3 4125 vmspipe = find_vmspipe(aTHX);
22d4bb9c
CB		 4126 if (vmspipe) {
4127 strcpy(tfilebuf+1,vmspipe);
4128 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4129 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4130 if (!tpipe) { /* a fish popular in Boston */
4131 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4132 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c
CB		 4133 }
4134 return Nullfp;
4135 }
4136 fgetname(tpipe,tfilebuf+1,1);
4137 }
4138 vmspipedsc.dsc$a_pointer = tfilebuf;
4139 vmspipedsc.dsc$w_length = strlen(tfilebuf);
a0d0e21e 4140
218fdd94 4141 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4142 if (!(sts & 1)) {
4143 switch (sts) {
4144 case RMS$_FNF: case RMS$_DNF:
4145 set_errno(ENOENT); break;
4146 case RMS$_DIR:
4147 set_errno(ENOTDIR); break;
4148 case RMS$_DEV:
4149 set_errno(ENODEV); break;
4150 case RMS$_PRV:
4151 set_errno(EACCES); break;
4152 case RMS$_SYN:
4153 set_errno(EINVAL); break;
4154 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4155 set_errno(E2BIG); break;
4156 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4157 _ckvmssts(sts); /* fall through */
4158 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4159 set_errno(EVMSERR);
4160 }
4161 set_vaxc_errno(sts);
cd1191f1 4162 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4163 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4164 }
ff7adb52 4165 *psts = sts;
a2669cfc
JH		 4166 return Nullfp;
4167 }
d4c83939
CB		 4168 n = sizeof(Info);
4169 _ckvmssts(lib$get_vm(&n, &info));
22d4bb9c 4170
ff7adb52 4171 strcpy(mode,in_mode);
22d4bb9c
CB		 4172 info->mode = *mode;
4173 info->done = FALSE;
4174 info->completion = 0;
4175 info->closing = FALSE;
4176 info->in = 0;
4177 info->out = 0;
4178 info->err = 0;
ff7adb52
CL		 4179 info->fp = Nullfp;
4180 info->useFILE = 0;
4181 info->waiting = 0;
22d4bb9c
CB		 4182 info->in_done = TRUE;
4183 info->out_done = TRUE;
4184 info->err_done = TRUE;
cd1191f1
CB		 4185 info->xchan = 0;
4186 info->xchan_valid = 0;
cfcfe586
JM		 4187
4188 in = PerlMem_malloc(VMS_MAXRSS);
4189 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4190 out = PerlMem_malloc(VMS_MAXRSS);
4191 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4192 err = PerlMem_malloc(VMS_MAXRSS);
4193 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4194
0e06870b 4195 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4196
ff7adb52
CL		 4197 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4198 info->useFILE = 1;
4199 strcpy(p,p+1);
4200 }
4201 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4202 wait = 1;
4203 strcpy(p,p+1);
4204 }
4205
22d4bb9c 4206 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4207
fd8cd3a3 4208 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4209 if (info->out) {
4210 info->out->pipe_done = &info->out_done;
4211 info->out_done = FALSE;
4212 info->out->info = info;
4213 }
ff7adb52 4214 if (!info->useFILE) {
cd1191f1 4215 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4216 } else {
4217 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4218 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4219 }
4220
22d4bb9c
CB		 4221 if (!info->fp && info->out) {
4222 sys$cancel(info->out->chan_out);
4223
4224 while (!info->out_done) {
4225 int done;
4226 _ckvmssts(sys$setast(0));
4227 done = info->out_done;
4228 if (!done) _ckvmssts(sys$clref(pipe_ef));
4229 _ckvmssts(sys$setast(1));
4230 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
0e06870b 4231 }
22d4bb9c 4232
d4c83939
CB		 4233 if (info->out->buf) {
4234 n = info->out->bufsize * sizeof(char);
4235 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4236 }
4237 n = sizeof(Pipe);
4238 _ckvmssts(lib$free_vm(&n, &info->out));
4239 n = sizeof(Info);
4240 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 4241 *psts = RMS$_FNF;
22d4bb9c 4242 return Nullfp;
0e06870b 4243 }
22d4bb9c 4244
fd8cd3a3 4245 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4246 if (info->err) {
4247 info->err->pipe_done = &info->err_done;
4248 info->err_done = FALSE;
4249 info->err->info = info;
4250 }
a0d0e21e 4251
ff7adb52
CL		 4252 } else if (*mode == 'w') { /* piping to subroutine */
4253
4254 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4255 if (info->out) {
4256 info->out->pipe_done = &info->out_done;
4257 info->out_done = FALSE;
4258 info->out->info = info;
4259 }
4260
4261 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4262 if (info->err) {
4263 info->err->pipe_done = &info->err_done;
4264 info->err_done = FALSE;
4265 info->err->info = info;
4266 }
a0d0e21e 4267
fd8cd3a3 4268 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4269 if (!info->useFILE) {
a480973c 4270 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4271 } else {
4272 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4273 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4274 }
4275
22d4bb9c
CB		 4276 if (info->in) {
4277 info->in->pipe_done = &info->in_done;
4278 info->in_done = FALSE;
4279 info->in->info = info;
4280 }
a0d0e21e 4281
22d4bb9c
CB		 4282 /* error cleanup */
4283 if (!info->fp && info->in) {
4284 info->done = TRUE;
4285 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4286 0, 0, 0, 0, 0, 0, 0, 0));
4287
4288 while (!info->in_done) {
4289 int done;
4290 _ckvmssts(sys$setast(0));
4291 done = info->in_done;
4292 if (!done) _ckvmssts(sys$clref(pipe_ef));
4293 _ckvmssts(sys$setast(1));
4294 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4295 }
a0d0e21e 4296
d4c83939
CB		 4297 if (info->in->buf) {
4298 n = info->in->bufsize * sizeof(char);
4299 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4300 }
4301 n = sizeof(Pipe);
4302 _ckvmssts(lib$free_vm(&n, &info->in));
4303 n = sizeof(Info);
4304 _ckvmssts(lib$free_vm(&n, &info));
ff7adb52 4305 *psts = RMS$_FNF;
0e06870b 4306 return Nullfp;
22d4bb9c 4307 }
a0d0e21e 4308
22d4bb9c 4309
ff7adb52 4310 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 4311 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4312 if (info->out) {
4313 info->out->pipe_done = &info->out_done;
4314 info->out_done = FALSE;
4315 info->out->info = info;
4316 }
0e06870b 4317
fd8cd3a3 4318 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4319 if (info->err) {
4320 info->err->pipe_done = &info->err_done;
4321 info->err_done = FALSE;
4322 info->err->info = info;
4323 }
748a9306 4324 }
22d4bb9c
CB		 4325
4326 symbol[MAX_DCL_SYMBOL] = '\0';
4327
4328 strncpy(symbol, in, MAX_DCL_SYMBOL);
4329 d_symbol.dsc$w_length = strlen(symbol);
4330 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4331
4332 strncpy(symbol, err, MAX_DCL_SYMBOL);
4333 d_symbol.dsc$w_length = strlen(symbol);
4334 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4335
0e06870b
CB		 4336 strncpy(symbol, out, MAX_DCL_SYMBOL);
4337 d_symbol.dsc$w_length = strlen(symbol);
4338 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4339
cfcfe586
JM		 4340 /* Done with the names for the pipes */
4341 PerlMem_free(err);
4342 PerlMem_free(out);
4343 PerlMem_free(in);
4344
218fdd94 4345 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4346 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4347 if (*p == '$') p++; /* remove leading $ */
4348 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4349
4350 for (j = 0; j < 4; j++) {
4351 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4352 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4353
22d4bb9c
CB		 4354 strncpy(symbol, p, MAX_DCL_SYMBOL);
4355 d_symbol.dsc$w_length = strlen(symbol);
4356 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4357
48b5a746
CL		 4358 if (strlen(p) > MAX_DCL_SYMBOL) {
4359 p += MAX_DCL_SYMBOL;
4360 } else {
4361 p += strlen(p);
4362 }
4363 }
22d4bb9c 4364 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 4365 info->next=open_pipes; /* prepend to list */
4366 open_pipes=info;
22d4bb9c 4367 _ckvmssts(sys$setast(1));
55f2b99c
CB		 4368 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4369 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4370 * have SYS$COMMAND if we need it.
4371 */
4372 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4373 0, &info->pid, &info->completion,
4374 0, popen_completion_ast,info,0,0,0));
4375
4376 /* if we were using a tempfile, close it now */
4377
4378 if (tpipe) fclose(tpipe);
4379
ff7adb52 4380 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4381 we can get rid of ours */
4382
48b5a746
CL		 4383 for (j = 0; j < 4; j++) {
4384 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4385 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
22d4bb9c 4386 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4387 }
22d4bb9c
CB		 4388 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4389 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
0e06870b 4390 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4391 vms_execfree(vmscmd);
a0d0e21e 4392
218fdd94
CL		 4393#ifdef PERL_IMPLICIT_CONTEXT
4394 if (aTHX)
4395#endif
6b88bc9c 4396 PL_forkprocess = info->pid;
218fdd94 4397
ff7adb52
CL		 4398 if (wait) {
4399 int done = 0;
4400 while (!done) {
4401 _ckvmssts(sys$setast(0));
4402 done = info->done;
4403 if (!done) _ckvmssts(sys$clref(pipe_ef));
4404 _ckvmssts(sys$setast(1));
4405 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4406 }
4407 *psts = info->completion;
2fbb330f
JM		 4408/* Caller thinks it is open and tries to close it. */
4409/* This causes some problems, as it changes the error status */
4410/* my_pclose(info->fp); */
ff7adb52 4411 } else {
eed5d6a1 4412 *psts = info->pid;
ff7adb52 4413 }
a0d0e21e 4414 return info->fp;
1e422769 4415} /* end of safe_popen */
4416
4417
a15cef0c
CB		 4418/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4419PerlIO *
2fbb330f 4420Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4421{
ff7adb52 4422 int sts;
1e422769 4423 TAINT_ENV();
4424 TAINT_PROPER("popen");
45bc9206 4425 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4426 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4427}
1e422769 4428
a0d0e21e
LW		 4429/*}}}*/
4430
a15cef0c
CB		 4431/*{{{ I32 my_pclose(PerlIO *fp)*/
4432I32 Perl_my_pclose(pTHX_ PerlIO *fp)
a0d0e21e 4433{
22d4bb9c 4434 pInfo info, last = NULL;
748a9306 4435 unsigned long int retsts;
d4c83939 4436 int done, iss, n;
cd1191f1 4437 int status;
a0d0e21e
LW		 4438
4439 for (info = open_pipes; info != NULL; last = info, info = info->next)
4440 if (info->fp == fp) break;
4441
1e422769 4442 if (info == NULL) { /* no such pipe open */
4443 set_errno(ECHILD); /* quoth POSIX */
4444 set_vaxc_errno(SS$_NONEXPR);
4445 return -1;
4446 }
748a9306 4447
bbce6d69 4448 /* If we were writing to a subprocess, insure that someone reading from
4449 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4450 * produce an EOF record in the mailbox.
4451 *
4452 * well, at least sometimes it *does*, so we have to watch out for
4453 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4454 */
ff7adb52 4455 if (info->fp) {
5ce486e0
CB		 4456 if (!info->useFILE
4457#if defined(USE_ITHREADS)
4458 && my_perl
4459#endif
4460 && PL_perlio_fd_refcnt)
4461 PerlIO_flush(info->fp);
ff7adb52
CL		 4462 else
4463 fflush((FILE *)info->fp);
4464 }
22d4bb9c 4465
b08af3f0 4466 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4467 info->closing = TRUE;
4468 done = info->done && info->in_done && info->out_done && info->err_done;
4469 /* hanging on write to Perl's input? cancel it */
4470 if (info->mode == 'r' && info->out && !info->out_done) {
4471 if (info->out->chan_out) {
4472 _ckvmssts(sys$cancel(info->out->chan_out));
4473 if (!info->out->chan_in) { /* EOF generation, need AST */
4474 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4475 }
4476 }
4477 }
4478 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4479 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4480 0, 0, 0, 0, 0, 0));
b08af3f0 4481 _ckvmssts(sys$setast(1));
ff7adb52 4482 if (info->fp) {
5ce486e0
CB		 4483 if (!info->useFILE
4484#if defined(USE_ITHREADS)
4485 && my_perl
4486#endif
4487 && PL_perlio_fd_refcnt)
d4c83939 4488 PerlIO_close(info->fp);
ff7adb52
CL		 4489 else
4490 fclose((FILE *)info->fp);
4491 }
22d4bb9c
CB		 4492 /*
4493 we have to wait until subprocess completes, but ALSO wait until all
4494 the i/o completes...otherwise we'll be freeing the "info" structure
4495 that the i/o ASTs could still be using...
4496 */
4497
4498 while (!done) {
4499 _ckvmssts(sys$setast(0));
4500 done = info->done && info->in_done && info->out_done && info->err_done;
4501 if (!done) _ckvmssts(sys$clref(pipe_ef));
4502 _ckvmssts(sys$setast(1));
4503 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4504 }
4505 retsts = info->completion;
a0d0e21e 4506
a0d0e21e 4507 /* remove from list of open pipes */
b08af3f0 4508 _ckvmssts(sys$setast(0));
a0d0e21e
LW		 4509 if (last) last->next = info->next;
4510 else open_pipes = info->next;
b08af3f0 4511 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4512
4513 /* free buffers and structures */
4514
4515 if (info->in) {
d4c83939
CB		 4516 if (info->in->buf) {
4517 n = info->in->bufsize * sizeof(char);
4518 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4519 }
4520 n = sizeof(Pipe);
4521 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4522 }
4523 if (info->out) {
d4c83939
CB		 4524 if (info->out->buf) {
4525 n = info->out->bufsize * sizeof(char);
4526 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4527 }
4528 n = sizeof(Pipe);
4529 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4530 }
4531 if (info->err) {
d4c83939
CB		 4532 if (info->err->buf) {
4533 n = info->err->bufsize * sizeof(char);
4534 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4535 }
4536 n = sizeof(Pipe);
4537 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4538 }
d4c83939
CB		 4539 n = sizeof(Info);
4540 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4541
4542 return retsts;
748a9306 4543
a0d0e21e
LW		 4544} /* end of my_pclose() */
4545
119586db 4546#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4547 /* Roll our own prototype because we want this regardless of whether
4548 * _VMS_WAIT is defined.
4549 */
4550 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4551#endif
4552/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4553 created with popen(); otherwise partially emulate waitpid() unless
4554 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4555 Also check processes not considered by the CRTL waitpid().
4556 */
4fdae800 4557/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4558Pid_t
fd8cd3a3 4559Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4560{
22d4bb9c
CB		 4561 pInfo info;
4562 int done;
aeb5cf3c 4563 int sts;
d85f548a 4564 int j;
aeb5cf3c
CB		 4565
4566 if (statusp) *statusp = 0;
a0d0e21e
LW		 4567
4568 for (info = open_pipes; info != NULL; info = info->next)
4569 if (info->pid == pid) break;
4570
4571 if (info != NULL) { /* we know about this child */
748a9306 4572 while (!info->done) {
22d4bb9c
CB		 4573 _ckvmssts(sys$setast(0));
4574 done = info->done;
4575 if (!done) _ckvmssts(sys$clref(pipe_ef));
4576 _ckvmssts(sys$setast(1));
4577 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4578 }
4579
aeb5cf3c 4580 if (statusp) *statusp = info->completion;
a0d0e21e 4581 return pid;
d85f548a
JH		 4582 }
4583
4584 /* child that already terminated? */
aeb5cf3c 4585
d85f548a
JH		 4586 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4587 if (closed_list[j].pid == pid) {
4588 if (statusp) *statusp = closed_list[j].completion;
4589 return pid;
4590 }
a0d0e21e 4591 }
d85f548a
JH		 4592
4593 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4594
119586db 4595#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4596
4597 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4598 * in 7.2 did we get a version that fills in the VMS completion
4599 * status as Perl has always tried to do.
4600 */
4601
4602 sts = __vms_waitpid( pid, statusp, flags );
4603
4604 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4605 return sts;
4606
4607 /* If the real waitpid tells us the child does not exist, we
4608 * fall through here to implement waiting for a child that
4609 * was created by some means other than exec() (say, spawned
4610 * from DCL) or to wait for a process that is not a subprocess
4611 * of the current process.
4612 */
4613
119586db 4614#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 4615
21bc9d50 4616 {
a0d0e21e 4617 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4618 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4619 unsigned long int pidcode = JPI$_PID, mypid;
4620 unsigned long int interval[2];
aeb5cf3c 4621 unsigned int jpi_iosb[2];
d85f548a 4622 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4623 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4624 { 0, 0, 0, 0}
4625 };
aeb5cf3c
CB		 4626
4627 if (pid <= 0) {
4628 /* Sorry folks, we don't presently implement rooting around for
4629 the first child we can find, and we definitely don't want to
4630 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4631 */
4632 set_errno(ENOTSUP);
4633 return -1;
4634 }
4635
d85f548a
JH		 4636 /* Get the owner of the child so I can warn if it's not mine. If the
4637 * process doesn't exist or I don't have the privs to look at it,
4638 * I can go home early.
aeb5cf3c
CB		 4639 */
4640 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4641 if (sts & 1) sts = jpi_iosb[0];
4642 if (!(sts & 1)) {
4643 switch (sts) {
4644 case SS$_NONEXPR:
4645 set_errno(ECHILD);
4646 break;
4647 case SS$_NOPRIV:
4648 set_errno(EACCES);
4649 break;
4650 default:
4651 _ckvmssts(sts);
4652 }
4653 set_vaxc_errno(sts);
4654 return -1;
4655 }
a0d0e21e 4656
3eeba6fb 4657 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4658 /* remind folks they are asking for non-standard waitpid behavior */
4659 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4660 if (ownerpid != mypid)
f98bc0c6 4661 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4662 "waitpid: process %x is not a child of process %x",
4663 pid,mypid);
748a9306 4664 }
a0d0e21e 4665
d85f548a
JH		 4666 /* simply check on it once a second until it's not there anymore. */
4667
4668 _ckvmssts(sys$bintim(&intdsc,interval));
4669 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4670 _ckvmssts(sys$schdwk(0,0,interval,0));
4671 _ckvmssts(sys$hiber());
d85f548a
JH		 4672 }
4673 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4674
4675 _ckvmssts(sts);
a0d0e21e 4676 return pid;
21bc9d50 4677 }
a0d0e21e 4678} /* end of waitpid() */
a0d0e21e
LW		 4679/*}}}*/
4680/*}}}*/
4681/*}}}*/
4682
4683/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4684char *
4685my_gconvert(double val, int ndig, int trail, char *buf)
4686{
4687 static char __gcvtbuf[DBL_DIG+1];
4688 char *loc;
4689
4690 loc = buf ? buf : __gcvtbuf;
71be2cbc 4691
4692#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4693 if (val < 1) {
4694 sprintf(loc,"%.*g",ndig,val);
4695 return loc;
4696 }
4697#endif
4698
a0d0e21e
LW		 4699 if (val) {
4700 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4701 return gcvt(val,ndig,loc);
4702 }
4703 else {
4704 loc[0] = '0'; loc[1] = '\0';
4705 return loc;
4706 }
4707
4708}
4709/*}}}*/
4710
988c775c 4711#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a480973c
JM		 4712static int rms_free_search_context(struct FAB * fab)
4713{
4714struct NAM * nam;
4715
4716 nam = fab->fab$l_nam;
4717 nam->nam$b_nop |= NAM$M_SYNCHK;
4718 nam->nam$l_rlf = NULL;
4719 fab->fab$b_dns = 0;
4720 return sys$parse(fab, NULL, NULL);
4721}
4722
4723#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4724#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4725#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4726#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4727#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4728#define rms_nam_esll(nam) nam.nam$b_esl
4729#define rms_nam_esl(nam) nam.nam$b_esl
4730#define rms_nam_name(nam) nam.nam$l_name
4731#define rms_nam_namel(nam) nam.nam$l_name
4732#define rms_nam_type(nam) nam.nam$l_type
4733#define rms_nam_typel(nam) nam.nam$l_type
4734#define rms_nam_ver(nam) nam.nam$l_ver
4735#define rms_nam_verl(nam) nam.nam$l_ver
4736#define rms_nam_rsll(nam) nam.nam$b_rsl
4737#define rms_nam_rsl(nam) nam.nam$b_rsl
4738#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4739#define rms_set_fna(fab, nam, name, size) \
a1887106 4740 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4741#define rms_get_fna(fab, nam) fab.fab$l_fna
4742#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4743 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4744#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4745#define rms_set_esa(nam, name, size) \
a1887106 4746 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4747#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4748 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4749#define rms_set_rsa(nam, name, size) \
a1887106 4750 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4751#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4752 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4753#define rms_nam_name_type_l_size(nam) \
4754 (nam.nam$b_name + nam.nam$b_type)
a480973c
JM		 4755#else
4756static int rms_free_search_context(struct FAB * fab)
4757{
4758struct NAML * nam;
4759
4760 nam = fab->fab$l_naml;
4761 nam->naml$b_nop |= NAM$M_SYNCHK;
4762 nam->naml$l_rlf = NULL;
4763 nam->naml$l_long_defname_size = 0;
988c775c 4764
a480973c
JM		 4765 fab->fab$b_dns = 0;
4766 return sys$parse(fab, NULL, NULL);
4767}
4768
4769#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4770#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4771#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4772#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4773#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4774#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4775#define rms_nam_esl(nam) nam.naml$b_esl
4776#define rms_nam_name(nam) nam.naml$l_name
4777#define rms_nam_namel(nam) nam.naml$l_long_name
4778#define rms_nam_type(nam) nam.naml$l_type
4779#define rms_nam_typel(nam) nam.naml$l_long_type
4780#define rms_nam_ver(nam) nam.naml$l_ver
4781#define rms_nam_verl(nam) nam.naml$l_long_ver
4782#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4783#define rms_nam_rsl(nam) nam.naml$b_rsl
4784#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4785#define rms_set_fna(fab, nam, name, size) \
a1887106 4786 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4787 nam.naml$l_long_filename_size = size; \
a1887106 4788 nam.naml$l_long_filename = name;}
a480973c
JM		 4789#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4790#define rms_set_dna(fab, nam, name, size) \
a1887106 4791 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4792 nam.naml$l_long_defname_size = size; \
a1887106 4793 nam.naml$l_long_defname = name; }
a480973c 4794#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4795#define rms_set_esa(nam, name, size) \
a1887106 4796 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4797 nam.naml$l_long_expand_alloc = size; \
a1887106 4798 nam.naml$l_long_expand = name; }
a480973c 4799#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4800 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4801 nam.naml$l_long_expand = l_name; \
a1887106 4802 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4803#define rms_set_rsa(nam, name, size) \
a1887106 4804 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4805 nam.naml$l_long_result = name; \
a1887106 4806 nam.naml$l_long_result_alloc = size; }
a480973c 4807#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4808 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4809 nam.naml$l_long_result = l_name; \
a1887106
JM		 4810 nam.naml$l_long_result_alloc = l_size; }
4811#define rms_nam_name_type_l_size(nam) \
4812 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4813#endif
4814
4fdf8f88 4815
e0e5e8d6
JM		 4816/* rms_erase
4817 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4818 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4819 * them if one of the PCP modes is active.
e0e5e8d6
JM		 4820 */
4821static int rms_erase(const char * vmsname)
4822{
4823 int status;
4824 struct FAB myfab = cc$rms_fab;
4825 rms_setup_nam(mynam);
4826
4827 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4828 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4829
e0e5e8d6
JM		 4830 /* Are we removing all versions? */
4831 if (vms_unlink_all_versions == 1) {
4832 const char * defspec = ";*";
4833 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4834 }
4835
4836#ifdef NAML$M_OPEN_SPECIAL
4837 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4838#endif
4839
d30c1055 4840 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 4841
4842 return status;
4843}
4844
bbce6d69 4845
4fdf8f88
JM		 4846static int
4847vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4848 const struct dsc$descriptor_s * vms_dst_dsc,
4849 unsigned long flags)
4850{
4851 /* VMS and UNIX handle file permissions differently and the
4852 * the same ACL trick may be needed for renaming files,
4853 * especially if they are directories.
4854 */
4855
4856 /* todo: get kill_file and rename to share common code */
4857 /* I can not find online documentation for $change_acl
4858 * it appears to be replaced by $set_security some time ago */
4859
4860const unsigned int access_mode = 0;
4861$DESCRIPTOR(obj_file_dsc,"FILE");
4862char *vmsname;
4863char *rslt;
4864unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4865int aclsts, fndsts, rnsts = -1;
4866unsigned int ctx = 0;
4867struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4868struct dsc$descriptor_s * clean_dsc;
4869
4870struct myacedef {
4871 unsigned char myace$b_length;
4872 unsigned char myace$b_type;
4873 unsigned short int myace$w_flags;
4874 unsigned long int myace$l_access;
4875 unsigned long int myace$l_ident;
4876} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4877 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4878 0},
4879 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4880
4881struct item_list_3
4882 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4883 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4884 {0,0,0,0}},
4885 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4886 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4887 {0,0,0,0}};
4888
4889
4890 /* Expand the input spec using RMS, since we do not want to put
4891 * ACLs on the target of a symbolic link */
4892 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4893 if (vmsname == NULL)
4894 return SS$_INSFMEM;
4895
4896 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4897 vmsname,
4898 0,
4899 NULL,
4900 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4901 NULL,
4902 NULL);
4903 if (rslt == NULL) {
4904 PerlMem_free(vmsname);
4905 return SS$_INSFMEM;
4906 }
4907
4908 /* So we get our own UIC to use as a rights identifier,
4909 * and the insert an ACE at the head of the ACL which allows us
4910 * to delete the file.
4911 */
4912 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4913
4914 fildsc.dsc$w_length = strlen(vmsname);
4915 fildsc.dsc$a_pointer = vmsname;
4916 ctx = 0;
4917 newace.myace$l_ident = oldace.myace$l_ident;
4918 rnsts = SS$_ABORT;
4919
4920 /* Grab any existing ACEs with this identifier in case we fail */
4921 clean_dsc = &fildsc;
4922 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4923 &fildsc,
4924 NULL,
4925 OSS$M_WLOCK,
4926 findlst,
4927 &ctx,
4928 &access_mode);
4929
4930 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4931 /* Add the new ACE . . . */
4932
4933 /* if the sys$get_security succeeded, then ctx is valid, and the
4934 * object/file descriptors will be ignored. But otherwise they
4935 * are needed
4936 */
4937 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4938 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4939 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4940 set_errno(EVMSERR);
4941 set_vaxc_errno(aclsts);
4942 PerlMem_free(vmsname);
4943 return aclsts;
4944 }
4945
4946 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4947 NULL, NULL,
4948 &flags,
4949 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4950
4951 if ($VMS_STATUS_SUCCESS(rnsts)) {
4952 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4953 }
4954
4955 /* Put things back the way they were. */
4956 ctx = 0;
4957 aclsts = sys$get_security(&obj_file_dsc,
4958 clean_dsc,
4959 NULL,
4960 OSS$M_WLOCK,
4961 findlst,
4962 &ctx,
4963 &access_mode);
4964
4965 if ($VMS_STATUS_SUCCESS(aclsts)) {
4966 int sec_flags;
4967
4968 sec_flags = 0;
4969 if (!$VMS_STATUS_SUCCESS(fndsts))
4970 sec_flags = OSS$M_RELCTX;
4971
4972 /* Get rid of the new ACE */
4973 aclsts = sys$set_security(NULL, NULL, NULL,
4974 sec_flags, dellst, &ctx, &access_mode);
4975
4976 /* If there was an old ACE, put it back */
4977 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4978 addlst[0].bufadr = &oldace;
4979 aclsts = sys$set_security(NULL, NULL, NULL,
4980 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4981 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4982 set_errno(EVMSERR);
4983 set_vaxc_errno(aclsts);
4984 rnsts = aclsts;
4985 }
4986 } else {
4987 int aclsts2;
4988
4989 /* Try to clear the lock on the ACL list */
4990 aclsts2 = sys$set_security(NULL, NULL, NULL,
4991 OSS$M_RELCTX, NULL, &ctx, &access_mode);
4992
4993 /* Rename errors are most important */
4994 if (!$VMS_STATUS_SUCCESS(rnsts))
4995 aclsts = rnsts;
4996 set_errno(EVMSERR);
4997 set_vaxc_errno(aclsts);
4998 rnsts = aclsts;
4999 }
5000 }
5001 else {
5002 if (aclsts != SS$_ACLEMPTY)
5003 rnsts = aclsts;
5004 }
5005 }
5006 else
5007 rnsts = fndsts;
5008
5009 PerlMem_free(vmsname);
5010 return rnsts;
5011}
5012
5013
5014/*{{{int rename(const char *, const char * */
5015/* Not exactly what X/Open says to do, but doing it absolutely right
5016 * and efficiently would require a lot more work. This should be close
5017 * enough to pass all but the most strict X/Open compliance test.
5018 */
5019int
5020Perl_rename(pTHX_ const char *src, const char * dst)
5021{
5022int retval;
5023int pre_delete = 0;
5024int src_sts;
5025int dst_sts;
5026Stat_t src_st;
5027Stat_t dst_st;
5028
5029 /* Validate the source file */
5030 src_sts = flex_lstat(src, &src_st);
5031 if (src_sts != 0) {
5032
5033 /* No source file or other problem */
5034 return src_sts;
5035 }
5036
5037 dst_sts = flex_lstat(dst, &dst_st);
5038 if (dst_sts == 0) {
5039
5040 if (dst_st.st_dev != src_st.st_dev) {
5041 /* Must be on the same device */
5042 errno = EXDEV;
5043 return -1;
5044 }
5045
5046 /* VMS_INO_T_COMPARE is true if the inodes are different
5047 * to match the output of memcmp
5048 */
5049
5050 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5051 /* That was easy, the files are the same! */
5052 return 0;
5053 }
5054
5055 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5056 /* If source is a directory, so must be dest */
5057 errno = EISDIR;
5058 return -1;
5059 }
5060
5061 }
5062
5063
5064 if ((dst_sts == 0) &&
5065 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5066
5067 /* We have issues here if vms_unlink_all_versions is set
5068 * If the destination exists, and is not a directory, then
5069 * we must delete in advance.
5070 *
5071 * If the src is a directory, then we must always pre-delete
5072 * the destination.
5073 *
5074 * If we successfully delete the dst in advance, and the rename fails
5075 * X/Open requires that errno be EIO.
5076 *
5077 */
5078
5079 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5080 int d_sts;
5081 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5082 if (d_sts != 0)
5083 return d_sts;
5084
5085 /* We killed the destination, so only errno now is EIO */
5086 pre_delete = 1;
5087 }
5088 }
5089
5090 /* Originally the idea was to call the CRTL rename() and only
5091 * try the lib$rename_file if it failed.
5092 * It turns out that there are too many variants in what the
5093 * the CRTL rename might do, so only use lib$rename_file
5094 */
5095 retval = -1;
5096
5097 {
5098 /* Is the source and dest both in VMS format */
5099 /* if the source is a directory, then need to fileify */
5100 /* and dest must be a directory or non-existant. */
5101
5102 char * vms_src;
5103 char * vms_dst;
5104 int sts;
5105 char * ret_str;
5106 unsigned long flags;
5107 struct dsc$descriptor_s old_file_dsc;
5108 struct dsc$descriptor_s new_file_dsc;
5109
5110 /* We need to modify the src and dst depending
5111 * on if one or more of them are directories.
5112 */
5113
5114 vms_src = PerlMem_malloc(VMS_MAXRSS);
5115 if (vms_src == NULL)
5116 _ckvmssts(SS$_INSFMEM);
5117
5118 /* Source is always a VMS format file */
5119 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5120 if (ret_str == NULL) {
5121 PerlMem_free(vms_src);
5122 errno = EIO;
5123 return -1;
5124 }
5125
5126 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5127 if (vms_dst == NULL)
5128 _ckvmssts(SS$_INSFMEM);
5129
5130 if (S_ISDIR(src_st.st_mode)) {
5131 char * ret_str;
5132 char * vms_dir_file;
5133
5134 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5135 if (vms_dir_file == NULL)
5136 _ckvmssts(SS$_INSFMEM);
5137
5138 /* The source must be a file specification */
5139 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5140 if (ret_str == NULL) {
5141 PerlMem_free(vms_src);
5142 PerlMem_free(vms_dst);
5143 PerlMem_free(vms_dir_file);
5144 errno = EIO;
5145 return -1;
5146 }
5147 PerlMem_free(vms_src);
5148 vms_src = vms_dir_file;
5149
5150 /* If the dest is a directory, we must remove it
5151 if (dst_sts == 0) {
5152 int d_sts;
5153 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5154 if (d_sts != 0) {
5155 PerlMem_free(vms_src);
5156 PerlMem_free(vms_dst);
5157 errno = EIO;
5158 return sts;
5159 }
5160
5161 pre_delete = 1;
5162 }
5163
5164 /* The dest must be a VMS file specification */
5165 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5166 if (ret_str == NULL) {
5167 PerlMem_free(vms_src);
5168 PerlMem_free(vms_dst);
5169 errno = EIO;
5170 return -1;
5171 }
5172
5173 /* The source must be a file specification */
5174 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5175 if (vms_dir_file == NULL)
5176 _ckvmssts(SS$_INSFMEM);
5177
5178 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5179 if (ret_str == NULL) {
5180 PerlMem_free(vms_src);
5181 PerlMem_free(vms_dst);
5182 PerlMem_free(vms_dir_file);
5183 errno = EIO;
5184 return -1;
5185 }
5186 PerlMem_free(vms_dst);
5187 vms_dst = vms_dir_file;
5188
5189 } else {
5190 /* File to file or file to new dir */
5191
5192 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5193 /* VMS pathify a dir target */
5194 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5195 if (ret_str == NULL) {
5196 PerlMem_free(vms_src);
5197 PerlMem_free(vms_dst);
5198 errno = EIO;
5199 return -1;
5200 }
5201 } else {
5202
5203 /* fileify a target VMS file specification */
5204 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5205 if (ret_str == NULL) {
5206 PerlMem_free(vms_src);
5207 PerlMem_free(vms_dst);
5208 errno = EIO;
5209 return -1;
5210 }
5211 }
5212 }
5213
5214 old_file_dsc.dsc$a_pointer = vms_src;
5215 old_file_dsc.dsc$w_length = strlen(vms_src);
5216 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5217 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5218
5219 new_file_dsc.dsc$a_pointer = vms_dst;
5220 new_file_dsc.dsc$w_length = strlen(vms_dst);
5221 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5222 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5223
5224 flags = 0;
5225#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5226 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5227#endif
5228
5229 sts = lib$rename_file(&old_file_dsc,
5230 &new_file_dsc,
5231 NULL, NULL,
5232 &flags,
5233 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5234 if (!$VMS_STATUS_SUCCESS(sts)) {
5235
5236 /* We could have failed because VMS style permissions do not
5237 * permit renames that UNIX will allow. Just like the hack
5238 * in for kill_file.
5239 */
5240 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5241 }
5242
5243 PerlMem_free(vms_src);
5244 PerlMem_free(vms_dst);
5245 if (!$VMS_STATUS_SUCCESS(sts)) {
5246 errno = EIO;
5247 return -1;
5248 }
5249 retval = 0;
5250 }
5251
5252 if (vms_unlink_all_versions) {
5253 /* Now get rid of any previous versions of the source file that
5254 * might still exist
5255 */
5256 int save_errno;
5257 save_errno = errno;
5258 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5259 errno = save_errno;
5260 }
5261
5262 /* We deleted the destination, so must force the error to be EIO */
5263 if ((retval != 0) && (pre_delete != 0))
5264 errno = EIO;
5265
5266 return retval;
5267}
5268/*}}}*/
5269
5270
bbce6d69 5271/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5272/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5273 * to expand file specification. Allows for a single default file
5274 * specification and a simple mask of options. If outbuf is non-NULL,
5275 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5276 * the resultant file specification is placed. If outbuf is NULL, the
5277 * resultant file specification is placed into a static buffer.
5278 * The third argument, if non-NULL, is taken to be a default file
5279 * specification string. The fourth argument is unused at present.
5280 * rmesexpand() returns the address of the resultant string if
5281 * successful, and NULL on error.
e886094b
JM		 5282 *
5283 * New functionality for previously unused opts value:
5284 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5285 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5286 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5287 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5288 */
360732b5 5289static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5290
bbce6d69 5291static char *
360732b5
JM		 5292mp_do_rmsexpand
5293 (pTHX_ const char *filespec,
5294 char *outbuf,
5295 int ts,
5296 const char *defspec,
5297 unsigned opts,
5298 int * fs_utf8,
5299 int * dfs_utf8)
bbce6d69 5300{
a1887106 5301 static char __rmsexpand_retbuf[VMS_MAXRSS];
18a3d61e
JM		 5302 char * vmsfspec, *tmpfspec;
5303 char * esa, *cp, *out = NULL;
c5375c28 5304 char * tbuf;
7566800d 5305 char * esal = NULL;
18a3d61e
JM		 5306 char * outbufl;
5307 struct FAB myfab = cc$rms_fab;
a480973c 5308 rms_setup_nam(mynam);
18a3d61e
JM		 5309 STRLEN speclen;
5310 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5311 int sts;
5312
360732b5
JM		 5313 /* temp hack until UTF8 is actually implemented */
5314 if (fs_utf8 != NULL)
5315 *fs_utf8 = 0;
5316
18a3d61e
JM		 5317 if (!filespec || !*filespec) {
5318 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5319 return NULL;
5320 }
5321 if (!outbuf) {
5322 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5323 else outbuf = __rmsexpand_retbuf;
5324 }
5325
5326 vmsfspec = NULL;
5327 tmpfspec = NULL;
5328 outbufl = NULL;
a1887106
JM		 5329
5330 isunix = 0;
5331 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5332 isunix = is_unix_filespec(filespec);
5333 if (isunix) {
5334 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5335 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 5336 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
c5375c28 5337 PerlMem_free(vmsfspec);
18a3d61e
JM		 5338 if (out)
5339 Safefree(out);
5340 return NULL;
a1887106
JM		 5341 }
5342 filespec = vmsfspec;
18a3d61e 5343
a1887106
JM		 5344 /* Unless we are forcing to VMS format, a UNIX input means
5345 * UNIX output, and that requires long names to be used
5346 */
b1a8dcd7 5347#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 5348 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
18a3d61e 5349 opts |= PERL_RMSEXPAND_M_LONG;
b1a8dcd7
JM		 5350 else
5351#endif
18a3d61e 5352 isunix = 0;
a1887106 5353 }
18a3d61e 5354 }
18a3d61e 5355
a480973c
JM		 5356 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5357 rms_bind_fab_nam(myfab, mynam);
18a3d61e
JM		 5358
5359 if (defspec && *defspec) {
5360 int t_isunix;
5361 t_isunix = is_unix_filespec(defspec);
5362 if (t_isunix) {
c5375c28
JM		 5363 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5364 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 5365 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
c5375c28 5366 PerlMem_free(tmpfspec);
18a3d61e 5367 if (vmsfspec != NULL)
c5375c28 5368 PerlMem_free(vmsfspec);
18a3d61e
JM		 5369 if (out)
5370 Safefree(out);
5371 return NULL;
5372 }
5373 defspec = tmpfspec;
5374 }
a480973c 5375 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
18a3d61e
JM		 5376 }
5377
c5375c28
JM		 5378 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5379 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5380#if !defined(__VAX) && defined(NAML$C_MAXRSS)
a1887106 5381 esal = PerlMem_malloc(VMS_MAXRSS);
c5375c28 5382 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5383#endif
a1887106 5384 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5385
d584a1c6
JM		 5386 /* If a NAML block is used RMS always writes to the long and short
5387 * addresses unless you suppress the short name.
5388 */
a480973c 5389#if !defined(__VAX) && defined(NAML$C_MAXRSS)
d584a1c6
JM		 5390 outbufl = PerlMem_malloc(VMS_MAXRSS);
5391 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5392#endif
d584a1c6 5393 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5394
f7ddb74a
JM		 5395#ifdef NAM$M_NO_SHORT_UPCASE
5396 if (decc_efs_case_preserve)
a480973c 5397 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5398#endif
18a3d61e 5399
e0e5e8d6
JM		 5400 /* We may not want to follow symbolic links */
5401#ifdef NAML$M_OPEN_SPECIAL
5402 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5403 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5404#endif
5405
18a3d61e
JM		 5406 /* First attempt to parse as an existing file */
5407 retsts = sys$parse(&myfab,0,0);
5408 if (!(retsts & STS$K_SUCCESS)) {
5409
5410 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5411 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
18a3d61e
JM		 5412 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5413 retsts = sys$parse(&myfab,0,0);
5414 if (retsts & STS$K_SUCCESS) goto expanded;
5415 }
5416
5417 /* Still could not parse the file specification */
5418 /*----------------------------------------------*/
a480973c 5419 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5420 if (out) Safefree(out);
5421 if (tmpfspec != NULL)
c5375c28 5422 PerlMem_free(tmpfspec);
18a3d61e 5423 if (vmsfspec != NULL)
c5375c28
JM		 5424 PerlMem_free(vmsfspec);
5425 if (outbufl != NULL)
5426 PerlMem_free(outbufl);
5427 PerlMem_free(esa);
7566800d
CB		 5428 if (esal != NULL)
5429 PerlMem_free(esal);
18a3d61e
JM		 5430 set_vaxc_errno(retsts);
5431 if (retsts == RMS$_PRV) set_errno(EACCES);
5432 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5433 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5434 else set_errno(EVMSERR);
5435 return NULL;
5436 }
5437 retsts = sys$search(&myfab,0,0);
5438 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5439 sts = rms_free_search_context(&myfab); /* Free search context */
18a3d61e
JM		 5440 if (out) Safefree(out);
5441 if (tmpfspec != NULL)
c5375c28 5442 PerlMem_free(tmpfspec);
18a3d61e 5443 if (vmsfspec != NULL)
c5375c28
JM		 5444 PerlMem_free(vmsfspec);
5445 if (outbufl != NULL)
5446 PerlMem_free(outbufl);
5447 PerlMem_free(esa);
7566800d
CB		 5448 if (esal != NULL)
5449 PerlMem_free(esal);
18a3d61e
JM		 5450 set_vaxc_errno(retsts);
5451 if (retsts == RMS$_PRV) set_errno(EACCES);
5452 else set_errno(EVMSERR);
5453 return NULL;
5454 }
5455
5456 /* If the input filespec contained any lowercase characters,
5457 * downcase the result for compatibility with Unix-minded code. */
5458 expanded:
5459 if (!decc_efs_case_preserve) {
c5375c28
JM		 5460 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5461 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5462 }
5463
5464 /* Is a long or a short name expected */
5465 /*------------------------------------*/
5466 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5467 if (rms_nam_rsll(mynam)) {
d584a1c6 5468 tbuf = outbufl;
a480973c 5469 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5470 }
5471 else {
c5375c28 5472 tbuf = esal; /* Not esa */
a480973c 5473 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5474 }
5475 }
5476 else {
a480973c 5477 if (rms_nam_rsl(mynam)) {
c5375c28 5478 tbuf = outbuf;
a480973c 5479 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5480 }
5481 else {
c5375c28 5482 tbuf = esa; /* Not esal */
a480973c 5483 speclen = rms_nam_esl(mynam);
18a3d61e
JM		 5484 }
5485 }
4d743a9b
JM		 5486 tbuf[speclen] = '\0';
5487
18a3d61e
JM		 5488 /* Trim off null fields added by $PARSE
5489 * If type > 1 char, must have been specified in original or default spec
5490 * (not true for version; $SEARCH may have added version of existing file).
5491 */
a480973c 5492 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5493 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5494 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5495 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5496 }
5497 else {
a480973c
JM		 5498 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5499 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5500 }
5501 if (trimver || trimtype) {
5502 if (defspec && *defspec) {
5503 char *defesal = NULL;
d584a1c6
JM		 5504 char *defesa = NULL;
5505 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5506 if (defesa != NULL) {
5507#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5508 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5509 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5510#endif
18a3d61e 5511 struct FAB deffab = cc$rms_fab;
a480973c 5512 rms_setup_nam(defnam);
18a3d61e 5513
a480973c
JM		 5514 rms_bind_fab_nam(deffab, defnam);
5515
5516 /* Cast ok */
5517 rms_set_fna
5518 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5519
d584a1c6
JM		 5520 /* RMS needs the esa/esal as a work area if wildcards are involved */
5521 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5522
4d743a9b 5523 rms_clear_nam_nop(defnam);
a480973c 5524 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5525#ifdef NAM$M_NO_SHORT_UPCASE
5526 if (decc_efs_case_preserve)
a480973c 5527 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5528#endif
e0e5e8d6
JM		 5529#ifdef NAML$M_OPEN_SPECIAL
5530 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5531 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5532#endif
18a3d61e
JM		 5533 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5534 if (trimver) {
a480973c 5535 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5536 }
5537 if (trimtype) {
a480973c 5538 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5539 }
5540 }
d584a1c6
JM		 5541 if (defesal != NULL)
5542 PerlMem_free(defesal);
5543 PerlMem_free(defesa);
18a3d61e
JM		 5544 }
5545 }
5546 if (trimver) {
5547 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5548 if (*(rms_nam_verl(mynam)) != '\"')
c5375c28 5549 speclen = rms_nam_verl(mynam) - tbuf;
18a3d61e
JM		 5550 }
5551 else {
a480973c 5552 if (*(rms_nam_ver(mynam)) != '\"')
c5375c28 5553 speclen = rms_nam_ver(mynam) - tbuf;
18a3d61e
JM		 5554 }
5555 }
5556 if (trimtype) {
5557 /* If we didn't already trim version, copy down */
5558 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
c5375c28 5559 if (speclen > rms_nam_verl(mynam) - tbuf)
18a3d61e 5560 memmove
a480973c
JM		 5561 (rms_nam_typel(mynam),
5562 rms_nam_verl(mynam),
c5375c28 5563 speclen - (rms_nam_verl(mynam) - tbuf));
a480973c 5564 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5565 }
5566 else {
c5375c28 5567 if (speclen > rms_nam_ver(mynam) - tbuf)
18a3d61e 5568 memmove
a480973c
JM		 5569 (rms_nam_type(mynam),
5570 rms_nam_ver(mynam),
c5375c28 5571 speclen - (rms_nam_ver(mynam) - tbuf));
a480973c 5572 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5573 }
5574 }
5575 }
5576
5577 /* Done with these copies of the input files */
5578 /*-------------------------------------------*/
5579 if (vmsfspec != NULL)
c5375c28 5580 PerlMem_free(vmsfspec);
18a3d61e 5581 if (tmpfspec != NULL)
c5375c28 5582 PerlMem_free(tmpfspec);
18a3d61e
JM		 5583
5584 /* If we just had a directory spec on input, $PARSE "helpfully"
5585 * adds an empty name and type for us */
d584a1c6 5586#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5587 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5588 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5589 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5590 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5591 speclen = rms_nam_namel(mynam) - tbuf;
18a3d61e 5592 }
d584a1c6
JM		 5593 else
5594#endif
5595 {
a480973c
JM		 5596 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5597 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5598 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
c5375c28 5599 speclen = rms_nam_name(mynam) - tbuf;
18a3d61e
JM		 5600 }
5601
5602 /* Posix format specifications must have matching quotes */
4d743a9b
JM		 5603 if (speclen < (VMS_MAXRSS - 1)) {
5604 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5605 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5606 tbuf[speclen] = '\"';
5607 speclen++;
5608 }
18a3d61e
JM		 5609 }
5610 }
c5375c28
JM		 5611 tbuf[speclen] = '\0';
5612 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
18a3d61e
JM		 5613
5614 /* Have we been working with an expanded, but not resultant, spec? */
5615 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5616 {
5617 int rsl;
18a3d61e 5618
d584a1c6
JM		 5619#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5620 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5621 rsl = rms_nam_rsll(mynam);
5622 } else
5623#endif
5624 {
5625 rsl = rms_nam_rsl(mynam);
5626 }
5627 if (!rsl) {
5628 if (isunix) {
5629 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5630 if (out) Safefree(out);
5631 if (esal != NULL)
7566800d 5632 PerlMem_free(esal);
d584a1c6
JM		 5633 PerlMem_free(esa);
5634 if (outbufl != NULL)
c5375c28 5635 PerlMem_free(outbufl);
d584a1c6
JM		 5636 return NULL;
5637 }
18a3d61e 5638 }
d584a1c6 5639 else strcpy(outbuf, tbuf);
18a3d61e 5640 }
d584a1c6
JM		 5641 else if (isunix) {
5642 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5643 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5644 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
c5375c28
JM		 5645 if (out) Safefree(out);
5646 PerlMem_free(esa);
7566800d
CB		 5647 if (esal != NULL)
5648 PerlMem_free(esal);
c5375c28
JM		 5649 PerlMem_free(tmpfspec);
5650 if (outbufl != NULL)
5651 PerlMem_free(outbufl);
18a3d61e 5652 return NULL;
d584a1c6
JM		 5653 }
5654 strcpy(outbuf,tmpfspec);
5655 PerlMem_free(tmpfspec);
18a3d61e 5656 }
18a3d61e 5657 }
a480973c
JM		 5658 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5659 sts = rms_free_search_context(&myfab); /* Free search context */
c5375c28 5660 PerlMem_free(esa);
7566800d
CB		 5661 if (esal != NULL)
5662 PerlMem_free(esal);
c5375c28
JM		 5663 if (outbufl != NULL)
5664 PerlMem_free(outbufl);
bbce6d69 5665 return outbuf;
5666}
5667/*}}}*/
5668/* External entry points */
2fbb330f 5669char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5 5670{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
2fbb330f 5671char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5
JM		 5672{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5673char *Perl_rmsexpand_utf8
5674 (pTHX_ const char *spec, char *buf, const char *def,
5675 unsigned opt, int * fs_utf8, int * dfs_utf8)
5676{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5677char *Perl_rmsexpand_utf8_ts
5678 (pTHX_ const char *spec, char *buf, const char *def,
5679 unsigned opt, int * fs_utf8, int * dfs_utf8)
5680{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
bbce6d69 5681
5682
a0d0e21e
LW		 5683/*
5684** The following routines are provided to make life easier when
5685** converting among VMS-style and Unix-style directory specifications.
5686** All will take input specifications in either VMS or Unix syntax. On
5687** failure, all return NULL. If successful, the routines listed below
748a9306 5688** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5689** reformatted spec (and, therefore, subsequent calls to that routine
5690** will clobber the result), while the routines of the same names with
5691** a _ts suffix appended will return a pointer to a mallocd string
5692** containing the appropriately reformatted spec.
5693** In all cases, only explicit syntax is altered; no check is made that
5694** the resulting string is valid or that the directory in question
5695** actually exists.
5696**
5697** fileify_dirspec() - convert a directory spec into the name of the
5698** directory file (i.e. what you can stat() to see if it's a dir).
5699** The style (VMS or Unix) of the result is the same as the style
5700** of the parameter passed in.
5701** pathify_dirspec() - convert a directory spec into a path (i.e.
5702** what you prepend to a filename to indicate what directory it's in).
5703** The style (VMS or Unix) of the result is the same as the style
5704** of the parameter passed in.
5705** tounixpath() - convert a directory spec into a Unix-style path.
5706** tovmspath() - convert a directory spec into a VMS-style path.
5707** tounixspec() - convert any file spec into a Unix-style file spec.
5708** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5709** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5710**
bd3fa61c 5711** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5712** Permission is given to distribute this code as part of the Perl
5713** standard distribution under the terms of the GNU General Public
5714** License or the Perl Artistic License. Copies of each may be
5715** found in the Perl standard distribution.
a0d0e21e
LW		 5716 */
5717
360732b5
JM		 5718/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5719static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a0d0e21e 5720{
a480973c 5721 static char __fileify_retbuf[VMS_MAXRSS];
b7ae7a0d 5722 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
a0d0e21e 5723 char *retspec, *cp1, *cp2, *lastdir;
a480973c 5724 char *trndir, *vmsdir;
2d9f3838 5725 unsigned short int trnlnm_iter_count;
f7ddb74a 5726 int sts;
360732b5
JM		 5727 if (utf8_fl != NULL)
5728 *utf8_fl = 0;
a0d0e21e 5729
c07a80fd 5730 if (!dir || !*dir) {
5731 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5732 }
a0d0e21e 5733 dirlen = strlen(dir);
a2a90019 5734 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 5735 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 5736 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5737 dir = "/sys$disk";
5738 dirlen = 9;
5739 }
5740 else
5741 dirlen = 1;
61bb5906 5742 }
a480973c
JM		 5743 if (dirlen > (VMS_MAXRSS - 1)) {
5744 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5745 return NULL;
c07a80fd 5746 }
c5375c28
JM		 5747 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5748 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 5749 if (!strpbrk(dir+1,"/]>:") &&
5750 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 5751 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 5752 trnlnm_iter_count = 0;
e538e23f 5753 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 5754 trnlnm_iter_count++;
5755 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5756 }
b8ffc8df 5757 dirlen = strlen(trndir);
e518068a 5758 }
01b8edb6 5759 else {
5760 strncpy(trndir,dir,dirlen);
5761 trndir[dirlen] = '\0';
01b8edb6 5762 }
b8ffc8df
RGS		 5763
5764 /* At this point we are done with *dir and use *trndir which is a
5765 * copy that can be modified. *dir must not be modified.
5766 */
5767
c07a80fd 5768 /* If we were handed a rooted logical name or spec, treat it like a
5769 * simple directory, so that
5770 * $ Define myroot dev:[dir.]
5771 * ... do_fileify_dirspec("myroot",buf,1) ...
5772 * does something useful.
5773 */
b8ffc8df
RGS		 5774 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5775 trndir[--dirlen] = '\0';
5776 trndir[dirlen-1] = ']';
c07a80fd 5777 }
b8ffc8df
RGS		 5778 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5779 trndir[--dirlen] = '\0';
5780 trndir[dirlen-1] = '>';
46112e17 5781 }
e518068a 5782
b8ffc8df 5783 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 5784 /* If we've got an explicit filename, we can just shuffle the string. */
5785 if (*(cp1+1)) hasfilename = 1;
5786 /* Similarly, we can just back up a level if we've got multiple levels
5787 of explicit directories in a VMS spec which ends with directories. */
5788 else {
b8ffc8df 5789 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 5790 if (*cp2 == '.') {
5791 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 5792/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 5793 *cp2 = *cp1; *cp1 = '\0';
5794 hasfilename = 1;
5795 break;
5796 }
b7ae7a0d 5797 }
5798 if (*cp2 == '[' || *cp2 == '<') break;
5799 }
5800 }
5801 }
5802
c5375c28
JM		 5803 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5804 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
a480973c 5805 cp1 = strpbrk(trndir,"]:>");
f7ddb74a 5806 if (hasfilename || !cp1) { /* Unix-style path or filename */
b8ffc8df 5807 if (trndir[0] == '.') {
a480973c 5808 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 5809 PerlMem_free(trndir);
5810 PerlMem_free(vmsdir);
360732b5 5811 return do_fileify_dirspec("[]",buf,ts,NULL);
a480973c 5812 }
b8ffc8df 5813 else if (trndir[1] == '.' &&
a480973c 5814 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 5815 PerlMem_free(trndir);
5816 PerlMem_free(vmsdir);
360732b5 5817 return do_fileify_dirspec("[-]",buf,ts,NULL);
a480973c 5818 }
748a9306 5819 }
b8ffc8df 5820 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 5821 dirlen -= 1; /* to last element */
b8ffc8df 5822 lastdir = strrchr(trndir,'/');
a0d0e21e 5823 }
b8ffc8df 5824 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 5825 /* If we have "/." or "/..", VMSify it and let the VMS code
5826 * below expand it, rather than repeating the code to handle
5827 * relative components of a filespec here */
4633a7c4
LW		 5828 do {
5829 if (*(cp1+2) == '.') cp1++;
5830 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 5831 char * ret_chr;
360732b5 5832 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
c5375c28
JM		 5833 PerlMem_free(trndir);
5834 PerlMem_free(vmsdir);
a480973c
JM		 5835 return NULL;
5836 }
fc1ce8cc
CB		 5837 if (strchr(vmsdir,'/') != NULL) {
5838 /* If do_tovmsspec() returned it, it must have VMS syntax
5839 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5840 * the time to check this here only so we avoid a recursion
5841 * loop; otherwise, gigo.
5842 */
c5375c28
JM		 5843 PerlMem_free(trndir);
5844 PerlMem_free(vmsdir);
a480973c
JM		 5845 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5846 return NULL;
fc1ce8cc 5847 }
360732b5 5848 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 5849 PerlMem_free(trndir);
5850 PerlMem_free(vmsdir);
a480973c
JM		 5851 return NULL;
5852 }
360732b5 5853 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
c5375c28
JM		 5854 PerlMem_free(trndir);
5855 PerlMem_free(vmsdir);
a480973c 5856 return ret_chr;
4633a7c4
LW		 5857 }
5858 cp1++;
5859 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 5860 lastdir = strrchr(trndir,'/');
748a9306 5861 }
b8ffc8df 5862 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 5863 char * ret_chr;
61bb5906
CB		 5864 /* Ditto for specs that end in an MFD -- let the VMS code
5865 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 5866
5867 /* This should not happen any more. Allowing the fake /000000
5868 * in a UNIX pathname causes all sorts of problems when trying
5869 * to run in UNIX emulation. So the VMS to UNIX conversions
5870 * now remove the fake /000000 directories.
5871 */
5872
b8ffc8df 5873 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
360732b5 5874 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
c5375c28
JM		 5875 PerlMem_free(trndir);
5876 PerlMem_free(vmsdir);
a480973c
JM		 5877 return NULL;
5878 }
360732b5 5879 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
c5375c28
JM		 5880 PerlMem_free(trndir);
5881 PerlMem_free(vmsdir);
a480973c
JM		 5882 return NULL;
5883 }
360732b5 5884 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
c5375c28
JM		 5885 PerlMem_free(trndir);
5886 PerlMem_free(vmsdir);
a480973c 5887 return ret_chr;
61bb5906 5888 }
a0d0e21e 5889 else {
f7ddb74a 5890
b8ffc8df
RGS		 5891 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5892 !(lastdir = cp1 = strrchr(trndir,']')) &&
5893 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
a0d0e21e 5894 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
b7ae7a0d 5895 int ver; char *cp3;
f7ddb74a
JM		 5896
5897 /* For EFS or ODS-5 look for the last dot */
5898 if (decc_efs_charset) {
5899 cp2 = strrchr(cp1,'.');
5900 }
5901 if (vms_process_case_tolerant) {
5902 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5903 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5904 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5905 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5906 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 5907 (ver || *cp3)))))) {
c5375c28
JM		 5908 PerlMem_free(trndir);
5909 PerlMem_free(vmsdir);
f7ddb74a
JM		 5910 set_errno(ENOTDIR);
5911 set_vaxc_errno(RMS$_DIR);
5912 return NULL;
5913 }
5914 }
5915 else {
5916 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5917 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5918 !*(cp2+3) || *(cp2+3) != 'R' ||
5919 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5920 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5921 (ver || *cp3)))))) {
c5375c28
JM		 5922 PerlMem_free(trndir);
5923 PerlMem_free(vmsdir);
f7ddb74a
JM		 5924 set_errno(ENOTDIR);
5925 set_vaxc_errno(RMS$_DIR);
5926 return NULL;
5927 }
a0d0e21e 5928 }
b8ffc8df 5929 dirlen = cp2 - trndir;
a0d0e21e 5930 }
748a9306 5931 }
f7ddb74a
JM		 5932
5933 retlen = dirlen + 6;
748a9306 5934 if (buf) retspec = buf;
a02a5408 5935 else if (ts) Newx(retspec,retlen+1,char);
748a9306 5936 else retspec = __fileify_retbuf;
f7ddb74a
JM		 5937 memcpy(retspec,trndir,dirlen);
5938 retspec[dirlen] = '\0';
5939
a0d0e21e
LW		 5940 /* We've picked up everything up to the directory file name.
5941 Now just add the type and version, and we're set. */
f7ddb74a
JM		 5942 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5943 strcat(retspec,".dir;1");
5944 else
5945 strcat(retspec,".DIR;1");
c5375c28
JM		 5946 PerlMem_free(trndir);
5947 PerlMem_free(vmsdir);
a0d0e21e
LW		 5948 return retspec;
5949 }
5950 else { /* VMS-style directory spec */
a480973c 5951
d584a1c6
JM		 5952 char *esa, *esal, term, *cp;
5953 char *my_esa;
5954 int my_esa_len;
01b8edb6 5955 unsigned long int sts, cmplen, haslower = 0;
a480973c
JM		 5956 unsigned int nam_fnb;
5957 char * nam_type;
a0d0e21e 5958 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 5959 rms_setup_nam(savnam);
5960 rms_setup_nam(dirnam);
5961
d584a1c6 5962 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 5963 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 5964 esal = NULL;
5965#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5966 esal = PerlMem_malloc(VMS_MAXRSS);
5967 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5968#endif
a480973c
JM		 5969 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5970 rms_bind_fab_nam(dirfab, dirnam);
5971 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 5972 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 5973#ifdef NAM$M_NO_SHORT_UPCASE
5974 if (decc_efs_case_preserve)
a480973c 5975 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5976#endif
01b8edb6 5977
b8ffc8df 5978 for (cp = trndir; *cp; cp++)
01b8edb6 5979 if (islower(*cp)) { haslower = 1; break; }
a480973c 5980 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
f7ddb74a 5981 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 5982 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5983 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 5984 }
5985 if (!sts) {
c5375c28 5986 PerlMem_free(esa);
d584a1c6
JM		 5987 if (esal != NULL)
5988 PerlMem_free(esal);
c5375c28
JM		 5989 PerlMem_free(trndir);
5990 PerlMem_free(vmsdir);
748a9306
LW		 5991 set_errno(EVMSERR);
5992 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 5993 return NULL;
5994 }
e518068a 5995 }
5996 else {
5997 savnam = dirnam;
a480973c
JM		 5998 /* Does the file really exist? */
5999 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6000 /* Yes; fake the fnb bits so we'll check type below */
a480973c 6001 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6002 }
752635ea
CB		 6003 else { /* No; just work with potential name */
6004 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6005 else {
2623a4a6
JM		 6006 int fab_sts;
6007 fab_sts = dirfab.fab$l_sts;
6008 sts = rms_free_search_context(&dirfab);
c5375c28 6009 PerlMem_free(esa);
d584a1c6
JM		 6010 if (esal != NULL)
6011 PerlMem_free(esal);
c5375c28
JM		 6012 PerlMem_free(trndir);
6013 PerlMem_free(vmsdir);
2623a4a6 6014 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6015 return NULL;
6016 }
e518068a 6017 }
a0d0e21e 6018 }
d584a1c6
JM		 6019
6020 /* Make sure we are using the right buffer */
6021 if (esal != NULL) {
6022 my_esa = esal;
6023 my_esa_len = rms_nam_esll(dirnam);
6024 } else {
6025 my_esa = esa;
6026 my_esa_len = rms_nam_esl(dirnam);
6027 }
6028 my_esa[my_esa_len] = '\0';
a480973c 6029 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6030 cp1 = strchr(my_esa,']');
6031 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6032 if (cp1) { /* Should always be true */
d584a1c6
JM		 6033 my_esa_len -= cp1 - my_esa - 1;
6034 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6035 }
6036 }
a480973c 6037 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6038 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6039 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6040 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6041 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6042 sts = rms_free_search_context(&dirfab);
c5375c28 6043 PerlMem_free(esa);
d584a1c6
JM		 6044 if (esal != NULL)
6045 PerlMem_free(esal);
c5375c28
JM		 6046 PerlMem_free(trndir);
6047 PerlMem_free(vmsdir);
748a9306
LW		 6048 set_errno(ENOTDIR);
6049 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6050 return NULL;
6051 }
748a9306 6052 }
ae6d78fe 6053
a480973c 6054 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306
LW		 6055 /* They provided at least the name; we added the type, if necessary, */
6056 if (buf) retspec = buf; /* in sys$parse() */
d584a1c6 6057 else if (ts) Newx(retspec, my_esa_len + 1, char);
748a9306 6058 else retspec = __fileify_retbuf;
d584a1c6 6059 strcpy(retspec,my_esa);
a480973c 6060 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6061 PerlMem_free(trndir);
6062 PerlMem_free(esa);
d584a1c6
JM		 6063 if (esal != NULL)
6064 PerlMem_free(esal);
c5375c28 6065 PerlMem_free(vmsdir);
748a9306
LW		 6066 return retspec;
6067 }
c07a80fd 6068 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6069 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6070 *cp1 = '\0';
d584a1c6 6071 my_esa_len -= 9;
c07a80fd 6072 }
d584a1c6 6073 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6074 if (cp1 == NULL) { /* should never happen */
a480973c 6075 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6076 PerlMem_free(trndir);
6077 PerlMem_free(esa);
d584a1c6
JM		 6078 if (esal != NULL)
6079 PerlMem_free(esal);
c5375c28 6080 PerlMem_free(vmsdir);
752635ea
CB		 6081 return NULL;
6082 }
748a9306
LW		 6083 term = *cp1;
6084 *cp1 = '\0';
d584a1c6
JM		 6085 retlen = strlen(my_esa);
6086 cp1 = strrchr(my_esa,'.');
f7ddb74a 6087 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6088 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6089 while (cp1 != NULL) {
d584a1c6 6090 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6091 break;
6092 else {
6093 cp1--;
d584a1c6 6094 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6095 cp1--;
6096 }
d584a1c6 6097 if (cp1 == my_esa)
f7ddb74a
JM		 6098 cp1 = NULL;
6099 }
6100
6101 if ((cp1) != NULL) {
748a9306
LW		 6102 /* There's more than one directory in the path. Just roll back. */
6103 *cp1 = term;
6104 if (buf) retspec = buf;
a02a5408 6105 else if (ts) Newx(retspec,retlen+7,char);
748a9306 6106 else retspec = __fileify_retbuf;
d584a1c6 6107 strcpy(retspec,my_esa);
a0d0e21e
LW		 6108 }
6109 else {
a480973c 6110 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6111 /* Go back and expand rooted logical name */
a480973c 6112 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6113#ifdef NAM$M_NO_SHORT_UPCASE
6114 if (decc_efs_case_preserve)
a480973c 6115 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6116#endif
a480973c
JM		 6117 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6118 sts = rms_free_search_context(&dirfab);
c5375c28 6119 PerlMem_free(esa);
d584a1c6
JM		 6120 if (esal != NULL)
6121 PerlMem_free(esal);
c5375c28
JM		 6122 PerlMem_free(trndir);
6123 PerlMem_free(vmsdir);
748a9306
LW		 6124 set_errno(EVMSERR);
6125 set_vaxc_errno(dirfab.fab$l_sts);
6126 return NULL;
6127 }
d584a1c6
JM		 6128
6129 /* This changes the length of the string of course */
6130 if (esal != NULL) {
6131 my_esa_len = rms_nam_esll(dirnam);
6132 } else {
6133 my_esa_len = rms_nam_esl(dirnam);
6134 }
6135
6136 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
a0d0e21e 6137 if (buf) retspec = buf;
a02a5408 6138 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6139 else retspec = __fileify_retbuf;
d584a1c6
JM		 6140 cp1 = strstr(my_esa,"][");
6141 if (!cp1) cp1 = strstr(my_esa,"]<");
6142 dirlen = cp1 - my_esa;
6143 memcpy(retspec,my_esa,dirlen);
748a9306
LW		 6144 if (!strncmp(cp1+2,"000000]",7)) {
6145 retspec[dirlen-1] = '\0';
657054d4 6146 /* fix-me Not full ODS-5, just extra dots in directories for now */
f7ddb74a
JM		 6147 cp1 = retspec + dirlen - 1;
6148 while (cp1 > retspec)
6149 {
6150 if (*cp1 == '[')
6151 break;
6152 if (*cp1 == '.') {
6153 if (*(cp1-1) != '^')
6154 break;
6155 }
6156 cp1--;
6157 }
4633a7c4
LW		 6158 if (*cp1 == '.') *cp1 = ']';
6159 else {
6160 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6161 memmove(cp1+1,"000000]",7);
4633a7c4 6162 }
748a9306
LW		 6163 }
6164 else {
18a3d61e 6165 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
748a9306
LW		 6166 retspec[retlen] = '\0';
6167 /* Convert last '.' to ']' */
f7ddb74a
JM		 6168 cp1 = retspec+retlen-1;
6169 while (*cp != '[') {
6170 cp1--;
6171 if (*cp1 == '.') {
6172 /* Do not trip on extra dots in ODS-5 directories */
6173 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6174 break;
6175 }
6176 }
4633a7c4
LW		 6177 if (*cp1 == '.') *cp1 = ']';
6178 else {
6179 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
18a3d61e 6180 memmove(cp1+1,"000000]",7);
4633a7c4 6181 }
748a9306 6182 }
a0d0e21e 6183 }
748a9306 6184 else { /* This is a top-level dir. Add the MFD to the path. */
a0d0e21e 6185 if (buf) retspec = buf;
a02a5408 6186 else if (ts) Newx(retspec,retlen+16,char);
a0d0e21e 6187 else retspec = __fileify_retbuf;
d584a1c6 6188 cp1 = my_esa;
a0d0e21e 6189 cp2 = retspec;
bbdb6c9a 6190 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 6191 strcpy(cp2,":[000000]");
6192 cp1 += 2;
6193 strcpy(cp2+9,cp1);
6194 }
748a9306 6195 }
a480973c 6196 sts = rms_free_search_context(&dirfab);
748a9306 6197 /* We've set up the string up through the filename. Add the
a0d0e21e
LW		 6198 type and version, and we're done. */
6199 strcat(retspec,".DIR;1");
01b8edb6 6200
6201 /* $PARSE may have upcased filespec, so convert output to lower
6202 * case if input contained any lowercase characters. */
f7ddb74a 6203 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
c5375c28
JM		 6204 PerlMem_free(trndir);
6205 PerlMem_free(esa);
d584a1c6
JM		 6206 if (esal != NULL)
6207 PerlMem_free(esal);
c5375c28 6208 PerlMem_free(vmsdir);
a0d0e21e
LW		 6209 return retspec;
6210 }
6211} /* end of do_fileify_dirspec() */
6212/*}}}*/
6213/* External entry points */
b8ffc8df 6214char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6215{ return do_fileify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6216char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6217{ return do_fileify_dirspec(dir,buf,1,NULL); }
6218char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219{ return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6220char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6221{ return do_fileify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e
LW		 6222
6223/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
360732b5 6224static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
a0d0e21e 6225{
a480973c 6226 static char __pathify_retbuf[VMS_MAXRSS];
a0d0e21e 6227 unsigned long int retlen;
a480973c 6228 char *retpath, *cp1, *cp2, *trndir;
2d9f3838 6229 unsigned short int trnlnm_iter_count;
baf3cf9c 6230 STRLEN trnlen;
f7ddb74a 6231 int sts;
360732b5
JM		 6232 if (utf8_fl != NULL)
6233 *utf8_fl = 0;
a0d0e21e 6234
c07a80fd 6235 if (!dir || !*dir) {
6236 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6237 }
6238
c5375c28
JM		 6239 trndir = PerlMem_malloc(VMS_MAXRSS);
6240 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 6241 if (*dir) strcpy(trndir,dir);
a480973c 6242 else getcwd(trndir,VMS_MAXRSS - 1);
c07a80fd 6243
2d9f3838 6244 trnlnm_iter_count = 0;
93948341
CB		 6245 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6246 && my_trnlnm(trndir,trndir,0)) {
2d9f3838
CB		 6247 trnlnm_iter_count++;
6248 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
baf3cf9c 6249 trnlen = strlen(trndir);
a0d0e21e 6250
c07a80fd 6251 /* Trap simple rooted lnms, and return lnm:[000000] */
6252 if (!strcmp(trndir+trnlen-2,".]")) {
6253 if (buf) retpath = buf;
a02a5408 6254 else if (ts) Newx(retpath,strlen(dir)+10,char);
c07a80fd 6255 else retpath = __pathify_retbuf;
6256 strcpy(retpath,dir);
6257 strcat(retpath,":[000000]");
c5375c28 6258 PerlMem_free(trndir);
c07a80fd 6259 return retpath;
6260 }
6261 }
748a9306 6262
b8ffc8df
RGS		 6263 /* At this point we do not work with *dir, but the copy in
6264 * *trndir that is modifiable.
6265 */
6266
6267 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6268 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6269 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6270 retlen = 2 + (*(trndir+1) != '\0');
748a9306 6271 else {
b8ffc8df
RGS		 6272 if ( !(cp1 = strrchr(trndir,'/')) &&
6273 !(cp1 = strrchr(trndir,']')) &&
6274 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
f86702cc 6275 if ((cp2 = strchr(cp1,'.')) != NULL &&
6276 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6277 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6278 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6279 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
b7ae7a0d 6280 int ver; char *cp3;
f7ddb74a
JM		 6281
6282 /* For EFS or ODS-5 look for the last dot */
6283 if (decc_efs_charset) {
6284 cp2 = strrchr(cp1,'.');
6285 }
6286 if (vms_process_case_tolerant) {
6287 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6288 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6289 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6290 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6291 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6292 (ver || *cp3)))))) {
c5375c28 6293 PerlMem_free(trndir);
f7ddb74a
JM		 6294 set_errno(ENOTDIR);
6295 set_vaxc_errno(RMS$_DIR);
6296 return NULL;
6297 }
6298 }
6299 else {
6300 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6301 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6302 !*(cp2+3) || *(cp2+3) != 'R' ||
6303 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6304 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6305 (ver || *cp3)))))) {
c5375c28 6306 PerlMem_free(trndir);
f7ddb74a
JM		 6307 set_errno(ENOTDIR);
6308 set_vaxc_errno(RMS$_DIR);
6309 return NULL;
6310 }
6311 }
b8ffc8df 6312 retlen = cp2 - trndir + 1;
a0d0e21e 6313 }
748a9306 6314 else { /* No file type present. Treat the filename as a directory. */
b8ffc8df 6315 retlen = strlen(trndir) + 1;
a0d0e21e
LW		 6316 }
6317 }
a0d0e21e 6318 if (buf) retpath = buf;
a02a5408 6319 else if (ts) Newx(retpath,retlen+1,char);
a0d0e21e 6320 else retpath = __pathify_retbuf;
b8ffc8df 6321 strncpy(retpath, trndir, retlen-1);
a0d0e21e
LW		 6322 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6323 retpath[retlen-1] = '/'; /* with '/', add it. */
6324 retpath[retlen] = '\0';
6325 }
6326 else retpath[retlen-1] = '\0';
6327 }
6328 else { /* VMS-style directory spec */
d584a1c6
JM		 6329 char *esa, *esal, *cp;
6330 char *my_esa;
6331 int my_esa_len;
01b8edb6 6332 unsigned long int sts, cmplen, haslower;
a0d0e21e 6333 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6334 int dirlen;
6335 rms_setup_nam(savnam);
6336 rms_setup_nam(dirnam);
a0d0e21e 6337
b7ae7a0d 6338 /* If we've got an explicit filename, we can just shuffle the string. */
b8ffc8df
RGS		 6339 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6340 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
b7ae7a0d 6341 if ((cp2 = strchr(cp1,'.')) != NULL) {
6342 int ver; char *cp3;
f7ddb74a
JM		 6343 if (vms_process_case_tolerant) {
6344 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6345 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6346 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6347 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6348 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
b7ae7a0d 6349 (ver || *cp3)))))) {
c5375c28 6350 PerlMem_free(trndir);
f7ddb74a
JM		 6351 set_errno(ENOTDIR);
6352 set_vaxc_errno(RMS$_DIR);
6353 return NULL;
6354 }
6355 }
6356 else {
6357 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6358 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6359 !*(cp2+3) || *(cp2+3) != 'R' ||
6360 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6361 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6362 (ver || *cp3)))))) {
c5375c28 6363 PerlMem_free(trndir);
f7ddb74a
JM		 6364 set_errno(ENOTDIR);
6365 set_vaxc_errno(RMS$_DIR);
6366 return NULL;
6367 }
6368 }
b7ae7a0d 6369 }
6370 else { /* No file type, so just draw name into directory part */
6371 for (cp2 = cp1; *cp2; cp2++) ;
6372 }
6373 *cp2 = *cp1;
6374 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6375 *cp1 = '.';
6376 /* We've now got a VMS 'path'; fall through */
6377 }
a480973c
JM		 6378
6379 dirlen = strlen(trndir);
6380 if (trndir[dirlen-1] == ']' ||
6381 trndir[dirlen-1] == '>' ||
6382 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
748a9306 6383 if (buf) retpath = buf;
f7ddb74a 6384 else if (ts) Newx(retpath,strlen(trndir)+1,char);
748a9306 6385 else retpath = __pathify_retbuf;
b8ffc8df 6386 strcpy(retpath,trndir);
c5375c28 6387 PerlMem_free(trndir);
748a9306 6388 return retpath;
a480973c
JM		 6389 }
6390 rms_set_fna(dirfab, dirnam, trndir, dirlen);
c5375c28
JM		 6391 esa = PerlMem_malloc(VMS_MAXRSS);
6392 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 6393 esal = NULL;
6394#if !defined(__VAX) && defined(NAML$C_MAXRSS)
6395 esal = PerlMem_malloc(VMS_MAXRSS);
6396 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6397#endif
a480973c
JM		 6398 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6399 rms_bind_fab_nam(dirfab, dirnam);
d584a1c6 6400 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
f7ddb74a
JM		 6401#ifdef NAM$M_NO_SHORT_UPCASE
6402 if (decc_efs_case_preserve)
a480973c 6403 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6404#endif
01b8edb6 6405
b8ffc8df 6406 for (cp = trndir; *cp; cp++)
01b8edb6 6407 if (islower(*cp)) { haslower = 1; break; }
6408
a480973c 6409 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
f7ddb74a 6410 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
a480973c
JM		 6411 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6412 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
e518068a 6413 }
6414 if (!sts) {
c5375c28
JM		 6415 PerlMem_free(trndir);
6416 PerlMem_free(esa);
d584a1c6
JM		 6417 if (esal != NULL)
6418 PerlMem_free(esal);
748a9306
LW		 6419 set_errno(EVMSERR);
6420 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6421 return NULL;
6422 }
a0d0e21e 6423 }
e518068a 6424 else {
6425 savnam = dirnam;
a480973c
JM		 6426 /* Does the file really exist? */
6427 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
e518068a 6428 if (dirfab.fab$l_sts != RMS$_FNF) {
f7ddb74a 6429 int sts1;
a480973c 6430 sts1 = rms_free_search_context(&dirfab);
c5375c28
JM		 6431 PerlMem_free(trndir);
6432 PerlMem_free(esa);
d584a1c6
JM		 6433 if (esal != NULL)
6434 PerlMem_free(esal);
e518068a 6435 set_errno(EVMSERR);
6436 set_vaxc_errno(dirfab.fab$l_sts);
6437 return NULL;
6438 }
6439 dirnam = savnam; /* No; just work with potential name */
6440 }
6441 }
a480973c 6442 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6443 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6444 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6445 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
f7ddb74a 6446 int sts2;
a0d0e21e 6447 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6448 sts2 = rms_free_search_context(&dirfab);
c5375c28
JM		 6449 PerlMem_free(trndir);
6450 PerlMem_free(esa);
d584a1c6
JM		 6451 if (esal != NULL)
6452 PerlMem_free(esal);
748a9306
LW		 6453 set_errno(ENOTDIR);
6454 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6455 return NULL;
6456 }
a0d0e21e 6457 }
d584a1c6
JM		 6458 /* Make sure we are using the right buffer */
6459 if (esal != NULL) {
6460 /* We only need one, clean up the other */
6461 my_esa = esal;
6462 my_esa_len = rms_nam_esll(dirnam);
6463 } else {
6464 my_esa = esa;
6465 my_esa_len = rms_nam_esl(dirnam);
6466 }
6467
6468 /* Null terminate the buffer */
6469 my_esa[my_esa_len] = '\0';
6470
748a9306
LW		 6471 /* OK, the type was fine. Now pull any file name into the
6472 directory path. */
d584a1c6 6473 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
a0d0e21e 6474 else {
d584a1c6 6475 cp1 = strrchr(my_esa,'>');
a480973c 6476 *(rms_nam_typel(dirnam)) = '>';
a0d0e21e 6477 }
748a9306 6478 *cp1 = '.';
a480973c 6479 *(rms_nam_typel(dirnam) + 1) = '\0';
d584a1c6 6480 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
a0d0e21e 6481 if (buf) retpath = buf;
a02a5408 6482 else if (ts) Newx(retpath,retlen,char);
a0d0e21e 6483 else retpath = __pathify_retbuf;
d584a1c6 6484 strcpy(retpath,my_esa);
c5375c28 6485 PerlMem_free(esa);
d584a1c6
JM		 6486 if (esal != NULL)
6487 PerlMem_free(esal);
a480973c 6488 sts = rms_free_search_context(&dirfab);
01b8edb6 6489 /* $PARSE may have upcased filespec, so convert output to lower
6490 * case if input contained any lowercase characters. */
f7ddb74a 6491 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
a0d0e21e
LW		 6492 }
6493
c5375c28 6494 PerlMem_free(trndir);
a0d0e21e
LW		 6495 return retpath;
6496} /* end of do_pathify_dirspec() */
6497/*}}}*/
6498/* External entry points */
b8ffc8df 6499char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6500{ return do_pathify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6501char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6502{ return do_pathify_dirspec(dir,buf,1,NULL); }
6503char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504{ return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6505char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6506{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e 6507
360732b5
JM		 6508/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6509static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
a0d0e21e 6510{
a480973c 6511 static char __tounixspec_retbuf[VMS_MAXRSS];
2f4077ca 6512 char *dirend, *rslt, *cp1, *cp3, *tmp;
b8ffc8df 6513 const char *cp2;
a480973c 6514 int devlen, dirlen, retlen = VMS_MAXRSS;
0f20d7df 6515 int expand = 1; /* guarantee room for leading and trailing slashes */
2d9f3838 6516 unsigned short int trnlnm_iter_count;
f7ddb74a 6517 int cmp_rslt;
360732b5
JM		 6518 if (utf8_fl != NULL)
6519 *utf8_fl = 0;
a0d0e21e 6520
748a9306 6521 if (spec == NULL) return NULL;
4d743a9b 6522 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
a0d0e21e 6523 if (buf) rslt = buf;
e518068a 6524 else if (ts) {
4d743a9b 6525 Newx(rslt, VMS_MAXRSS, char);
e518068a 6526 }
a0d0e21e 6527 else rslt = __tounixspec_retbuf;
f7ddb74a 6528
2497a41f
JM		 6529 /* New VMS specific format needs translation
6530 * glob passes filenames with trailing '\n' and expects this preserved.
6531 */
6532 if (decc_posix_compliant_pathnames) {
6533 if (strncmp(spec, "\"^UP^", 5) == 0) {
6534 char * uspec;
6535 char *tunix;
6536 int tunix_len;
6537 int nl_flag;
6538
c5375c28
JM		 6539 tunix = PerlMem_malloc(VMS_MAXRSS);
6540 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
2497a41f
JM		 6541 strcpy(tunix, spec);
6542 tunix_len = strlen(tunix);
6543 nl_flag = 0;
6544 if (tunix[tunix_len - 1] == '\n') {
6545 tunix[tunix_len - 1] = '\"';
6546 tunix[tunix_len] = '\0';
6547 tunix_len--;
6548 nl_flag = 1;
6549 }
6550 uspec = decc$translate_vms(tunix);
367e4b85 6551 PerlMem_free(tunix);
2497a41f
JM		 6552 if ((int)uspec > 0) {
6553 strcpy(rslt,uspec);
6554 if (nl_flag) {
6555 strcat(rslt,"\n");
6556 }
6557 else {
6558 /* If we can not translate it, makemaker wants as-is */
6559 strcpy(rslt, spec);
6560 }
6561 return rslt;
6562 }
6563 }
6564 }
6565
f7ddb74a
JM		 6566 cmp_rslt = 0; /* Presume VMS */
6567 cp1 = strchr(spec, '/');
6568 if (cp1 == NULL)
6569 cmp_rslt = 0;
6570
6571 /* Look for EFS ^/ */
6572 if (decc_efs_charset) {
6573 while (cp1 != NULL) {
6574 cp2 = cp1 - 1;
6575 if (*cp2 != '^') {
6576 /* Found illegal VMS, assume UNIX */
6577 cmp_rslt = 1;
6578 break;
6579 }
6580 cp1++;
6581 cp1 = strchr(cp1, '/');
6582 }
6583 }
6584
6585 /* Look for "." and ".." */
6586 if (decc_filename_unix_report) {
6587 if (spec[0] == '.') {
6588 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6589 cmp_rslt = 1;
6590 }
6591 else {
6592 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6593 cmp_rslt = 1;
6594 }
6595 }
6596 }
6597 }
6598 /* This is already UNIX or at least nothing VMS understands */
6599 if (cmp_rslt) {
a0d0e21e
LW		 6600 strcpy(rslt,spec);
6601 return rslt;
6602 }
6603
6604 cp1 = rslt;
6605 cp2 = spec;
6606 dirend = strrchr(spec,']');
6607 if (dirend == NULL) dirend = strrchr(spec,'>');
6608 if (dirend == NULL) dirend = strchr(spec,':');
6609 if (dirend == NULL) {
6610 strcpy(rslt,spec);
6611 return rslt;
6612 }
f7ddb74a
JM		 6613
6614 /* Special case 1 - sys$posix_root = / */
6615#if __CRTL_VER >= 70000000
6616 if (!decc_disable_posix_root) {
6617 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6618 *cp1 = '/';
6619 cp1++;
6620 cp2 = cp2 + 15;
6621 }
6622 }
6623#endif
6624
6625 /* Special case 2 - Convert NLA0: to /dev/null */
6626#if __CRTL_VER < 70000000
6627 cmp_rslt = strncmp(spec,"NLA0:", 5);
6628 if (cmp_rslt != 0)
6629 cmp_rslt = strncmp(spec,"nla0:", 5);
6630#else
6631 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6632#endif
6633 if (cmp_rslt == 0) {
6634 strcpy(rslt, "/dev/null");
6635 cp1 = cp1 + 9;
6636 cp2 = cp2 + 5;
6637 if (spec[6] != '\0') {
6638 cp1[9] == '/';
6639 cp1++;
6640 cp2++;
6641 }
6642 }
6643
6644 /* Also handle special case "SYS$SCRATCH:" */
6645#if __CRTL_VER < 70000000
6646 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6647 if (cmp_rslt != 0)
6648 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6649#else
6650 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6651#endif
c5375c28
JM		 6652 tmp = PerlMem_malloc(VMS_MAXRSS);
6653 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
f7ddb74a
JM		 6654 if (cmp_rslt == 0) {
6655 int islnm;
6656
6657 islnm = my_trnlnm(tmp, "TMP", 0);
6658 if (!islnm) {
6659 strcpy(rslt, "/tmp");
6660 cp1 = cp1 + 4;
6661 cp2 = cp2 + 12;
6662 if (spec[12] != '\0') {
6663 cp1[4] == '/';
6664 cp1++;
6665 cp2++;
6666 }
6667 }
6668 }
6669
a5f75d66 6670 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 6671 *(cp1++) = '/';
6672 }
6673 else { /* the VMS spec begins with directories */
6674 cp2++;
a5f75d66 6675 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 6676 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
367e4b85 6677 PerlMem_free(tmp);
a5f75d66
AD		 6678 return rslt;
6679 }
f7ddb74a 6680 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 6681 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
a0d0e21e 6682 if (ts) Safefree(rslt);
367e4b85 6683 PerlMem_free(tmp);
a0d0e21e
LW		 6684 return NULL;
6685 }
2d9f3838 6686 trnlnm_iter_count = 0;
a0d0e21e
LW		 6687 do {
6688 cp3 = tmp;
6689 while (*cp3 != ':' && *cp3) cp3++;
6690 *(cp3++) = '\0';
6691 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 6692 trnlnm_iter_count++;
6693 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 6694 } while (vmstrnenv(tmp,tmp,0,fildev,0));
f86702cc 6695 if (ts && !buf &&
e518068a 6696 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
e518068a 6697 retlen = devlen + dirlen;
f86702cc 6698 Renew(rslt,retlen+1+2*expand,char);
6699 cp1 = rslt;
6700 }
6701 cp3 = tmp;
6702 *(cp1++) = '/';
6703 while (*cp3) {
6704 *(cp1++) = *(cp3++);
2f4077ca 6705 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
367e4b85 6706 PerlMem_free(tmp);
2f4077ca
JM		 6707 return NULL; /* No room */
6708 }
a0d0e21e 6709 }
f86702cc 6710 *(cp1++) = '/';
6711 }
f7ddb74a
JM		 6712 if ((*cp2 == '^')) {
6713 /* EFS file escape, pass the next character as is */
38a44b82 6714 /* Fix me: HEX encoding for Unicode not implemented */
f7ddb74a
JM		 6715 cp2++;
6716 }
f86702cc 6717 else if ( *cp2 == '.') {
6718 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6719 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6720 cp2 += 3;
6721 }
6722 else cp2++;
a0d0e21e 6723 }
a0d0e21e 6724 }
367e4b85 6725 PerlMem_free(tmp);
a0d0e21e 6726 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 6727 if ((*cp2 == '^')) {
6728 /* EFS file escape, pass the next character as is */
38a44b82 6729 /* Fix me: HEX encoding for Unicode not implemented */
42cd432e
CB		 6730 *(cp1++) = *(++cp2);
6731 /* An escaped dot stays as is -- don't convert to slash */
6732 if (*cp2 == '.') cp2++;
f7ddb74a 6733 }
a0d0e21e
LW		 6734 if (*cp2 == ':') {
6735 *(cp1++) = '/';
6736 if (*(cp2+1) == '[') cp2++;
6737 }
f86702cc 6738 else if (*cp2 == ']' || *cp2 == '>') {
6739 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6740 }
f7ddb74a 6741 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 6742 *(cp1++) = '/';
e518068a 6743 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6744 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6745 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6746 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6747 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6748 }
f86702cc 6749 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6750 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6751 cp2 += 2;
6752 }
a0d0e21e
LW		 6753 }
6754 else if (*cp2 == '-') {
6755 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6756 while (*cp2 == '-') {
6757 cp2++;
6758 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6759 }
6760 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6761 if (ts) Safefree(rslt); /* filespecs like */
01b8edb6 6762 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
a0d0e21e
LW		 6763 return NULL;
6764 }
a0d0e21e
LW		 6765 }
6766 else *(cp1++) = *cp2;
6767 }
6768 else *(cp1++) = *cp2;
6769 }
42cd432e
CB		 6770 while (*cp2) {
6771 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6772 *(cp1++) = *(cp2++);
6773 }
a0d0e21e
LW		 6774 *cp1 = '\0';
6775
f7ddb74a
JM		 6776 /* This still leaves /000000/ when working with a
6777 * VMS device root or concealed root.
6778 */
6779 {
6780 int ulen;
6781 char * zeros;
6782
6783 ulen = strlen(rslt);
6784
6785 /* Get rid of "000000/ in rooted filespecs */
6786 if (ulen > 7) {
6787 zeros = strstr(rslt, "/000000/");
6788 if (zeros != NULL) {
6789 int mlen;
6790 mlen = ulen - (zeros - rslt) - 7;
6791 memmove(zeros, &zeros[7], mlen);
6792 ulen = ulen - 7;
6793 rslt[ulen] = '\0';
6794 }
6795 }
6796 }
6797
a0d0e21e
LW		 6798 return rslt;
6799
6800} /* end of do_tounixspec() */
6801/*}}}*/
6802/* External entry points */
360732b5
JM		 6803char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6804 { return do_tounixspec(spec,buf,0, NULL); }
6805char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6806 { return do_tounixspec(spec,buf,1, NULL); }
6807char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808 { return do_tounixspec(spec,buf,0, utf8_fl); }
6809char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6810 { return do_tounixspec(spec,buf,1, utf8_fl); }
a0d0e21e 6811
360732b5 6812#if __CRTL_VER >= 70200000 && !defined(__VAX)
2497a41f 6813
360732b5
JM		 6814/*
6815 This procedure is used to identify if a path is based in either
6816 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6817 it returns the OpenVMS format directory for it.
6818
6819 It is expecting specifications of only '/' or '/xxxx/'
6820
6821 If a posix root does not exist, or 'xxxx' is not a directory
6822 in the posix root, it returns a failure.
6823
6824 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6825
6826 It is used only internally by posix_to_vmsspec_hardway().
6827 */
6828
6829static int posix_root_to_vms
6830 (char *vmspath, int vmspath_len,
6831 const char *unixpath,
d584a1c6
JM		 6832 const int * utf8_fl)
6833{
2497a41f
JM		 6834int sts;
6835struct FAB myfab = cc$rms_fab;
d584a1c6 6836rms_setup_nam(mynam);
2497a41f 6837struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
d584a1c6
JM		 6838struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6839char * esa, * esal, * rsa, * rsal;
2497a41f
JM		 6840char *vms_delim;
6841int dir_flag;
6842int unixlen;
6843
360732b5 6844 dir_flag = 0;
d584a1c6 6845 vmspath[0] = '\0';
360732b5
JM		 6846 unixlen = strlen(unixpath);
6847 if (unixlen == 0) {
360732b5
JM		 6848 return RMS$_FNF;
6849 }
6850
6851#if __CRTL_VER >= 80200000
2497a41f 6852 /* If not a posix spec already, convert it */
360732b5
JM		 6853 if (decc_posix_compliant_pathnames) {
6854 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6855 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6856 }
6857 else {
6858 /* This is already a VMS specification, no conversion */
6859 unixlen--;
6860 strncpy(vmspath,unixpath, vmspath_len);
6861 }
2497a41f 6862 }
360732b5
JM		 6863 else
6864#endif
6865 {
6866 int path_len;
6867 int i,j;
6868
6869 /* Check to see if this is under the POSIX root */
6870 if (decc_disable_posix_root) {
6871 return RMS$_FNF;
6872 }
6873
6874 /* Skip leading / */
6875 if (unixpath[0] == '/') {
6876 unixpath++;
6877 unixlen--;
6878 }
6879
6880
6881 strcpy(vmspath,"SYS$POSIX_ROOT:");
6882
6883 /* If this is only the / , or blank, then... */
6884 if (unixpath[0] == '\0') {
6885 /* by definition, this is the answer */
6886 return SS$_NORMAL;
6887 }
6888
6889 /* Need to look up a directory */
6890 vmspath[15] = '[';
6891 vmspath[16] = '\0';
6892
6893 /* Copy and add '^' escape characters as needed */
6894 j = 16;
6895 i = 0;
6896 while (unixpath[i] != 0) {
6897 int k;
6898
6899 j += copy_expand_unix_filename_escape
6900 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6901 i += k;
6902 }
6903
6904 path_len = strlen(vmspath);
6905 if (vmspath[path_len - 1] == '/')
6906 path_len--;
6907 vmspath[path_len] = ']';
6908 path_len++;
6909 vmspath[path_len] = '\0';
6910
2497a41f
JM		 6911 }
6912 vmspath[vmspath_len] = 0;
6913 if (unixpath[unixlen - 1] == '/')
6914 dir_flag = 1;
d584a1c6
JM		 6915 esal = PerlMem_malloc(VMS_MAXRSS);
6916 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 6918 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 6919 rsal = PerlMem_malloc(VMS_MAXRSS);
6920 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6922 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6923 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6924 rms_bind_fab_nam(myfab, mynam);
6925 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6926 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 6927 if (decc_efs_case_preserve)
6928 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 6929#ifdef NAML$M_OPEN_SPECIAL
2497a41f 6930 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 6931#endif
2497a41f
JM		 6932
6933 /* Set up the remaining naml fields */
6934 sts = sys$parse(&myfab);
6935
6936 /* It failed! Try again as a UNIX filespec */
6937 if (!(sts & 1)) {
d584a1c6 6938 PerlMem_free(esal);
367e4b85 6939 PerlMem_free(esa);
d584a1c6
JM		 6940 PerlMem_free(rsal);
6941 PerlMem_free(rsa);
2497a41f
JM		 6942 return sts;
6943 }
6944
6945 /* get the Device ID and the FID */
6946 sts = sys$search(&myfab);
d584a1c6
JM		 6947
6948 /* These are no longer needed */
6949 PerlMem_free(esa);
6950 PerlMem_free(rsal);
6951 PerlMem_free(rsa);
6952
2497a41f
JM		 6953 /* on any failure, returned the POSIX ^UP^ filespec */
6954 if (!(sts & 1)) {
d584a1c6 6955 PerlMem_free(esal);
2497a41f
JM		 6956 return sts;
6957 }
6958 specdsc.dsc$a_pointer = vmspath;
6959 specdsc.dsc$w_length = vmspath_len;
6960
6961 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6962 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6963 sts = lib$fid_to_name
6964 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6965
6966 /* on any failure, returned the POSIX ^UP^ filespec */
6967 if (!(sts & 1)) {
6968 /* This can happen if user does not have permission to read directories */
6969 if (strncmp(unixpath,"\"^UP^",5) != 0)
6970 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6971 else
6972 strcpy(vmspath, unixpath);
6973 }
6974 else {
6975 vmspath[specdsc.dsc$w_length] = 0;
6976
6977 /* Are we expecting a directory? */
6978 if (dir_flag != 0) {
6979 int i;
6980 char *eptr;
6981
6982 eptr = NULL;
6983
6984 i = specdsc.dsc$w_length - 1;
6985 while (i > 0) {
6986 int zercnt;
6987 zercnt = 0;
6988 /* Version must be '1' */
6989 if (vmspath[i--] != '1')
6990 break;
6991 /* Version delimiter is one of ".;" */
6992 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6993 break;
6994 i--;
6995 if (vmspath[i--] != 'R')
6996 break;
6997 if (vmspath[i--] != 'I')
6998 break;
6999 if (vmspath[i--] != 'D')
7000 break;
7001 if (vmspath[i--] != '.')
7002 break;
7003 eptr = &vmspath[i+1];
7004 while (i > 0) {
7005 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7006 if (vmspath[i-1] != '^') {
7007 if (zercnt != 6) {
7008 *eptr = vmspath[i];
7009 eptr[1] = '\0';
7010 vmspath[i] = '.';
7011 break;
7012 }
7013 else {
7014 /* Get rid of 6 imaginary zero directory filename */
7015 vmspath[i+1] = '\0';
7016 }
7017 }
7018 }
7019 if (vmspath[i] == '0')
7020 zercnt++;
7021 else
7022 zercnt = 10;
7023 i--;
7024 }
7025 break;
7026 }
7027 }
7028 }
d584a1c6 7029 PerlMem_free(esal);
2497a41f
JM		 7030 return sts;
7031}
7032
360732b5
JM		 7033/* /dev/mumble needs to be handled special.
7034 /dev/null becomes NLA0:, And there is the potential for other stuff
7035 like /dev/tty which may need to be mapped to something.
7036*/
7037
7038static int
7039slash_dev_special_to_vms
7040 (const char * unixptr,
7041 char * vmspath,
7042 int vmspath_len)
7043{
7044char * nextslash;
7045int len;
7046int cmp;
7047int islnm;
7048
7049 unixptr += 4;
7050 nextslash = strchr(unixptr, '/');
7051 len = strlen(unixptr);
7052 if (nextslash != NULL)
7053 len = nextslash - unixptr;
7054 cmp = strncmp("null", unixptr, 5);
7055 if (cmp == 0) {
7056 if (vmspath_len >= 6) {
7057 strcpy(vmspath, "_NLA0:");
7058 return SS$_NORMAL;
7059 }
7060 }
7061}
7062
7063
7064/* The built in routines do not understand perl's special needs, so
7065 doing a manual conversion from UNIX to VMS
7066
7067 If the utf8_fl is not null and points to a non-zero value, then
7068 treat 8 bit characters as UTF-8.
7069
7070 The sequence starting with '$(' and ending with ')' will be passed
7071 through with out interpretation instead of being escaped.
7072
7073 */
2497a41f 7074static int posix_to_vmsspec_hardway
360732b5
JM		 7075 (char *vmspath, int vmspath_len,
7076 const char *unixpath,
7077 int dir_flag,
7078 int * utf8_fl) {
2497a41f
JM		 7079
7080char *esa;
7081const char *unixptr;
360732b5 7082const char *unixend;
2497a41f
JM		 7083char *vmsptr;
7084const char *lastslash;
7085const char *lastdot;
7086int unixlen;
7087int vmslen;
7088int dir_start;
7089int dir_dot;
7090int quoted;
360732b5
JM		 7091char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7092int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7093
360732b5
JM		 7094 if (utf8_fl != NULL)
7095 *utf8_fl = 0;
2497a41f
JM		 7096
7097 unixptr = unixpath;
7098 dir_dot = 0;
7099
7100 /* Ignore leading "/" characters */
7101 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7102 unixptr++;
7103 }
7104 unixlen = strlen(unixptr);
7105
7106 /* Do nothing with blank paths */
7107 if (unixlen == 0) {
7108 vmspath[0] = '\0';
7109 return SS$_NORMAL;
7110 }
7111
360732b5
JM		 7112 quoted = 0;
7113 /* This could have a "^UP^ on the front */
7114 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7115 quoted = 1;
7116 unixptr+= 5;
7117 unixlen-= 5;
7118 }
7119
2497a41f
JM		 7120 lastslash = strrchr(unixptr,'/');
7121 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7122 unixend = strrchr(unixptr,'\"');
7123 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7124 unixend = unixptr + unixlen;
7125 }
2497a41f
JM		 7126
7127 /* last dot is last dot or past end of string */
7128 if (lastdot == NULL)
7129 lastdot = unixptr + unixlen;
7130
7131 /* if no directories, set last slash to beginning of string */
7132 if (lastslash == NULL) {
7133 lastslash = unixptr;
7134 }
7135 else {
7136 /* Watch out for trailing "." after last slash, still a directory */
7137 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7138 lastslash = unixptr + unixlen;
7139 }
7140
7141 /* Watch out for traiing ".." after last slash, still a directory */
7142 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7143 lastslash = unixptr + unixlen;
7144 }
7145
7146 /* dots in directories are aways escaped */
7147 if (lastdot < lastslash)
7148 lastdot = unixptr + unixlen;
7149 }
7150
7151 /* if (unixptr < lastslash) then we are in a directory */
7152
7153 dir_start = 0;
2497a41f
JM		 7154
7155 vmsptr = vmspath;
7156 vmslen = 0;
7157
2497a41f
JM		 7158 /* Start with the UNIX path */
7159 if (*unixptr != '/') {
7160 /* relative paths */
360732b5
JM		 7161
7162 /* If allowing logical names on relative pathnames, then handle here */
7163 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7164 !decc_posix_compliant_pathnames) {
7165 char * nextslash;
7166 int seg_len;
7167 char * trn;
7168 int islnm;
7169
7170 /* Find the next slash */
7171 nextslash = strchr(unixptr,'/');
7172
7173 esa = PerlMem_malloc(vmspath_len);
7174 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7175
7176 trn = PerlMem_malloc(VMS_MAXRSS);
7177 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7178
7179 if (nextslash != NULL) {
7180
7181 seg_len = nextslash - unixptr;
7182 strncpy(esa, unixptr, seg_len);
7183 esa[seg_len] = 0;
7184 }
7185 else {
7186 strcpy(esa, unixptr);
7187 seg_len = strlen(unixptr);
7188 }
7189 /* trnlnm(section) */
7190 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7191
7192 if (islnm) {
7193 /* Now fix up the directory */
7194
7195 /* Split up the path to find the components */
7196 sts = vms_split_path
7197 (trn,
7198 &v_spec,
7199 &v_len,
7200 &r_spec,
7201 &r_len,
7202 &d_spec,
7203 &d_len,
7204 &n_spec,
7205 &n_len,
7206 &e_spec,
7207 &e_len,
7208 &vs_spec,
7209 &vs_len);
7210
7211 while (sts == 0) {
7212 char * strt;
7213 int cmp;
7214
7215 /* A logical name must be a directory or the full
7216 specification. It is only a full specification if
7217 it is the only component */
7218 if ((unixptr[seg_len] == '\0') ||
7219 (unixptr[seg_len+1] == '\0')) {
7220
7221 /* Is a directory being required? */
7222 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7223 /* Not a logical name */
7224 break;
7225 }
7226
7227
7228 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7229 /* This must be a directory */
7230 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7231 strcpy(vmsptr, esa);
7232 vmslen=strlen(vmsptr);
7233 vmsptr[vmslen] = ':';
7234 vmslen++;
7235 vmsptr[vmslen] = '\0';
7236 return SS$_NORMAL;
7237 }
7238 }
7239
7240 }
7241
7242
7243 /* must be dev/directory - ignore version */
7244 if ((n_len + e_len) != 0)
7245 break;
7246
7247 /* transfer the volume */
7248 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7249 strncpy(vmsptr, v_spec, v_len);
7250 vmsptr += v_len;
7251 vmsptr[0] = '\0';
7252 vmslen += v_len;
7253 }
7254
7255 /* unroot the rooted directory */
7256 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7257 r_spec[0] = '[';
7258 r_spec[r_len - 1] = ']';
7259
7260 /* This should not be there, but nothing is perfect */
7261 if (r_len > 9) {
7262 cmp = strcmp(&r_spec[1], "000000.");
7263 if (cmp == 0) {
7264 r_spec += 7;
7265 r_spec[7] = '[';
7266 r_len -= 7;
7267 if (r_len == 2)
7268 r_len = 0;
7269 }
7270 }
7271 if (r_len > 0) {
7272 strncpy(vmsptr, r_spec, r_len);
7273 vmsptr += r_len;
7274 vmslen += r_len;
7275 vmsptr[0] = '\0';
7276 }
7277 }
7278 /* Bring over the directory. */
7279 if ((d_len > 0) &&
7280 ((d_len + vmslen) < vmspath_len)) {
7281 d_spec[0] = '[';
7282 d_spec[d_len - 1] = ']';
7283 if (d_len > 9) {
7284 cmp = strcmp(&d_spec[1], "000000.");
7285 if (cmp == 0) {
7286 d_spec += 7;
7287 d_spec[7] = '[';
7288 d_len -= 7;
7289 if (d_len == 2)
7290 d_len = 0;
7291 }
7292 }
7293
7294 if (r_len > 0) {
7295 /* Remove the redundant root */
7296 if (r_len > 0) {
7297 /* remove the ][ */
7298 vmsptr--;
7299 vmslen--;
7300 d_spec++;
7301 d_len--;
7302 }
7303 strncpy(vmsptr, d_spec, d_len);
7304 vmsptr += d_len;
7305 vmslen += d_len;
7306 vmsptr[0] = '\0';
7307 }
7308 }
7309 break;
7310 }
7311 }
7312
7313 PerlMem_free(esa);
7314 PerlMem_free(trn);
7315 }
7316
2497a41f
JM		 7317 if (lastslash > unixptr) {
7318 int dotdir_seen;
7319
7320 /* skip leading ./ */
7321 dotdir_seen = 0;
7322 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7323 dotdir_seen = 1;
7324 unixptr++;
7325 unixptr++;
7326 }
7327
7328 /* Are we still in a directory? */
7329 if (unixptr <= lastslash) {
7330 *vmsptr++ = '[';
7331 vmslen = 1;
7332 dir_start = 1;
7333
7334 /* if not backing up, then it is relative forward. */
7335 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7336 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7337 *vmsptr++ = '.';
7338 vmslen++;
7339 dir_dot = 1;
360732b5 7340 }
2497a41f
JM		 7341 }
7342 else {
7343 if (dotdir_seen) {
7344 /* Perl wants an empty directory here to tell the difference
7345 * between a DCL commmand and a filename
7346 */
7347 *vmsptr++ = '[';
7348 *vmsptr++ = ']';
7349 vmslen = 2;
7350 }
7351 }
7352 }
7353 else {
7354 /* Handle two special files . and .. */
7355 if (unixptr[0] == '.') {
360732b5 7356 if (&unixptr[1] == unixend) {
2497a41f
JM		 7357 *vmsptr++ = '[';
7358 *vmsptr++ = ']';
7359 vmslen += 2;
7360 *vmsptr++ = '\0';
7361 return SS$_NORMAL;
7362 }
360732b5 7363 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7364 *vmsptr++ = '[';
7365 *vmsptr++ = '-';
7366 *vmsptr++ = ']';
7367 vmslen += 3;
7368 *vmsptr++ = '\0';
7369 return SS$_NORMAL;
7370 }
7371 }
7372 }
7373 }
7374 else { /* Absolute PATH handling */
7375 int sts;
7376 char * nextslash;
7377 int seg_len;
7378 /* Need to find out where root is */
7379
7380 /* In theory, this procedure should never get an absolute POSIX pathname
7381 * that can not be found on the POSIX root.
7382 * In practice, that can not be relied on, and things will show up
7383 * here that are a VMS device name or concealed logical name instead.
7384 * So to make things work, this procedure must be tolerant.
7385 */
c5375c28
JM		 7386 esa = PerlMem_malloc(vmspath_len);
7387 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7388
7389 sts = SS$_NORMAL;
7390 nextslash = strchr(&unixptr[1],'/');
7391 seg_len = 0;
7392 if (nextslash != NULL) {
360732b5 7393 int cmp;
2497a41f
JM		 7394 seg_len = nextslash - &unixptr[1];
7395 strncpy(vmspath, unixptr, seg_len + 1);
7396 vmspath[seg_len+1] = 0;
360732b5
JM		 7397 cmp = 1;
7398 if (seg_len == 3) {
7399 cmp = strncmp(vmspath, "dev", 4);
7400 if (cmp == 0) {
7401 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7402 if (sts = SS$_NORMAL)
7403 return SS$_NORMAL;
7404 }
7405 }
7406 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 7407 }
7408
360732b5 7409 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 7410 /* This is verified to be a real path */
7411
360732b5
JM		 7412 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7413 if ($VMS_STATUS_SUCCESS(sts)) {
7414 strcpy(vmspath, esa);
7415 vmslen = strlen(vmspath);
7416 vmsptr = vmspath + vmslen;
7417 unixptr++;
7418 if (unixptr < lastslash) {
7419 char * rptr;
7420 vmsptr--;
7421 *vmsptr++ = '.';
7422 dir_start = 1;
7423 dir_dot = 1;
7424 if (vmslen > 7) {
7425 int cmp;
7426 rptr = vmsptr - 7;
7427 cmp = strcmp(rptr,"000000.");
7428 if (cmp == 0) {
7429 vmslen -= 7;
7430 vmsptr -= 7;
7431 vmsptr[1] = '\0';
7432 } /* removing 6 zeros */
7433 } /* vmslen < 7, no 6 zeros possible */
7434 } /* Not in a directory */
7435 } /* Posix root found */
7436 else {
7437 /* No posix root, fall back to default directory */
7438 strcpy(vmspath, "SYS$DISK:[");
7439 vmsptr = &vmspath[10];
7440 vmslen = 10;
7441 if (unixptr > lastslash) {
7442 *vmsptr = ']';
7443 vmsptr++;
7444 vmslen++;
7445 }
7446 else {
7447 dir_start = 1;
7448 }
7449 }
2497a41f
JM		 7450 } /* end of verified real path handling */
7451 else {
7452 int add_6zero;
7453 int islnm;
7454
7455 /* Ok, we have a device or a concealed root that is not in POSIX
7456 * or we have garbage. Make the best of it.
7457 */
7458
7459 /* Posix to VMS destroyed this, so copy it again */
7460 strncpy(vmspath, &unixptr[1], seg_len);
7461 vmspath[seg_len] = 0;
7462 vmslen = seg_len;
7463 vmsptr = &vmsptr[vmslen];
7464 islnm = 0;
7465
7466 /* Now do we need to add the fake 6 zero directory to it? */
7467 add_6zero = 1;
7468 if ((*lastslash == '/') && (nextslash < lastslash)) {
7469 /* No there is another directory */
7470 add_6zero = 0;
7471 }
7472 else {
7473 int trnend;
360732b5 7474 int cmp;
2497a41f
JM		 7475
7476 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 7477 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 7478
7479 if (!islnm && !decc_posix_compliant_pathnames) {
7480
7481 cmp = strncmp("bin", vmspath, 4);
7482 if (cmp == 0) {
7483 /* bin => SYS$SYSTEM: */
7484 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7485 }
7486 else {
7487 /* tmp => SYS$SCRATCH: */
7488 cmp = strncmp("tmp", vmspath, 4);
7489 if (cmp == 0) {
7490 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7491 }
7492 }
7493 }
7494
7ded3206 7495 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 7496
7497 /* if this was a logical name, ']' or '>' must be present */
7498 /* if not a logical name, then assume a device and hope. */
7499 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7500
7501 /* if log name and trailing '.' then rooted - treat as device */
7502 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7503
7504 /* Fix me, if not a logical name, a device lookup should be
7505 * done to see if the device is file structured. If the device
7506 * is not file structured, the 6 zeros should not be put on.
7507 *
7508 * As it is, perl is occasionally looking for dev:[000000]tty.
7509 * which looks a little strange.
360732b5
JM		 7510 *
7511 * Not that easy to detect as "/dev" may be file structured with
7512 * special device files.
2497a41f
JM		 7513 */
7514
360732b5
JM		 7515 if ((add_6zero == 0) && (*nextslash == '/') &&
7516 (&nextslash[1] == unixend)) {
2497a41f
JM		 7517 /* No real directory present */
7518 add_6zero = 1;
7519 }
7520 }
7521
7522 /* Put the device delimiter on */
7523 *vmsptr++ = ':';
7524 vmslen++;
7525 unixptr = nextslash;
7526 unixptr++;
7527
7528 /* Start directory if needed */
7529 if (!islnm || add_6zero) {
7530 *vmsptr++ = '[';
7531 vmslen++;
7532 dir_start = 1;
7533 }
7534
7535 /* add fake 000000] if needed */
7536 if (add_6zero) {
7537 *vmsptr++ = '0';
7538 *vmsptr++ = '0';
7539 *vmsptr++ = '0';
7540 *vmsptr++ = '0';
7541 *vmsptr++ = '0';
7542 *vmsptr++ = '0';
7543 *vmsptr++ = ']';
7544 vmslen += 7;
7545 dir_start = 0;
7546 }
7547
7548 } /* non-POSIX translation */
367e4b85 7549 PerlMem_free(esa);
2497a41f
JM		 7550 } /* End of relative/absolute path handling */
7551
360732b5 7552 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
2497a41f 7553 int dash_flag;
360732b5
JM		 7554 int in_cnt;
7555 int out_cnt;
2497a41f
JM		 7556
7557 dash_flag = 0;
7558
7559 if (dir_start != 0) {
7560
7561 /* First characters in a directory are handled special */
7562 while ((*unixptr == '/') ||
7563 ((*unixptr == '.') &&
360732b5
JM		 7564 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7565 (&unixptr[1]==unixend)))) {
2497a41f
JM		 7566 int loop_flag;
7567
7568 loop_flag = 0;
7569
7570 /* Skip redundant / in specification */
7571 while ((*unixptr == '/') && (dir_start != 0)) {
7572 loop_flag = 1;
7573 unixptr++;
7574 if (unixptr == lastslash)
7575 break;
7576 }
7577 if (unixptr == lastslash)
7578 break;
7579
7580 /* Skip redundant ./ characters */
7581 while ((*unixptr == '.') &&
360732b5 7582 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 7583 loop_flag = 1;
7584 unixptr++;
7585 if (unixptr == lastslash)
7586 break;
7587 if (*unixptr == '/')
7588 unixptr++;
7589 }
7590 if (unixptr == lastslash)
7591 break;
7592
7593 /* Skip redundant ../ characters */
7594 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7595 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 7596 /* Set the backing up flag */
7597 loop_flag = 1;
7598 dir_dot = 0;
7599 dash_flag = 1;
7600 *vmsptr++ = '-';
7601 vmslen++;
7602 unixptr++; /* first . */
7603 unixptr++; /* second . */
7604 if (unixptr == lastslash)
7605 break;
7606 if (*unixptr == '/') /* The slash */
7607 unixptr++;
7608 }
7609 if (unixptr == lastslash)
7610 break;
7611
7612 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7613 /* Not needed when VMS is pretending to be UNIX. */
7614
7615 /* Is this loop stuck because of too many dots? */
7616 if (loop_flag == 0) {
7617 /* Exit the loop and pass the rest through */
7618 break;
7619 }
7620 }
7621
7622 /* Are we done with directories yet? */
7623 if (unixptr >= lastslash) {
7624
7625 /* Watch out for trailing dots */
7626 if (dir_dot != 0) {
7627 vmslen --;
7628 vmsptr--;
7629 }
7630 *vmsptr++ = ']';
7631 vmslen++;
7632 dash_flag = 0;
7633 dir_start = 0;
7634 if (*unixptr == '/')
7635 unixptr++;
7636 }
7637 else {
7638 /* Have we stopped backing up? */
7639 if (dash_flag) {
7640 *vmsptr++ = '.';
7641 vmslen++;
7642 dash_flag = 0;
7643 /* dir_start continues to be = 1 */
7644 }
7645 if (*unixptr == '-') {
7646 *vmsptr++ = '^';
7647 *vmsptr++ = *unixptr++;
7648 vmslen += 2;
7649 dir_start = 0;
7650
7651 /* Now are we done with directories yet? */
7652 if (unixptr >= lastslash) {
7653
7654 /* Watch out for trailing dots */
7655 if (dir_dot != 0) {
7656 vmslen --;
7657 vmsptr--;
7658 }
7659
7660 *vmsptr++ = ']';
7661 vmslen++;
7662 dash_flag = 0;
7663 dir_start = 0;
7664 }
7665 }
7666 }
7667 }
7668
7669 /* All done? */
360732b5 7670 if (unixptr >= unixend)
2497a41f
JM		 7671 break;
7672
7673 /* Normal characters - More EFS work probably needed */
7674 dir_start = 0;
7675 dir_dot = 0;
7676
7677 switch(*unixptr) {
7678 case '/':
7679 /* remove multiple / */
7680 while (unixptr[1] == '/') {
7681 unixptr++;
7682 }
7683 if (unixptr == lastslash) {
7684 /* Watch out for trailing dots */
7685 if (dir_dot != 0) {
7686 vmslen --;
7687 vmsptr--;
7688 }
7689 *vmsptr++ = ']';
7690 }
7691 else {
7692 dir_start = 1;
7693 *vmsptr++ = '.';
7694 dir_dot = 1;
7695
7696 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7697 /* Not needed when VMS is pretending to be UNIX. */
7698
7699 }
7700 dash_flag = 0;
360732b5 7701 if (unixptr != unixend)
2497a41f
JM		 7702 unixptr++;
7703 vmslen++;
7704 break;
2497a41f 7705 case '.':
360732b5
JM		 7706 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7707 (&unixptr[1] == unixend)) {
2497a41f
JM		 7708 *vmsptr++ = '^';
7709 *vmsptr++ = '.';
7710 vmslen += 2;
7711 unixptr++;
7712
7713 /* trailing dot ==> '^..' on VMS */
360732b5 7714 if (unixptr == unixend) {
2497a41f
JM		 7715 *vmsptr++ = '.';
7716 vmslen++;
360732b5 7717 unixptr++;
2497a41f 7718 }
2497a41f
JM		 7719 break;
7720 }
360732b5 7721
2497a41f 7722 *vmsptr++ = *unixptr++;
360732b5
JM		 7723 vmslen ++;
7724 break;
7725 case '"':
7726 if (quoted && (&unixptr[1] == unixend)) {
7727 unixptr++;
7728 break;
7729 }
7730 in_cnt = copy_expand_unix_filename_escape
7731 (vmsptr, unixptr, &out_cnt, utf8_fl);
7732 vmsptr += out_cnt;
7733 unixptr += in_cnt;
2497a41f
JM		 7734 break;
7735 case '~':
7736 case ';':
7737 case '\\':
360732b5
JM		 7738 case '?':
7739 case ' ':
2497a41f 7740 default:
360732b5
JM		 7741 in_cnt = copy_expand_unix_filename_escape
7742 (vmsptr, unixptr, &out_cnt, utf8_fl);
7743 vmsptr += out_cnt;
7744 unixptr += in_cnt;
2497a41f
JM		 7745 break;
7746 }
7747 }
7748
7749 /* Make sure directory is closed */
7750 if (unixptr == lastslash) {
7751 char *vmsptr2;
7752 vmsptr2 = vmsptr - 1;
7753
7754 if (*vmsptr2 != ']') {
7755 *vmsptr2--;
7756
7757 /* directories do not end in a dot bracket */
7758 if (*vmsptr2 == '.') {
7759 vmsptr2--;
7760
7761 /* ^. is allowed */
7762 if (*vmsptr2 != '^') {
7763 vmsptr--; /* back up over the dot */
7764 }
7765 }
7766 *vmsptr++ = ']';
7767 }
7768 }
7769 else {
7770 char *vmsptr2;
7771 /* Add a trailing dot if a file with no extension */
7772 vmsptr2 = vmsptr - 1;
360732b5
JM		 7773 if ((vmslen > 1) &&
7774 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7775 (*vmsptr2 != ')') && (*lastdot != '.')) {
2497a41f
JM		 7776 *vmsptr++ = '.';
7777 vmslen++;
7778 }
7779 }
7780
7781 *vmsptr = '\0';
7782 return SS$_NORMAL;
7783}
7784#endif
7785
360732b5
JM		 7786 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7787static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7788{
7789char * result;
7790int utf8_flag;
7791
7792 /* If a UTF8 flag is being passed, honor it */
7793 utf8_flag = 0;
7794 if (utf8_fl != NULL) {
7795 utf8_flag = *utf8_fl;
7796 *utf8_fl = 0;
7797 }
7798
7799 if (utf8_flag) {
7800 /* If there is a possibility of UTF8, then if any UTF8 characters
7801 are present, then they must be converted to VTF-7
7802 */
7803 result = strcpy(rslt, path); /* FIX-ME */
7804 }
7805 else
7806 result = strcpy(rslt, path);
7807
7808 return result;
7809}
7810
7811
7812/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7813static char *mp_do_tovmsspec
7814 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
a480973c 7815 static char __tovmsspec_retbuf[VMS_MAXRSS];
e518068a 7816 char *rslt, *dirend;
f7ddb74a
JM		 7817 char *lastdot;
7818 char *vms_delim;
b8ffc8df
RGS		 7819 register char *cp1;
7820 const char *cp2;
e518068a 7821 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 7822 int rslt_len;
7823 int no_type_seen;
360732b5
JM		 7824 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7825 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 7826
748a9306 7827 if (path == NULL) return NULL;
4d743a9b 7828 rslt_len = VMS_MAXRSS-1;
a0d0e21e 7829 if (buf) rslt = buf;
a480973c 7830 else if (ts) Newx(rslt, VMS_MAXRSS, char);
a0d0e21e 7831 else rslt = __tovmsspec_retbuf;
360732b5
JM		 7832
7833 /* '.' and '..' are "[]" and "[-]" for a quick check */
7834 if (path[0] == '.') {
7835 if (path[1] == '\0') {
7836 strcpy(rslt,"[]");
7837 if (utf8_flag != NULL)
7838 *utf8_flag = 0;
7839 return rslt;
7840 }
7841 else {
7842 if (path[1] == '.' && path[2] == '\0') {
7843 strcpy(rslt,"[-]");
7844 if (utf8_flag != NULL)
7845 *utf8_flag = 0;
7846 return rslt;
7847 }
7848 }
a0d0e21e 7849 }
f7ddb74a 7850
2497a41f
JM		 7851 /* Posix specifications are now a native VMS format */
7852 /*--------------------------------------------------*/
7853#if __CRTL_VER >= 80200000 && !defined(__VAX)
7854 if (decc_posix_compliant_pathnames) {
7855 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 7856 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 7857 return rslt;
7858 }
7859 }
7860#endif
7861
360732b5
JM		 7862 /* This is really the only way to see if this is already in VMS format */
7863 sts = vms_split_path
7864 (path,
7865 &v_spec,
7866 &v_len,
7867 &r_spec,
7868 &r_len,
7869 &d_spec,
7870 &d_len,
7871 &n_spec,
7872 &n_len,
7873 &e_spec,
7874 &e_len,
7875 &vs_spec,
7876 &vs_len);
7877 if (sts == 0) {
7878 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7879 replacement, because the above parse just took care of most of
7880 what is needed to do vmspath when the specification is already
7881 in VMS format.
7882
7883 And if it is not already, it is easier to do the conversion as
7884 part of this routine than to call this routine and then work on
7885 the result.
7886 */
2497a41f 7887
360732b5
JM		 7888 /* If VMS punctuation was found, it is already VMS format */
7889 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7890 if (utf8_flag != NULL)
7891 *utf8_flag = 0;
7892 strcpy(rslt, path);
7893 return rslt;
7894 }
7895 /* Now, what to do with trailing "." cases where there is no
7896 extension? If this is a UNIX specification, and EFS characters
7897 are enabled, then the trailing "." should be converted to a "^.".
7898 But if this was already a VMS specification, then it should be
7899 left alone.
2497a41f 7900
360732b5
JM		 7901 So in the case of ambiguity, leave the specification alone.
7902 */
2497a41f 7903
2497a41f 7904
360732b5
JM		 7905 /* If there is a possibility of UTF8, then if any UTF8 characters
7906 are present, then they must be converted to VTF-7
7907 */
7908 if (utf8_flag != NULL)
7909 *utf8_flag = 0;
7910 strcpy(rslt, path);
2497a41f
JM		 7911 return rslt;
7912 }
7913
360732b5
JM		 7914 dirend = strrchr(path,'/');
7915
7916 if (dirend == NULL) {
7917 /* If we get here with no UNIX directory delimiters, then this is
7918 not a complete file specification, either garbage a UNIX glob
7919 specification that can not be converted to a VMS wildcard, or
7920 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7921 so apparently other programs expect this also.
7922
7923 utf8 flag setting needs to be preserved.
7924 */
7925 strcpy(rslt, path);
7926 return rslt;
7927 }
7928
2497a41f
JM		 7929/* If POSIX mode active, handle the conversion */
7930#if __CRTL_VER >= 80200000 && !defined(__VAX)
360732b5
JM		 7931 if (decc_efs_charset) {
7932 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 7933 return rslt;
7934 }
7935#endif
f7ddb74a 7936
f86702cc 7937 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 7938 if (!*(dirend+2)) dirend +=2;
7939 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
360732b5
JM		 7940 if (decc_efs_charset == 0) {
7941 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7942 }
748a9306 7943 }
f7ddb74a 7944
a0d0e21e
LW		 7945 cp1 = rslt;
7946 cp2 = path;
f7ddb74a 7947 lastdot = strrchr(cp2,'.');
a0d0e21e 7948 if (*cp2 == '/') {
a480973c 7949 char *trndev;
e518068a 7950 int islnm, rooted;
7951 STRLEN trnend;
7952
b7ae7a0d 7953 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 7954 if (!*(cp2+1)) {
f7ddb74a
JM		 7955 if (decc_disable_posix_root) {
7956 strcpy(rslt,"sys$disk:[000000]");
7957 }
7958 else {
7959 strcpy(rslt,"sys$posix_root:[000000]");
7960 }
360732b5
JM		 7961 if (utf8_flag != NULL)
7962 *utf8_flag = 0;
61bb5906
CB		 7963 return rslt;
7964 }
a0d0e21e 7965 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 7966 *cp1 = '\0';
c5375c28
JM		 7967 trndev = PerlMem_malloc(VMS_MAXRSS);
7968 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
c07a80fd 7969 islnm = my_trnlnm(rslt,trndev,0);
f7ddb74a
JM		 7970
7971 /* DECC special handling */
7972 if (!islnm) {
7973 if (strcmp(rslt,"bin") == 0) {
7974 strcpy(rslt,"sys$system");
7975 cp1 = rslt + 10;
7976 *cp1 = 0;
7977 islnm = my_trnlnm(rslt,trndev,0);
7978 }
7979 else if (strcmp(rslt,"tmp") == 0) {
7980 strcpy(rslt,"sys$scratch");
7981 cp1 = rslt + 11;
7982 *cp1 = 0;
7983 islnm = my_trnlnm(rslt,trndev,0);
7984 }
7985 else if (!decc_disable_posix_root) {
7986 strcpy(rslt, "sys$posix_root");
7987 cp1 = rslt + 13;
7988 *cp1 = 0;
7989 cp2 = path;
7990 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7991 islnm = my_trnlnm(rslt,trndev,0);
7992 }
7993 else if (strcmp(rslt,"dev") == 0) {
7994 if (strncmp(cp2,"/null", 5) == 0) {
7995 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7996 strcpy(rslt,"NLA0");
7997 cp1 = rslt + 4;
7998 *cp1 = 0;
7999 cp2 = cp2 + 5;
8000 islnm = my_trnlnm(rslt,trndev,0);
8001 }
8002 }
8003 }
8004 }
8005
e518068a 8006 trnend = islnm ? strlen(trndev) - 1 : 0;
8007 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8008 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8009 /* If the first element of the path is a logical name, determine
8010 * whether it has to be translated so we can add more directories. */
8011 if (!islnm || rooted) {
8012 *(cp1++) = ':';
8013 *(cp1++) = '[';
8014 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8015 else cp2++;
8016 }
8017 else {
8018 if (cp2 != dirend) {
e518068a 8019 strcpy(rslt,trndev);
8020 cp1 = rslt + trnend;
755b3d5d
JM		 8021 if (*cp2 != 0) {
8022 *(cp1++) = '.';
8023 cp2++;
8024 }
e518068a 8025 }
8026 else {
f7ddb74a
JM		 8027 if (decc_disable_posix_root) {
8028 *(cp1++) = ':';
8029 hasdir = 0;
8030 }
e518068a 8031 }
8032 }
367e4b85 8033 PerlMem_free(trndev);
748a9306 8034 }
a0d0e21e
LW		 8035 else {
8036 *(cp1++) = '[';
748a9306
LW		 8037 if (*cp2 == '.') {
8038 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8039 cp2 += 2; /* skip over "./" - it's redundant */
8040 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8041 }
8042 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8043 *(cp1++) = '-'; /* "../" --> "-" */
8044 cp2 += 3;
8045 }
f86702cc 8046 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8047 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8048 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8049 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8050 cp2 += 4;
8051 }
f7ddb74a
JM		 8052 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8053 /* Escape the extra dots in EFS file specifications */
8054 *(cp1++) = '^';
8055 }
748a9306
LW		 8056 if (cp2 > dirend) cp2 = dirend;
8057 }
8058 else *(cp1++) = '.';
8059 }
8060 for (; cp2 < dirend; cp2++) {
8061 if (*cp2 == '/') {
01b8edb6 8062 if (*(cp2-1) == '/') continue;
748a9306
LW		 8063 if (*(cp1-1) != '.') *(cp1++) = '.';
8064 infront = 0;
8065 }
8066 else if (!infront && *cp2 == '.') {
01b8edb6 8067 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8068 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 8069 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8070 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 8071 else if (*(cp1-2) == '[') *(cp1-1) = '-';
fd7385b9
CB		 8072 else { /* back up over previous directory name */
8073 cp1--;
8074 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8075 if (*(cp1-1) == '[') {
8076 memcpy(cp1,"000000.",7);
8077 cp1 += 7;
8078 }
748a9306
LW		 8079 }
8080 cp2 += 2;
01b8edb6 8081 if (cp2 == dirend) break;
748a9306 8082 }
f86702cc 8083 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8084 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8085 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8086 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8087 if (!*(cp2+3)) {
8088 *(cp1++) = '.'; /* Simulate trailing '/' */
8089 cp2 += 2; /* for loop will incr this to == dirend */
8090 }
8091 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8092 }
f7ddb74a
JM		 8093 else {
8094 if (decc_efs_charset == 0)
8095 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8096 else {
8097 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8098 *(cp1++) = '.';
8099 }
8100 }
748a9306
LW		 8101 }
8102 else {
e518068a 8103 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 8104 if (*cp2 == '.') {
8105 if (decc_efs_charset == 0)
8106 *(cp1++) = '_';
8107 else {
8108 *(cp1++) = '^';
8109 *(cp1++) = '.';
8110 }
8111 }
748a9306
LW		 8112 else *(cp1++) = *cp2;
8113 infront = 1;
8114 }
a0d0e21e 8115 }
748a9306 8116 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8117 if (hasdir) *(cp1++) = ']';
748a9306 8118 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 8119 /* fixme for ODS5 */
8120 no_type_seen = 0;
8121 if (cp2 > lastdot)
8122 no_type_seen = 1;
8123 while (*cp2) {
8124 switch(*cp2) {
8125 case '?':
360732b5
JM		 8126 if (decc_efs_charset == 0)
8127 *(cp1++) = '%';
8128 else
8129 *(cp1++) = '?';
f7ddb74a
JM		 8130 cp2++;
8131 case ' ':
8132 *(cp1)++ = '^';
8133 *(cp1)++ = '_';
8134 cp2++;
8135 break;
8136 case '.':
8137 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8138 decc_readdir_dropdotnotype) {
8139 *(cp1)++ = '^';
8140 *(cp1)++ = '.';
8141 cp2++;
8142
8143 /* trailing dot ==> '^..' on VMS */
8144 if (*cp2 == '\0') {
8145 *(cp1++) = '.';
8146 no_type_seen = 0;
8147 }
8148 }
8149 else {
8150 *(cp1++) = *(cp2++);
8151 no_type_seen = 0;
8152 }
8153 break;
360732b5
JM		 8154 case '$':
8155 /* This could be a macro to be passed through */
8156 *(cp1++) = *(cp2++);
8157 if (*cp2 == '(') {
8158 const char * save_cp2;
8159 char * save_cp1;
8160 int is_macro;
8161
8162 /* paranoid check */
8163 save_cp2 = cp2;
8164 save_cp1 = cp1;
8165 is_macro = 0;
8166
8167 /* Test through */
8168 *(cp1++) = *(cp2++);
8169 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170 *(cp1++) = *(cp2++);
8171 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8172 *(cp1++) = *(cp2++);
8173 }
8174 if (*cp2 == ')') {
8175 *(cp1++) = *(cp2++);
8176 is_macro = 1;
8177 }
8178 }
8179 if (is_macro == 0) {
8180 /* Not really a macro - never mind */
8181 cp2 = save_cp2;
8182 cp1 = save_cp1;
8183 }
8184 }
8185 break;
f7ddb74a
JM		 8186 case '\"':
8187 case '~':
8188 case '`':
8189 case '!':
8190 case '#':
8191 case '%':
8192 case '^':
adc11f0b
CB		 8193 /* Don't escape again if following character is
8194 * already something we escape.
8195 */
8196 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8197 *(cp1++) = *(cp2++);
8198 break;
8199 }
8200 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8201 case '&':
8202 case '(':
8203 case ')':
8204 case '=':
8205 case '+':
8206 case '\'':
8207 case '@':
8208 case '[':
8209 case ']':
8210 case '{':
8211 case '}':
8212 case ':':
8213 case '\\':
8214 case '|':
8215 case '<':
8216 case '>':
8217 *(cp1++) = '^';
8218 *(cp1++) = *(cp2++);
8219 break;
8220 case ';':
8221 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
657054d4 8222 * which is wrong. UNIX notation should be ".dir." unless
f7ddb74a
JM		 8223 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8224 * changing this behavior could break more things at this time.
2497a41f
JM		 8225 * efs character set effectively does not allow "." to be a version
8226 * delimiter as a further complication about changing this.
f7ddb74a
JM		 8227 */
8228 if (decc_filename_unix_report != 0) {
8229 *(cp1++) = '^';
8230 }
8231 *(cp1++) = *(cp2++);
8232 break;
8233 default:
8234 *(cp1++) = *(cp2++);
8235 }
8236 }
8237 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8238 char *lcp1;
8239 lcp1 = cp1;
8240 lcp1--;
8241 /* Fix me for "^]", but that requires making sure that you do
8242 * not back up past the start of the filename
8243 */
8244 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8245 *cp1++ = '.';
8246 }
a0d0e21e
LW		 8247 *cp1 = '\0';
8248
360732b5
JM		 8249 if (utf8_flag != NULL)
8250 *utf8_flag = 0;
a0d0e21e
LW		 8251 return rslt;
8252
8253} /* end of do_tovmsspec() */
8254/*}}}*/
8255/* External entry points */
360732b5
JM		 8256char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8257 { return do_tovmsspec(path,buf,0,NULL); }
8258char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8259 { return do_tovmsspec(path,buf,1,NULL); }
8260char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8261 { return do_tovmsspec(path,buf,0,utf8_fl); }
8262char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8263 { return do_tovmsspec(path,buf,1,utf8_fl); }
8264
8265/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8266static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8267 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8268 int vmslen;
a480973c 8269 char *pathified, *vmsified, *cp;
a0d0e21e 8270
748a9306 8271 if (path == NULL) return NULL;
c5375c28
JM		 8272 pathified = PerlMem_malloc(VMS_MAXRSS);
8273 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8274 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8275 PerlMem_free(pathified);
a480973c
JM		 8276 return NULL;
8277 }
c5375c28
JM		 8278
8279 vmsified = NULL;
8280 if (buf == NULL)
8281 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8282 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8283 PerlMem_free(pathified);
8284 if (vmsified) Safefree(vmsified);
a480973c
JM		 8285 return NULL;
8286 }
c5375c28 8287 PerlMem_free(pathified);
a480973c 8288 if (buf) {
a480973c
JM		 8289 return buf;
8290 }
a0d0e21e
LW		 8291 else if (ts) {
8292 vmslen = strlen(vmsified);
a02a5408 8293 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8294 memcpy(cp,vmsified,vmslen);
8295 cp[vmslen] = '\0';
a480973c 8296 Safefree(vmsified);
a0d0e21e
LW		 8297 return cp;
8298 }
8299 else {
8300 strcpy(__tovmspath_retbuf,vmsified);
a480973c 8301 Safefree(vmsified);
a0d0e21e
LW		 8302 return __tovmspath_retbuf;
8303 }
8304
8305} /* end of do_tovmspath() */
8306/*}}}*/
8307/* External entry points */
360732b5
JM		 8308char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8309 { return do_tovmspath(path,buf,0, NULL); }
8310char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8311 { return do_tovmspath(path,buf,1, NULL); }
8312char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8313 { return do_tovmspath(path,buf,0,utf8_fl); }
8314char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8315 { return do_tovmspath(path,buf,1,utf8_fl); }
8316
8317
8318/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8319static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8320 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 8321 int unixlen;
a480973c 8322 char *pathified, *unixified, *cp;
a0d0e21e 8323
748a9306 8324 if (path == NULL) return NULL;
c5375c28
JM		 8325 pathified = PerlMem_malloc(VMS_MAXRSS);
8326 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
360732b5 8327 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
c5375c28 8328 PerlMem_free(pathified);
a480973c
JM		 8329 return NULL;
8330 }
c5375c28
JM		 8331
8332 unixified = NULL;
8333 if (buf == NULL) {
8334 Newx(unixified, VMS_MAXRSS, char);
8335 }
360732b5 8336 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 8337 PerlMem_free(pathified);
8338 if (unixified) Safefree(unixified);
a480973c
JM		 8339 return NULL;
8340 }
c5375c28 8341 PerlMem_free(pathified);
a480973c 8342 if (buf) {
a480973c
JM		 8343 return buf;
8344 }
a0d0e21e
LW		 8345 else if (ts) {
8346 unixlen = strlen(unixified);
a02a5408 8347 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 8348 memcpy(cp,unixified,unixlen);
8349 cp[unixlen] = '\0';
a480973c 8350 Safefree(unixified);
a0d0e21e
LW		 8351 return cp;
8352 }
8353 else {
8354 strcpy(__tounixpath_retbuf,unixified);
a480973c 8355 Safefree(unixified);
a0d0e21e
LW		 8356 return __tounixpath_retbuf;
8357 }
8358
8359} /* end of do_tounixpath() */
8360/*}}}*/
8361/* External entry points */
360732b5
JM		 8362char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8363 { return do_tounixpath(path,buf,0,NULL); }
8364char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8365 { return do_tounixpath(path,buf,1,NULL); }
8366char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8367 { return do_tounixpath(path,buf,0,utf8_fl); }
8368char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8369 { return do_tounixpath(path,buf,1,utf8_fl); }
a0d0e21e
LW		 8370
8371/*
cbb8049c 8372 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8373 *
8374 *****************************************************************************
8375 * *
cbb8049c 8376 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 8377 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8378 * *
cbb8049c
MP		 8379 * Permission is hereby granted for the reproduction of this software *
8380 * on condition that this copyright notice is included in source *
8381 * distributions of the software. The code may be modified and *
8382 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 8383 * *
8384 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 8385 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 8386 *****************************************************************************
8387 */
8388
8389/*
8390 * getredirection() is intended to aid in porting C programs
8391 * to VMS (Vax-11 C). The native VMS environment does not support
8392 * '>' and '<' I/O redirection, or command line wild card expansion,
8393 * or a command line pipe mechanism using the '|' AND background
8394 * command execution '&'. All of these capabilities are provided to any
8395 * C program which calls this procedure as the first thing in the
8396 * main program.
8397 * The piping mechanism will probably work with almost any 'filter' type
8398 * of program. With suitable modification, it may useful for other
8399 * portability problems as well.
8400 *
cbb8049c 8401 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8402 */
8403struct list_item
8404 {
8405 struct list_item *next;
8406 char *value;
8407 };
8408
8409static void add_item(struct list_item **head,
8410 struct list_item **tail,
8411 char *value,
8412 int *count);
8413
4b19af01
CB		 8414static void mp_expand_wild_cards(pTHX_ char *item,
8415 struct list_item **head,
8416 struct list_item **tail,
8417 int *count);
a0d0e21e 8418
8df869cb 8419static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 8420
fd8cd3a3 8421static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 8422
8423/*{{{ void getredirection(int *ac, char ***av)*/
84902520 8424static void
4b19af01 8425mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 8426/*
8427 * Process vms redirection arg's. Exit if any error is seen.
8428 * If getredirection() processes an argument, it is erased
8429 * from the vector. getredirection() returns a new argc and argv value.
8430 * In the event that a background command is requested (by a trailing "&"),
8431 * this routine creates a background subprocess, and simply exits the program.
8432 *
8433 * Warning: do not try to simplify the code for vms. The code
8434 * presupposes that getredirection() is called before any data is
8435 * read from stdin or written to stdout.
8436 *
8437 * Normal usage is as follows:
8438 *
8439 * main(argc, argv)
8440 * int argc;
8441 * char *argv[];
8442 * {
8443 * getredirection(&argc, &argv);
8444 * }
8445 */
8446{
8447 int argc = *ac; /* Argument Count */
8448 char **argv = *av; /* Argument Vector */
8449 char *ap; /* Argument pointer */
8450 int j; /* argv[] index */
8451 int item_count = 0; /* Count of Items in List */
8452 struct list_item *list_head = 0; /* First Item in List */
8453 struct list_item *list_tail; /* Last Item in List */
8454 char *in = NULL; /* Input File Name */
8455 char *out = NULL; /* Output File Name */
8456 char *outmode = "w"; /* Mode to Open Output File */
8457 char *err = NULL; /* Error File Name */
8458 char *errmode = "w"; /* Mode to Open Error File */
8459 int cmargc = 0; /* Piped Command Arg Count */
8460 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 8461
8462 /*
8463 * First handle the case where the last thing on the line ends with
8464 * a '&'. This indicates the desire for the command to be run in a
8465 * subprocess, so we satisfy that desire.
8466 */
8467 ap = argv[argc-1];
8468 if (0 == strcmp("&", ap))
8c3eed29 8469 exit(background_process(aTHX_ --argc, argv));
e518068a 8470 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 8471 {
8472 ap[strlen(ap)-1] = '\0';
8c3eed29 8473 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 8474 }
8475 /*
8476 * Now we handle the general redirection cases that involve '>', '>>',
8477 * '<', and pipes '|'.
8478 */
8479 for (j = 0; j < argc; ++j)
8480 {
8481 if (0 == strcmp("<", argv[j]))
8482 {
8483 if (j+1 >= argc)
8484 {
fd71b04b 8485 fprintf(stderr,"No input file after < on command line");
748a9306 8486 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8487 }
8488 in = argv[++j];
8489 continue;
8490 }
8491 if ('<' == *(ap = argv[j]))
8492 {
8493 in = 1 + ap;
8494 continue;
8495 }
8496 if (0 == strcmp(">", ap))
8497 {
8498 if (j+1 >= argc)
8499 {
fd71b04b 8500 fprintf(stderr,"No output file after > on command line");
748a9306 8501 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8502 }
8503 out = argv[++j];
8504 continue;
8505 }
8506 if ('>' == *ap)
8507 {
8508 if ('>' == ap[1])
8509 {
8510 outmode = "a";
8511 if ('\0' == ap[2])
8512 out = argv[++j];
8513 else
8514 out = 2 + ap;
8515 }
8516 else
8517 out = 1 + ap;
8518 if (j >= argc)
8519 {
fd71b04b 8520 fprintf(stderr,"No output file after > or >> on command line");
748a9306 8521 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8522 }
8523 continue;
8524 }
8525 if (('2' == *ap) && ('>' == ap[1]))
8526 {
8527 if ('>' == ap[2])
8528 {
8529 errmode = "a";
8530 if ('\0' == ap[3])
8531 err = argv[++j];
8532 else
8533 err = 3 + ap;
8534 }
8535 else
8536 if ('\0' == ap[2])
8537 err = argv[++j];
8538 else
748a9306 8539 err = 2 + ap;
a0d0e21e
LW		 8540 if (j >= argc)
8541 {
fd71b04b 8542 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 8543 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8544 }
8545 continue;
8546 }
8547 if (0 == strcmp("|", argv[j]))
8548 {
8549 if (j+1 >= argc)
8550 {
fd71b04b 8551 fprintf(stderr,"No command into which to pipe on command line");
748a9306 8552 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8553 }
8554 cmargc = argc-(j+1);
8555 cmargv = &argv[j+1];
8556 argc = j;
8557 continue;
8558 }
8559 if ('|' == *(ap = argv[j]))
8560 {
8561 ++argv[j];
8562 cmargc = argc-j;
8563 cmargv = &argv[j];
8564 argc = j;
8565 continue;
8566 }
8567 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8568 }
8569 /*
8570 * Allocate and fill in the new argument vector, Some Unix's terminate
8571 * the list with an extra null pointer.
8572 */
e0ef6b43 8573 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 8574 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8575 *av = argv;
8576 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8577 argv[j] = list_head->value;
8578 *ac = item_count;
8579 if (cmargv != NULL)
8580 {
8581 if (out != NULL)
8582 {
fd71b04b 8583 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 8584 exit(LIB$_INVARGORD);
a0d0e21e 8585 }
fd8cd3a3 8586 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 8587 }
8588
8589 /* Check for input from a pipe (mailbox) */
8590
a5f75d66 8591 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 8592 {
8593 char mbxname[L_tmpnam];
8594 long int bufsize;
8595 long int dvi_item = DVI$_DEVBUFSIZ;
8596 $DESCRIPTOR(mbxnam, "");
8597 $DESCRIPTOR(mbxdevnam, "");
8598
8599 /* Input from a pipe, reopen it in binary mode to disable */
8600 /* carriage control processing. */
8601
fd71b04b 8602 fgetname(stdin, mbxname);
a0d0e21e
LW		 8603 mbxnam.dsc$a_pointer = mbxname;
8604 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8605 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8606 mbxdevnam.dsc$a_pointer = mbxname;
8607 mbxdevnam.dsc$w_length = sizeof(mbxname);
8608 dvi_item = DVI$_DEVNAM;
8609 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8610 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 8611 set_errno(0);
8612 set_vaxc_errno(1);
a0d0e21e
LW		 8613 freopen(mbxname, "rb", stdin);
8614 if (errno != 0)
8615 {
fd71b04b 8616 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 8617 exit(vaxc$errno);
a0d0e21e
LW		 8618 }
8619 }
8620 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8621 {
fd71b04b 8622 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 8623 exit(vaxc$errno);
a0d0e21e
LW		 8624 }
8625 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8626 {
fd71b04b 8627 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 8628 exit(vaxc$errno);
a0d0e21e 8629 }
fd8cd3a3 8630 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
0e06870b 8631
748a9306 8632 if (err != NULL) {
71d7ec5d 8633 if (strcmp(err,"&1") == 0) {
a15cef0c 8634 dup2(fileno(stdout), fileno(stderr));
fd8cd3a3 8635 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
71d7ec5d 8636 } else {
748a9306
LW		 8637 FILE *tmperr;
8638 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8639 {
fd71b04b 8640 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 8641 exit(vaxc$errno);
8642 }
8643 fclose(tmperr);
a15cef0c 8644 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 8645 {
8646 exit(vaxc$errno);
8647 }
fd8cd3a3 8648 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
a0d0e21e 8649 }
71d7ec5d 8650 }
a0d0e21e 8651#ifdef ARGPROC_DEBUG
740ce14c 8652 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 8653 for (j = 0; j < *ac; ++j)
740ce14c 8654 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 8655#endif
b7ae7a0d 8656 /* Clear errors we may have hit expanding wildcards, so they don't
8657 show up in Perl's $! later */
8658 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 8659} /* end of getredirection() */
8660/*}}}*/
8661
8662static void add_item(struct list_item **head,
8663 struct list_item **tail,
8664 char *value,
8665 int *count)
8666{
8667 if (*head == 0)
8668 {
e0ef6b43 8669 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 8670 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8671 *tail = *head;
8672 }
8673 else {
e0ef6b43 8674 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 8675 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8676 *tail = (*tail)->next;
8677 }
8678 (*tail)->value = value;
8679 ++(*count);
8680}
8681
4b19af01 8682static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 8683 struct list_item **head,
8684 struct list_item **tail,
8685 int *count)
8686{
8687int expcount = 0;
748a9306 8688unsigned long int context = 0;
a0d0e21e 8689int isunix = 0;
773da73d 8690int item_len = 0;
a0d0e21e
LW		 8691char *had_version;
8692char *had_device;
8693int had_directory;
f675dbe5 8694char *devdir,*cp;
a480973c 8695char *vmsspec;
a0d0e21e 8696$DESCRIPTOR(filespec, "");
748a9306 8697$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 8698$DESCRIPTOR(resultspec, "");
a480973c
JM		 8699unsigned long int lff_flags = 0;
8700int sts;
dca5a913 8701int rms_sts;
a480973c
JM		 8702
8703#ifdef VMS_LONGNAME_SUPPORT
8704 lff_flags = LIB$M_FIL_LONG_NAMES;
8705#endif
a0d0e21e 8706
f675dbe5
CB		 8707 for (cp = item; *cp; cp++) {
8708 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8709 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8710 }
8711 if (!*cp || isspace(*cp))
a0d0e21e
LW		 8712 {
8713 add_item(head, tail, item, count);
8714 return;
8715 }
773da73d
JH		 8716 else
8717 {
8718 /* "double quoted" wild card expressions pass as is */
8719 /* From DCL that means using e.g.: */
8720 /* perl program """perl.*""" */
8721 item_len = strlen(item);
8722 if ( '"' == *item && '"' == item[item_len-1] )
8723 {
8724 item++;
8725 item[item_len-2] = '\0';
8726 add_item(head, tail, item, count);
8727 return;
8728 }
8729 }
a0d0e21e
LW		 8730 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8731 resultspec.dsc$b_class = DSC$K_CLASS_D;
8732 resultspec.dsc$a_pointer = NULL;
c5375c28
JM		 8733 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8734 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 8735 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
360732b5 8736 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
a0d0e21e
LW		 8737 if (!isunix || !filespec.dsc$a_pointer)
8738 filespec.dsc$a_pointer = item;
8739 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8740 /*
8741 * Only return version specs, if the caller specified a version
8742 */
8743 had_version = strchr(item, ';');
8744 /*
8745 * Only return device and directory specs, if the caller specifed either.
8746 */
8747 had_device = strchr(item, ':');
8748 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8749
a480973c
JM		 8750 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8751 (&filespec, &resultspec, &context,
dca5a913 8752 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 8753 {
8754 char *string;
8755 char *c;
8756
c5375c28
JM		 8757 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8758 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 8759 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8760 string[resultspec.dsc$w_length] = '\0';
8761 if (NULL == had_version)
f7ddb74a 8762 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 8763 if ((!had_directory) && (had_device == NULL))
8764 {
8765 if (NULL == (devdir = strrchr(string, ']')))
8766 devdir = strrchr(string, '>');
8767 strcpy(string, devdir + 1);
8768 }
8769 /*
8770 * Be consistent with what the C RTL has already done to the rest of
8771 * the argv items and lowercase all of these names.
8772 */
f7ddb74a
JM		 8773 if (!decc_efs_case_preserve) {
8774 for (c = string; *c; ++c)
a0d0e21e
LW		 8775 if (isupper(*c))
8776 *c = tolower(*c);
f7ddb74a 8777 }
f86702cc 8778 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 8779 add_item(head, tail, string, count);
8780 ++expcount;
a480973c 8781 }
367e4b85 8782 PerlMem_free(vmsspec);
c07a80fd 8783 if (sts != RMS$_NMF)
8784 {
8785 set_vaxc_errno(sts);
8786 switch (sts)
8787 {
f282b18d 8788 case RMS$_FNF: case RMS$_DNF:
c07a80fd 8789 set_errno(ENOENT); break;
f282b18d
CB		 8790 case RMS$_DIR:
8791 set_errno(ENOTDIR); break;
c07a80fd 8792 case RMS$_DEV:
8793 set_errno(ENODEV); break;
f282b18d 8794 case RMS$_FNM: case RMS$_SYN:
c07a80fd 8795 set_errno(EINVAL); break;
8796 case RMS$_PRV:
8797 set_errno(EACCES); break;
8798 default:
b7ae7a0d 8799 _ckvmssts_noperl(sts);
c07a80fd 8800 }
8801 }
a0d0e21e
LW		 8802 if (expcount == 0)
8803 add_item(head, tail, item, count);
b7ae7a0d 8804 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8805 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 8806}
8807
8808static int child_st[2];/* Event Flag set when child process completes */
8809
748a9306 8810static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 8811
748a9306 8812static unsigned long int exit_handler(int *status)
a0d0e21e
LW		 8813{
8814short iosb[4];
8815
8816 if (0 == child_st[0])
8817 {
8818#ifdef ARGPROC_DEBUG
740ce14c 8819 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 8820#endif
8821 fflush(stdout); /* Have to flush pipe for binary data to */
8822 /* terminate properly -- <tp@mccall.com> */
8823 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8824 sys$dassgn(child_chan);
8825 fclose(stdout);
8826 sys$synch(0, child_st);
8827 }
8828 return(1);
8829}
8830
8831static void sig_child(int chan)
8832{
8833#ifdef ARGPROC_DEBUG
740ce14c 8834 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 8835#endif
8836 if (child_st[0] == 0)
8837 child_st[0] = 1;
8838}
8839
748a9306 8840static struct exit_control_block exit_block =
a0d0e21e
LW		 8841 {
8842 0,
8843 exit_handler,
8844 1,
8845 &exit_block.exit_status,
8846 0
8847 };
8848
ff7adb52
CL		 8849static void
8850pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 8851{
ff7adb52 8852 PerlIO *fp;
218fdd94 8853 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 8854 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8855 int sts, j, l, ismcr, quote, tquote = 0;
8856
218fdd94
CL		 8857 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8858 vms_execfree(vmscmd);
ff7adb52
CL		 8859
8860 j = l = 0;
8861 p = subcmd;
8862 q = cmargv[0];
8863 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8864 && toupper(*(q+2)) == 'R' && !*(q+3);
8865
8866 while (q && l < MAX_DCL_LINE_LENGTH) {
8867 if (!*q) {
8868 if (j > 0 && quote) {
8869 *p++ = '"';
8870 l++;
8871 }
8872 q = cmargv[++j];
8873 if (q) {
8874 if (ismcr && j > 1) quote = 1;
8875 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8876 *p++ = ' ';
8877 l++;
8878 if (quote || tquote) {
8879 *p++ = '"';
8880 l++;
8881 }
988c775c 8882 }
ff7adb52
CL		 8883 } else {
8884 if ((quote||tquote) && *q == '"') {
8885 *p++ = '"';
8886 l++;
988c775c 8887 }
ff7adb52
CL		 8888 *p++ = *q++;
8889 l++;
8890 }
8891 }
8892 *p = '\0';
a0d0e21e 8893
218fdd94 8894 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
ff7adb52
CL		 8895 if (fp == Nullfp) {
8896 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 8897 }
a0d0e21e
LW		 8898}
8899
8df869cb 8900static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 8901{
a480973c 8902char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 8903$DESCRIPTOR(value, "");
8904static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8905static $DESCRIPTOR(null, "NLA0:");
8906static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8907char pidstring[80];
8908$DESCRIPTOR(pidstr, "");
8909int pid;
748a9306 8910unsigned long int flags = 17, one = 1, retsts;
a480973c 8911int len;
a0d0e21e
LW		 8912
8913 strcat(command, argv[0]);
a480973c
JM		 8914 len = strlen(command);
8915 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e
LW		 8916 {
8917 strcat(command, " \"");
8918 strcat(command, *(++argv));
8919 strcat(command, "\"");
a480973c 8920 len = strlen(command);
a0d0e21e
LW		 8921 }
8922 value.dsc$a_pointer = command;
8923 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 8924 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 8925 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8926 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 8927 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 8928 }
8929 else {
b7ae7a0d 8930 _ckvmssts_noperl(retsts);
748a9306 8931 }
a0d0e21e 8932#ifdef ARGPROC_DEBUG
740ce14c 8933 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 8934#endif
8935 sprintf(pidstring, "%08X", pid);
740ce14c 8936 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 8937 pidstr.dsc$a_pointer = pidstring;
8938 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8939 lib$set_symbol(&pidsymbol, &pidstr);
8940 return(SS$_NORMAL);
8941}
8942/*}}}*/
8943/***** End of code taken from Mark Pizzolato's argproc.c package *****/
8944
84902520
TB		 8945
8946/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 8947/* Older VAXC header files lack these constants */
8948#ifndef JPI$_RIGHTS_SIZE
8949# define JPI$_RIGHTS_SIZE 817
8950#endif
8951#ifndef KGB$M_SUBSYSTEM
8952# define KGB$M_SUBSYSTEM 0x8
8953#endif
a480973c 8954
e0ef6b43
CB		 8955/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8956
84902520
TB		 8957/*{{{void vms_image_init(int *, char ***)*/
8958void
8959vms_image_init(int *argcp, char ***argvp)
8960{
f675dbe5
CB		 8961 char eqv[LNM$C_NAMLENGTH+1] = "";
8962 unsigned int len, tabct = 8, tabidx = 0;
8963 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 8964 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8965 unsigned short int dummy, rlen;
f675dbe5 8966 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 8967#if defined(PERL_IMPLICIT_CONTEXT)
8968 pTHX = NULL;
8969#endif
61bb5906
CB		 8970 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8971 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8972 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8973 { 0, 0, 0, 0} };
84902520 8974
2e34cc90 8975#ifdef KILL_BY_SIGPRC
f7ddb74a 8976 Perl_csighandler_init();
2e34cc90
CL		 8977#endif
8978
fd8cd3a3
DS		 8979 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8980 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 8981 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8982 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 8983 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 8984 will_taint = TRUE;
84902520
TB		 8985 break;
8986 }
8987 }
61bb5906 8988 /* Rights identifiers might trigger tainting as well. */
f675dbe5 8989 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 8990 while (rlen < rsz) {
8991 /* We didn't get all the identifiers on the first pass. Allocate a
8992 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8993 * were needed to hold all identifiers at time of last call; we'll
8994 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 8995 * If it gave us less than it wanted to despite ample buffer space,
8996 * something's broken. Is your system missing a system identifier?
61bb5906 8997 */
22d4bb9c
CB		 8998 if (rsz <= jpilist[1].buflen) {
8999 /* Perl_croak accvios when used this early in startup. */
9000 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9001 rsz, (unsigned long) jpilist[1].buflen,
9002 "Check your rights database for corruption.\n");
9003 exit(SS$_ABORT);
9004 }
e0ef6b43
CB		 9005 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9006 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9007 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9008 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9009 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9010 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9011 }
9012 mask = jpilist[1].bufadr;
9013 /* Check attribute flags for each identifier (2nd longword); protected
9014 * subsystem identifiers trigger tainting.
9015 */
9016 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9017 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9018 will_taint = TRUE;
61bb5906
CB		 9019 break;
9020 }
9021 }
367e4b85 9022 if (mask != rlst) PerlMem_free(mask);
61bb5906 9023 }
f7ddb74a
JM		 9024
9025 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9026 * logical, some versions of the CRTL will add a phanthom /000000/
9027 * directory. This needs to be removed.
9028 */
9029 if (decc_filename_unix_report) {
9030 char * zeros;
9031 int ulen;
9032 ulen = strlen(argvp[0][0]);
9033 if (ulen > 7) {
9034 zeros = strstr(argvp[0][0], "/000000/");
9035 if (zeros != NULL) {
9036 int mlen;
9037 mlen = ulen - (zeros - argvp[0][0]) - 7;
9038 memmove(zeros, &zeros[7], mlen);
9039 ulen = ulen - 7;
9040 argvp[0][0][ulen] = '\0';
9041 }
9042 }
9043 /* It also may have a trailing dot that needs to be removed otherwise
9044 * it will be converted to VMS mode incorrectly.
9045 */
9046 ulen--;
9047 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9048 argvp[0][0][ulen] = '\0';
9049 }
9050
61bb5906 9051 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9052 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9053 * hasn't been allocated when vms_image_init() is called.
9054 */
f675dbe5 9055 if (will_taint) {
ec618cdf
CB		 9056 char **newargv, **oldargv;
9057 oldargv = *argvp;
e0ef6b43 9058 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9059 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9060 newargv[0] = oldargv[0];
c5375c28
JM		 9061 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9062 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9063 strcpy(newargv[1], "-T");
9064 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9065 (*argcp)++;
9066 newargv[*argcp] = NULL;
61bb5906
CB		 9067 /* We orphan the old argv, since we don't know where it's come from,
9068 * so we don't know how to free it.
9069 */
ec618cdf 9070 *argvp = newargv;
61bb5906 9071 }
f675dbe5
CB		 9072 else { /* Did user explicitly request tainting? */
9073 int i;
9074 char *cp, **av = *argvp;
9075 for (i = 1; i < *argcp; i++) {
9076 if (*av[i] != '-') break;
9077 for (cp = av[i]+1; *cp; cp++) {
9078 if (*cp == 'T') { will_taint = 1; break; }
9079 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9080 strchr("DFIiMmx",*cp)) break;
9081 }
9082 if (will_taint) break;
9083 }
9084 }
9085
9086 for (tabidx = 0;
9087 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9088 tabidx++) {
c5375c28
JM		 9089 if (!tabidx) {
9090 tabvec = (struct dsc$descriptor_s **)
9091 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9092 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9093 }
f675dbe5
CB		 9094 else if (tabidx >= tabct) {
9095 tabct += 8;
e0ef6b43 9096 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9097 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9098 }
e0ef6b43 9099 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9100 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5
CB		 9101 tabvec[tabidx]->dsc$w_length = 0;
9102 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9103 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9104 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 9105 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 9106 }
9107 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9108
84902520 9109 getredirection(argcp,argvp);
3bc25146
CB		 9110#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9111 {
9112# include <reentrancy.h>
f7ddb74a 9113 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9114 }
9115#endif
84902520
TB		 9116 return;
9117}
9118/*}}}*/
9119
9120
a0d0e21e
LW		 9121/* trim_unixpath()
9122 * Trim Unix-style prefix off filespec, so it looks like what a shell
9123 * glob expansion would return (i.e. from specified prefix on, not
9124 * full path). Note that returned filespec is Unix-style, regardless
9125 * of whether input filespec was VMS-style or Unix-style.
9126 *
a3e9d8c9 9127 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9128 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9129 * vector of options; at present, only bit 0 is used, and if set tells
9130 * trim unixpath to try the current default directory as a prefix when
9131 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9132 *
9133 * Returns !=0 on success, with trimmed filespec replacing contents of
9134 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9135 */
f86702cc 9136/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9137int
2fbb330f 9138Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9139{
a480973c 9140 char *unixified, *unixwild,
f86702cc 9141 *template, *base, *end, *cp1, *cp2;
9142 register int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9143
c5375c28
JM		 9144 unixwild = PerlMem_malloc(VMS_MAXRSS);
9145 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
a3e9d8c9 9146 if (!wildspec || !fspec) return 0;
2fbb330f 9147 template = unixwild;
a3e9d8c9 9148 if (strpbrk(wildspec,"]>:") != NULL) {
360732b5 9149 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
367e4b85 9150 PerlMem_free(unixwild);
a480973c
JM		 9151 return 0;
9152 }
a3e9d8c9 9153 }
2fbb330f 9154 else {
a480973c
JM		 9155 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9156 unixwild[VMS_MAXRSS-1] = 0;
2fbb330f 9157 }
c5375c28
JM		 9158 unixified = PerlMem_malloc(VMS_MAXRSS);
9159 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
a0d0e21e 9160 if (strpbrk(fspec,"]>:") != NULL) {
360732b5 9161 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
367e4b85
JM		 9162 PerlMem_free(unixwild);
9163 PerlMem_free(unixified);
a480973c
JM		 9164 return 0;
9165 }
a0d0e21e 9166 else base = unixified;
a3e9d8c9 9167 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9168 * check to see that final result fits into (isn't longer than) fspec */
9169 reslen = strlen(fspec);
a0d0e21e
LW		 9170 }
9171 else base = fspec;
a3e9d8c9 9172
9173 /* No prefix or absolute path on wildcard, so nothing to remove */
9174 if (!*template || *template == '/') {
367e4b85 9175 PerlMem_free(unixwild);
a480973c 9176 if (base == fspec) {
367e4b85 9177 PerlMem_free(unixified);
a480973c
JM		 9178 return 1;
9179 }
a3e9d8c9 9180 tmplen = strlen(unixified);
a480973c 9181 if (tmplen > reslen) {
367e4b85 9182 PerlMem_free(unixified);
a480973c
JM		 9183 return 0; /* not enough space */
9184 }
a3e9d8c9 9185 /* Copy unixified resultant, including trailing NUL */
9186 memmove(fspec,unixified,tmplen+1);
367e4b85 9187 PerlMem_free(unixified);
a3e9d8c9 9188 return 1;
9189 }
a0d0e21e 9190
f86702cc 9191 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9192 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9193 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9194 for (cp1 = end ;cp1 >= base; cp1--)
9195 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9196 { cp1++; break; }
9197 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9198 PerlMem_free(unixified);
9199 PerlMem_free(unixwild);
a3e9d8c9 9200 return 1;
9201 }
f86702cc 9202 else {
a480973c 9203 char *tpl, *lcres;
f86702cc 9204 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9205 int ells = 1, totells, segdirs, match;
a480973c 9206 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9207 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9208
9209 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9210 totells = ells;
9211 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
367e4b85 9212 tpl = PerlMem_malloc(VMS_MAXRSS);
c5375c28 9213 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
f86702cc 9214 if (ellipsis == template && opts & 1) {
9215 /* Template begins with an ellipsis. Since we can't tell how many
9216 * directory names at the front of the resultant to keep for an
9217 * arbitrary starting point, we arbitrarily choose the current
9218 * default directory as a starting point. If it's there as a prefix,
9219 * clip it off. If not, fall through and act as if the leading
9220 * ellipsis weren't there (i.e. return shortest possible path that
9221 * could match template).
9222 */
a480973c 9223 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9224 PerlMem_free(tpl);
9225 PerlMem_free(unixified);
9226 PerlMem_free(unixwild);
a480973c
JM		 9227 return 0;
9228 }
f7ddb74a
JM		 9229 if (!decc_efs_case_preserve) {
9230 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9231 if (_tolower(*cp1) != _tolower(*cp2)) break;
9232 }
f86702cc 9233 segdirs = dirs - totells; /* Min # of dirs we must have left */
9234 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9235 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9236 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9237 PerlMem_free(tpl);
9238 PerlMem_free(unixified);
9239 PerlMem_free(unixwild);
f86702cc 9240 return 1;
a3e9d8c9 9241 }
a3e9d8c9 9242 }
f86702cc 9243 /* First off, back up over constant elements at end of path */
9244 if (dirs) {
9245 for (front = end ; front >= base; front--)
9246 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9247 }
c5375c28
JM		 9248 lcres = PerlMem_malloc(VMS_MAXRSS);
9249 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 9250 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9251 cp1++,cp2++) {
9252 if (!decc_efs_case_preserve) {
9253 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9254 }
9255 else {
9256 *cp2 = *cp1;
9257 }
9258 }
9259 if (cp1 != '\0') {
367e4b85
JM		 9260 PerlMem_free(tpl);
9261 PerlMem_free(unixified);
9262 PerlMem_free(unixwild);
c5375c28 9263 PerlMem_free(lcres);
a480973c 9264 return 0; /* Path too long. */
f7ddb74a 9265 }
f86702cc 9266 lcend = cp2;
9267 *cp2 = '\0'; /* Pick up with memcpy later */
9268 lcfront = lcres + (front - base);
9269 /* Now skip over each ellipsis and try to match the path in front of it. */
9270 while (ells--) {
9271 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9272 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9273 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9274 if (cp1 < template) break; /* template started with an ellipsis */
9275 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9276 ellipsis = cp1; continue;
9277 }
a480973c 9278 wilddsc.dsc$a_pointer = tpl;
f86702cc 9279 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9280 nextell = cp1;
9281 for (segdirs = 0, cp2 = tpl;
a480973c 9282 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9283 cp1++, cp2++) {
9284 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9285 else {
9286 if (!decc_efs_case_preserve) {
9287 *cp2 = _tolower(*cp1); /* else lowercase for match */
9288 }
9289 else {
9290 *cp2 = *cp1; /* else preserve case for match */
9291 }
9292 }
f86702cc 9293 if (*cp2 == '/') segdirs++;
9294 }
a480973c 9295 if (cp1 != ellipsis - 1) {
367e4b85
JM		 9296 PerlMem_free(tpl);
9297 PerlMem_free(unixified);
9298 PerlMem_free(unixwild);
9299 PerlMem_free(lcres);
a480973c
JM		 9300 return 0; /* Path too long */
9301 }
f86702cc 9302 /* Back up at least as many dirs as in template before matching */
9303 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9304 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9305 for (match = 0; cp1 > lcres;) {
9306 resdsc.dsc$a_pointer = cp1;
9307 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9308 match++;
9309 if (match == 1) lcfront = cp1;
9310 }
9311 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9312 }
a480973c 9313 if (!match) {
367e4b85
JM		 9314 PerlMem_free(tpl);
9315 PerlMem_free(unixified);
9316 PerlMem_free(unixwild);
9317 PerlMem_free(lcres);
a480973c
JM		 9318 return 0; /* Can't find prefix ??? */
9319 }
f86702cc 9320 if (match > 1 && opts & 1) {
9321 /* This ... wildcard could cover more than one set of dirs (i.e.
9322 * a set of similar dir names is repeated). If the template
9323 * contains more than 1 ..., upstream elements could resolve the
9324 * ambiguity, but it's not worth a full backtracking setup here.
9325 * As a quick heuristic, clip off the current default directory
9326 * if it's present to find the trimmed spec, else use the
9327 * shortest string that this ... could cover.
9328 */
9329 char def[NAM$C_MAXRSS+1], *st;
9330
a480973c
JM		 9331 if (getcwd(def, sizeof def,0) == NULL) {
9332 Safefree(unixified);
9333 Safefree(unixwild);
9334 Safefree(lcres);
9335 Safefree(tpl);
9336 return 0;
9337 }
f7ddb74a
JM		 9338 if (!decc_efs_case_preserve) {
9339 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9340 if (_tolower(*cp1) != _tolower(*cp2)) break;
9341 }
f86702cc 9342 segdirs = dirs - totells; /* Min # of dirs we must have left */
9343 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9344 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 9345 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9346 PerlMem_free(tpl);
9347 PerlMem_free(unixified);
9348 PerlMem_free(unixwild);
9349 PerlMem_free(lcres);
f86702cc 9350 return 1;
9351 }
9352 /* Nope -- stick with lcfront from above and keep going. */
9353 }
9354 }
18a3d61e 9355 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 9356 PerlMem_free(tpl);
9357 PerlMem_free(unixified);
9358 PerlMem_free(unixwild);
9359 PerlMem_free(lcres);
a3e9d8c9 9360 return 1;
f86702cc 9361 ellipsis = nextell;
a0d0e21e 9362 }
a0d0e21e
LW		 9363
9364} /* end of trim_unixpath() */
9365/*}}}*/
9366
a0d0e21e
LW		 9367
9368/*
9369 * VMS readdir() routines.
9370 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 9371 *
bd3fa61c 9372 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 9373 * Minor modifications to original routines.
9374 */
9375
a9852f7c
CB		 9376/* readdir may have been redefined by reentr.h, so make sure we get
9377 * the local version for what we do here.
9378 */
9379#ifdef readdir
9380# undef readdir
9381#endif
9382#if !defined(PERL_IMPLICIT_CONTEXT)
9383# define readdir Perl_readdir
9384#else
9385# define readdir(a) Perl_readdir(aTHX_ a)
9386#endif
9387
a0d0e21e
LW		 9388 /* Number of elements in vms_versions array */
9389#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9390
9391/*
9392 * Open a directory, return a handle for later use.
9393 */
9394/*{{{ DIR *opendir(char*name) */
ddcbaa1c 9395DIR *
b8ffc8df 9396Perl_opendir(pTHX_ const char *name)
a0d0e21e 9397{
ddcbaa1c 9398 DIR *dd;
657054d4 9399 char *dir;
61bb5906 9400 Stat_t sb;
657054d4
JM		 9401
9402 Newx(dir, VMS_MAXRSS, char);
360732b5 9403 if (do_tovmspath(name,dir,0,NULL) == NULL) {
657054d4 9404 Safefree(dir);
61bb5906 9405 return NULL;
a0d0e21e 9406 }
ada67d10
CB		 9407 /* Check access before stat; otherwise stat does not
9408 * accurately report whether it's a directory.
9409 */
a1887106 9410 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 9411 /* cando_by_name has already set errno */
657054d4 9412 Safefree(dir);
ada67d10
CB		 9413 return NULL;
9414 }
61bb5906
CB		 9415 if (flex_stat(dir,&sb) == -1) return NULL;
9416 if (!S_ISDIR(sb.st_mode)) {
657054d4 9417 Safefree(dir);
61bb5906
CB		 9418 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9419 return NULL;
9420 }
61bb5906 9421 /* Get memory for the handle, and the pattern. */
ddcbaa1c 9422 Newx(dd,1,DIR);
a02a5408 9423 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 9424
9425 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 9426 sprintf(dd->pattern, "%s*.*",dir);
657054d4 9427 Safefree(dir);
a0d0e21e
LW		 9428 dd->context = 0;
9429 dd->count = 0;
657054d4 9430 dd->flags = 0;
a096370a
CB		 9431 /* By saying we always want the result of readdir() in unix format, we
9432 * are really saying we want all the escapes removed. Otherwise the caller,
9433 * having no way to know whether it's already in VMS format, might send it
9434 * through tovmsspec again, thus double escaping.
9435 */
9436 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
a0d0e21e
LW		 9437 dd->pat.dsc$a_pointer = dd->pattern;
9438 dd->pat.dsc$w_length = strlen(dd->pattern);
9439 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9440 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 9441#if defined(USE_ITHREADS)
a02a5408 9442 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 9443 MUTEX_INIT( (perl_mutex *) dd->mutex );
9444#else
9445 dd->mutex = NULL;
9446#endif
a0d0e21e
LW		 9447
9448 return dd;
9449} /* end of opendir() */
9450/*}}}*/
9451
9452/*
9453 * Set the flag to indicate we want versions or not.
9454 */
9455/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9456void
ddcbaa1c 9457vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 9458{
657054d4
JM		 9459 if (flag)
9460 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9461 else
9462 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 9463}
9464/*}}}*/
9465
9466/*
9467 * Free up an opened directory.
9468 */
9469/*{{{ void closedir(DIR *dd)*/
9470void
ddcbaa1c 9471Perl_closedir(DIR *dd)
a0d0e21e 9472{
f7ddb74a
JM		 9473 int sts;
9474
9475 sts = lib$find_file_end(&dd->context);
a0d0e21e 9476 Safefree(dd->pattern);
3bc25146 9477#if defined(USE_ITHREADS)
a9852f7c
CB		 9478 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9479 Safefree(dd->mutex);
9480#endif
f7ddb74a 9481 Safefree(dd);
a0d0e21e
LW		 9482}
9483/*}}}*/
9484
9485/*
9486 * Collect all the version numbers for the current file.
9487 */
9488static void
ddcbaa1c 9489collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 9490{
9491 struct dsc$descriptor_s pat;
9492 struct dsc$descriptor_s res;
ddcbaa1c 9493 struct dirent *e;
657054d4 9494 char *p, *text, *buff;
a0d0e21e
LW		 9495 int i;
9496 unsigned long context, tmpsts;
9497
9498 /* Convenient shorthand. */
9499 e = &dd->entry;
9500
9501 /* Add the version wildcard, ignoring the "*.*" put on before */
9502 i = strlen(dd->pattern);
a02a5408 9503 Newx(text,i + e->d_namlen + 3,char);
f7ddb74a
JM		 9504 strcpy(text, dd->pattern);
9505 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 9506
9507 /* Set up the pattern descriptor. */
9508 pat.dsc$a_pointer = text;
9509 pat.dsc$w_length = i + e->d_namlen - 1;
9510 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9511 pat.dsc$b_class = DSC$K_CLASS_S;
9512
9513 /* Set up result descriptor. */
657054d4 9514 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 9515 res.dsc$a_pointer = buff;
657054d4 9516 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 9517 res.dsc$b_dtype = DSC$K_DTYPE_T;
9518 res.dsc$b_class = DSC$K_CLASS_S;
9519
9520 /* Read files, collecting versions. */
9521 for (context = 0, e->vms_verscount = 0;
9522 e->vms_verscount < VERSIZE(e);
9523 e->vms_verscount++) {
657054d4
JM		 9524 unsigned long rsts;
9525 unsigned long flags = 0;
9526
9527#ifdef VMS_LONGNAME_SUPPORT
988c775c 9528 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 9529#endif
9530 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 9531 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 9532 _ckvmssts(tmpsts);
657054d4 9533 buff[VMS_MAXRSS - 1] = '\0';
748a9306 9534 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 9535 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9536 else
9537 e->vms_versions[e->vms_verscount] = -1;
9538 }
9539
748a9306 9540 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 9541 Safefree(text);
657054d4 9542 Safefree(buff);
a0d0e21e
LW		 9543
9544} /* end of collectversions() */
9545
9546/*
9547 * Read the next entry from the directory.
9548 */
9549/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 9550struct dirent *
9551Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 9552{
9553 struct dsc$descriptor_s res;
657054d4 9554 char *p, *buff;
a0d0e21e 9555 unsigned long int tmpsts;
657054d4
JM		 9556 unsigned long rsts;
9557 unsigned long flags = 0;
dca5a913 9558 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 9559 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 9560
9561 /* Set up result descriptor, and get next file. */
657054d4 9562 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 9563 res.dsc$a_pointer = buff;
657054d4 9564 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 9565 res.dsc$b_dtype = DSC$K_DTYPE_T;
9566 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 9567
9568#ifdef VMS_LONGNAME_SUPPORT
988c775c 9569 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 9570#endif
9571
9572 tmpsts = lib$find_file
9573 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
4633a7c4
LW		 9574 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9575 if (!(tmpsts & 1)) {
9576 set_vaxc_errno(tmpsts);
9577 switch (tmpsts) {
9578 case RMS$_PRV:
c07a80fd 9579 set_errno(EACCES); break;
4633a7c4 9580 case RMS$_DEV:
c07a80fd 9581 set_errno(ENODEV); break;
4633a7c4 9582 case RMS$_DIR:
f282b18d
CB		 9583 set_errno(ENOTDIR); break;
9584 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9585 set_errno(ENOENT); break;
4633a7c4
LW		 9586 default:
9587 set_errno(EVMSERR);
9588 }
657054d4 9589 Safefree(buff);
4633a7c4
LW		 9590 return NULL;
9591 }
9592 dd->count++;
a0d0e21e 9593 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
f7ddb74a 9594 if (!decc_efs_case_preserve) {
657054d4 9595 buff[VMS_MAXRSS - 1] = '\0';
f7ddb74a 9596 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a
JM		 9597 }
9598 else {
9599 /* we don't want to force to lowercase, just null terminate */
9600 buff[res.dsc$w_length] = '\0';
9601 }
f675dbe5 9602 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
a0d0e21e
LW		 9603 *p = '\0';
9604
9605 /* Skip any directory component and just copy the name. */
657054d4 9606 sts = vms_split_path
360732b5 9607 (buff,
657054d4
JM		 9608 &v_spec,
9609 &v_len,
9610 &r_spec,
9611 &r_len,
9612 &d_spec,
9613 &d_len,
9614 &n_spec,
9615 &n_len,
9616 &e_spec,
9617 &e_len,
9618 &vs_spec,
9619 &vs_len);
9620
dca5a913
JM		 9621 /* Drop NULL extensions on UNIX file specification */
9622 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9623 (e_len == 1) && decc_readdir_dropdotnotype)) {
9624 e_len = 0;
9625 e_spec[0] = '\0';
9626 }
9627
657054d4
JM		 9628 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9629 dd->entry.d_name[n_len + e_len] = '\0';
9630 dd->entry.d_namlen = strlen(dd->entry.d_name);
a0d0e21e 9631
657054d4
JM		 9632 /* Convert the filename to UNIX format if needed */
9633 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9634
9635 /* Translate the encoded characters. */
38a44b82 9636 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 9637 if (strchr(dd->entry.d_name, '^') != NULL) {
9638 char new_name[256];
9639 char * q;
657054d4
JM		 9640 p = dd->entry.d_name;
9641 q = new_name;
9642 while (*p != 0) {
f617045b
CB		 9643 int inchars_read, outchars_added;
9644 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9645 p += inchars_read;
9646 q += outchars_added;
dca5a913 9647 /* fix-me */
f617045b 9648 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 9649 /* Wide file specifications need to be passed in Perl */
38a44b82 9650 /* counted strings apparently with a Unicode flag */
657054d4
JM		 9651 }
9652 *q = 0;
9653 strcpy(dd->entry.d_name, new_name);
f617045b 9654 dd->entry.d_namlen = strlen(dd->entry.d_name);
657054d4 9655 }
657054d4 9656 }
a0d0e21e 9657
a0d0e21e 9658 dd->entry.vms_verscount = 0;
657054d4
JM		 9659 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9660 Safefree(buff);
a0d0e21e
LW		 9661 return &dd->entry;
9662
9663} /* end of readdir() */
9664/*}}}*/
9665
9666/*
a9852f7c
CB		 9667 * Read the next entry from the directory -- thread-safe version.
9668 */
9669/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9670int
ddcbaa1c 9671Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 9672{
9673 int retval;
9674
9675 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9676
7ded3206 9677 entry = readdir(dd);
a9852f7c
CB		 9678 *result = entry;
9679 retval = ( *result == NULL ? errno : 0 );
9680
9681 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9682
9683 return retval;
9684
9685} /* end of readdir_r() */
9686/*}}}*/
9687
9688/*
a0d0e21e
LW		 9689 * Return something that can be used in a seekdir later.
9690 */
9691/*{{{ long telldir(DIR *dd)*/
9692long
ddcbaa1c 9693Perl_telldir(DIR *dd)
a0d0e21e
LW		 9694{
9695 return dd->count;
9696}
9697/*}}}*/
9698
9699/*
9700 * Return to a spot where we used to be. Brute force.
9701 */
9702/*{{{ void seekdir(DIR *dd,long count)*/
9703void
ddcbaa1c 9704Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 9705{
657054d4 9706 int old_flags;
a0d0e21e
LW		 9707
9708 /* If we haven't done anything yet... */
9709 if (dd->count == 0)
9710 return;
9711
9712 /* Remember some state, and clear it. */
657054d4
JM		 9713 old_flags = dd->flags;
9714 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 9715 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 9716 dd->context = 0;
9717
9718 /* The increment is in readdir(). */
9719 for (dd->count = 0; dd->count < count; )
f7ddb74a 9720 readdir(dd);
a0d0e21e 9721
657054d4 9722 dd->flags = old_flags;
a0d0e21e
LW		 9723
9724} /* end of seekdir() */
9725/*}}}*/
9726
9727/* VMS subprocess management
9728 *
9729 * my_vfork() - just a vfork(), after setting a flag to record that
9730 * the current script is trying a Unix-style fork/exec.
9731 *
9732 * vms_do_aexec() and vms_do_exec() are called in response to the
9733 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 9734 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 9735 * execvp (for those who really want to try this under VMS).
9736 * Otherwise, they do exactly what the perl docs say exec should
9737 * do - terminate the current script and invoke a new command
9738 * (See below for notes on command syntax.)
9739 *
9740 * do_aspawn() and do_spawn() implement the VMS side of the perl
9741 * 'system' function.
9742 *
9743 * Note on command arguments to perl 'exec' and 'system': When handled
9744 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 9745 * are concatenated to form a DCL command string. If the first non-numeric
9746 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 9747 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 9748 * the first token of the command is taken as the filespec of an image
9749 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 9750 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 9751 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 9752 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 9753 * but I hope it will form a happy medium between what VMS folks expect
9754 * from lib$spawn and what Unix folks expect from exec.
9755 */
9756
9757static int vfork_called;
9758
9759/*{{{int my_vfork()*/
9760int
9761my_vfork()
9762{
748a9306 9763 vfork_called++;
a0d0e21e
LW		 9764 return vfork();
9765}
9766/*}}}*/
9767
4633a7c4 9768
a0d0e21e 9769static void
218fdd94
CL		 9770vms_execfree(struct dsc$descriptor_s *vmscmd)
9771{
9772 if (vmscmd) {
9773 if (vmscmd->dsc$a_pointer) {
c5375c28 9774 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 9775 }
c5375c28 9776 PerlMem_free(vmscmd);
4633a7c4
LW		 9777 }
9778}
9779
9780static char *
fd8cd3a3 9781setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 9782{
4633a7c4 9783 char *junk, *tmps = Nullch;
a0d0e21e
LW		 9784 register size_t cmdlen = 0;
9785 size_t rlen;
9786 register SV **idx;
2d8e6c8d 9787 STRLEN n_a;
a0d0e21e
LW		 9788
9789 idx = mark;
4633a7c4
LW		 9790 if (really) {
9791 tmps = SvPV(really,rlen);
9792 if (*tmps) {
9793 cmdlen += rlen + 1;
9794 idx++;
9795 }
a0d0e21e
LW		 9796 }
9797
9798 for (idx++; idx <= sp; idx++) {
9799 if (*idx) {
9800 junk = SvPVx(*idx,rlen);
9801 cmdlen += rlen ? rlen + 1 : 0;
9802 }
9803 }
c5375c28 9804 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 9805
4633a7c4 9806 if (tmps && *tmps) {
6b88bc9c 9807 strcpy(PL_Cmd,tmps);
a0d0e21e
LW		 9808 mark++;
9809 }
6b88bc9c 9810 else *PL_Cmd = '\0';
a0d0e21e
LW		 9811 while (++mark <= sp) {
9812 if (*mark) {
3eeba6fb
CB		 9813 char *s = SvPVx(*mark,n_a);
9814 if (!*s) continue;
9815 if (*PL_Cmd) strcat(PL_Cmd," ");
9816 strcat(PL_Cmd,s);
a0d0e21e
LW		 9817 }
9818 }
6b88bc9c 9819 return PL_Cmd;
a0d0e21e
LW		 9820
9821} /* end of setup_argstr() */
9822
4633a7c4 9823
a0d0e21e 9824static unsigned long int
2fbb330f 9825setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 9826 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 9827{
aa779de1 9828 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
e886094b
JM		 9829 char image_name[NAM$C_MAXRSS+1];
9830 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 9831 $DESCRIPTOR(defdsc,".EXE");
8012a33e 9832 $DESCRIPTOR(defdsc2,".");
a0d0e21e 9833 $DESCRIPTOR(resdsc,resspec);
218fdd94 9834 struct dsc$descriptor_s *vmscmd;
a0d0e21e 9835 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 9836 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
aa779de1 9837 register char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 9838 char * cmd;
9839 int cmdlen;
aa779de1 9840 register int isdcl;
a0d0e21e 9841
c5375c28
JM		 9842 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9843 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 9844
9845 /* Make a copy for modification */
9846 cmdlen = strlen(incmd);
c5375c28
JM		 9847 cmd = PerlMem_malloc(cmdlen+1);
9848 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
2fbb330f
JM		 9849 strncpy(cmd, incmd, cmdlen);
9850 cmd[cmdlen] = 0;
e886094b
JM		 9851 image_name[0] = 0;
9852 image_argv[0] = 0;
2fbb330f 9853
218fdd94
CL		 9854 vmscmd->dsc$a_pointer = NULL;
9855 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9856 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9857 vmscmd->dsc$w_length = 0;
9858 if (pvmscmd) *pvmscmd = vmscmd;
9859
ff7adb52
CL		 9860 if (suggest_quote) *suggest_quote = 0;
9861
2fbb330f 9862 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 9863 PerlMem_free(cmd);
a2669cfc 9864 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 9865 }
9866
a0d0e21e 9867 s = cmd;
2fbb330f 9868
a0d0e21e 9869 while (*s && isspace(*s)) s++;
aa779de1
CB		 9870
9871 if (*s == '@' || *s == '$') {
9872 vmsspec[0] = *s; rest = s + 1;
9873 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9874 }
9875 else { cp = vmsspec; rest = s; }
9876 if (*rest == '.' || *rest == '/') {
9877 char *cp2;
9878 for (cp2 = resspec;
9879 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9880 rest++, cp2++) *cp2 = *rest;
9881 *cp2 = '\0';
360732b5 9882 if (do_tovmsspec(resspec,cp,0,NULL)) {
aa779de1
CB		 9883 s = vmsspec;
9884 if (*rest) {
9885 for (cp2 = vmsspec + strlen(vmsspec);
9886 *rest && cp2 - vmsspec < sizeof vmsspec;
9887 rest++, cp2++) *cp2 = *rest;
9888 *cp2 = '\0';
a0d0e21e
LW		 9889 }
9890 }
9891 }
aa779de1
CB		 9892 /* Intuit whether verb (first word of cmd) is a DCL command:
9893 * - if first nonspace char is '@', it's a DCL indirection
9894 * otherwise
9895 * - if verb contains a filespec separator, it's not a DCL command
9896 * - if it doesn't, caller tells us whether to default to a DCL
9897 * command, or to a local image unless told it's DCL (by leading '$')
9898 */
ff7adb52
CL		 9899 if (*s == '@') {
9900 isdcl = 1;
9901 if (suggest_quote) *suggest_quote = 1;
9902 } else {
aa779de1
CB		 9903 register char *filespec = strpbrk(s,":<[.;");
9904 rest = wordbreak = strpbrk(s," \"\t/");
9905 if (!wordbreak) wordbreak = s + strlen(s);
9906 if (*s == '$') check_img = 0;
9907 if (filespec && (filespec < wordbreak)) isdcl = 0;
9908 else isdcl = !check_img;
9909 }
9910
3eeba6fb 9911 if (!isdcl) {
dca5a913 9912 int rsts;
aa779de1
CB		 9913 imgdsc.dsc$a_pointer = s;
9914 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 9915 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e
CB		 9916 if (!(retsts&1)) {
9917 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 9918 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 9919 if (!(retsts & 1) && *s == '$') {
9920 _ckvmssts(lib$find_file_end(&cxt));
9921 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 9922 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f
JM		 9923 if (!(retsts&1)) {
9924 _ckvmssts(lib$find_file_end(&cxt));
dca5a913 9925 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 9926 }
9927 }
aa779de1 9928 }
8012a33e
CB		 9929 _ckvmssts(lib$find_file_end(&cxt));
9930
aa779de1 9931 if (retsts & 1) {
8012a33e 9932 FILE *fp;
a0d0e21e
LW		 9933 s = resspec;
9934 while (*s && !isspace(*s)) s++;
9935 *s = '\0';
8012a33e
CB		 9936
9937 /* check that it's really not DCL with no file extension */
e886094b 9938 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 9939 if (fp) {
2497a41f
JM		 9940 char b[256] = {0,0,0,0};
9941 read(fileno(fp), b, 256);
8012a33e 9942 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 9943 if (isdcl) {
e886094b
JM		 9944 int shebang_len;
9945
2497a41f 9946 /* Check for script */
e886094b
JM		 9947 shebang_len = 0;
9948 if ((b[0] == '#') && (b[1] == '!'))
9949 shebang_len = 2;
9950#ifdef ALTERNATE_SHEBANG
9951 else {
9952 shebang_len = strlen(ALTERNATE_SHEBANG);
9953 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9954 char * perlstr;
9955 perlstr = strstr("perl",b);
9956 if (perlstr == NULL)
9957 shebang_len = 0;
9958 }
9959 else
9960 shebang_len = 0;
9961 }
9962#endif
9963
9964 if (shebang_len > 0) {
9965 int i;
9966 int j;
9967 char tmpspec[NAM$C_MAXRSS + 1];
9968
9969 i = shebang_len;
9970 /* Image is following after white space */
9971 /*--------------------------------------*/
9972 while (isprint(b[i]) && isspace(b[i]))
9973 i++;
9974
9975 j = 0;
9976 while (isprint(b[i]) && !isspace(b[i])) {
9977 tmpspec[j++] = b[i++];
9978 if (j >= NAM$C_MAXRSS)
9979 break;
9980 }
9981 tmpspec[j] = '\0';
9982
9983 /* There may be some default parameters to the image */
9984 /*---------------------------------------------------*/
9985 j = 0;
9986 while (isprint(b[i])) {
9987 image_argv[j++] = b[i++];
9988 if (j >= NAM$C_MAXRSS)
9989 break;
9990 }
9991 while ((j > 0) && !isprint(image_argv[j-1]))
9992 j--;
9993 image_argv[j] = 0;
9994
2497a41f 9995 /* It will need to be converted to VMS format and validated */
e886094b
JM		 9996 if (tmpspec[0] != '\0') {
9997 char * iname;
9998
9999 /* Try to find the exact program requested to be run */
10000 /*---------------------------------------------------*/
10001 iname = do_rmsexpand
360732b5
JM		 10002 (tmpspec, image_name, 0, ".exe",
10003 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10004 if (iname != NULL) {
a1887106
JM		 10005 if (cando_by_name_int
10006 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10007 /* MCR prefix needed */
10008 isdcl = 0;
10009 }
10010 else {
10011 /* Try again with a null type */
10012 /*----------------------------*/
10013 iname = do_rmsexpand
360732b5
JM		 10014 (tmpspec, image_name, 0, ".",
10015 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10016 if (iname != NULL) {
a1887106
JM		 10017 if (cando_by_name_int
10018 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10019 /* MCR prefix needed */
10020 isdcl = 0;
10021 }
10022 }
10023 }
10024
10025 /* Did we find the image to run the script? */
10026 /*------------------------------------------*/
10027 if (isdcl) {
10028 char *tchr;
10029
10030 /* Assume DCL or foreign command exists */
10031 /*--------------------------------------*/
10032 tchr = strrchr(tmpspec, '/');
10033 if (tchr != NULL) {
10034 tchr++;
10035 }
10036 else {
10037 tchr = tmpspec;
10038 }
10039 strcpy(image_name, tchr);
10040 }
10041 }
10042 }
2497a41f
JM		 10043 }
10044 }
8012a33e
CB		 10045 fclose(fp);
10046 }
10047 if (check_img && isdcl) return RMS$_FNF;
10048
3eeba6fb 10049 if (cando_by_name(S_IXUSR,0,resspec)) {
c5375c28
JM		 10050 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10051 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8012a33e 10052 if (!isdcl) {
218fdd94 10053 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
e886094b
JM		 10054 if (image_name[0] != 0) {
10055 strcat(vmscmd->dsc$a_pointer, image_name);
10056 strcat(vmscmd->dsc$a_pointer, " ");
10057 }
10058 } else if (image_name[0] != 0) {
10059 strcpy(vmscmd->dsc$a_pointer, image_name);
10060 strcat(vmscmd->dsc$a_pointer, " ");
8012a33e 10061 } else {
218fdd94 10062 strcpy(vmscmd->dsc$a_pointer,"@");
8012a33e 10063 }
e886094b
JM		 10064 if (suggest_quote) *suggest_quote = 1;
10065
10066 /* If there is an image name, use original command */
10067 if (image_name[0] == 0)
10068 strcat(vmscmd->dsc$a_pointer,resspec);
10069 else {
10070 rest = cmd;
10071 while (*rest && isspace(*rest)) rest++;
10072 }
10073
10074 if (image_argv[0] != 0) {
10075 strcat(vmscmd->dsc$a_pointer,image_argv);
10076 strcat(vmscmd->dsc$a_pointer, " ");
10077 }
10078 if (rest) {
10079 int rest_len;
10080 int vmscmd_len;
10081
10082 rest_len = strlen(rest);
10083 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10084 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10085 strcat(vmscmd->dsc$a_pointer,rest);
10086 else
10087 retsts = CLI$_BUFOVF;
10088 }
218fdd94 10089 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10090 PerlMem_free(cmd);
218fdd94 10091 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10092 }
c5375c28
JM		 10093 else
10094 retsts = RMS$_PRV;
a0d0e21e
LW		 10095 }
10096 }
3eeba6fb 10097 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10098 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10099
b011c7bd 10100 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
c5375c28 10101 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
b011c7bd 10102 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
c5375c28
JM		 10103
10104 PerlMem_free(cmd);
2fbb330f 10105
ff7adb52
CL		 10106 /* check if it's a symbol (for quoting purposes) */
10107 if (suggest_quote && !*suggest_quote) {
10108 int iss;
10109 char equiv[LNM$C_NAMLENGTH];
10110 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10111 eqvdsc.dsc$a_pointer = equiv;
10112
218fdd94 10113 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10114 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10115 }
3eeba6fb
CB		 10116 if (!(retsts & 1)) {
10117 /* just hand off status values likely to be due to user error */
10118 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10119 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10120 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10121 else { _ckvmssts(retsts); }
10122 }
a0d0e21e 10123
218fdd94 10124 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10125
a0d0e21e
LW		 10126} /* end of setup_cmddsc() */
10127
a3e9d8c9 10128
a0d0e21e
LW		 10129/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10130bool
fd8cd3a3 10131Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10132{
c5375c28
JM		 10133bool exec_sts;
10134char * cmd;
10135
a0d0e21e
LW		 10136 if (sp > mark) {
10137 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10138 vfork_called--;
10139 if (vfork_called < 0) {
5c84aa53 10140 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10141 vfork_called = 0;
10142 }
10143 else return do_aexec(really,mark,sp);
a0d0e21e 10144 }
4633a7c4 10145 /* no vfork - act VMSish */
c5375c28
JM		 10146 cmd = setup_argstr(aTHX_ really,mark,sp);
10147 exec_sts = vms_do_exec(cmd);
10148 Safefree(cmd); /* Clean up from setup_argstr() */
10149 return exec_sts;
a0d0e21e
LW		 10150 }
10151
10152 return FALSE;
10153} /* end of vms_do_aexec() */
10154/*}}}*/
10155
10156/* {{{bool vms_do_exec(char *cmd) */
10157bool
2fbb330f 10158Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10159{
218fdd94 10160 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10161
10162 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10163 vfork_called--;
10164 if (vfork_called < 0) {
5c84aa53 10165 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10166 vfork_called = 0;
10167 }
10168 else return do_exec(cmd);
a0d0e21e 10169 }
748a9306
LW		 10170
10171 { /* no vfork - act VMSish */
748a9306 10172 unsigned long int retsts;
a0d0e21e 10173
1e422769 10174 TAINT_ENV();
10175 TAINT_PROPER("exec");
218fdd94
CL		 10176 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10177 retsts = lib$do_command(vmscmd);
a0d0e21e 10178
09b7f37c 10179 switch (retsts) {
f282b18d 10180 case RMS$_FNF: case RMS$_DNF:
09b7f37c 10181 set_errno(ENOENT); break;
f282b18d 10182 case RMS$_DIR:
09b7f37c 10183 set_errno(ENOTDIR); break;
f282b18d
CB		 10184 case RMS$_DEV:
10185 set_errno(ENODEV); break;
09b7f37c
CB		 10186 case RMS$_PRV:
10187 set_errno(EACCES); break;
10188 case RMS$_SYN:
10189 set_errno(EINVAL); break;
a2669cfc 10190 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 10191 set_errno(E2BIG); break;
10192 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10193 _ckvmssts(retsts); /* fall through */
10194 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10195 set_errno(EVMSERR);
10196 }
748a9306 10197 set_vaxc_errno(retsts);
3eeba6fb 10198 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10199 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 10200 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 10201 }
218fdd94 10202 vms_execfree(vmscmd);
a0d0e21e
LW		 10203 }
10204
10205 return FALSE;
10206
10207} /* end of vms_do_exec() */
10208/*}}}*/
10209
2fbb330f 10210unsigned long int Perl_do_spawn(pTHX_ const char *);
eed5d6a1 10211unsigned long int do_spawn2(pTHX_ const char *, int);
a0d0e21e 10212
61bb5906 10213/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
a0d0e21e 10214unsigned long int
fd8cd3a3 10215Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
a0d0e21e 10216{
c5375c28
JM		 10217unsigned long int sts;
10218char * cmd;
eed5d6a1 10219int flags = 0;
a0d0e21e 10220
c5375c28 10221 if (sp > mark) {
eed5d6a1
CB		 10222
10223 /* We'll copy the (undocumented?) Win32 behavior and allow a
10224 * numeric first argument. But the only value we'll support
10225 * through do_aspawn is a value of 1, which means spawn without
10226 * waiting for completion -- other values are ignored.
10227 */
10228 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10229 ++mark;
10230 flags = SvIVx(*(SV**)mark);
10231 }
10232
10233 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10234 flags = CLI$M_NOWAIT;
10235 else
10236 flags = 0;
10237
c5375c28 10238 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
eed5d6a1 10239 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 10240 /* pp_sys will clean up cmd */
10241 return sts;
10242 }
a0d0e21e
LW		 10243 return SS$_ABORT;
10244} /* end of do_aspawn() */
10245/*}}}*/
10246
eed5d6a1 10247
a0d0e21e
LW		 10248/* {{{unsigned long int do_spawn(char *cmd) */
10249unsigned long int
2fbb330f 10250Perl_do_spawn(pTHX_ const char *cmd)
a0d0e21e 10251{
eed5d6a1
CB		 10252 return do_spawn2(aTHX_ cmd, 0);
10253}
10254/*}}}*/
10255
10256/* {{{unsigned long int do_spawn2(char *cmd) */
10257unsigned long int
10258do_spawn2(pTHX_ const char *cmd, int flags)
10259{
209030df 10260 unsigned long int sts, substs;
a0d0e21e 10261
c5375c28
JM		 10262 /* The caller of this routine expects to Safefree(PL_Cmd) */
10263 Newx(PL_Cmd,10,char);
10264
1e422769 10265 TAINT_ENV();
10266 TAINT_PROPER("spawn");
748a9306 10267 if (!cmd || !*cmd) {
eed5d6a1 10268 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 10269 if (!(sts & 1)) {
10270 switch (sts) {
209030df
JH		 10271 case RMS$_FNF: case RMS$_DNF:
10272 set_errno(ENOENT); break;
10273 case RMS$_DIR:
10274 set_errno(ENOTDIR); break;
10275 case RMS$_DEV:
10276 set_errno(ENODEV); break;
10277 case RMS$_PRV:
10278 set_errno(EACCES); break;
10279 case RMS$_SYN:
10280 set_errno(EINVAL); break;
10281 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10282 set_errno(E2BIG); break;
10283 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10284 _ckvmssts(sts); /* fall through */
10285 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10286 set_errno(EVMSERR);
c8795d8b
JH		 10287 }
10288 set_vaxc_errno(sts);
10289 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10290 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 10291 Strerror(errno));
10292 }
09b7f37c 10293 }
c8795d8b 10294 sts = substs;
48023aa8
CL		 10295 }
10296 else {
eed5d6a1 10297 char mode[3];
2fbb330f 10298 PerlIO * fp;
eed5d6a1
CB		 10299 if (flags & CLI$M_NOWAIT)
10300 strcpy(mode, "n");
10301 else
10302 strcpy(mode, "nW");
10303
10304 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 10305 if (fp != NULL)
10306 my_pclose(fp);
eed5d6a1 10307 /* sts will be the pid in the nowait case */
48023aa8 10308 }
48023aa8 10309 return sts;
eed5d6a1 10310} /* end of do_spawn2() */
a0d0e21e
LW		 10311/*}}}*/
10312
bc10a425
CB		 10313
10314static unsigned int *sockflags, sockflagsize;
10315
10316/*
10317 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10318 * routines found in some versions of the CRTL can't deal with sockets.
10319 * We don't shim the other file open routines since a socket isn't
10320 * likely to be opened by a name.
10321 */
275feba9
CB		 10322/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10323FILE *my_fdopen(int fd, const char *mode)
bc10a425 10324{
f7ddb74a 10325 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 10326
10327 if (fp) {
10328 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 10329 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 10330 if (!sockflagsize || fdoff > sockflagsize) {
10331 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 10332 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 10333 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10334 sockflagsize = fdoff + 2;
10335 }
2497a41f 10336 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 10337 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10338 }
10339 return fp;
10340
10341}
10342/*}}}*/
10343
10344
10345/*
10346 * Clear the corresponding bit when the (possibly) socket stream is closed.
10347 * There still a small hole: we miss an implicit close which might occur
10348 * via freopen(). >> Todo
10349 */
10350/*{{{ int my_fclose(FILE *fp)*/
10351int my_fclose(FILE *fp) {
10352 if (fp) {
10353 unsigned int fd = fileno(fp);
10354 unsigned int fdoff = fd / sizeof(unsigned int);
10355
10356 if (sockflagsize && fdoff <= sockflagsize)
10357 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10358 }
10359 return fclose(fp);
10360}
10361/*}}}*/
10362
10363
a0d0e21e
LW		 10364/*
10365 * A simple fwrite replacement which outputs itmsz*nitm chars without
10366 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 10367 * We are using fputs, which depends on a terminating null. We may
10368 * well be writing binary data, so we need to accommodate not only
10369 * data with nulls sprinkled in the middle but also data with no null
10370 * byte at the end.
a0d0e21e 10371 */
a15cef0c 10372/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 10373int
a15cef0c 10374my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 10375{
22d4bb9c 10376 register char *cp, *end, *cpd, *data;
bc10a425
CB		 10377 register unsigned int fd = fileno(dest);
10378 register unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 10379 int retval;
bc10a425
CB		 10380 int bufsize = itmsz * nitm + 1;
10381
10382 if (fdoff < sockflagsize &&
10383 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10384 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10385 return nitm;
10386 }
22d4bb9c 10387
bc10a425 10388 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 10389 memcpy( data, src, itmsz*nitm );
10390 data[itmsz*nitm] = '\0';
a0d0e21e 10391
22d4bb9c
CB		 10392 end = data + itmsz * nitm;
10393 retval = (int) nitm; /* on success return # items written */
a0d0e21e 10394
22d4bb9c
CB		 10395 cpd = data;
10396 while (cpd <= end) {
10397 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10398 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 10399 if (cp < end)
22d4bb9c
CB		 10400 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10401 cpd = cp + 1;
a0d0e21e
LW		 10402 }
10403
bc10a425 10404 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 10405 return retval;
a0d0e21e
LW		 10406
10407} /* end of my_fwrite() */
10408/*}}}*/
10409
d27fe803
JH		 10410/*{{{ int my_flush(FILE *fp)*/
10411int
fd8cd3a3 10412Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 10413{
10414 int res;
93948341 10415 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 10416#ifdef VMS_DO_SOCKETS
61bb5906 10417 Stat_t s;
d27fe803
JH		 10418 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10419#endif
10420 res = fsync(fileno(fp));
10421 }
22d4bb9c
CB		 10422/*
10423 * If the flush succeeded but set end-of-file, we need to clear
10424 * the error because our caller may check ferror(). BTW, this
10425 * probably means we just flushed an empty file.
10426 */
10427 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10428
d27fe803
JH		 10429 return res;
10430}
10431/*}}}*/
10432
748a9306
LW		 10433/*
10434 * Here are replacements for the following Unix routines in the VMS environment:
10435 * getpwuid Get information for a particular UIC or UID
10436 * getpwnam Get information for a named user
10437 * getpwent Get information for each user in the rights database
10438 * setpwent Reset search to the start of the rights database
10439 * endpwent Finish searching for users in the rights database
10440 *
10441 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10442 * (defined in pwd.h), which contains the following fields:-
10443 * struct passwd {
10444 * char *pw_name; Username (in lower case)
10445 * char *pw_passwd; Hashed password
10446 * unsigned int pw_uid; UIC
10447 * unsigned int pw_gid; UIC group number
10448 * char *pw_unixdir; Default device/directory (VMS-style)
10449 * char *pw_gecos; Owner name
10450 * char *pw_dir; Default device/directory (Unix-style)
10451 * char *pw_shell; Default CLI name (eg. DCL)
10452 * };
10453 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10454 *
10455 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10456 * not the UIC member number (eg. what's returned by getuid()),
10457 * getpwuid() can accept either as input (if uid is specified, the caller's
10458 * UIC group is used), though it won't recognise gid=0.
10459 *
10460 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10461 * information about other users in your group or in other groups, respectively.
10462 * If the required privilege is not available, then these routines fill only
10463 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10464 * string).
10465 *
10466 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10467 */
10468
10469/* sizes of various UAF record fields */
10470#define UAI$S_USERNAME 12
10471#define UAI$S_IDENT 31
10472#define UAI$S_OWNER 31
10473#define UAI$S_DEFDEV 31
10474#define UAI$S_DEFDIR 63
10475#define UAI$S_DEFCLI 31
10476#define UAI$S_PWD 8
10477
10478#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10479 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10480 (uic).uic$v_group != UIC$K_WILD_GROUP)
10481
4633a7c4
LW		 10482static char __empty[]= "";
10483static struct passwd __passwd_empty=
748a9306
LW		 10484 {(char *) __empty, (char *) __empty, 0, 0,
10485 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10486static int contxt= 0;
10487static struct passwd __pwdcache;
10488static char __pw_namecache[UAI$S_IDENT+1];
10489
748a9306
LW		 10490/*
10491 * This routine does most of the work extracting the user information.
10492 */
fd8cd3a3 10493static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 10494{
748a9306
LW		 10495 static struct {
10496 unsigned char length;
10497 char pw_gecos[UAI$S_OWNER+1];
10498 } owner;
10499 static union uicdef uic;
10500 static struct {
10501 unsigned char length;
10502 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10503 } defdev;
10504 static struct {
10505 unsigned char length;
10506 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10507 } defdir;
10508 static struct {
10509 unsigned char length;
10510 char pw_shell[UAI$S_DEFCLI+1];
10511 } defcli;
10512 static char pw_passwd[UAI$S_PWD+1];
10513
10514 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10515 struct dsc$descriptor_s name_desc;
c07a80fd 10516 unsigned long int sts;
748a9306 10517
4633a7c4 10518 static struct itmlst_3 itmlst[]= {
748a9306
LW		 10519 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10520 {sizeof(uic), UAI$_UIC, &uic, &luic},
10521 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10522 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10523 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10524 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10525 {0, 0, NULL, NULL}};
10526
10527 name_desc.dsc$w_length= strlen(name);
10528 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10529 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 10530 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 10531
10532/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 10533 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10534 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10535 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10536 }
10537 else { _ckvmssts(sts); }
10538 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 10539
10540 if ((int) owner.length < lowner) lowner= (int) owner.length;
10541 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10542 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10543 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10544 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10545 owner.pw_gecos[lowner]= '\0';
10546 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10547 defcli.pw_shell[ldefcli]= '\0';
10548 if (valid_uic(uic)) {
10549 pwd->pw_uid= uic.uic$l_uic;
10550 pwd->pw_gid= uic.uic$v_group;
10551 }
10552 else
5c84aa53 10553 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 10554 pwd->pw_passwd= pw_passwd;
10555 pwd->pw_gecos= owner.pw_gecos;
10556 pwd->pw_dir= defdev.pw_dir;
360732b5 10557 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 10558 pwd->pw_shell= defcli.pw_shell;
10559 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10560 int ldir;
10561 ldir= strlen(pwd->pw_unixdir) - 1;
10562 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10563 }
10564 else
10565 strcpy(pwd->pw_unixdir, pwd->pw_dir);
f7ddb74a
JM		 10566 if (!decc_efs_case_preserve)
10567 __mystrtolower(pwd->pw_unixdir);
c07a80fd 10568 return 1;
a0d0e21e 10569}
748a9306
LW		 10570
10571/*
10572 * Get information for a named user.
10573*/
10574/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 10575struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 10576{
10577 struct dsc$descriptor_s name_desc;
10578 union uicdef uic;
aa689395 10579 unsigned long int status, sts;
748a9306
LW		 10580
10581 __pwdcache = __passwd_empty;
fd8cd3a3 10582 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 10583 /* We still may be able to determine pw_uid and pw_gid */
10584 name_desc.dsc$w_length= strlen(name);
10585 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10586 name_desc.dsc$b_class= DSC$K_CLASS_S;
10587 name_desc.dsc$a_pointer= (char *) name;
aa689395 10588 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 10589 __pwdcache.pw_uid= uic.uic$l_uic;
10590 __pwdcache.pw_gid= uic.uic$v_group;
10591 }
c07a80fd 10592 else {
aa689395 10593 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10594 set_vaxc_errno(sts);
10595 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 10596 return NULL;
10597 }
aa689395 10598 else { _ckvmssts(sts); }
c07a80fd 10599 }
748a9306 10600 }
748a9306
LW		 10601 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10602 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10603 __pwdcache.pw_name= __pw_namecache;
10604 return &__pwdcache;
10605} /* end of my_getpwnam() */
a0d0e21e
LW		 10606/*}}}*/
10607
748a9306
LW		 10608/*
10609 * Get information for a particular UIC or UID.
10610 * Called by my_getpwent with uid=-1 to list all users.
10611*/
10612/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 10613struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 10614{
748a9306
LW		 10615 const $DESCRIPTOR(name_desc,__pw_namecache);
10616 unsigned short lname;
10617 union uicdef uic;
10618 unsigned long int status;
10619
10620 if (uid == (unsigned int) -1) {
10621 do {
10622 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10623 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 10624 set_vaxc_errno(status);
10625 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 10626 my_endpwent();
10627 return NULL;
10628 }
10629 else { _ckvmssts(status); }
10630 } while (!valid_uic (uic));
10631 }
10632 else {
10633 uic.uic$l_uic= uid;
c07a80fd 10634 if (!uic.uic$v_group)
76e3520e 10635 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 10636 if (valid_uic(uic))
10637 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10638 else status = SS$_IVIDENT;
c07a80fd 10639 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10640 status == RMS$_PRV) {
10641 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10642 return NULL;
10643 }
10644 else { _ckvmssts(status); }
748a9306
LW		 10645 }
10646 __pw_namecache[lname]= '\0';
01b8edb6 10647 __mystrtolower(__pw_namecache);
748a9306
LW		 10648
10649 __pwdcache = __passwd_empty;
10650 __pwdcache.pw_name = __pw_namecache;
10651
10652/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10653 The identifier's value is usually the UIC, but it doesn't have to be,
10654 so if we can, we let fillpasswd update this. */
10655 __pwdcache.pw_uid = uic.uic$l_uic;
10656 __pwdcache.pw_gid = uic.uic$v_group;
10657
fd8cd3a3 10658 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 10659 return &__pwdcache;
a0d0e21e 10660
748a9306
LW		 10661} /* end of my_getpwuid() */
10662/*}}}*/
10663
10664/*
10665 * Get information for next user.
10666*/
10667/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 10668struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 10669{
10670 return (my_getpwuid((unsigned int) -1));
10671}
10672/*}}}*/
a0d0e21e 10673
748a9306
LW		 10674/*
10675 * Finish searching rights database for users.
10676*/
10677/*{{{void my_endpwent()*/
fd8cd3a3 10678void Perl_my_endpwent(pTHX)
748a9306
LW		 10679{
10680 if (contxt) {
10681 _ckvmssts(sys$finish_rdb(&contxt));
10682 contxt= 0;
10683 }
a0d0e21e
LW		 10684}
10685/*}}}*/
748a9306 10686
61bb5906
CB		 10687#ifdef HOMEGROWN_POSIX_SIGNALS
10688 /* Signal handling routines, pulled into the core from POSIX.xs.
10689 *
10690 * We need these for threads, so they've been rolled into the core,
10691 * rather than left in POSIX.xs.
10692 *
10693 * (DRS, Oct 23, 1997)
10694 */
5b411029 10695
61bb5906
CB		 10696 /* sigset_t is atomic under VMS, so these routines are easy */
10697/*{{{int my_sigemptyset(sigset_t *) */
5b411029 10698int my_sigemptyset(sigset_t *set) {
61bb5906
CB		 10699 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10700 *set = 0; return 0;
5b411029 10701}
61bb5906
CB		 10702/*}}}*/
10703
10704
10705/*{{{int my_sigfillset(sigset_t *)*/
5b411029 10706int my_sigfillset(sigset_t *set) {
61bb5906
CB		 10707 int i;
10708 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10709 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10710 return 0;
5b411029 10711}
61bb5906
CB		 10712/*}}}*/
10713
10714
10715/*{{{int my_sigaddset(sigset_t *set, int sig)*/
5b411029 10716int my_sigaddset(sigset_t *set, int sig) {
61bb5906
CB		 10717 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10718 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10719 *set |= (1 << (sig - 1));
10720 return 0;
5b411029 10721}
61bb5906
CB		 10722/*}}}*/
10723
10724
10725/*{{{int my_sigdelset(sigset_t *set, int sig)*/
5b411029 10726int my_sigdelset(sigset_t *set, int sig) {
61bb5906
CB		 10727 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10728 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10729 *set &= ~(1 << (sig - 1));
10730 return 0;
5b411029 10731}
61bb5906
CB		 10732/*}}}*/
10733
10734
10735/*{{{int my_sigismember(sigset_t *set, int sig)*/
5b411029 10736int my_sigismember(sigset_t *set, int sig) {
61bb5906
CB		 10737 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10738 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
73e350d9 10739 return *set & (1 << (sig - 1));
5b411029 10740}
61bb5906 10741/*}}}*/
5b411029 10742
5b411029 10743
61bb5906
CB		 10744/*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10745int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10746 sigset_t tempmask;
10747
10748 /* If set and oset are both null, then things are badly wrong. Bail out. */
10749 if ((oset == NULL) && (set == NULL)) {
10750 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5b411029
MB		 10751 return -1;
10752 }
5b411029 10753
61bb5906
CB		 10754 /* If set's null, then we're just handling a fetch. */
10755 if (set == NULL) {
10756 tempmask = sigblock(0);
10757 }
10758 else {
10759 switch (how) {
10760 case SIG_SETMASK:
10761 tempmask = sigsetmask(*set);
10762 break;
10763 case SIG_BLOCK:
10764 tempmask = sigblock(*set);
10765 break;
10766 case SIG_UNBLOCK:
10767 tempmask = sigblock(0);
10768 sigsetmask(*oset & ~tempmask);
10769 break;
10770 default:
10771 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10772 return -1;
10773 }
10774 }
10775
10776 /* Did they pass us an oset? If so, stick our holding mask into it */
10777 if (oset)
10778 *oset = tempmask;
5b411029 10779
61bb5906 10780 return 0;
5b411029 10781}
61bb5906
CB		 10782/*}}}*/
10783#endif /* HOMEGROWN_POSIX_SIGNALS */
10784
5b411029 10785
ff0cee69 10786/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10787 * my_utime(), and flex_stat(), all of which operate on UTC unless
10788 * VMSISH_TIMES is true.
10789 */
10790/* method used to handle UTC conversions:
10791 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 10792 */
ff0cee69 10793static int gmtime_emulation_type;
10794/* number of secs to add to UTC POSIX-style time to get local time */
10795static long int utc_offset_secs;
e518068a 10796
ff0cee69 10797/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10798 * in vmsish.h. #undef them here so we can call the CRTL routines
10799 * directly.
e518068a 10800 */
10801#undef gmtime
ff0cee69 10802#undef localtime
10803#undef time
10804
61bb5906 10805
a44ceb8e
CB		 10806/*
10807 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10808 * qualifier with the extern prefix pragma. This provisional
10809 * hack circumvents this prefix pragma problem in previous
10810 * precompilers.
10811 */
10812#if defined(__VMS_VER) && __VMS_VER >= 70000000
10813# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10814# pragma __extern_prefix save
10815# pragma __extern_prefix "" /* set to empty to prevent prefixing */
10816# define gmtime decc$__utctz_gmtime
10817# define localtime decc$__utctz_localtime
10818# define time decc$__utc_time
10819# pragma __extern_prefix restore
10820
10821 struct tm *gmtime(), *localtime();
10822
10823# endif
10824#endif
10825
10826
61bb5906
CB		 10827static time_t toutc_dst(time_t loc) {
10828 struct tm *rsltmp;
10829
10830 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10831 loc -= utc_offset_secs;
10832 if (rsltmp->tm_isdst) loc -= 3600;
10833 return loc;
10834}
32da55ab 10835#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 10836 ((gmtime_emulation_type || my_time(NULL)), \
10837 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10838 ((secs) - utc_offset_secs))))
10839
10840static time_t toloc_dst(time_t utc) {
10841 struct tm *rsltmp;
10842
10843 utc += utc_offset_secs;
10844 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10845 if (rsltmp->tm_isdst) utc += 3600;
10846 return utc;
10847}
32da55ab 10848#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 10849 ((gmtime_emulation_type || my_time(NULL)), \
10850 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10851 ((secs) + utc_offset_secs))))
10852
22d4bb9c
CB		 10853#ifndef RTL_USES_UTC
10854/*
10855
10856 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10857 DST starts on 1st sun of april at 02:00 std time
10858 ends on last sun of october at 02:00 dst time
10859 see the UCX management command reference, SET CONFIG TIMEZONE
10860 for formatting info.
10861
10862 No, it's not as general as it should be, but then again, NOTHING
10863 will handle UK times in a sensible way.
10864*/
10865
10866
10867/*
10868 parse the DST start/end info:
10869 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10870*/
10871
10872static char *
10873tz_parse_startend(char *s, struct tm *w, int *past)
10874{
10875 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10876 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10877 time_t g;
10878
10879 if (!s) return 0;
10880 if (!w) return 0;
10881 if (!past) return 0;
10882
10883 ly = 0;
10884 if (w->tm_year % 4 == 0) ly = 1;
10885 if (w->tm_year % 100 == 0) ly = 0;
10886 if (w->tm_year+1900 % 400 == 0) ly = 1;
10887 if (ly) dinm[1]++;
10888
10889 dozjd = isdigit(*s);
10890 if (*s == 'J' || *s == 'j' || dozjd) {
10891 if (!dozjd && !isdigit(*++s)) return 0;
10892 d = *s++ - '0';
10893 if (isdigit(*s)) {
10894 d = d*10 + *s++ - '0';
10895 if (isdigit(*s)) {
10896 d = d*10 + *s++ - '0';
10897 }
10898 }
10899 if (d == 0) return 0;
10900 if (d > 366) return 0;
10901 d--;
10902 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10903 g = d * 86400;
10904 dozjd = 1;
10905 } else if (*s == 'M' || *s == 'm') {
10906 if (!isdigit(*++s)) return 0;
10907 m = *s++ - '0';
10908 if (isdigit(*s)) m = 10*m + *s++ - '0';
10909 if (*s != '.') return 0;
10910 if (!isdigit(*++s)) return 0;
10911 n = *s++ - '0';
10912 if (n < 1 || n > 5) return 0;
10913 if (*s != '.') return 0;
10914 if (!isdigit(*++s)) return 0;
10915 d = *s++ - '0';
10916 if (d > 6) return 0;
10917 }
10918
10919 if (*s == '/') {
10920 if (!isdigit(*++s)) return 0;
10921 hour = *s++ - '0';
10922 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10923 if (*s == ':') {
10924 if (!isdigit(*++s)) return 0;
10925 min = *s++ - '0';
10926 if (isdigit(*s)) min = 10*min + *s++ - '0';
10927 if (*s == ':') {
10928 if (!isdigit(*++s)) return 0;
10929 sec = *s++ - '0';
10930 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10931 }
10932 }
10933 } else {
10934 hour = 2;
10935 min = 0;
10936 sec = 0;
10937 }
10938
10939 if (dozjd) {
10940 if (w->tm_yday < d) goto before;
10941 if (w->tm_yday > d) goto after;
10942 } else {
10943 if (w->tm_mon+1 < m) goto before;
10944 if (w->tm_mon+1 > m) goto after;
10945
10946 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10947 k = d - j; /* mday of first d */
10948 if (k <= 0) k += 7;
10949 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10950 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10951 if (w->tm_mday < k) goto before;
10952 if (w->tm_mday > k) goto after;
10953 }
10954
10955 if (w->tm_hour < hour) goto before;
10956 if (w->tm_hour > hour) goto after;
10957 if (w->tm_min < min) goto before;
10958 if (w->tm_min > min) goto after;
10959 if (w->tm_sec < sec) goto before;
10960 goto after;
10961
10962before:
10963 *past = 0;
10964 return s;
10965after:
10966 *past = 1;
10967 return s;
10968}
10969
10970
10971
10972
10973/* parse the offset: (+|-)hh[:mm[:ss]] */
10974
10975static char *
10976tz_parse_offset(char *s, int *offset)
10977{
10978 int hour = 0, min = 0, sec = 0;
10979 int neg = 0;
10980 if (!s) return 0;
10981 if (!offset) return 0;
10982
10983 if (*s == '-') {neg++; s++;}
10984 if (*s == '+') s++;
10985 if (!isdigit(*s)) return 0;
10986 hour = *s++ - '0';
10987 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10988 if (hour > 24) return 0;
10989 if (*s == ':') {
10990 if (!isdigit(*++s)) return 0;
10991 min = *s++ - '0';
10992 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10993 if (min > 59) return 0;
10994 if (*s == ':') {
10995 if (!isdigit(*++s)) return 0;
10996 sec = *s++ - '0';
10997 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10998 if (sec > 59) return 0;
10999 }
11000 }
11001
11002 *offset = (hour*60+min)*60 + sec;
11003 if (neg) *offset = -*offset;
11004 return s;
11005}
11006
11007/*
11008 input time is w, whatever type of time the CRTL localtime() uses.
11009 sets dst, the zone, and the gmtoff (seconds)
11010
11011 caches the value of TZ and UCX$TZ env variables; note that
11012 my_setenv looks for these and sets a flag if they're changed
11013 for efficiency.
11014
11015 We have to watch out for the "australian" case (dst starts in
11016 october, ends in april)...flagged by "reverse" and checked by
11017 scanning through the months of the previous year.
11018
11019*/
11020
11021static int
fd8cd3a3 11022tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
22d4bb9c
CB		 11023{
11024 time_t when;
11025 struct tm *w2;
11026 char *s,*s2;
11027 char *dstzone, *tz, *s_start, *s_end;
11028 int std_off, dst_off, isdst;
11029 int y, dststart, dstend;
11030 static char envtz[1025]; /* longer than any logical, symbol, ... */
11031 static char ucxtz[1025];
11032 static char reversed = 0;
11033
11034 if (!w) return 0;
11035
11036 if (tz_updated) {
11037 tz_updated = 0;
11038 reversed = -1; /* flag need to check */
11039 envtz[0] = ucxtz[0] = '\0';
11040 tz = my_getenv("TZ",0);
11041 if (tz) strcpy(envtz, tz);
11042 tz = my_getenv("UCX$TZ",0);
11043 if (tz) strcpy(ucxtz, tz);
11044 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11045 }
11046 tz = envtz;
11047 if (!*tz) tz = ucxtz;
11048
11049 s = tz;
11050 while (isalpha(*s)) s++;
11051 s = tz_parse_offset(s, &std_off);
11052 if (!s) return 0;
11053 if (!*s) { /* no DST, hurray we're done! */
11054 isdst = 0;
11055 goto done;
11056 }
11057
11058 dstzone = s;
11059 while (isalpha(*s)) s++;
11060 s2 = tz_parse_offset(s, &dst_off);
11061 if (s2) {
11062 s = s2;
11063 } else {
11064 dst_off = std_off - 3600;
11065 }
11066
11067 if (!*s) { /* default dst start/end?? */
11068 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11069 s = strchr(ucxtz,',');
11070 }
11071 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11072 }
11073 if (*s != ',') return 0;
11074
11075 when = *w;
11076 when = _toutc(when); /* convert to utc */
11077 when = when - std_off; /* convert to pseudolocal time*/
11078
11079 w2 = localtime(&when);
11080 y = w2->tm_year;
11081 s_start = s+1;
11082 s = tz_parse_startend(s_start,w2,&dststart);
11083 if (!s) return 0;
11084 if (*s != ',') return 0;
11085
11086 when = *w;
11087 when = _toutc(when); /* convert to utc */
11088 when = when - dst_off; /* convert to pseudolocal time*/
11089 w2 = localtime(&when);
11090 if (w2->tm_year != y) { /* spans a year, just check one time */
11091 when += dst_off - std_off;
11092 w2 = localtime(&when);
11093 }
11094 s_end = s+1;
11095 s = tz_parse_startend(s_end,w2,&dstend);
11096 if (!s) return 0;
11097
11098 if (reversed == -1) { /* need to check if start later than end */
11099 int j, ds, de;
11100
11101 when = *w;
11102 if (when < 2*365*86400) {
11103 when += 2*365*86400;
11104 } else {
11105 when -= 365*86400;
11106 }
11107 w2 =localtime(&when);
11108 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11109
11110 for (j = 0; j < 12; j++) {
11111 w2 =localtime(&when);
f7ddb74a
JM		 11112 tz_parse_startend(s_start,w2,&ds);
11113 tz_parse_startend(s_end,w2,&de);
22d4bb9c
CB		 11114 if (ds != de) break;
11115 when += 30*86400;
11116 }
11117 reversed = 0;
11118 if (de && !ds) reversed = 1;
11119 }
11120
11121 isdst = dststart && !dstend;
11122 if (reversed) isdst = dststart || !dstend;
11123
11124done:
11125 if (dst) *dst = isdst;
11126 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11127 if (isdst) tz = dstzone;
11128 if (zone) {
11129 while(isalpha(*tz)) *zone++ = *tz++;
11130 *zone = '\0';
11131 }
11132 return 1;
11133}
11134
11135#endif /* !RTL_USES_UTC */
61bb5906 11136
ff0cee69 11137/* my_time(), my_localtime(), my_gmtime()
61bb5906 11138 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11139 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11140 * Note: We need to use these functions even when the CRTL has working
11141 * UTC support, since they also handle C<use vmsish qw(times);>
11142 *
ff0cee69 11143 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11144 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11145 */
11146
11147/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 11148time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 11149{
e518068a 11150 time_t when;
61bb5906 11151 struct tm *tm_p;
e518068a 11152
11153 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11154 int dstnow;
11155 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11156 /* results of calls to gmtime() and localtime() */
11157 /* for same &base */
ff0cee69 11158
e518068a 11159 gmtime_emulation_type++;
ff0cee69 11160 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11161 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11162
e518068a 11163 gmtime_emulation_type++;
f675dbe5 11164 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11165 gmtime_emulation_type++;
22d4bb9c 11166 utc_offset_secs = 0;
5c84aa53 11167 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11168 }
11169 else { utc_offset_secs = atol(off); }
e518068a 11170 }
ff0cee69 11171 else { /* We've got a working gmtime() */
11172 struct tm gmt, local;
e518068a 11173
ff0cee69 11174 gmt = *tm_p;
11175 tm_p = localtime(&base);
11176 local = *tm_p;
11177 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11178 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11179 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11180 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11181 }
e518068a 11182 }
ff0cee69 11183
11184 when = time(NULL);
61bb5906
CB		 11185# ifdef VMSISH_TIME
11186# ifdef RTL_USES_UTC
11187 if (VMSISH_TIME) when = _toloc(when);
11188# else
11189 if (!VMSISH_TIME) when = _toutc(when);
11190# endif
11191# endif
ff0cee69 11192 if (timep != NULL) *timep = when;
11193 return when;
11194
11195} /* end of my_time() */
11196/*}}}*/
11197
11198
11199/*{{{struct tm *my_gmtime(const time_t *timep)*/
11200struct tm *
fd8cd3a3 11201Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11202{
11203 char *p;
11204 time_t when;
61bb5906 11205 struct tm *rsltmp;
ff0cee69 11206
68dc0745 11207 if (timep == NULL) {
11208 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11209 return NULL;
11210 }
11211 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11212
11213 when = *timep;
11214# ifdef VMSISH_TIME
61bb5906
CB		 11215 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11216# endif
11217# ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11218 return gmtime(&when);
11219# else
ff0cee69 11220 /* CRTL localtime() wants local time as input, so does no tz correction */
61bb5906
CB		 11221 rsltmp = localtime(&when);
11222 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11223 return rsltmp;
11224#endif
e518068a 11225} /* end of my_gmtime() */
e518068a 11226/*}}}*/
11227
11228
ff0cee69 11229/*{{{struct tm *my_localtime(const time_t *timep)*/
11230struct tm *
fd8cd3a3 11231Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11232{
22d4bb9c 11233 time_t when, whenutc;
61bb5906 11234 struct tm *rsltmp;
22d4bb9c 11235 int dst, offset;
ff0cee69 11236
68dc0745 11237 if (timep == NULL) {
11238 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11239 return NULL;
11240 }
11241 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11242 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11243
11244 when = *timep;
61bb5906 11245# ifdef RTL_USES_UTC
ff0cee69 11246# ifdef VMSISH_TIME
61bb5906 11247 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11248# endif
61bb5906 11249 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11250 return localtime(&when);
22d4bb9c
CB		 11251
11252# else /* !RTL_USES_UTC */
11253 whenutc = when;
61bb5906 11254# ifdef VMSISH_TIME
22d4bb9c
CB		 11255 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11256 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
61bb5906 11257# endif
22d4bb9c
CB		 11258 dst = -1;
11259#ifndef RTL_USES_UTC
32af7c23 11260 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
22d4bb9c
CB		 11261 when = whenutc - offset; /* pseudolocal time*/
11262 }
61bb5906
CB		 11263# endif
11264 /* CRTL localtime() wants local time as input, so does no tz correction */
11265 rsltmp = localtime(&when);
22d4bb9c 11266 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
61bb5906 11267 return rsltmp;
22d4bb9c 11268# endif
ff0cee69 11269
11270} /* end of my_localtime() */
11271/*}}}*/
11272
11273/* Reset definitions for later calls */
11274#define gmtime(t) my_gmtime(t)
11275#define localtime(t) my_localtime(t)
11276#define time(t) my_time(t)
11277
11278
941b3de1
CB		 11279/* my_utime - update modification/access time of a file
11280 *
11281 * VMS 7.3 and later implementation
11282 * Only the UTC translation is home-grown. The rest is handled by the
11283 * CRTL utime(), which will take into account the relevant feature
11284 * logicals and ODS-5 volume characteristics for true access times.
11285 *
11286 * pre VMS 7.3 implementation:
11287 * The calling sequence is identical to POSIX utime(), but under
11288 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11289 * not maintain access times. Restrictions differ from the POSIX
ff0cee69 11290 * definition in that the time can be changed as long as the
11291 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11292 * no separate checks are made to insure that the caller is the
11293 * owner of the file or has special privs enabled.
11294 * Code here is based on Joe Meadows' FILE utility.
941b3de1 11295 *
ff0cee69 11296 */
11297
11298/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11299 * to VMS epoch (01-JAN-1858 00:00:00.00)
11300 * in 100 ns intervals.
11301 */
11302static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11303
94a11853
CB		 11304/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11305int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11306{
941b3de1
CB		 11307#if __CRTL_VER >= 70300000
11308 struct utimbuf utc_utimes, *utc_utimesp;
11309
11310 if (utimes != NULL) {
11311 utc_utimes.actime = utimes->actime;
11312 utc_utimes.modtime = utimes->modtime;
11313# ifdef VMSISH_TIME
11314 /* If input was local; convert to UTC for sys svc */
11315 if (VMSISH_TIME) {
11316 utc_utimes.actime = _toutc(utimes->actime);
11317 utc_utimes.modtime = _toutc(utimes->modtime);
11318 }
11319# endif
11320 utc_utimesp = &utc_utimes;
11321 }
11322 else {
11323 utc_utimesp = NULL;
11324 }
11325
11326 return utime(file, utc_utimesp);
11327
11328#else /* __CRTL_VER < 70300000 */
11329
ff0cee69 11330 register int i;
f7ddb74a 11331 int sts;
ff0cee69 11332 long int bintime[2], len = 2, lowbit, unixtime,
11333 secscale = 10000000; /* seconds --> 100 ns intervals */
11334 unsigned long int chan, iosb[2], retsts;
11335 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11336 struct FAB myfab = cc$rms_fab;
11337 struct NAM mynam = cc$rms_nam;
11338#if defined (__DECC) && defined (__VAX)
11339 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11340 * at least through VMS V6.1, which causes a type-conversion warning.
11341 */
11342# pragma message save
11343# pragma message disable cvtdiftypes
11344#endif
11345 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11346 struct fibdef myfib;
11347#if defined (__DECC) && defined (__VAX)
11348 /* This should be right after the declaration of myatr, but due
11349 * to a bug in VAX DEC C, this takes effect a statement early.
11350 */
11351# pragma message restore
11352#endif
f7ddb74a 11353 /* cast ok for read only parameter */
ff0cee69 11354 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11355 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11356 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
704c2eb3 11357
ff0cee69 11358 if (file == NULL || *file == '\0') {
941b3de1 11359 SETERRNO(ENOENT, LIB$_INVARG);
ff0cee69 11360 return -1;
11361 }
704c2eb3
JM		 11362
11363 /* Convert to VMS format ensuring that it will fit in 255 characters */
360732b5 11364 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
941b3de1
CB		 11365 SETERRNO(ENOENT, LIB$_INVARG);
11366 return -1;
11367 }
ff0cee69 11368 if (utimes != NULL) {
11369 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11370 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11371 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11372 * as input, we force the sign bit to be clear by shifting unixtime right
11373 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11374 */
11375 lowbit = (utimes->modtime & 1) ? secscale : 0;
11376 unixtime = (long int) utimes->modtime;
61bb5906
CB		 11377# ifdef VMSISH_TIME
11378 /* If input was UTC; convert to local for sys svc */
11379 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 11380# endif
1a6334fb 11381 unixtime >>= 1; secscale <<= 1;
ff0cee69 11382 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11383 if (!(retsts & 1)) {
941b3de1 11384 SETERRNO(EVMSERR, retsts);
ff0cee69 11385 return -1;
11386 }
11387 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11388 if (!(retsts & 1)) {
941b3de1 11389 SETERRNO(EVMSERR, retsts);
ff0cee69 11390 return -1;
11391 }
11392 }
11393 else {
11394 /* Just get the current time in VMS format directly */
11395 retsts = sys$gettim(bintime);
11396 if (!(retsts & 1)) {
941b3de1 11397 SETERRNO(EVMSERR, retsts);
ff0cee69 11398 return -1;
11399 }
11400 }
11401
11402 myfab.fab$l_fna = vmsspec;
11403 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11404 myfab.fab$l_nam = &mynam;
11405 mynam.nam$l_esa = esa;
11406 mynam.nam$b_ess = (unsigned char) sizeof esa;
11407 mynam.nam$l_rsa = rsa;
11408 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 11409 if (decc_efs_case_preserve)
11410 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 11411
11412 /* Look for the file to be affected, letting RMS parse the file
11413 * specification for us as well. I have set errno using only
11414 * values documented in the utime() man page for VMS POSIX.
11415 */
11416 retsts = sys$parse(&myfab,0,0);
11417 if (!(retsts & 1)) {
11418 set_vaxc_errno(retsts);
11419 if (retsts == RMS$_PRV) set_errno(EACCES);
11420 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11421 else set_errno(EVMSERR);
11422 return -1;
11423 }
11424 retsts = sys$search(&myfab,0,0);
11425 if (!(retsts & 1)) {
752635ea 11426 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11427 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11428 set_vaxc_errno(retsts);
11429 if (retsts == RMS$_PRV) set_errno(EACCES);
11430 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11431 else set_errno(EVMSERR);
11432 return -1;
11433 }
11434
11435 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 11436 /* cast ok for read only parameter */
ff0cee69 11437 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11438
11439 retsts = sys$assign(&devdsc,&chan,0,0);
11440 if (!(retsts & 1)) {
752635ea 11441 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11442 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11443 set_vaxc_errno(retsts);
11444 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11445 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11446 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11447 else set_errno(EVMSERR);
11448 return -1;
11449 }
11450
11451 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11452 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11453
11454 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 11455#if defined(__DECC) || defined(__DECCXX)
ff0cee69 11456 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11457 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11458 /* This prevents the revision time of the file being reset to the current
11459 * time as a result of our IO$_MODIFY $QIO. */
11460 myfib.fib$l_acctl = FIB$M_NORECORD;
11461#else
11462 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11463 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11464 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11465#endif
11466 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 11467 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11468 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11469 _ckvmssts(sys$dassgn(chan));
11470 if (retsts & 1) retsts = iosb[0];
11471 if (!(retsts & 1)) {
11472 set_vaxc_errno(retsts);
11473 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11474 else set_errno(EVMSERR);
11475 return -1;
11476 }
11477
11478 return 0;
941b3de1
CB		 11479
11480#endif /* #if __CRTL_VER >= 70300000 */
11481
ff0cee69 11482} /* end of my_utime() */
11483/*}}}*/
11484
748a9306 11485/*
2497a41f 11486 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11487 * basic stat, but gets it right when asked to stat
11488 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11489 */
11490
2497a41f 11491#ifndef _USE_STD_STAT
748a9306
LW		 11492/* encode_dev packs a VMS device name string into an integer to allow
11493 * simple comparisons. This can be used, for example, to check whether two
11494 * files are located on the same device, by comparing their encoded device
11495 * names. Even a string comparison would not do, because stat() reuses the
11496 * device name buffer for each call; so without encode_dev, it would be
11497 * necessary to save the buffer and use strcmp (this would mean a number of
11498 * changes to the standard Perl code, to say nothing of what a Perl script
11499 * would have to do.
11500 *
11501 * The device lock id, if it exists, should be unique (unless perhaps compared
11502 * with lock ids transferred from other nodes). We have a lock id if the disk is
11503 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11504 * device names. Thus we use the lock id in preference, and only if that isn't
11505 * available, do we try to pack the device name into an integer (flagged by
11506 * the sign bit (LOCKID_MASK) being set).
11507 *
e518068a 11508 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11509 * name and its encoded form, but it seems very unlikely that we will find
11510 * two files on different disks that share the same encoded device names,
11511 * and even more remote that they will share the same file id (if the test
11512 * is to check for the same file).
11513 *
11514 * A better method might be to use sys$device_scan on the first call, and to
11515 * search for the device, returning an index into the cached array.
cb9e088c 11516 * The number returned would be more intelligible.
748a9306
LW		 11517 * This is probably not worth it, and anyway would take quite a bit longer
11518 * on the first call.
11519 */
11520#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 11521static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 11522{
11523 int i;
11524 unsigned long int f;
aa689395 11525 mydev_t enc;
748a9306
LW		 11526 char c;
11527 const char *q;
11528
11529 if (!dev || !dev[0]) return 0;
11530
11531#if LOCKID_MASK
11532 {
11533 struct dsc$descriptor_s dev_desc;
cb9e088c 11534 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11535
11536 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11537 can try that first. */
11538 dev_desc.dsc$w_length = strlen (dev);
11539 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11540 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11541 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11542 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11543 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11544 switch (status) {
11545 case SS$_NOSUCHDEV:
11546 SETERRNO(ENODEV, status);
11547 return 0;
11548 default:
11549 _ckvmssts(status);
11550 }
11551 }
748a9306
LW		 11552 if (lockid) return (lockid & ~LOCKID_MASK);
11553 }
a0d0e21e 11554#endif
748a9306
LW		 11555
11556 /* Otherwise we try to encode the device name */
11557 enc = 0;
11558 f = 1;
11559 i = 0;
11560 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11561 if (*q == ':')
11562 break;
748a9306
LW		 11563 if (isdigit (*q))
11564 c= (*q) - '0';
11565 else if (isalpha (toupper (*q)))
11566 c= toupper (*q) - 'A' + (char)10;
11567 else
11568 continue; /* Skip '$'s */
11569 i++;
11570 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11571 if (i>1) f *= 36;
11572 enc += f * (unsigned long int) c;
11573 }
11574 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11575
11576} /* end of encode_dev() */
cfcfe586
JM		 11577#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11578 device_no = encode_dev(aTHX_ devname)
11579#else
11580#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11581 device_no = new_dev_no
2497a41f 11582#endif
748a9306 11583
748a9306
LW		 11584static int
11585is_null_device(name)
11586 const char *name;
11587{
2497a41f 11588 if (decc_bug_devnull != 0) {
682e4b71 11589 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 11590 return 1;
11591 }
748a9306
LW		 11592 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11593 The underscore prefix, controller letter, and unit number are
11594 independently optional; for our purposes, the colon punctuation
11595 is not. The colon can be trailed by optional directory and/or
11596 filename, but two consecutive colons indicates a nodename rather
11597 than a device. [pr] */
11598 if (*name == '_') ++name;
11599 if (tolower(*name++) != 'n') return 0;
11600 if (tolower(*name++) != 'l') return 0;
11601 if (tolower(*name) == 'a') ++name;
11602 if (*name == '0') ++name;
11603 return (*name++ == ':') && (*name != ':');
11604}
11605
c07a80fd 11606
a1887106
JM		 11607static I32
11608Perl_cando_by_name_int
11609 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11610{
e538e23f
CB		 11611 char usrname[L_cuserid];
11612 struct dsc$descriptor_s usrdsc =
748a9306 11613 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11614 char *vmsname = NULL, *fileified = NULL;
597c27e2 11615 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11616 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11617 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11618 union prvdef curprv;
597c27e2
CB		 11619 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11620 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11621 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11622 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11623 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11624 {0,0,0,0}};
11625 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11626 {0,0,0,0}};
ada67d10 11627 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11628 Stat_t st;
6151c65c 11629 static int profile_context = -1;
748a9306
LW		 11630
11631 if (!fname || !*fname) return FALSE;
a1887106 11632
e538e23f
CB		 11633 /* Make sure we expand logical names, since sys$check_access doesn't */
11634 fileified = PerlMem_malloc(VMS_MAXRSS);
11635 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11636 if (!strpbrk(fname,"/]>:")) {
a1887106
JM		 11637 strcpy(fileified,fname);
11638 trnlnm_iter_count = 0;
e538e23f 11639 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11640 trnlnm_iter_count++;
11641 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11642 }
11643 fname = fileified;
e538e23f
CB		 11644 }
11645
11646 vmsname = PerlMem_malloc(VMS_MAXRSS);
11647 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11648 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11649 /* Don't know if already in VMS format, so make sure */
360732b5 11650 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11651 PerlMem_free(fileified);
e538e23f 11652 PerlMem_free(vmsname);
a1887106
JM		 11653 return FALSE;
11654 }
a1887106
JM		 11655 }
11656 else {
e538e23f 11657 strcpy(vmsname,fname);
a5f75d66
AD		 11658 }
11659
858aded6
CB		 11660 /* sys$check_access needs a file spec, not a directory spec.
11661 * Don't use flex_stat here, as that depends on thread context
11662 * having been initialized, and we may get here during startup.
11663 */
e538e23f
CB		 11664
11665 retlen = namdsc.dsc$w_length = strlen(vmsname);
11666 if (vmsname[retlen-1] == ']'
11667 || vmsname[retlen-1] == '>'
858aded6
CB		 11668 || vmsname[retlen-1] == ':'
11669 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
e538e23f
CB		 11670
11671 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11672 PerlMem_free(fileified);
11673 PerlMem_free(vmsname);
11674 return FALSE;
11675 }
11676 fname = fileified;
11677 }
858aded6
CB		 11678 else {
11679 fname = vmsname;
11680 }
e538e23f
CB		 11681
11682 retlen = namdsc.dsc$w_length = strlen(fname);
11683 namdsc.dsc$a_pointer = (char *)fname;
11684
748a9306 11685 switch (bit) {
f282b18d 11686 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11687 access = ARM$M_EXECUTE;
597c27e2
CB		 11688 flags = CHP$M_READ;
11689 break;
f282b18d 11690 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11691 access = ARM$M_READ;
597c27e2
CB		 11692 flags = CHP$M_READ | CHP$M_USEREADALL;
11693 break;
f282b18d 11694 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11695 access = ARM$M_WRITE;
597c27e2
CB		 11696 flags = CHP$M_READ | CHP$M_WRITE;
11697 break;
f282b18d 11698 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11699 access = ARM$M_DELETE;
597c27e2
CB		 11700 flags = CHP$M_READ | CHP$M_WRITE;
11701 break;
748a9306 11702 default:
a1887106
JM		 11703 if (fileified != NULL)
11704 PerlMem_free(fileified);
e538e23f
CB		 11705 if (vmsname != NULL)
11706 PerlMem_free(vmsname);
748a9306
LW		 11707 return FALSE;
11708 }
11709
ada67d10
CB		 11710 /* Before we call $check_access, create a user profile with the current
11711 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11712 * UAF and might give false positives or negatives. This only works on
11713 * VMS versions v6.0 and later since that's when sys$create_user_profile
11714 * became available.
ada67d10
CB		 11715 */
11716
11717 /* get current process privs and username */
11718 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11719 _ckvmssts(iosb[0]);
11720
baf3cf9c
CB		 11721#if defined(__VMS_VER) && __VMS_VER >= 60000000
11722
ada67d10
CB		 11723 /* find out the space required for the profile */
11724 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11725 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11726
11727 /* allocate space for the profile and get it filled in */
c5375c28
JM		 11728 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11729 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
ada67d10 11730 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 11731 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11732
11733 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 11734 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 11735 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 11736 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c
CB		 11737
11738#else
11739
11740 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11741
11742#endif
11743
bbce6d69 11744 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 11745 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 11746 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 11747 set_vaxc_errno(retsts);
11748 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11749 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11750 else set_errno(ENOENT);
a1887106
JM		 11751 if (fileified != NULL)
11752 PerlMem_free(fileified);
e538e23f
CB		 11753 if (vmsname != NULL)
11754 PerlMem_free(vmsname);
a3e9d8c9 11755 return FALSE;
11756 }
ada67d10 11757 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 11758 if (fileified != NULL)
11759 PerlMem_free(fileified);
e538e23f
CB		 11760 if (vmsname != NULL)
11761 PerlMem_free(vmsname);
3a385817
GS		 11762 return TRUE;
11763 }
748a9306
LW		 11764 _ckvmssts(retsts);
11765
a1887106
JM		 11766 if (fileified != NULL)
11767 PerlMem_free(fileified);
e538e23f
CB		 11768 if (vmsname != NULL)
11769 PerlMem_free(vmsname);
748a9306
LW		 11770 return FALSE; /* Should never get here */
11771
a1887106
JM		 11772}
11773
11774/* Do the permissions allow some operation? Assumes PL_statcache already set. */
11775/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11776 * subset of the applicable information.
11777 */
11778bool
11779Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11780{
11781 return cando_by_name_int
11782 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11783} /* end of cando() */
11784/*}}}*/
11785
11786
11787/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11788I32
11789Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11790{
11791 return cando_by_name_int(bit, effective, fname, 0);
11792
748a9306
LW		 11793} /* end of cando_by_name() */
11794/*}}}*/
11795
11796
61bb5906 11797/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 11798int
fd8cd3a3 11799Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 11800{
b7ae7a0d 11801 if (!fstat(fd,(stat_t *) statbufp)) {
75796008 11802 char *cptr;
988c775c
JM		 11803 char *vms_filename;
11804 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11805 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 11806
988c775c
JM		 11807 /* Save name for cando by name in VMS format */
11808 cptr = getname(fd, vms_filename, 1);
75796008 11809
988c775c
JM		 11810 /* This should not happen, but just in case */
11811 if (cptr == NULL) {
11812 statbufp->st_devnam[0] = 0;
11813 }
11814 else {
11815 /* Make sure that the saved name fits in 255 characters */
11816 cptr = do_rmsexpand
11817 (vms_filename,
11818 statbufp->st_devnam,
11819 0,
11820 NULL,
360732b5
JM		 11821 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11822 NULL,
11823 NULL);
75796008 11824 if (cptr == NULL)
988c775c 11825 statbufp->st_devnam[0] = 0;
75796008 11826 }
988c775c 11827 PerlMem_free(vms_filename);
682e4b71
JM		 11828
11829 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 11830 VMS_DEVICE_ENCODE
11831 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 11832
61bb5906
CB		 11833# ifdef RTL_USES_UTC
11834# ifdef VMSISH_TIME
11835 if (VMSISH_TIME) {
11836 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11837 statbufp->st_atime = _toloc(statbufp->st_atime);
11838 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11839 }
11840# endif
11841# else
ff0cee69 11842# ifdef VMSISH_TIME
11843 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11844# else
11845 if (1) {
11846# endif
61bb5906
CB		 11847 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11848 statbufp->st_atime = _toutc(statbufp->st_atime);
11849 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 11850 }
61bb5906 11851#endif
b7ae7a0d 11852 return 0;
11853 }
11854 return -1;
748a9306
LW		 11855
11856} /* end of flex_fstat() */
11857/*}}}*/
11858
2497a41f
JM		 11859#if !defined(__VAX) && __CRTL_VER >= 80200000
11860#ifdef lstat
11861#undef lstat
11862#endif
11863#else
11864#ifdef lstat
11865#undef lstat
11866#endif
11867#define lstat(_x, _y) stat(_x, _y)
11868#endif
11869
7ded3206
CB		 11870#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11871
2497a41f
JM		 11872static int
11873Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 11874{
988c775c
JM		 11875 char fileified[VMS_MAXRSS];
11876 char temp_fspec[VMS_MAXRSS];
11877 char *save_spec;
bbce6d69 11878 int retval = -1;
9543c6b6 11879 int saved_errno, saved_vaxc_errno;
748a9306 11880
e956e27a 11881 if (!fspec) return retval;
9543c6b6 11882 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
cc077a9f 11883 strcpy(temp_fspec, fspec);
988c775c 11884
2497a41f
JM		 11885 if (decc_bug_devnull != 0) {
11886 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11887 memset(statbufp,0,sizeof *statbufp);
cfcfe586 11888 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 11889 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11890 statbufp->st_uid = 0x00010001;
11891 statbufp->st_gid = 0x0001;
11892 time((time_t *)&statbufp->st_mtime);
11893 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11894 return 0;
11895 }
748a9306
LW		 11896 }
11897
bbce6d69 11898 /* Try for a directory name first. If fspec contains a filename without
61bb5906 11899 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
bbce6d69 11900 * and sea:[wine.dark]water. exist, we prefer the directory here.
11901 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11902 * not sea:[wine.dark]., if the latter exists. If the intended target is
11903 * the file with null type, specify this by calling flex_stat() with
11904 * a '.' at the end of fspec.
2497a41f
JM		 11905 *
11906 * If we are in Posix filespec mode, accept the filename as is.
bbce6d69 11907 */
f36b279d
CB		 11908
11909
11910#if __CRTL_VER >= 70300000 && !defined(__VAX)
11911 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11912 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11913 */
11914 if (!decc_efs_charset)
11915 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11916#endif
11917
2497a41f
JM		 11918#if __CRTL_VER >= 80200000 && !defined(__VAX)
11919 if (decc_posix_compliant_pathnames == 0) {
11920#endif
360732b5 11921 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
2497a41f
JM		 11922 if (lstat_flag == 0)
11923 retval = stat(fileified,(stat_t *) statbufp);
11924 else
11925 retval = lstat(fileified,(stat_t *) statbufp);
988c775c 11926 save_spec = fileified;
748a9306 11927 }
2497a41f
JM		 11928 if (retval) {
11929 if (lstat_flag == 0)
11930 retval = stat(temp_fspec,(stat_t *) statbufp);
11931 else
11932 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 11933 save_spec = temp_fspec;
2497a41f 11934 }
f1db9cda
JM		 11935/*
11936 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11937 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11938 * and lstat was working correctly for the same file.
11939 * The only syntax that was working for stat was "foo:[bar]t.dir".
11940 *
11941 * Other directories with the same syntax worked fine.
11942 * So work around the problem when it shows up here.
11943 */
11944 if (retval) {
11945 int save_errno = errno;
11946 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11947 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11948 retval = stat(fileified, (stat_t *) statbufp);
11949 save_spec = fileified;
11950 }
11951 }
11952 /* Restore the errno value if third stat does not succeed */
11953 if (retval != 0)
11954 errno = save_errno;
11955 }
2497a41f
JM		 11956#if __CRTL_VER >= 80200000 && !defined(__VAX)
11957 } else {
11958 if (lstat_flag == 0)
11959 retval = stat(temp_fspec,(stat_t *) statbufp);
11960 else
11961 retval = lstat(temp_fspec,(stat_t *) statbufp);
988c775c 11962 save_spec = temp_fspec;
2497a41f
JM		 11963 }
11964#endif
f36b279d
CB		 11965
11966#if __CRTL_VER >= 70300000 && !defined(__VAX)
11967 /* As you were... */
11968 if (!decc_efs_charset)
11969 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11970#endif
11971
ff0cee69 11972 if (!retval) {
988c775c 11973 char * cptr;
d584a1c6
JM		 11974 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11975
11976 /* If this is an lstat, do not follow the link */
11977 if (lstat_flag)
11978 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11979
988c775c 11980 cptr = do_rmsexpand
d584a1c6 11981 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
988c775c
JM		 11982 if (cptr == NULL)
11983 statbufp->st_devnam[0] = 0;
11984
682e4b71 11985 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 11986 VMS_DEVICE_ENCODE
11987 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 11988# ifdef RTL_USES_UTC
11989# ifdef VMSISH_TIME
11990 if (VMSISH_TIME) {
11991 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11992 statbufp->st_atime = _toloc(statbufp->st_atime);
11993 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11994 }
11995# endif
11996# else
ff0cee69 11997# ifdef VMSISH_TIME
11998 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11999# else
12000 if (1) {
12001# endif
61bb5906
CB		 12002 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12003 statbufp->st_atime = _toutc(statbufp->st_atime);
12004 statbufp->st_ctime = _toutc(statbufp->st_ctime);
ff0cee69 12005 }
61bb5906 12006# endif
ff0cee69 12007 }
9543c6b6
CB		 12008 /* If we were successful, leave errno where we found it */
12009 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
748a9306
LW		 12010 return retval;
12011
2497a41f
JM		 12012} /* end of flex_stat_int() */
12013
12014
12015/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12016int
12017Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12018{
7ded3206 12019 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12020}
12021/*}}}*/
12022
12023/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12024int
12025Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12026{
7ded3206 12027 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12028}
748a9306
LW		 12029/*}}}*/
12030
b7ae7a0d 12031
c07a80fd 12032/*{{{char *my_getlogin()*/
12033/* VMS cuserid == Unix getlogin, except calling sequence */
12034char *
2fbb330f 12035my_getlogin(void)
c07a80fd 12036{
12037 static char user[L_cuserid];
12038 return cuserid(user);
12039}
12040/*}}}*/
12041
12042
a5f75d66
AD		 12043/* rmscopy - copy a file using VMS RMS routines
12044 *
12045 * Copies contents and attributes of spec_in to spec_out, except owner
12046 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12047 * defaults for spec_out. The third parameter specifies whether rmscopy()
12048 * should try to propagate timestamps from the input file to the output file.
12049 * If it is less than 0, no timestamps are preserved. If it is 0, then
12050 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12051 * propagated to the output file at creation iff the output file specification
12052 * did not contain an explicit name or type, and the revision date is always
12053 * updated at the end of the copy operation. If it is greater than 0, then
12054 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12055 * other than the revision date should be propagated, and bit 1 indicates
12056 * that the revision date should be propagated.
12057 *
12058 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12059 *
bd3fa61c 12060 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12061 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12062 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12063 * as part of the Perl standard distribution under the terms of the
12064 * GNU General Public License or the Perl Artistic License. Copies
12065 * of each may be found in the Perl standard distribution.
a480973c 12066 */ /* FIXME */
a3e9d8c9 12067/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12068int
12069Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12070{
d584a1c6
JM		 12071 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12072 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
a480973c 12073 unsigned long int i, sts, sts2;
a1887106 12074 int dna_len;
a480973c
JM		 12075 struct FAB fab_in, fab_out;
12076 struct RAB rab_in, rab_out;
a1887106
JM		 12077 rms_setup_nam(nam);
12078 rms_setup_nam(nam_out);
a480973c
JM		 12079 struct XABDAT xabdat;
12080 struct XABFHC xabfhc;
12081 struct XABRDT xabrdt;
12082 struct XABSUM xabsum;
12083
c5375c28
JM		 12084 vmsin = PerlMem_malloc(VMS_MAXRSS);
12085 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12086 vmsout = PerlMem_malloc(VMS_MAXRSS);
12087 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
360732b5
JM		 12088 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12089 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
c5375c28
JM		 12090 PerlMem_free(vmsin);
12091 PerlMem_free(vmsout);
a480973c
JM		 12092 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12093 return 0;
12094 }
12095
b1a8dcd7 12096 esa = PerlMem_malloc(VMS_MAXRSS);
c5375c28 12097 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12098 esal = NULL;
12099#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12100 esal = PerlMem_malloc(VMS_MAXRSS);
12101 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12102#endif
a480973c 12103 fab_in = cc$rms_fab;
a1887106 12104 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12105 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12106 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12107 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12108 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12109 fab_in.fab$l_xab = (void *) &xabdat;
12110
b1a8dcd7 12111 rsa = PerlMem_malloc(VMS_MAXRSS);
c5375c28 12112 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12113 rsal = NULL;
12114#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12115 rsal = PerlMem_malloc(VMS_MAXRSS);
12116 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12117#endif
12118 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12119 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12120 rms_nam_esl(nam) = 0;
12121 rms_nam_rsl(nam) = 0;
12122 rms_nam_esll(nam) = 0;
12123 rms_nam_rsll(nam) = 0;
a480973c
JM		 12124#ifdef NAM$M_NO_SHORT_UPCASE
12125 if (decc_efs_case_preserve)
a1887106 12126 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12127#endif
12128
12129 xabdat = cc$rms_xabdat; /* To get creation date */
12130 xabdat.xab$l_nxt = (void *) &xabfhc;
12131
12132 xabfhc = cc$rms_xabfhc; /* To get record length */
12133 xabfhc.xab$l_nxt = (void *) &xabsum;
12134
12135 xabsum = cc$rms_xabsum; /* To get key and area information */
12136
12137 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12138 PerlMem_free(vmsin);
12139 PerlMem_free(vmsout);
12140 PerlMem_free(esa);
d584a1c6
JM		 12141 if (esal != NULL)
12142 PerlMem_free(esal);
c5375c28 12143 PerlMem_free(rsa);
d584a1c6
JM		 12144 if (rsal != NULL)
12145 PerlMem_free(rsal);
a480973c
JM		 12146 set_vaxc_errno(sts);
12147 switch (sts) {
12148 case RMS$_FNF: case RMS$_DNF:
12149 set_errno(ENOENT); break;
12150 case RMS$_DIR:
12151 set_errno(ENOTDIR); break;
12152 case RMS$_DEV:
12153 set_errno(ENODEV); break;
12154 case RMS$_SYN:
12155 set_errno(EINVAL); break;
12156 case RMS$_PRV:
12157 set_errno(EACCES); break;
12158 default:
12159 set_errno(EVMSERR);
12160 }
12161 return 0;
12162 }
12163
12164 nam_out = nam;
12165 fab_out = fab_in;
12166 fab_out.fab$w_ifi = 0;
12167 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12168 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12169 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12170 rms_bind_fab_nam(fab_out, nam_out);
12171 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12172 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12173 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
d584a1c6 12174 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 12175 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
d584a1c6
JM		 12176 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12177 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12178 esal_out = NULL;
12179 rsal_out = NULL;
12180#if !defined(__VAX) && defined(NAML$C_MAXRSS)
12181 esal_out = PerlMem_malloc(VMS_MAXRSS);
12182 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12183 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12184 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12185#endif
12186 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12187 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12188
12189 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12190 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12191 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12192 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12193 PerlMem_free(vmsin);
12194 PerlMem_free(vmsout);
12195 PerlMem_free(esa);
d584a1c6
JM		 12196 if (esal != NULL)
12197 PerlMem_free(esal);
c5375c28 12198 PerlMem_free(rsa);
d584a1c6
JM		 12199 if (rsal != NULL)
12200 PerlMem_free(rsal);
c5375c28 12201 PerlMem_free(esa_out);
d584a1c6
JM		 12202 if (esal_out != NULL)
12203 PerlMem_free(esal_out);
12204 PerlMem_free(rsa_out);
12205 if (rsal_out != NULL)
12206 PerlMem_free(rsal_out);
a480973c
JM		 12207 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12208 set_vaxc_errno(sts);
12209 return 0;
12210 }
12211 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12212 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12213 preserve_dates = 1;
a480973c
JM		 12214 }
12215 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12216 preserve_dates =0; /* bitmask from this point forward */
12217
12218 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12219 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12220 PerlMem_free(vmsin);
12221 PerlMem_free(vmsout);
12222 PerlMem_free(esa);
d584a1c6
JM		 12223 if (esal != NULL)
12224 PerlMem_free(esal);
c5375c28 12225 PerlMem_free(rsa);
d584a1c6
JM		 12226 if (rsal != NULL)
12227 PerlMem_free(rsal);
c5375c28 12228 PerlMem_free(esa_out);
d584a1c6
JM		 12229 if (esal_out != NULL)
12230 PerlMem_free(esal_out);
12231 PerlMem_free(rsa_out);
12232 if (rsal_out != NULL)
12233 PerlMem_free(rsal_out);
a480973c
JM		 12234 set_vaxc_errno(sts);
12235 switch (sts) {
12236 case RMS$_DNF:
12237 set_errno(ENOENT); break;
12238 case RMS$_DIR:
12239 set_errno(ENOTDIR); break;
12240 case RMS$_DEV:
12241 set_errno(ENODEV); break;
12242 case RMS$_SYN:
12243 set_errno(EINVAL); break;
12244 case RMS$_PRV:
12245 set_errno(EACCES); break;
12246 default:
12247 set_errno(EVMSERR);
12248 }
12249 return 0;
12250 }
12251 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12252 if (preserve_dates & 2) {
12253 /* sys$close() will process xabrdt, not xabdat */
12254 xabrdt = cc$rms_xabrdt;
12255#ifndef __GNUC__
12256 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12257#else
12258 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12259 * is unsigned long[2], while DECC & VAXC use a struct */
12260 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12261#endif
12262 fab_out.fab$l_xab = (void *) &xabrdt;
12263 }
12264
c5375c28
JM		 12265 ubf = PerlMem_malloc(32256);
12266 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
a480973c
JM		 12267 rab_in = cc$rms_rab;
12268 rab_in.rab$l_fab = &fab_in;
12269 rab_in.rab$l_rop = RAB$M_BIO;
12270 rab_in.rab$l_ubf = ubf;
12271 rab_in.rab$w_usz = 32256;
12272 if (!((sts = sys$connect(&rab_in)) & 1)) {
12273 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12274 PerlMem_free(vmsin);
12275 PerlMem_free(vmsout);
c5375c28 12276 PerlMem_free(ubf);
d584a1c6
JM		 12277 PerlMem_free(esa);
12278 if (esal != NULL)
12279 PerlMem_free(esal);
c5375c28 12280 PerlMem_free(rsa);
d584a1c6
JM		 12281 if (rsal != NULL)
12282 PerlMem_free(rsal);
c5375c28 12283 PerlMem_free(esa_out);
d584a1c6
JM		 12284 if (esal_out != NULL)
12285 PerlMem_free(esal_out);
12286 PerlMem_free(rsa_out);
12287 if (rsal_out != NULL)
12288 PerlMem_free(rsal_out);
a480973c
JM		 12289 set_errno(EVMSERR); set_vaxc_errno(sts);
12290 return 0;
12291 }
12292
12293 rab_out = cc$rms_rab;
12294 rab_out.rab$l_fab = &fab_out;
12295 rab_out.rab$l_rbf = ubf;
12296 if (!((sts = sys$connect(&rab_out)) & 1)) {
12297 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12298 PerlMem_free(vmsin);
12299 PerlMem_free(vmsout);
c5375c28 12300 PerlMem_free(ubf);
d584a1c6
JM		 12301 PerlMem_free(esa);
12302 if (esal != NULL)
12303 PerlMem_free(esal);
c5375c28 12304 PerlMem_free(rsa);
d584a1c6
JM		 12305 if (rsal != NULL)
12306 PerlMem_free(rsal);
c5375c28 12307 PerlMem_free(esa_out);
d584a1c6
JM		 12308 if (esal_out != NULL)
12309 PerlMem_free(esal_out);
12310 PerlMem_free(rsa_out);
12311 if (rsal_out != NULL)
12312 PerlMem_free(rsal_out);
a480973c
JM		 12313 set_errno(EVMSERR); set_vaxc_errno(sts);
12314 return 0;
12315 }
12316
12317 while ((sts = sys$read(&rab_in))) { /* always true */
12318 if (sts == RMS$_EOF) break;
12319 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12320 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12321 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12322 PerlMem_free(vmsin);
12323 PerlMem_free(vmsout);
c5375c28 12324 PerlMem_free(ubf);
d584a1c6
JM		 12325 PerlMem_free(esa);
12326 if (esal != NULL)
12327 PerlMem_free(esal);
c5375c28 12328 PerlMem_free(rsa);
d584a1c6
JM		 12329 if (rsal != NULL)
12330 PerlMem_free(rsal);
c5375c28 12331 PerlMem_free(esa_out);
d584a1c6
JM		 12332 if (esal_out != NULL)
12333 PerlMem_free(esal_out);
12334 PerlMem_free(rsa_out);
12335 if (rsal_out != NULL)
12336 PerlMem_free(rsal_out);
a480973c
JM		 12337 set_errno(EVMSERR); set_vaxc_errno(sts);
12338 return 0;
12339 }
12340 }
12341
12342
12343 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12344 sys$close(&fab_in); sys$close(&fab_out);
12345 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12346
c5375c28
JM		 12347 PerlMem_free(vmsin);
12348 PerlMem_free(vmsout);
c5375c28 12349 PerlMem_free(ubf);
d584a1c6
JM		 12350 PerlMem_free(esa);
12351 if (esal != NULL)
12352 PerlMem_free(esal);
c5375c28 12353 PerlMem_free(rsa);
d584a1c6
JM		 12354 if (rsal != NULL)
12355 PerlMem_free(rsal);
c5375c28 12356 PerlMem_free(esa_out);
d584a1c6
JM		 12357 if (esal_out != NULL)
12358 PerlMem_free(esal_out);
12359 PerlMem_free(rsa_out);
12360 if (rsal_out != NULL)
12361 PerlMem_free(rsal_out);
12362
12363 if (!(sts & 1)) {
12364 set_errno(EVMSERR); set_vaxc_errno(sts);
12365 return 0;
12366 }
12367
a480973c
JM		 12368 return 1;
12369
12370} /* end of rmscopy() */
a5f75d66
AD		 12371/*}}}*/
12372
12373
748a9306
LW		 12374/*** The following glue provides 'hooks' to make some of the routines
12375 * from this file available from Perl. These routines are sufficiently
12376 * basic, and are required sufficiently early in the build process,
12377 * that's it's nice to have them available to miniperl as well as the
12378 * full Perl, so they're set up here instead of in an extension. The
12379 * Perl code which handles importation of these names into a given
12380 * package lives in [.VMS]Filespec.pm in @INC.
12381 */
12382
12383void
5c84aa53 12384rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12385{
12386 dXSARGS;
bbce6d69 12387 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12388 STRLEN n_a;
360732b5 12389 int fs_utf8, dfs_utf8;
01b8edb6 12390
360732b5
JM		 12391 fs_utf8 = 0;
12392 dfs_utf8 = 0;
bbce6d69 12393 if (!items || items > 2)
5c84aa53 12394 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12395 fspec = SvPV(ST(0),n_a);
360732b5 12396 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12397 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12398 if (items == 2) {
12399 defspec = SvPV(ST(1),n_a);
12400 dfs_utf8 = SvUTF8(ST(1));
12401 }
12402 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12403 ST(0) = sv_newmortal();
360732b5
JM		 12404 if (rslt != NULL) {
12405 sv_usepvn(ST(0),rslt,strlen(rslt));
12406 if (fs_utf8) {
12407 SvUTF8_on(ST(0));
12408 }
12409 }
740ce14c 12410 XSRETURN(1);
01b8edb6 12411}
12412
12413void
5c84aa53 12414vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12415{
12416 dXSARGS;
12417 char *vmsified;
2d8e6c8d 12418 STRLEN n_a;
360732b5 12419 int utf8_fl;
748a9306 12420
5c84aa53 12421 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12422 utf8_fl = SvUTF8(ST(0));
12423 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12424 ST(0) = sv_newmortal();
360732b5
JM		 12425 if (vmsified != NULL) {
12426 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12427 if (utf8_fl) {
12428 SvUTF8_on(ST(0));
12429 }
12430 }
748a9306
LW		 12431 XSRETURN(1);
12432}
12433
12434void
5c84aa53 12435unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12436{
12437 dXSARGS;
12438 char *unixified;
2d8e6c8d 12439 STRLEN n_a;
360732b5 12440 int utf8_fl;
748a9306 12441
5c84aa53 12442 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12443 utf8_fl = SvUTF8(ST(0));
12444 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12445 ST(0) = sv_newmortal();
360732b5
JM		 12446 if (unixified != NULL) {
12447 sv_usepvn(ST(0),unixified,strlen(unixified));
12448 if (utf8_fl) {
12449 SvUTF8_on(ST(0));
12450 }
12451 }
748a9306
LW		 12452 XSRETURN(1);
12453}
12454
12455void
5c84aa53 12456fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12457{
12458 dXSARGS;
12459 char *fileified;
2d8e6c8d 12460 STRLEN n_a;
360732b5 12461 int utf8_fl;
748a9306 12462
5c84aa53 12463 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12464 utf8_fl = SvUTF8(ST(0));
12465 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12466 ST(0) = sv_newmortal();
360732b5
JM		 12467 if (fileified != NULL) {
12468 sv_usepvn(ST(0),fileified,strlen(fileified));
12469 if (utf8_fl) {
12470 SvUTF8_on(ST(0));
12471 }
12472 }
748a9306
LW		 12473 XSRETURN(1);
12474}
12475
12476void
5c84aa53 12477pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12478{
12479 dXSARGS;
12480 char *pathified;
2d8e6c8d 12481 STRLEN n_a;
360732b5 12482 int utf8_fl;
748a9306 12483
5c84aa53 12484 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12485 utf8_fl = SvUTF8(ST(0));
12486 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12487 ST(0) = sv_newmortal();
360732b5
JM		 12488 if (pathified != NULL) {
12489 sv_usepvn(ST(0),pathified,strlen(pathified));
12490 if (utf8_fl) {
12491 SvUTF8_on(ST(0));
12492 }
12493 }
748a9306
LW		 12494 XSRETURN(1);
12495}
12496
12497void
5c84aa53 12498vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12499{
12500 dXSARGS;
12501 char *vmspath;
2d8e6c8d 12502 STRLEN n_a;
360732b5 12503 int utf8_fl;
748a9306 12504
5c84aa53 12505 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12506 utf8_fl = SvUTF8(ST(0));
12507 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12508 ST(0) = sv_newmortal();
360732b5
JM		 12509 if (vmspath != NULL) {
12510 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12511 if (utf8_fl) {
12512 SvUTF8_on(ST(0));
12513 }
12514 }
748a9306
LW		 12515 XSRETURN(1);
12516}
12517
12518void
5c84aa53 12519unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12520{
12521 dXSARGS;
12522 char *unixpath;
2d8e6c8d 12523 STRLEN n_a;
360732b5 12524 int utf8_fl;
748a9306 12525
5c84aa53 12526 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12527 utf8_fl = SvUTF8(ST(0));
12528 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12529 ST(0) = sv_newmortal();
360732b5
JM		 12530 if (unixpath != NULL) {
12531 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12532 if (utf8_fl) {
12533 SvUTF8_on(ST(0));
12534 }
12535 }
748a9306
LW		 12536 XSRETURN(1);
12537}
12538
12539void
5c84aa53 12540candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12541{
12542 dXSARGS;
988c775c 12543 char *fspec, *fsp;
a5f75d66
AD		 12544 SV *mysv;
12545 IO *io;
2d8e6c8d 12546 STRLEN n_a;
748a9306 12547
5c84aa53 12548 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12549
12550 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12551 Newx(fspec, VMS_MAXRSS, char);
12552 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
a5f75d66 12553 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12554 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12555 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12556 ST(0) = &PL_sv_no;
988c775c 12557 Safefree(fspec);
a5f75d66
AD		 12558 XSRETURN(1);
12559 }
12560 fsp = fspec;
12561 }
12562 else {
2d8e6c8d 12563 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 12564 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12565 ST(0) = &PL_sv_no;
988c775c 12566 Safefree(fspec);
a5f75d66
AD		 12567 XSRETURN(1);
12568 }
12569 }
12570
54310121 12571 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12572 Safefree(fspec);
a5f75d66
AD		 12573 XSRETURN(1);
12574}
12575
12576void
5c84aa53 12577rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12578{
12579 dXSARGS;
a480973c 12580 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12581 int date_flag;
a5f75d66
AD		 12582 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12583 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12584 unsigned long int sts;
12585 SV *mysv;
12586 IO *io;
2d8e6c8d 12587 STRLEN n_a;
a5f75d66 12588
a3e9d8c9 12589 if (items < 2 || items > 3)
5c84aa53 12590 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12591
12592 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12593 Newx(inspec, VMS_MAXRSS, char);
a5f75d66 12594 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12595 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12596 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12597 ST(0) = &PL_sv_no;
a480973c 12598 Safefree(inspec);
a5f75d66
AD		 12599 XSRETURN(1);
12600 }
12601 inp = inspec;
12602 }
12603 else {
2d8e6c8d 12604 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 12605 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12606 ST(0) = &PL_sv_no;
a480973c 12607 Safefree(inspec);
a5f75d66
AD		 12608 XSRETURN(1);
12609 }
12610 }
12611 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12612 Newx(outspec, VMS_MAXRSS, char);
a5f75d66 12613 if (SvTYPE(mysv) == SVt_PVGV) {
a15cef0c 12614 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12615 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12616 ST(0) = &PL_sv_no;
a480973c
JM		 12617 Safefree(inspec);
12618 Safefree(outspec);
a5f75d66
AD		 12619 XSRETURN(1);
12620 }
12621 outp = outspec;
12622 }
12623 else {
2d8e6c8d 12624 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12625 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12626 ST(0) = &PL_sv_no;
a480973c
JM		 12627 Safefree(inspec);
12628 Safefree(outspec);
a5f75d66
AD		 12629 XSRETURN(1);
12630 }
12631 }
a3e9d8c9 12632 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12633
54310121 12634 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
a480973c
JM		 12635 Safefree(inspec);
12636 Safefree(outspec);
748a9306
LW		 12637 XSRETURN(1);
12638}
12639
a480973c
JM		 12640/* The mod2fname is limited to shorter filenames by design, so it should
12641 * not be modified to support longer EFS pathnames
12642 */
4b19af01 12643void
fd8cd3a3 12644mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12645{
12646 dXSARGS;
12647 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12648 workbuff[NAM$C_MAXRSS*1 + 1];
12649 int total_namelen = 3, counter, num_entries;
12650 /* ODS-5 ups this, but we want to be consistent, so... */
12651 int max_name_len = 39;
12652 AV *in_array = (AV *)SvRV(ST(0));
12653
12654 num_entries = av_len(in_array);
12655
12656 /* All the names start with PL_. */
12657 strcpy(ultimate_name, "PL_");
12658
12659 /* Clean up our working buffer */
12660 Zero(work_name, sizeof(work_name), char);
12661
12662 /* Run through the entries and build up a working name */
12663 for(counter = 0; counter <= num_entries; counter++) {
12664 /* If it's not the first name then tack on a __ */
12665 if (counter) {
12666 strcat(work_name, "__");
12667 }
12668 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12669 PL_na));
12670 }
12671
12672 /* Check to see if we actually have to bother...*/
12673 if (strlen(work_name) + 3 <= max_name_len) {
12674 strcat(ultimate_name, work_name);
12675 } else {
12676 /* It's too darned big, so we need to go strip. We use the same */
12677 /* algorithm as xsubpp does. First, strip out doubled __ */
12678 char *source, *dest, last;
12679 dest = workbuff;
12680 last = 0;
12681 for (source = work_name; *source; source++) {
12682 if (last == *source && last == '_') {
12683 continue;
12684 }
12685 *dest++ = *source;
12686 last = *source;
12687 }
12688 /* Go put it back */
12689 strcpy(work_name, workbuff);
12690 /* Is it still too big? */
12691 if (strlen(work_name) + 3 > max_name_len) {
12692 /* Strip duplicate letters */
12693 last = 0;
12694 dest = workbuff;
12695 for (source = work_name; *source; source++) {
12696 if (last == toupper(*source)) {
12697 continue;
12698 }
12699 *dest++ = *source;
12700 last = toupper(*source);
12701 }
12702 strcpy(work_name, workbuff);
12703 }
12704
12705 /* Is it *still* too big? */
12706 if (strlen(work_name) + 3 > max_name_len) {
12707 /* Too bad, we truncate */
12708 work_name[max_name_len - 2] = 0;
12709 }
12710 strcat(ultimate_name, work_name);
12711 }
12712
12713 /* Okay, return it */
12714 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12715 XSRETURN(1);
12716}
12717
748a9306 12718void
96e176bf
CL		 12719hushexit_fromperl(pTHX_ CV *cv)
12720{
12721 dXSARGS;
12722
12723 if (items > 0) {
12724 VMSISH_HUSHED = SvTRUE(ST(0));
12725 }
12726 ST(0) = boolSV(VMSISH_HUSHED);
12727 XSRETURN(1);
12728}
12729
dca5a913
JM		 12730
12731PerlIO *
12732Perl_vms_start_glob
12733 (pTHX_ SV *tmpglob,
12734 IO *io)
12735{
12736 PerlIO *fp;
12737 struct vs_str_st *rslt;
12738 char *vmsspec;
12739 char *rstr;
12740 char *begin, *cp;
12741 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12742 PerlIO *tmpfp;
12743 STRLEN i;
12744 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12745 struct dsc$descriptor_vs rsdsc;
12746 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12747 unsigned long hasver = 0, isunix = 0;
12748 unsigned long int lff_flags = 0;
12749 int rms_sts;
12750
12751#ifdef VMS_LONGNAME_SUPPORT
12752 lff_flags = LIB$M_FIL_LONG_NAMES;
12753#endif
12754 /* The Newx macro will not allow me to assign a smaller array
12755 * to the rslt pointer, so we will assign it to the begin char pointer
12756 * and then copy the value into the rslt pointer.
12757 */
12758 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12759 rslt = (struct vs_str_st *)begin;
12760 rslt->length = 0;
12761 rstr = &rslt->str[0];
12762 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12763 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12764 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12765 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12766
12767 Newx(vmsspec, VMS_MAXRSS, char);
12768
12769 /* We could find out if there's an explicit dev/dir or version
12770 by peeking into lib$find_file's internal context at
12771 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12772 but that's unsupported, so I don't want to do it now and
12773 have it bite someone in the future. */
12774 /* Fix-me: vms_split_path() is the only way to do this, the
12775 existing method will fail with many legal EFS or UNIX specifications
12776 */
12777
12778 cp = SvPV(tmpglob,i);
12779
12780 for (; i; i--) {
12781 if (cp[i] == ';') hasver = 1;
12782 if (cp[i] == '.') {
12783 if (sts) hasver = 1;
12784 else sts = 1;
12785 }
12786 if (cp[i] == '/') {
12787 hasdir = isunix = 1;
12788 break;
12789 }
12790 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12791 hasdir = 1;
12792 break;
12793 }
12794 }
12795 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
990cad08 12796 int found = 0;
dca5a913
JM		 12797 Stat_t st;
12798 int stat_sts;
12799 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12800 if (!stat_sts && S_ISDIR(st.st_mode)) {
360732b5 12801 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913 12802 ok = (wilddsc.dsc$a_pointer != NULL);
ff675744
CB		 12803 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12804 hasdir = 1;
dca5a913
JM		 12805 }
12806 else {
360732b5 12807 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 12808 ok = (wilddsc.dsc$a_pointer != NULL);
12809 }
12810 if (ok)
12811 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12812
12813 /* If not extended character set, replace ? with % */
12814 /* With extended character set, ? is a wildcard single character */
12815 if (!decc_efs_case_preserve) {
12816 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12817 if (*cp == '?') *cp = '%';
12818 }
12819 sts = SS$_NORMAL;
12820 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12821 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12822 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12823
12824 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12825 &dfltdsc,NULL,&rms_sts,&lff_flags);
12826 if (!$VMS_STATUS_SUCCESS(sts))
12827 break;
12828
990cad08
CB		 12829 found++;
12830
dca5a913
JM		 12831 /* with varying string, 1st word of buffer contains result length */
12832 rstr[rslt->length] = '\0';
12833
12834 /* Find where all the components are */
12835 v_sts = vms_split_path
360732b5 12836 (rstr,
dca5a913
JM		 12837 &v_spec,
12838 &v_len,
12839 &r_spec,
12840 &r_len,
12841 &d_spec,
12842 &d_len,
12843 &n_spec,
12844 &n_len,
12845 &e_spec,
12846 &e_len,
12847 &vs_spec,
12848 &vs_len);
12849
12850 /* If no version on input, truncate the version on output */
12851 if (!hasver && (vs_len > 0)) {
12852 *vs_spec = '\0';
12853 vs_len = 0;
12854
12855 /* No version & a null extension on UNIX handling */
12856 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12857 e_len = 0;
12858 *e_spec = '\0';
12859 }
12860 }
12861
12862 if (!decc_efs_case_preserve) {
12863 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12864 }
12865
12866 if (hasdir) {
12867 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12868 begin = rstr;
12869 }
12870 else {
12871 /* Start with the name */
12872 begin = n_spec;
12873 }
12874 strcat(begin,"\n");
12875 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12876 }
12877 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 12878
12879 if (!found) {
12880 /* Be POSIXish: return the input pattern when no matches */
2da7a6b5
CB		 12881 strcpy(rstr,SvPVX(tmpglob));
12882 strcat(rstr,"\n");
12883 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 12884 }
12885
dca5a913
JM		 12886 if (ok && sts != RMS$_NMF &&
12887 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12888 if (!ok) {
12889 if (!(sts & 1)) {
12890 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12891 }
12892 PerlIO_close(tmpfp);
12893 fp = NULL;
12894 }
12895 else {
12896 PerlIO_rewind(tmpfp);
12897 IoTYPE(io) = IoTYPE_RDONLY;
12898 IoIFP(io) = fp = tmpfp;
12899 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12900 }
12901 }
12902 Safefree(vmsspec);
12903 Safefree(rslt);
12904 return fp;
12905}
12906
cd1191f1 12907
2497a41f 12908static char *
5c4d031a 12909mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 12910 int *utf8_fl);
2497a41f
JM		 12911
12912void
12913vms_realpath_fromperl(pTHX_ CV *cv)
12914{
d584a1c6
JM		 12915 dXSARGS;
12916 char *fspec, *rslt_spec, *rslt;
12917 STRLEN n_a;
2497a41f 12918
d584a1c6
JM		 12919 if (!items || items != 1)
12920 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
2497a41f 12921
d584a1c6
JM		 12922 fspec = SvPV(ST(0),n_a);
12923 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 12924
d584a1c6
JM		 12925 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12926 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12927
12928 ST(0) = sv_newmortal();
12929 if (rslt != NULL)
12930 sv_usepvn(ST(0),rslt,strlen(rslt));
12931 else
12932 Safefree(rslt_spec);
12933 XSRETURN(1);
2497a41f 12934}
2ee6e19d 12935
b1a8dcd7
JM		 12936static char *
12937mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12938 int *utf8_fl);
12939
12940void
12941vms_realname_fromperl(pTHX_ CV *cv)
12942{
12943 dXSARGS;
12944 char *fspec, *rslt_spec, *rslt;
12945 STRLEN n_a;
12946
12947 if (!items || items != 1)
12948 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realname(spec)");
12949
12950 fspec = SvPV(ST(0),n_a);
12951 if (!fspec || !*fspec) XSRETURN_UNDEF;
12952
12953 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12954 rslt = do_vms_realname(fspec, rslt_spec, NULL);
12955
12956 ST(0) = sv_newmortal();
12957 if (rslt != NULL)
12958 sv_usepvn(ST(0),rslt,strlen(rslt));
12959 else
12960 Safefree(rslt_spec);
12961 XSRETURN(1);
12962}
12963
12964#ifdef HAS_SYMLINK
2ee6e19d
CB		 12965/*
12966 * A thin wrapper around decc$symlink to make sure we follow the
12967 * standard and do not create a symlink with a zero-length name.
12968 */
12969/*{{{ int my_symlink(const char *path1, const char *path2)*/
12970int my_symlink(const char *path1, const char *path2) {
12971 if (!path2 || !*path2) {
12972 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12973 return -1;
12974 }
12975 return symlink(path1, path2);
12976}
12977/*}}}*/
12978
12979#endif /* HAS_SYMLINK */
2497a41f 12980
2497a41f
JM		 12981int do_vms_case_tolerant(void);
12982
12983void
12984vms_case_tolerant_fromperl(pTHX_ CV *cv)
12985{
12986 dXSARGS;
12987 ST(0) = boolSV(do_vms_case_tolerant());
12988 XSRETURN(1);
12989}
2497a41f 12990
96e176bf
CL		 12991void
12992Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12993 struct interp_intern *dst)
12994{
12995 memcpy(dst,src,sizeof(struct interp_intern));
12996}
12997
12998void
12999Perl_sys_intern_clear(pTHX)
13000{
13001}
13002
13003void
13004Perl_sys_intern_init(pTHX)
13005{
3ff49832
CL		 13006 unsigned int ix = RAND_MAX;
13007 double x;
96e176bf
CL		 13008
13009 VMSISH_HUSHED = 0;
13010
7a7fd8e0
JM		 13011 /* fix me later to track running under GNV */
13012 /* this allows some limited testing */
13013 MY_POSIX_EXIT = decc_filename_unix_report;
13014
96e176bf
CL		 13015 x = (float)ix;
13016 MY_INV_RAND_MAX = 1./x;
ff7adb52 13017}
96e176bf
CL		 13018
13019void
f7ddb74a 13020init_os_extras(void)
748a9306 13021{
a69a6dba 13022 dTHX;
748a9306 13023 char* file = __FILE__;
988c775c 13024 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 13025 no_translate_barewords = TRUE;
13026 } else {
13027 no_translate_barewords = FALSE;
13028 }
748a9306 13029
740ce14c 13030 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13031 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13032 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13033 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13034 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13035 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13036 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13037 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13038 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13039 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13040 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
f7ddb74a 13041 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
b1a8dcd7 13042 newXSproto("VMS::Filespec::vms_realname",vms_realname_fromperl,file,"$;$");
d584a1c6
JM		 13043 newXSproto("VMS::Filepec::vms_case_tolerant",
13044 vms_case_tolerant_fromperl, file, "$");
17f28c40 13045
afd8f436 13046 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13047
748a9306
LW		 13048 return;
13049}
13050
f7ddb74a
JM		 13051#if __CRTL_VER == 80200000
13052/* This missed getting in to the DECC SDK for 8.2 */
13053char *realpath(const char *file_name, char * resolved_name, ...);
13054#endif
13055
13056/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13057/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13058 * The perl fallback routine to provide realpath() is not as efficient
13059 * on OpenVMS.
13060 */
d584a1c6
JM		 13061
13062/* Hack, use old stat() as fastest way of getting ino_t and device */
13063int decc$stat(const char *name, void * statbuf);
13064
13065
13066/* Realpath is fragile. In 8.3 it does not work if the feature
13067 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13068 * links are implemented in RMS, not the CRTL. It also can fail if the
13069 * user does not have read/execute access to some of the directories.
13070 * So in order for Do What I Mean mode to work, if realpath() fails,
13071 * fall back to looking up the filename by the device name and FID.
13072 */
13073
13074int vms_fid_to_name(char * outname, int outlen, const char * name)
13075{
13076struct statbuf_t {
13077 char * st_dev;
b1a8dcd7 13078 unsigned short st_ino[3];
d584a1c6
JM		 13079 unsigned short padw;
13080 unsigned long padl[30]; /* plenty of room */
13081} statbuf;
13082int sts;
13083struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13084struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13085
13086 sts = decc$stat(name, &statbuf);
13087 if (sts == 0) {
13088
13089 dvidsc.dsc$a_pointer=statbuf.st_dev;
13090 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13091
13092 specdsc.dsc$a_pointer = outname;
13093 specdsc.dsc$w_length = outlen-1;
13094
13095 sts = lib$fid_to_name
13096 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13097 if ($VMS_STATUS_SUCCESS(sts)) {
13098 outname[specdsc.dsc$w_length] = 0;
13099 return 0;
13100 }
13101 }
13102 return sts;
13103}
13104
13105
13106
f7ddb74a 13107static char *
5c4d031a 13108mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13109 int *utf8_fl)
f7ddb74a 13110{
d584a1c6
JM		 13111 char * rslt = NULL;
13112
b1a8dcd7
JM		 13113#ifdef HAS_SYMLINK
13114 if (decc_posix_compliant_pathnames > 0 ) {
13115 /* realpath currently only works if posix compliant pathnames are
13116 * enabled. It may start working when they are not, but in that
13117 * case we still want the fallback behavior for backwards compatibility
13118 */
d584a1c6 13119 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13120 }
13121#endif
d584a1c6
JM		 13122
13123 if (rslt == NULL) {
13124 char * vms_spec;
13125 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13126 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13127 int file_len;
13128
13129 /* Fall back to fid_to_name */
13130
13131 Newx(vms_spec, VMS_MAXRSS + 1, char);
13132
13133 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13134 if (sts == 0) {
13135
13136
13137 /* Now need to trim the version off */
13138 sts = vms_split_path
13139 (vms_spec,
13140 &v_spec,
13141 &v_len,
13142 &r_spec,
13143 &r_len,
13144 &d_spec,
13145 &d_len,
13146 &n_spec,
13147 &n_len,
13148 &e_spec,
13149 &e_len,
13150 &vs_spec,
13151 &vs_len);
13152
13153
13154 if (sts == 0) {
13155 int file_len;
13156
13157 /* Trim off the version */
13158 file_len = v_len + r_len + d_len + n_len + e_len;
13159 vms_spec[file_len] = 0;
13160
13161 /* The result is expected to be in UNIX format */
13162 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13163 }
13164 }
13165
13166 Safefree(vms_spec);
13167 }
13168 return rslt;
f7ddb74a
JM		 13169}
13170
b1a8dcd7
JM		 13171static char *
13172mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13173 int *utf8_fl)
13174{
13175 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13176 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13177 int file_len;
13178
13179 /* Fall back to fid_to_name */
13180
13181 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
cd43acd7
CB		 13182 if (sts != 0) {
13183 return NULL;
13184 }
13185 else {
b1a8dcd7
JM		 13186
13187
13188 /* Now need to trim the version off */
13189 sts = vms_split_path
13190 (outbuf,
13191 &v_spec,
13192 &v_len,
13193 &r_spec,
13194 &r_len,
13195 &d_spec,
13196 &d_len,
13197 &n_spec,
13198 &n_len,
13199 &e_spec,
13200 &e_len,
13201 &vs_spec,
13202 &vs_len);
13203
13204
13205 if (sts == 0) {
13206 int file_len;
13207
13208 /* Trim off the version */
13209 file_len = v_len + r_len + d_len + n_len + e_len;
13210 outbuf[file_len] = 0;
13211 }
13212 }
13213 return outbuf;
13214}
13215
13216
f7ddb74a
JM		 13217/*}}}*/
13218/* External entry points */
360732b5
JM		 13219char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13220{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
f7ddb74a 13221
b1a8dcd7
JM		 13222char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13223{ return do_vms_realname(filespec, outbuf, utf8_fl); }
f7ddb74a 13224
f7ddb74a
JM		 13225/* case_tolerant */
13226
13227/*{{{int do_vms_case_tolerant(void)*/
13228/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13229 * controlled by a process setting.
13230 */
13231int do_vms_case_tolerant(void)
13232{
13233 return vms_process_case_tolerant;
13234}
13235/*}}}*/
13236/* External entry points */
b1a8dcd7 13237#if __CRTL_VER >= 70301000 && !defined(__VAX)
f7ddb74a
JM		 13238int Perl_vms_case_tolerant(void)
13239{ return do_vms_case_tolerant(); }
13240#else
13241int Perl_vms_case_tolerant(void)
13242{ return vms_process_case_tolerant; }
13243#endif
13244
13245
13246 /* Start of DECC RTL Feature handling */
13247
13248static int sys_trnlnm
13249 (const char * logname,
13250 char * value,
13251 int value_len)
13252{
13253 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13254 const unsigned long attr = LNM$M_CASE_BLIND;
13255 struct dsc$descriptor_s name_dsc;
13256 int status;
13257 unsigned short result;
13258 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13259 {0, 0, 0, 0}};
13260
13261 name_dsc.dsc$w_length = strlen(logname);
13262 name_dsc.dsc$a_pointer = (char *)logname;
13263 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13264 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13265
13266 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13267
13268 if ($VMS_STATUS_SUCCESS(status)) {
13269
13270 /* Null terminate and return the string */
13271 /*--------------------------------------*/
13272 value[result] = 0;
13273 }
13274
13275 return status;
13276}
13277
13278static int sys_crelnm
13279 (const char * logname,
13280 const char * value)
13281{
13282 int ret_val;
13283 const char * proc_table = "LNM$PROCESS_TABLE";
13284 struct dsc$descriptor_s proc_table_dsc;
13285 struct dsc$descriptor_s logname_dsc;
13286 struct itmlst_3 item_list[2];
13287
13288 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13289 proc_table_dsc.dsc$w_length = strlen(proc_table);
13290 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13291 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13292
13293 logname_dsc.dsc$a_pointer = (char *) logname;
13294 logname_dsc.dsc$w_length = strlen(logname);
13295 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13296 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13297
13298 item_list[0].buflen = strlen(value);
13299 item_list[0].itmcode = LNM$_STRING;
13300 item_list[0].bufadr = (char *)value;
13301 item_list[0].retlen = NULL;
13302
13303 item_list[1].buflen = 0;
13304 item_list[1].itmcode = 0;
13305
13306 ret_val = sys$crelnm
13307 (NULL,
13308 (const struct dsc$descriptor_s *)&proc_table_dsc,
13309 (const struct dsc$descriptor_s *)&logname_dsc,
13310 NULL,
13311 (const struct item_list_3 *) item_list);
13312
13313 return ret_val;
13314}
13315
f7ddb74a
JM		 13316/* C RTL Feature settings */
13317
13318static int set_features
13319 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13320 int (* cli_routine)(void), /* Not documented */
13321 void *image_info) /* Not documented */
13322{
13323 int status;
13324 int s;
13325 int dflt;
13326 char* str;
13327 char val_str[10];
3c841f20 13328#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13329 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13330 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13331 unsigned long case_perm;
13332 unsigned long case_image;
3c841f20 13333#endif
f7ddb74a 13334
9c1171d1
JM		 13335 /* Allow an exception to bring Perl into the VMS debugger */
13336 vms_debug_on_exception = 0;
13337 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13338 if ($VMS_STATUS_SUCCESS(status)) {
13339 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13340 vms_debug_on_exception = 1;
13341 else
13342 vms_debug_on_exception = 0;
13343 }
13344
38a44b82 13345 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5
JM		 13346 vms_vtf7_filenames = 0;
13347 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13348 if ($VMS_STATUS_SUCCESS(status)) {
13349 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13350 vms_vtf7_filenames = 1;
13351 else
13352 vms_vtf7_filenames = 0;
13353 }
13354
e0e5e8d6
JM		 13355
13356 /* unlink all versions on unlink() or rename() */
d584a1c6 13357 vms_unlink_all_versions = 0;
e0e5e8d6
JM		 13358 status = sys_trnlnm
13359 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13360 if ($VMS_STATUS_SUCCESS(status)) {
13361 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13362 vms_unlink_all_versions = 1;
13363 else
13364 vms_unlink_all_versions = 0;
13365 }
13366
360732b5
JM		 13367 /* Dectect running under GNV Bash or other UNIX like shell */
13368#if __CRTL_VER >= 70300000 && !defined(__VAX)
13369 gnv_unix_shell = 0;
13370 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13371 if ($VMS_STATUS_SUCCESS(status)) {
13372 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13373 gnv_unix_shell = 1;
13374 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13375 set_feature_default("DECC$EFS_CHARSET", 1);
13376 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13377 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13378 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13379 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13380 vms_unlink_all_versions = 1;
360732b5
JM		 13381 }
13382 else
13383 gnv_unix_shell = 0;
13384 }
13385#endif
9c1171d1 13386
2497a41f
JM		 13387 /* hacks to see if known bugs are still present for testing */
13388
13389 /* Readdir is returning filenames in VMS syntax always */
13390 decc_bug_readdir_efs1 = 1;
13391 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13392 if ($VMS_STATUS_SUCCESS(status)) {
13393 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13394 decc_bug_readdir_efs1 = 1;
13395 else
13396 decc_bug_readdir_efs1 = 0;
13397 }
13398
13399 /* PCP mode requires creating /dev/null special device file */
2623a4a6 13400 decc_bug_devnull = 0;
2497a41f
JM		 13401 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13402 if ($VMS_STATUS_SUCCESS(status)) {
13403 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13404 decc_bug_devnull = 1;
682e4b71
JM		 13405 else
13406 decc_bug_devnull = 0;
2497a41f
JM		 13407 }
13408
13409 /* fgetname returning a VMS name in UNIX mode */
13410 decc_bug_fgetname = 1;
13411 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13412 if ($VMS_STATUS_SUCCESS(status)) {
13413 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13414 decc_bug_fgetname = 1;
13415 else
13416 decc_bug_fgetname = 0;
13417 }
13418
13419 /* UNIX directory names with no paths are broken in a lot of places */
13420 decc_dir_barename = 1;
13421 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13422 if ($VMS_STATUS_SUCCESS(status)) {
13423 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13424 decc_dir_barename = 1;
13425 else
13426 decc_dir_barename = 0;
13427 }
13428
f7ddb74a
JM		 13429#if __CRTL_VER >= 70300000 && !defined(__VAX)
13430 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13431 if (s >= 0) {
13432 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13433 if (decc_disable_to_vms_logname_translation < 0)
13434 decc_disable_to_vms_logname_translation = 0;
13435 }
13436
13437 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13438 if (s >= 0) {
13439 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13440 if (decc_efs_case_preserve < 0)
13441 decc_efs_case_preserve = 0;
13442 }
13443
13444 s = decc$feature_get_index("DECC$EFS_CHARSET");
13445 if (s >= 0) {
13446 decc_efs_charset = decc$feature_get_value(s, 1);
13447 if (decc_efs_charset < 0)
13448 decc_efs_charset = 0;
13449 }
13450
13451 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13452 if (s >= 0) {
13453 decc_filename_unix_report = decc$feature_get_value(s, 1);
13454 if (decc_filename_unix_report > 0)
13455 decc_filename_unix_report = 1;
13456 else
13457 decc_filename_unix_report = 0;
13458 }
13459
13460 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13461 if (s >= 0) {
13462 decc_filename_unix_only = decc$feature_get_value(s, 1);
13463 if (decc_filename_unix_only > 0) {
13464 decc_filename_unix_only = 1;
13465 }
13466 else {
13467 decc_filename_unix_only = 0;
13468 }
13469 }
13470
13471 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13472 if (s >= 0) {
13473 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13474 if (decc_filename_unix_no_version < 0)
13475 decc_filename_unix_no_version = 0;
13476 }
13477
13478 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13479 if (s >= 0) {
13480 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13481 if (decc_readdir_dropdotnotype < 0)
13482 decc_readdir_dropdotnotype = 0;
13483 }
13484
13485 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13486 if ($VMS_STATUS_SUCCESS(status)) {
13487 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13488 if (s >= 0) {
13489 dflt = decc$feature_get_value(s, 4);
13490 if (dflt > 0) {
13491 decc_disable_posix_root = decc$feature_get_value(s, 1);
13492 if (decc_disable_posix_root <= 0) {
13493 decc$feature_set_value(s, 1, 1);
13494 decc_disable_posix_root = 1;
13495 }
13496 }
13497 else {
13498 /* Traditionally Perl assumes this is off */
13499 decc_disable_posix_root = 1;
13500 decc$feature_set_value(s, 1, 1);
13501 }
13502 }
13503 }
13504
13505#if __CRTL_VER >= 80200000
13506 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13507 if (s >= 0) {
13508 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13509 if (decc_posix_compliant_pathnames < 0)
13510 decc_posix_compliant_pathnames = 0;
13511 if (decc_posix_compliant_pathnames > 4)
13512 decc_posix_compliant_pathnames = 0;
13513 }
13514
13515#endif
13516#else
13517 status = sys_trnlnm
13518 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13519 if ($VMS_STATUS_SUCCESS(status)) {
13520 val_str[0] = _toupper(val_str[0]);
13521 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13522 decc_disable_to_vms_logname_translation = 1;
13523 }
13524 }
13525
13526#ifndef __VAX
13527 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13528 if ($VMS_STATUS_SUCCESS(status)) {
13529 val_str[0] = _toupper(val_str[0]);
13530 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13531 decc_efs_case_preserve = 1;
13532 }
13533 }
13534#endif
13535
13536 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13537 if ($VMS_STATUS_SUCCESS(status)) {
13538 val_str[0] = _toupper(val_str[0]);
13539 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13540 decc_filename_unix_report = 1;
13541 }
13542 }
13543 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13544 if ($VMS_STATUS_SUCCESS(status)) {
13545 val_str[0] = _toupper(val_str[0]);
13546 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13547 decc_filename_unix_only = 1;
13548 decc_filename_unix_report = 1;
13549 }
13550 }
13551 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13552 if ($VMS_STATUS_SUCCESS(status)) {
13553 val_str[0] = _toupper(val_str[0]);
13554 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13555 decc_filename_unix_no_version = 1;
13556 }
13557 }
13558 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13559 if ($VMS_STATUS_SUCCESS(status)) {
13560 val_str[0] = _toupper(val_str[0]);
13561 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13562 decc_readdir_dropdotnotype = 1;
13563 }
13564 }
13565#endif
13566
3c841f20 13567#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13568
13569 /* Report true case tolerance */
13570 /*----------------------------*/
13571 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13572 if (!$VMS_STATUS_SUCCESS(status))
13573 case_perm = PPROP$K_CASE_BLIND;
13574 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13575 if (!$VMS_STATUS_SUCCESS(status))
13576 case_image = PPROP$K_CASE_BLIND;
13577 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13578 (case_image == PPROP$K_CASE_SENSITIVE))
13579 vms_process_case_tolerant = 0;
13580
13581#endif
13582
13583
13584 /* CRTL can be initialized past this point, but not before. */
13585/* DECC$CRTL_INIT(); */
13586
13587 return SS$_NORMAL;
13588}
13589
13590#ifdef __DECC
f7ddb74a
JM		 13591#pragma nostandard
13592#pragma extern_model save
13593#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
f7ddb74a 13594 const __align (LONGWORD) int spare[8] = {0};
dfffea70
CB		 13595
13596/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13597#if __DECC_VER >= 60560002
13598#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13599#else
13600#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
f7ddb74a 13601#endif
dfffea70
CB		 13602#endif /* __DECC */
13603
f7ddb74a
JM		 13604const long vms_cc_features = (const long)set_features;
13605
13606/*
13607** Force a reference to LIB$INITIALIZE to ensure it
13608** exists in the image.
13609*/
13610int lib$initialize(void);
13611#ifdef __DECC
13612#pragma extern_model strict_refdef
13613#endif
13614 int lib_init_ref = (int) lib$initialize;
13615
13616#ifdef __DECC
13617#pragma extern_model restore
13618#pragma standard
13619#endif
13620
748a9306 13621/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.