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
regen/mk_invlists.pl: Rmv extraneous tab in output
[perl5.git] / vms / vms.c
CommitLineData
b429d381 1/* vms.c
a0d0e21e 2 *
82dd182c 3 * VMS-specific routines for perl5
748a9306 4 *
4ae858b0 5 * Copyright (C) 1993-2015 by Charles Bailey and others.
82dd182c
CB		 6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
a0d0e21e
LW		 9 */
10
7c884029 11/*
4ac71550
TC		 12 * Yet small as was their hunted band
13 * still fell and fearless was each hand,
14 * and strong deeds they wrought yet oft,
15 * and loved the woods, whose ways more soft
16 * them seemed than thralls of that black throne
17 * to live and languish in halls of stone.
18 * "The Lay of Leithian", Canto II, lines 135-40
7c884029 19 *
4ac71550 20 * [p.162 of _The Lays of Beleriand_]
7c884029
CB		 21 */
22
a0d0e21e
LW		 23#include <acedef.h>
24#include <acldef.h>
25#include <armdef.h>
26#include <chpdef.h>
8fde5078 27#include <clidef.h>
a3e9d8c9 28#include <climsgdef.h>
cd1191f1 29#include <dcdef.h>
a0d0e21e 30#include <descrip.h>
22d4bb9c 31#include <devdef.h>
a0d0e21e
LW		 32#include <dvidef.h>
33#include <float.h>
34#include <fscndef.h>
35#include <iodef.h>
36#include <jpidef.h>
61bb5906 37#include <kgbdef.h>
f675dbe5 38#include <libclidef.h>
a0d0e21e
LW		 39#include <libdef.h>
40#include <lib$routines.h>
41#include <lnmdef.h>
4fdf8f88 42#include <ossdef.h>
f7ddb74a 43#include <ppropdef.h>
748a9306 44#include <prvdef.h>
96f902ff 45#include <pscandef.h>
a0d0e21e
LW		 46#include <psldef.h>
47#include <rms.h>
48#include <shrdef.h>
49#include <ssdef.h>
50#include <starlet.h>
f86702cc 51#include <strdef.h>
52#include <str$routines.h>
a0d0e21e 53#include <syidef.h>
748a9306
LW		 54#include <uaidef.h>
55#include <uicdef.h>
2fbb330f 56#include <stsdef.h>
cfcfe586
JM		 57#include <efndef.h>
58#define NO_EFN EFN$C_ENF
a0d0e21e 59
f7ddb74a 60#include <unixlib.h>
f7ddb74a 61
cfcfe586
JM		 62#pragma member_alignment save
63#pragma nomember_alignment longword
64struct item_list_3 {
65 unsigned short len;
66 unsigned short code;
67 void * bufadr;
68 unsigned short * retadr;
69};
70#pragma member_alignment restore
71
740ce14c 72/* Older versions of ssdef.h don't have these */
73#ifndef SS$_INVFILFOROP
74# define SS$_INVFILFOROP 3930
75#endif
76#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 77# define SS$_NOSUCHOBJECT 2696
78#endif
79
a15cef0c
CB		 80/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
81#define PERLIO_NOT_STDIO 0
82
2497a41f 83/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 84 * code below needs to get to the underlying CRTL routines. */
85#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 86#include "EXTERN.h"
87#include "perl.h"
748a9306 88#include "XSUB.h"
3eeba6fb
CB		 89/* Anticipating future expansion in lexical warnings . . . */
90#ifndef WARN_INTERNAL
91# define WARN_INTERNAL WARN_MISC
92#endif
a0d0e21e 93
988c775c
JM		 94#ifdef VMS_LONGNAME_SUPPORT
95#include <libfildef.h>
96#endif
97
054a3baf 98#if __CRTL_VER >= 80200000
58472d87
CB		 99#ifdef lstat
100#undef lstat
101#endif
102#else
103#ifdef lstat
104#undef lstat
105#endif
106#define lstat(_x, _y) stat(_x, _y)
107#endif
108
5f1992ed
CB		 109/* Routine to create a decterm for use with the Perl debugger */
110/* No headers, this information was found in the Programming Concepts Manual */
111
8cb5d3d5 112static int (*decw_term_port)
5f1992ed
CB		 113 (const struct dsc$descriptor_s * display,
114 const struct dsc$descriptor_s * setup_file,
115 const struct dsc$descriptor_s * customization,
116 struct dsc$descriptor_s * result_device_name,
117 unsigned short * result_device_name_length,
118 void * controller,
119 void * char_buffer,
8cb5d3d5 120 void * char_change_buffer) = 0;
22d4bb9c 121
c645ec3f
GS		 122#if defined(NEED_AN_H_ERRNO)
123dEXT int h_errno;
124#endif
c07a80fd 125
81bca5f9 126#if defined(__DECC) || defined(__DECCXX)
f7ddb74a
JM		 127#pragma member_alignment save
128#pragma nomember_alignment longword
129#pragma message save
130#pragma message disable misalgndmem
131#endif
a0d0e21e
LW		 132struct itmlst_3 {
133 unsigned short int buflen;
134 unsigned short int itmcode;
135 void *bufadr;
748a9306 136 unsigned short int *retlen;
a0d0e21e 137};
657054d4
JM		 138
139struct filescan_itmlst_2 {
140 unsigned short length;
141 unsigned short itmcode;
142 char * component;
143};
144
dca5a913
JM		 145struct vs_str_st {
146 unsigned short length;
7202b047
CB		 147 char str[VMS_MAXRSS];
148 unsigned short pad; /* for longword struct alignment */
dca5a913
JM		 149};
150
81bca5f9 151#if defined(__DECC) || defined(__DECCXX)
f7ddb74a
JM		 152#pragma message restore
153#pragma member_alignment restore
154#endif
a0d0e21e 155
360732b5
JM		 156#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
157#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
158#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
159#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
160#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
161#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 162#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 163#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
164#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 165#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 166#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
167#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
168
360732b5
JM		 169static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
170static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
171static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
172static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 173
6fb6c614
JM		 174static char * int_rmsexpand_vms(
175 const char * filespec, char * outbuf, unsigned opts);
176static char * int_rmsexpand_tovms(
177 const char * filespec, char * outbuf, unsigned opts);
df278665
JM		 178static char *int_tovmsspec
179 (const char *path, char *buf, int dir_flag, int * utf8_flag);
a979ce91 180static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
0e5ce2c7 181static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
4846f1d7 182static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
df278665 183
0e06870b
CB		 184/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
185#define PERL_LNM_MAX_ALLOWED_INDEX 127
186
2d9f3838
CB		 187/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
188 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
189 * the Perl facility.
190 */
191#define PERL_LNM_MAX_ITER 10
192
2497a41f 193 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
2497a41f
JM		 194#define MAX_DCL_SYMBOL (8192)
195#define MAX_DCL_LINE_LENGTH (4096 - 4)
ff7adb52 196
01b8edb6 197static char *__mystrtolower(char *str)
198{
30048647 199 if (str) for (; *str; ++str) *str= toLOWER_L1(*str);
01b8edb6 200 return str;
201}
202
f675dbe5
CB		 203static struct dsc$descriptor_s fildevdsc =
204 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
205static struct dsc$descriptor_s crtlenvdsc =
206 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
207static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
208static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
209static struct dsc$descriptor_s **env_tables = defenv;
210static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
211
93948341
CB		 212/* True if we shouldn't treat barewords as logicals during directory */
213/* munching */
214static int no_translate_barewords;
215
1d60dc3f
CB		 216/* DECC feature indexes. We grab the indexes at start-up
217 * time for later use with decc$feature_get_value.
f7ddb74a 218 */
1d60dc3f
CB		 219static int disable_to_vms_logname_translation_index = -1;
220static int disable_posix_root_index = -1;
221static int efs_case_preserve_index = -1;
222static int efs_charset_index = -1;
223static int filename_unix_no_version_index = -1;
224static int filename_unix_only_index = -1;
225static int filename_unix_report_index = -1;
226static int posix_compliant_pathnames_index = -1;
227static int readdir_dropdotnotype_index = -1;
228
229#define DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION \
230 (decc$feature_get_value(disable_to_vms_logname_translation_index,__FEATURE_MODE_CURVAL)>0)
231#define DECC_DISABLE_POSIX_ROOT \
232 (decc$feature_get_value(disable_posix_root_index,__FEATURE_MODE_CURVAL)>0)
233#define DECC_EFS_CASE_PRESERVE \
234 (decc$feature_get_value(efs_case_preserve_index,__FEATURE_MODE_CURVAL)>0)
235#define DECC_EFS_CHARSET \
236 (decc$feature_get_value(efs_charset_index,__FEATURE_MODE_CURVAL)>0)
237#define DECC_FILENAME_UNIX_NO_VERSION \
238 (decc$feature_get_value(filename_unix_no_version_index,__FEATURE_MODE_CURVAL)>0)
239#define DECC_FILENAME_UNIX_ONLY \
240 (decc$feature_get_value(filename_unix_only_index,__FEATURE_MODE_CURVAL)>0)
241#define DECC_FILENAME_UNIX_REPORT \
242 (decc$feature_get_value(filename_unix_report_index,__FEATURE_MODE_CURVAL)>0)
243#define DECC_POSIX_COMPLIANT_PATHNAMES \
244 (decc$feature_get_value(posix_compliant_pathnames_index,__FEATURE_MODE_CURVAL)>0)
245#define DECC_READDIR_DROPDOTNOTYPE \
246 (decc$feature_get_value(readdir_dropdotnotype_index,__FEATURE_MODE_CURVAL)>0)
247
f7ddb74a 248static int vms_process_case_tolerant = 1;
360732b5
JM		 249int vms_vtf7_filenames = 0;
250int gnv_unix_shell = 0;
e0e5e8d6 251static int vms_unlink_all_versions = 0;
1a3aec58 252static int vms_posix_exit = 0;
f7ddb74a 253
2497a41f 254/* bug workarounds if needed */
682e4b71 255int decc_bug_devnull = 1;
b53f3677 256int vms_bug_stat_filename = 0;
2497a41f 257
9c1171d1 258static int vms_debug_on_exception = 0;
b53f3677
JM		 259static int vms_debug_fileify = 0;
260
261/* Simple logical name translation */
ce12d4b7
CB		 262static int
263simple_trnlnm(const char * logname, char * value, int value_len)
b53f3677
JM		 264{
265 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
266 const unsigned long attr = LNM$M_CASE_BLIND;
267 struct dsc$descriptor_s name_dsc;
268 int status;
269 unsigned short result;
270 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
271 {0, 0, 0, 0}};
272
273 name_dsc.dsc$w_length = strlen(logname);
274 name_dsc.dsc$a_pointer = (char *)logname;
275 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
276 name_dsc.dsc$b_class = DSC$K_CLASS_S;
277
278 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
279
280 if ($VMS_STATUS_SUCCESS(status)) {
281
282 /* Null terminate and return the string */
283 /*--------------------------------------*/
284 value[result] = 0;
285 return result;
286 }
287
288 return 0;
289}
290
9c1171d1 291
f7ddb74a
JM		 292/* Is this a UNIX file specification?
293 * No longer a simple check with EFS file specs
294 * For now, not a full check, but need to
295 * handle POSIX ^UP^ specifications
296 * Fixing to handle ^/ cases would require
297 * changes to many other conversion routines.
298 */
299
ce12d4b7
CB		 300static int
301is_unix_filespec(const char *path)
f7ddb74a 302{
ce12d4b7
CB		 303 int ret_val;
304 const char * pch1;
f7ddb74a
JM		 305
306 ret_val = 0;
f55ac4a4 307 if (! strBEGINs(path,"\"^UP^")) {
f7ddb74a
JM		 308 pch1 = strchr(path, '/');
309 if (pch1 != NULL)
310 ret_val = 1;
311 else {
312
313 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
1d60dc3f 314 if (DECC_FILENAME_UNIX_REPORT || DECC_FILENAME_UNIX_ONLY) {
b0c1d0e3 315 if (strEQ(path,"."))
f7ddb74a
JM		 316 ret_val = 1;
317 }
318 }
319 }
320 return ret_val;
321}
322
360732b5
JM		 323/* This routine converts a UCS-2 character to be VTF-7 encoded.
324 */
325
ce12d4b7
CB		 326static void
327ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
360732b5 328{
ce12d4b7
CB		 329 unsigned char * ucs_ptr;
330 int hex;
360732b5
JM		 331
332 ucs_ptr = (unsigned char *)&ucs2_char;
333
334 outspec[0] = '^';
335 outspec[1] = 'U';
336 hex = (ucs_ptr[1] >> 4) & 0xf;
337 if (hex < 0xA)
338 outspec[2] = hex + '0';
339 else
340 outspec[2] = (hex - 9) + 'A';
341 hex = ucs_ptr[1] & 0xF;
342 if (hex < 0xA)
343 outspec[3] = hex + '0';
344 else {
345 outspec[3] = (hex - 9) + 'A';
346 }
347 hex = (ucs_ptr[0] >> 4) & 0xf;
348 if (hex < 0xA)
349 outspec[4] = hex + '0';
350 else
351 outspec[4] = (hex - 9) + 'A';
352 hex = ucs_ptr[1] & 0xF;
353 if (hex < 0xA)
354 outspec[5] = hex + '0';
355 else {
356 outspec[5] = (hex - 9) + 'A';
357 }
358 *output_cnt = 6;
359}
360
361
362/* This handles the conversion of a UNIX extended character set to a ^
363 * escaped VMS character.
364 * in a UNIX file specification.
365 *
366 * The output count variable contains the number of characters added
367 * to the output string.
368 *
369 * The return value is the number of characters read from the input string
370 */
ce12d4b7
CB		 371static int
372copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
360732b5 373{
ce12d4b7
CB		 374 int count;
375 int utf8_flag;
360732b5
JM		 376
377 utf8_flag = 0;
378 if (utf8_fl)
379 utf8_flag = *utf8_fl;
380
381 count = 0;
382 *output_cnt = 0;
383 if (*inspec >= 0x80) {
384 if (utf8_fl && vms_vtf7_filenames) {
385 unsigned long ucs_char;
386
387 ucs_char = 0;
388
389 if ((*inspec & 0xE0) == 0xC0) {
390 /* 2 byte Unicode */
391 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
392 if (ucs_char >= 0x80) {
393 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
394 return 2;
395 }
396 } else if ((*inspec & 0xF0) == 0xE0) {
397 /* 3 byte Unicode */
398 ucs_char = ((inspec[0] & 0xF) << 12) +
399 ((inspec[1] & 0x3f) << 6) +
400 (inspec[2] & 0x3f);
401 if (ucs_char >= 0x800) {
402 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
403 return 3;
404 }
405
406#if 0 /* I do not see longer sequences supported by OpenVMS */
407 /* Maybe some one can fix this later */
408 } else if ((*inspec & 0xF8) == 0xF0) {
409 /* 4 byte Unicode */
410 /* UCS-4 to UCS-2 */
411 } else if ((*inspec & 0xFC) == 0xF8) {
412 /* 5 byte Unicode */
413 /* UCS-4 to UCS-2 */
414 } else if ((*inspec & 0xFE) == 0xFC) {
415 /* 6 byte Unicode */
416 /* UCS-4 to UCS-2 */
417#endif
418 }
419 }
420
38a44b82 421 /* High bit set, but not a Unicode character! */
360732b5
JM		 422
423 /* Non printing DECMCS or ISO Latin-1 character? */
b931d62c
CB		 424 if ((unsigned char)*inspec <= 0x9F) {
425 int hex;
360732b5
JM		 426 outspec[0] = '^';
427 outspec++;
428 hex = (*inspec >> 4) & 0xF;
429 if (hex < 0xA)
430 outspec[1] = hex + '0';
431 else {
432 outspec[1] = (hex - 9) + 'A';
433 }
434 hex = *inspec & 0xF;
435 if (hex < 0xA)
436 outspec[2] = hex + '0';
437 else {
438 outspec[2] = (hex - 9) + 'A';
439 }
440 *output_cnt = 3;
441 return 1;
b931d62c 442 } else if ((unsigned char)*inspec == 0xA0) {
360732b5
JM		 443 outspec[0] = '^';
444 outspec[1] = 'A';
445 outspec[2] = '0';
446 *output_cnt = 3;
447 return 1;
b931d62c 448 } else if ((unsigned char)*inspec == 0xFF) {
360732b5
JM		 449 outspec[0] = '^';
450 outspec[1] = 'F';
451 outspec[2] = 'F';
452 *output_cnt = 3;
453 return 1;
454 }
455 *outspec = *inspec;
456 *output_cnt = 1;
457 return 1;
458 }
459
460 /* Is this a macro that needs to be passed through?
461 * Macros start with $( and an alpha character, followed
462 * by a string of alpha numeric characters ending with a )
463 * If this does not match, then encode it as ODS-5.
464 */
465 if ((inspec[0] == '$') && (inspec[1] == '(')) {
466 int tcnt;
467
30048647 468 if (isALPHA_L1(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
360732b5
JM		 469 tcnt = 3;
470 outspec[0] = inspec[0];
471 outspec[1] = inspec[1];
472 outspec[2] = inspec[2];
473
30048647 474 while(isALPHA_L1(inspec[tcnt]) ||
360732b5
JM		 475 (inspec[2] == '.') || (inspec[2] == '_')) {
476 outspec[tcnt] = inspec[tcnt];
477 tcnt++;
478 }
479 if (inspec[tcnt] == ')') {
480 outspec[tcnt] = inspec[tcnt];
481 tcnt++;
482 *output_cnt = tcnt;
483 return tcnt;
484 }
485 }
486 }
487
488 switch (*inspec) {
489 case 0x7f:
490 outspec[0] = '^';
491 outspec[1] = '7';
492 outspec[2] = 'F';
493 *output_cnt = 3;
494 return 1;
495 break;
496 case '?':
1556073b 497 if (!DECC_EFS_CHARSET)
360732b5
JM		 498 outspec[0] = '%';
499 else
500 outspec[0] = '?';
501 *output_cnt = 1;
502 return 1;
503 break;
504 case '.':
360732b5
JM		 505 case '!':
506 case '#':
507 case '&':
508 case '\'':
509 case '`':
510 case '(':
511 case ')':
512 case '+':
513 case '@':
514 case '{':
515 case '}':
516 case ',':
517 case ';':
518 case '[':
519 case ']':
520 case '%':
521 case '^':
449de3c2 522 case '\\':
adc11f0b
CB		 523 /* Don't escape again if following character is
524 * already something we escape.
525 */
1d86dd2f 526 if (strchr(".!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 527 *outspec = *inspec;
528 *output_cnt = 1;
529 return 1;
530 break;
531 }
532 /* But otherwise fall through and escape it. */
360732b5
JM		 533 case '=':
534 /* Assume that this is to be escaped */
535 outspec[0] = '^';
536 outspec[1] = *inspec;
537 *output_cnt = 2;
538 return 1;
539 break;
540 case ' ': /* space */
541 /* Assume that this is to be escaped */
542 outspec[0] = '^';
543 outspec[1] = '_';
544 *output_cnt = 2;
545 return 1;
546 break;
547 default:
548 *outspec = *inspec;
549 *output_cnt = 1;
550 return 1;
551 break;
552 }
c11536f5 553 return 0;
360732b5
JM		 554}
555
556
657054d4
JM		 557/* This handles the expansion of a '^' prefix to the proper character
558 * in a UNIX file specification.
559 *
560 * The output count variable contains the number of characters added
561 * to the output string.
562 *
563 * The return value is the number of characters read from the input
564 * string
565 */
ce12d4b7
CB		 566static int
567copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
657054d4 568{
ce12d4b7
CB		 569 int count;
570 int scnt;
657054d4
JM		 571
572 count = 0;
573 *output_cnt = 0;
574 if (*inspec == '^') {
575 inspec++;
576 switch (*inspec) {
adc11f0b
CB		 577 /* Spaces and non-trailing dots should just be passed through,
578 * but eat the escape character.
579 */
657054d4 580 case '.':
657054d4 581 *outspec = *inspec;
adc11f0b
CB		 582 count += 2;
583 (*output_cnt)++;
657054d4
JM		 584 break;
585 case '_': /* space */
586 *outspec = ' ';
adc11f0b 587 count += 2;
657054d4
JM		 588 (*output_cnt)++;
589 break;
adc11f0b
CB		 590 case '^':
591 /* Hmm. Better leave the escape escaped. */
592 outspec[0] = '^';
593 outspec[1] = '^';
594 count += 2;
595 (*output_cnt) += 2;
596 break;
360732b5 597 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 598 inspec++;
599 count++;
600 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
601 if (scnt == 4) {
2f4077ca
JM		 602 unsigned int c1, c2;
603 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
9960802c
NK		 604 outspec[0] = c1 & 0xff;
605 outspec[1] = c2 & 0xff;
657054d4
JM		 606 if (scnt > 1) {
607 (*output_cnt) += 2;
608 count += 4;
609 }
610 }
611 else {
612 /* Error - do best we can to continue */
613 *outspec = 'U';
614 outspec++;
615 (*output_cnt++);
616 *outspec = *inspec;
617 count++;
618 (*output_cnt++);
619 }
620 break;
621 default:
622 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
623 if (scnt == 2) {
624 /* Hex encoded */
2f4077ca
JM		 625 unsigned int c1;
626 scnt = sscanf(inspec, "%2x", &c1);
627 outspec[0] = c1 & 0xff;
657054d4
JM		 628 if (scnt > 0) {
629 (*output_cnt++);
630 count += 2;
631 }
632 }
633 else {
634 *outspec = *inspec;
635 count++;
636 (*output_cnt++);
637 }
638 }
639 }
640 else {
641 *outspec = *inspec;
642 count++;
643 (*output_cnt)++;
644 }
645 return count;
646}
647
657054d4
JM		 648/* vms_split_path - Verify that the input file specification is a
649 * VMS format file specification, and provide pointers to the components of
650 * it. With EFS format filenames, this is virtually the only way to
651 * parse a VMS path specification into components.
652 *
653 * If the sum of the components do not add up to the length of the
654 * string, then the passed file specification is probably a UNIX style
655 * path.
656 */
ce12d4b7
CB		 657static int
658vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
659 char * * dir, int * dir_len, char * * name, int * name_len,
660 char * * ext, int * ext_len, char * * version, int * ver_len)
661{
662 struct dsc$descriptor path_desc;
663 int status;
664 unsigned long flags;
665 int ret_stat;
666 struct filescan_itmlst_2 item_list[9];
667 const int filespec = 0;
668 const int nodespec = 1;
669 const int devspec = 2;
670 const int rootspec = 3;
671 const int dirspec = 4;
672 const int namespec = 5;
673 const int typespec = 6;
674 const int verspec = 7;
657054d4
JM		 675
676 /* Assume the worst for an easy exit */
677 ret_stat = -1;
678 *volume = NULL;
679 *vol_len = 0;
680 *root = NULL;
681 *root_len = 0;
682 *dir = NULL;
657054d4
JM		 683 *name = NULL;
684 *name_len = 0;
685 *ext = NULL;
686 *ext_len = 0;
687 *version = NULL;
688 *ver_len = 0;
689
690 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
691 path_desc.dsc$w_length = strlen(path);
692 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
693 path_desc.dsc$b_class = DSC$K_CLASS_S;
694
695 /* Get the total length, if it is shorter than the string passed
696 * then this was probably not a VMS formatted file specification
697 */
698 item_list[filespec].itmcode = FSCN$_FILESPEC;
699 item_list[filespec].length = 0;
700 item_list[filespec].component = NULL;
701
702 /* If the node is present, then it gets considered as part of the
703 * volume name to hopefully make things simple.
704 */
705 item_list[nodespec].itmcode = FSCN$_NODE;
706 item_list[nodespec].length = 0;
707 item_list[nodespec].component = NULL;
708
709 item_list[devspec].itmcode = FSCN$_DEVICE;
710 item_list[devspec].length = 0;
711 item_list[devspec].component = NULL;
712
713 /* root is a special case, adding it to either the directory or
94ae10c0 714 * the device components will probably complicate things for the
657054d4
JM		 715 * callers of this routine, so leave it separate.
716 */
717 item_list[rootspec].itmcode = FSCN$_ROOT;
718 item_list[rootspec].length = 0;
719 item_list[rootspec].component = NULL;
720
721 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
722 item_list[dirspec].length = 0;
723 item_list[dirspec].component = NULL;
724
725 item_list[namespec].itmcode = FSCN$_NAME;
726 item_list[namespec].length = 0;
727 item_list[namespec].component = NULL;
728
729 item_list[typespec].itmcode = FSCN$_TYPE;
730 item_list[typespec].length = 0;
731 item_list[typespec].component = NULL;
732
733 item_list[verspec].itmcode = FSCN$_VERSION;
734 item_list[verspec].length = 0;
735 item_list[verspec].component = NULL;
736
737 item_list[8].itmcode = 0;
738 item_list[8].length = 0;
739 item_list[8].component = NULL;
740
7566800d 741 status = sys$filescan
657054d4
JM		 742 ((const struct dsc$descriptor_s *)&path_desc, item_list,
743 &flags, NULL, NULL);
360732b5 744 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 745
746 /* If we parsed it successfully these two lengths should be the same */
747 if (path_desc.dsc$w_length != item_list[filespec].length)
748 return ret_stat;
749
750 /* If we got here, then it is a VMS file specification */
751 ret_stat = 0;
752
753 /* set the volume name */
754 if (item_list[nodespec].length > 0) {
755 *volume = item_list[nodespec].component;
756 *vol_len = item_list[nodespec].length + item_list[devspec].length;
757 }
758 else {
759 *volume = item_list[devspec].component;
760 *vol_len = item_list[devspec].length;
761 }
762
763 *root = item_list[rootspec].component;
764 *root_len = item_list[rootspec].length;
765
766 *dir = item_list[dirspec].component;
767 *dir_len = item_list[dirspec].length;
768
769 /* Now fun with versions and EFS file specifications
770 * The parser can not tell the difference when a "." is a version
771 * delimiter or a part of the file specification.
772 */
1d60dc3f 773 if ((DECC_EFS_CHARSET) &&
657054d4
JM		 774 (item_list[verspec].length > 0) &&
775 (item_list[verspec].component[0] == '.')) {
776 *name = item_list[namespec].component;
777 *name_len = item_list[namespec].length + item_list[typespec].length;
778 *ext = item_list[verspec].component;
779 *ext_len = item_list[verspec].length;
780 *version = NULL;
781 *ver_len = 0;
782 }
783 else {
784 *name = item_list[namespec].component;
785 *name_len = item_list[namespec].length;
786 *ext = item_list[typespec].component;
787 *ext_len = item_list[typespec].length;
788 *version = item_list[verspec].component;
789 *ver_len = item_list[verspec].length;
790 }
791 return ret_stat;
792}
793
df278665 794/* Routine to determine if the file specification ends with .dir */
ce12d4b7
CB		 795static int
796is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
797{
df278665
JM		 798
799 /* e_len must be 4, and version must be <= 2 characters */
800 if (e_len != 4 || vs_len > 2)
801 return 0;
802
803 /* If a version number is present, it needs to be one */
804 if ((vs_len == 2) && (vs_spec[1] != '1'))
805 return 0;
806
807 /* Look for the DIR on the extension */
808 if (vms_process_case_tolerant) {
30048647
CB		 809 if ((toUPPER_A(e_spec[1]) == 'D') &&
810 (toUPPER_A(e_spec[2]) == 'I') &&
811 (toUPPER_A(e_spec[3]) == 'R')) {
df278665
JM		 812 return 1;
813 }
814 } else {
815 /* Directory extensions are supposed to be in upper case only */
816 /* I would not be surprised if this rule can not be enforced */
817 /* if and when someone fully debugs the case sensitive mode */
818 if ((e_spec[1] == 'D') &&
819 (e_spec[2] == 'I') &&
820 (e_spec[3] == 'R')) {
821 return 1;
822 }
823 }
824 return 0;
825}
826
f7ddb74a 827
fa537f88
CB		 828/* my_maxidx
829 * Routine to retrieve the maximum equivalence index for an input
830 * logical name. Some calls to this routine have no knowledge if
831 * the variable is a logical or not. So on error we return a max
832 * index of zero.
833 */
f7ddb74a 834/*{{{int my_maxidx(const char *lnm) */
fa537f88 835static int
f7ddb74a 836my_maxidx(const char *lnm)
fa537f88
CB		 837{
838 int status;
839 int midx;
840 int attr = LNM$M_CASE_BLIND;
841 struct dsc$descriptor lnmdsc;
842 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
843 {0, 0, 0, 0}};
844
845 lnmdsc.dsc$w_length = strlen(lnm);
846 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
847 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 848 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 849
850 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
851 if ((status & 1) == 0)
852 midx = 0;
853
854 return (midx);
855}
856/*}}}*/
857
bdbc6804
CB		 858/* Routine to remove the 2-byte prefix from the translation of a
859 * process-permanent file (PPF).
860 */
861static inline unsigned short int
862S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
863{
864 if (*((int *)lnm) == *((int *)"SYS$") &&
865 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
083b2a61
KW		 866 ( (lnm[4] == 'O' && strEQ(lnm,"SYS$OUTPUT")) ||
867 (lnm[4] == 'I' && strEQ(lnm,"SYS$INPUT")) ||
868 (lnm[4] == 'E' && strEQ(lnm,"SYS$ERROR")) ||
869 (lnm[4] == 'C' && strEQ(lnm,"SYS$COMMAND")) ) ) {
bdbc6804
CB		 870
871 memmove(eqv, eqv+4, eqvlen-4);
872 eqvlen -= 4;
873 }
874 return eqvlen;
875}
876
f675dbe5 877/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 878int
fd8cd3a3 879Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 880 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 881{
f7ddb74a
JM		 882 const char *cp1;
883 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 884 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
2364b895 885 bool found_in_crtlenv = 0, found_in_clisym = 0;
748a9306 886 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 887 int midx;
f675dbe5
CB		 888 unsigned char acmode;
889 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
890 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
891 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
892 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 893 {0, 0, 0, 0}};
f675dbe5 894 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 895#if defined(PERL_IMPLICIT_CONTEXT)
896 pTHX = NULL;
fd8cd3a3
DS		 897 if (PL_curinterp) {
898 aTHX = PERL_GET_INTERP;
cc077a9f 899 } else {
fd8cd3a3 900 aTHX = NULL;
cc077a9f
HM		 901 }
902#endif
748a9306 903
fa537f88 904 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 905 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
906 }
f7ddb74a 907 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
30048647 908 *cp2 = toUPPER_A(*cp1);
f675dbe5
CB		 909 if (cp1 - lnm > LNM$C_NAMLENGTH) {
910 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
911 return 0;
912 }
913 }
914 lnmdsc.dsc$w_length = cp1 - lnm;
915 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 916 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 917 secure = flags & PERL__TRNENV_SECURE;
918 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
919 if (!tabvec || !*tabvec) tabvec = env_tables;
920
921 for (curtab = 0; tabvec[curtab]; curtab++) {
922 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
923 if (!ivenv && !secure) {
4e0c9737 924 char *eq;
f675dbe5
CB		 925 int i;
926 if (!environ) {
927 ivenv = 1;
ebd4d70b
JM		 928#if defined(PERL_IMPLICIT_CONTEXT)
929 if (aTHX == NULL) {
930 fprintf(stderr,
873f5ddf 931 "Can't read CRTL environ\n");
ebd4d70b
JM		 932 } else
933#endif
934 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 935 continue;
936 }
937 retsts = SS$_NOLOGNAM;
938 for (i = 0; environ[i]; i++) {
939 if ((eq = strchr(environ[i],'=')) &&
299d126a 940 lnmdsc.dsc$w_length == (eq - environ[i]) &&
a15aa957 941 strnEQ(environ[i],lnm,eq - environ[i])) {
f675dbe5
CB		 942 eq++;
943 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
944 if (!eqvlen) continue;
945 retsts = SS$_NORMAL;
946 break;
947 }
948 }
2364b895
CB		 949 if (retsts != SS$_NOLOGNAM) {
950 found_in_crtlenv = 1;
951 break;
952 }
f675dbe5
CB		 953 }
954 }
955 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
956 !str$case_blind_compare(&tmpdsc,&clisym)) {
957 if (!ivsym && !secure) {
958 unsigned short int deflen = LNM$C_NAMLENGTH;
959 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
94ae10c0 960 /* dynamic dsc to accommodate possible long value */
ebd4d70b 961 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 962 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
963 if (retsts & 1) {
2497a41f 964 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 965 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 966 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 967 /* Special hack--we might be called before the interpreter's */
968 /* fully initialized, in which case either thr or PL_curcop */
969 /* might be bogus. We have to check, since ckWARN needs them */
970 /* both to be valid if running threaded */
8a646e0b
JM		 971#if defined(PERL_IMPLICIT_CONTEXT)
972 if (aTHX == NULL) {
973 fprintf(stderr,
873f5ddf 974 "Value of CLI symbol \"%s\" too long",lnm);
8a646e0b
JM		 975 } else
976#endif
cc077a9f 977 if (ckWARN(WARN_MISC)) {
f98bc0c6 978 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 979 }
f675dbe5
CB		 980 }
981 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
982 }
ebd4d70b 983 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 984 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
985 if (retsts == LIB$_NOSUCHSYM) continue;
2364b895 986 found_in_clisym = 1;
f675dbe5
CB		 987 break;
988 }
989 }
990 else if (!ivlnm) {
843027b0 991 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 992 midx = my_maxidx(lnm);
993 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
994 lnmlst[1].bufadr = cp2;
fa537f88
CB		 995 eqvlen = 0;
996 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
997 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
998 if (retsts == SS$_NOLOGNAM) break;
bdbc6804 999 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
f7ddb74a
JM		 1000 cp2 += eqvlen;
1001 *cp2 = '\0';
fa537f88
CB		 1002 }
1003 if ((retsts == SS$_IVLOGNAM) ||
1004 (retsts == SS$_NOLOGNAM)) { continue; }
bdbc6804 1005 eqvlen = strlen(eqv);
fd7385b9 1006 }
fa537f88 1007 else {
fa537f88
CB		 1008 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1009 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1010 if (retsts == SS$_NOLOGNAM) continue;
bdbc6804 1011 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
fa537f88
CB		 1012 eqv[eqvlen] = '\0';
1013 }
f675dbe5
CB		 1014 break;
1015 }
c07a80fd 1016 }
2364b895
CB		 1017 /* An index only makes sense for logical names, so make sure we aren't
1018 * iterating over an index for an environ var or DCL symbol and getting
1019 * the same answer ad infinitum.
1020 */
1021 if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
1022 return 0;
1023 }
1024 else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
998ae67e 1025 else if (retsts == LIB$_NOSUCHSYM ||
f675dbe5 1026 retsts == SS$_NOLOGNAM) {
998ae67e
CB		 1027 /* Unsuccessful lookup is normal -- no need to set errno */
1028 return 0;
1029 }
1030 else if (retsts == LIB$_INVSYMNAM ||
1031 retsts == SS$_IVLOGNAM ||
1032 retsts == SS$_IVLOGTAB) {
f675dbe5 1033 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1034 }
ebd4d70b 1035 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1036 return 0;
1037} /* end of vmstrnenv */
1038/*}}}*/
c07a80fd 1039
f675dbe5
CB		 1040/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1041/* Define as a function so we can access statics. */
ce12d4b7
CB		 1042int
1043Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1044{
8a646e0b
JM		 1045 int flags = 0;
1046
1047#if defined(PERL_IMPLICIT_CONTEXT)
1048 if (aTHX != NULL)
1049#endif
f675dbe5 1050#ifdef SECURE_INTERNAL_GETENV
284167a5 1051 flags = (PL_curinterp ? TAINTING_get : will_taint) ?
8a646e0b 1052 PERL__TRNENV_SECURE : 0;
f675dbe5 1053#endif
8a646e0b
JM		 1054
1055 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1056}
1057/*}}}*/
a0d0e21e
LW		 1058
1059/* my_getenv
61bb5906
CB		 1060 * Note: Uses Perl temp to store result so char * can be returned to
1061 * caller; this pointer will be invalidated at next Perl statement
1062 * transition.
a6c40364 1063 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1064 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1065 * allocate SVs).
a0d0e21e 1066 */
f675dbe5 1067/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1068char *
5c84aa53 1069Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1070{
f7ddb74a 1071 const char *cp1;
fa537f88 1072 static char *__my_getenv_eqv = NULL;
f7ddb74a 1073 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1074 unsigned long int idx = 0;
998ae67e 1075 int success, secure;
843027b0 1076 int midx, flags;
61bb5906 1077 SV *tmpsv;
a0d0e21e 1078
f7ddb74a 1079 midx = my_maxidx(lnm) + 1;
fa537f88 1080
6b88bc9c 1081 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1082 /* Set up a temporary buffer for the return value; Perl will
1083 * clean it up at the next statement transition */
fa537f88 1084 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1085 if (!tmpsv) return NULL;
1086 eqv = SvPVX(tmpsv);
1087 }
fa537f88
CB		 1088 else {
1089 /* Assume no interpreter ==> single thread */
1090 if (__my_getenv_eqv != NULL) {
1091 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1092 }
1093 else {
a02a5408 1094 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1095 }
1096 eqv = __my_getenv_eqv;
1097 }
1098
30048647 1099 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
b59bf0b2 1100 if (memEQs(eqv, cp1 - lnm, "DEFAULT")) {
2497a41f 1101 int len;
61bb5906 1102 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1103
1104 len = strlen(eqv);
1105
1106 /* Get rid of "000000/ in rooted filespecs */
1107 if (len > 7) {
1108 char * zeros;
1109 zeros = strstr(eqv, "/000000/");
1110 if (zeros != NULL) {
1111 int mlen;
1112 mlen = len - (zeros - eqv) - 7;
1113 memmove(zeros, &zeros[7], mlen);
1114 len = len - 7;
1115 eqv[len] = '\0';
1116 }
1117 }
61bb5906 1118 return eqv;
748a9306 1119 }
a0d0e21e 1120 else {
2512681b 1121 /* Impose security constraints only if tainting */
bc10a425
CB		 1122 if (sys) {
1123 /* Impose security constraints only if tainting */
284167a5 1124 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425 1125 }
843027b0
CB		 1126 else {
1127 secure = 0;
1128 }
1129
1130 flags =
f675dbe5 1131#ifdef SECURE_INTERNAL_GETENV
843027b0 1132 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1133#else
843027b0 1134 0
f675dbe5 1135#endif
843027b0
CB		 1136 ;
1137
1138 /* For the getenv interface we combine all the equivalence names
1139 * of a search list logical into one value to acquire a maximum
1140 * value length of 255*128 (assuming %ENV is using logicals).
1141 */
1142 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1143
1144 /* If the name contains a semicolon-delimited index, parse it
1145 * off and make sure we only retrieve the equivalence name for
1146 * that index. */
1147 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1148 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
843027b0
CB		 1149 idx = strtoul(cp2+1,NULL,0);
1150 lnm = uplnm;
1151 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1152 }
1153
1154 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1155
4e205ed6 1156 return success ? eqv : NULL;
a0d0e21e 1157 }
a0d0e21e
LW		 1158
1159} /* end of my_getenv() */
1160/*}}}*/
1161
f675dbe5 1162
a6c40364
GS		 1163/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1164char *
fd8cd3a3 1165Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1166{
f7ddb74a
JM		 1167 const char *cp1;
1168 char *buf, *cp2;
a6c40364 1169 unsigned long idx = 0;
843027b0 1170 int midx, flags;
fa537f88 1171 static char *__my_getenv_len_eqv = NULL;
998ae67e 1172 int secure;
cc077a9f
HM		 1173 SV *tmpsv;
1174
f7ddb74a 1175 midx = my_maxidx(lnm) + 1;
fa537f88 1176
cc077a9f
HM		 1177 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1178 /* Set up a temporary buffer for the return value; Perl will
1179 * clean it up at the next statement transition */
fa537f88 1180 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1181 if (!tmpsv) return NULL;
1182 buf = SvPVX(tmpsv);
1183 }
fa537f88
CB		 1184 else {
1185 /* Assume no interpreter ==> single thread */
1186 if (__my_getenv_len_eqv != NULL) {
1187 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1188 }
1189 else {
a02a5408 1190 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1191 }
1192 buf = __my_getenv_len_eqv;
1193 }
1194
30048647 1195 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
b59bf0b2 1196 if (memEQs(buf, cp1 - lnm, "DEFAULT")) {
f7ddb74a
JM		 1197 char * zeros;
1198
f675dbe5 1199 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1200 *len = strlen(buf);
f7ddb74a
JM		 1201
1202 /* Get rid of "000000/ in rooted filespecs */
1203 if (*len > 7) {
1204 zeros = strstr(buf, "/000000/");
1205 if (zeros != NULL) {
1206 int mlen;
1207 mlen = *len - (zeros - buf) - 7;
1208 memmove(zeros, &zeros[7], mlen);
1209 *len = *len - 7;
1210 buf[*len] = '\0';
1211 }
1212 }
a6c40364 1213 return buf;
f675dbe5
CB		 1214 }
1215 else {
bc10a425
CB		 1216 if (sys) {
1217 /* Impose security constraints only if tainting */
284167a5 1218 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425 1219 }
843027b0
CB		 1220 else {
1221 secure = 0;
1222 }
1223
1224 flags =
f675dbe5 1225#ifdef SECURE_INTERNAL_GETENV
843027b0 1226 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1227#else
843027b0 1228 0
f675dbe5 1229#endif
843027b0
CB		 1230 ;
1231
1232 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1233
1234 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1235 my_strlcpy(buf, lnm, cp2 - lnm + 1);
843027b0
CB		 1236 idx = strtoul(cp2+1,NULL,0);
1237 lnm = buf;
1238 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1239 }
1240
1241 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1242
f7ddb74a
JM		 1243 /* Get rid of "000000/ in rooted filespecs */
1244 if (*len > 7) {
ce12d4b7 1245 char * zeros;
f7ddb74a
JM		 1246 zeros = strstr(buf, "/000000/");
1247 if (zeros != NULL) {
1248 int mlen;
1249 mlen = *len - (zeros - buf) - 7;
1250 memmove(zeros, &zeros[7], mlen);
1251 *len = *len - 7;
1252 buf[*len] = '\0';
1253 }
1254 }
1255
4e205ed6 1256 return *len ? buf : NULL;
f675dbe5
CB		 1257 }
1258
a6c40364 1259} /* end of my_getenv_len() */
f675dbe5
CB		 1260/*}}}*/
1261
8a646e0b 1262static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1263
1264static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1265
740ce14c 1266/*{{{ void prime_env_iter() */
1267void
1268prime_env_iter(void)
1269/* Fill the %ENV associative array with all logical names we can
1270 * find, in preparation for iterating over it.
1271 */
1272{
17f28c40 1273 static int primed = 0;
3eeba6fb 1274 HV *seenhv = NULL, *envhv;
22be8b3c 1275 SV *sv = NULL;
4e205ed6 1276 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1277 unsigned short int chan;
1278#ifndef CLI$M_TRUSTED
1279# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1280#endif
f675dbe5 1281 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
4e0c9737 1282 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
f675dbe5
CB		 1283 long int i;
1284 bool have_sym = FALSE, have_lnm = FALSE;
1285 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1286 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1287 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1288 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1289 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1290#if defined(PERL_IMPLICIT_CONTEXT)
1291 pTHX;
1292#endif
3db8f154 1293#if defined(USE_ITHREADS)
b2b3adea
HM		 1294 static perl_mutex primenv_mutex;
1295 MUTEX_INIT(&primenv_mutex);
61bb5906 1296#endif
740ce14c 1297
fd8cd3a3
DS		 1298#if defined(PERL_IMPLICIT_CONTEXT)
1299 /* We jump through these hoops because we can be called at */
1300 /* platform-specific initialization time, which is before anything is */
1301 /* set up--we can't even do a plain dTHX since that relies on the */
1302 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1303 if (PL_curinterp) {
1304 aTHX = PERL_GET_INTERP;
1305 } else {
ebd4d70b
JM		 1306 /* we never get here because the NULL pointer will cause the */
1307 /* several of the routines called by this routine to access violate */
1308
1309 /* This routine is only called by hv.c/hv_iterinit which has a */
1310 /* context, so the real fix may be to pass it through instead of */
1311 /* the hoops above */
fd8cd3a3
DS		 1312 aTHX = NULL;
1313 }
1314#endif
fd8cd3a3 1315
3eeba6fb 1316 if (primed || !PL_envgv) return;
61bb5906
CB		 1317 MUTEX_LOCK(&primenv_mutex);
1318 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1319 envhv = GvHVn(PL_envgv);
740ce14c 1320 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1321 * set up. Otherwise, the hv_store() will turn into a nullop. */
2808d9d8 1322 (void) hv_fetchs(envhv,"DEFAULT",TRUE);
740ce14c 1323
f675dbe5
CB		 1324 for (i = 0; env_tables[i]; i++) {
1325 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1326 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1327 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1328 }
f675dbe5
CB		 1329 if (have_sym || have_lnm) {
1330 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1331 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1332 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1333 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1334 }
f675dbe5
CB		 1335
1336 for (i--; i >= 0; i--) {
1337 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1338 char *start;
1339 int j;
9dee5840
CB		 1340 /* Start at the end, so if there is a duplicate we keep the first one. */
1341 for (j = 0; environ[j]; j++);
1342 for (j--; j >= 0; j--) {
f675dbe5 1343 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1344 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1345 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1346 }
1347 else {
1348 start++;
22be8b3c
CB		 1349 sv = newSVpv(start,0);
1350 SvTAINTED_on(sv);
1351 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1352 }
1353 }
1354 continue;
740ce14c 1355 }
f675dbe5
CB		 1356 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1357 !str$case_blind_compare(&tmpdsc,&clisym)) {
a35dcc95 1358 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
f675dbe5
CB		 1359 cmddsc.dsc$w_length = 20;
1360 if (env_tables[i]->dsc$w_length == 12 &&
1361 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
a35dcc95 1362 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
f675dbe5
CB		 1363 flags = defflags | CLI$M_NOLOGNAM;
1364 }
1365 else {
a35dcc95 1366 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
f675dbe5 1367 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
a35dcc95 1368 my_strlcat(cmd," /Table=", sizeof(cmd));
88e3936f 1369 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
f675dbe5
CB		 1370 }
1371 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1372 flags = defflags | CLI$M_NOCLISYM;
1373 }
1374
1375 /* Create a new subprocess to execute each command, to exclude the
1376 * remote possibility that someone could subvert a mbx or file used
1377 * to write multiple commands to a single subprocess.
1378 */
1379 do {
1380 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1381 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1382 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1383 defflags &= ~CLI$M_TRUSTED;
1384 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1385 _ckvmssts(retsts);
a02a5408 1386 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1387 if (seenhv) SvREFCNT_dec(seenhv);
1388 seenhv = newHV();
1389 while (1) {
1390 char *cp1, *cp2, *key;
1391 unsigned long int sts, iosb[2], retlen, keylen;
eb578fdb 1392 U32 hash;
f675dbe5
CB		 1393
1394 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1395 if (sts & 1) sts = iosb[0] & 0xffff;
1396 if (sts == SS$_ENDOFFILE) {
1397 int wakect = 0;
1398 while (substs == 0) { sys$hiber(); wakect++;}
1399 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1400 _ckvmssts(substs);
1401 break;
1402 }
1403 _ckvmssts(sts);
1404 retlen = iosb[0] >> 16;
1405 if (!retlen) continue; /* blank line */
1406 buf[retlen] = '\0';
1407 if (iosb[1] != subpid) {
1408 if (iosb[1]) {
5c84aa53 1409 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1410 }
1411 continue;
1412 }
3eeba6fb 1413 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1414 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5 1415
30048647 1416 for (cp1 = buf; *cp1 && isSPACE_L1(*cp1); cp1++) ;
f675dbe5
CB		 1417 if (*cp1 == '(' || /* Logical name table name */
1418 *cp1 == '=' /* Next eqv of searchlist */) continue;
1419 if (*cp1 == '"') cp1++;
1420 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1421 key = cp1; keylen = cp2 - cp1;
1422 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1423 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1424 while (*cp2 && *cp2 == '=') cp2++;
1425 while (*cp2 && *cp2 == ' ') cp2++;
1426 if (*cp2 == '"') { /* String translation; may embed "" */
1427 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1428 cp2++; cp1--; /* Skip "" surrounding translation */
1429 }
1430 else { /* Numeric translation */
1431 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1432 cp1--; /* stop on last non-space char */
1433 }
1434 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1435 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1436 continue;
1437 }
5afd6d42 1438 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1439
1440 if (cp1 == cp2 && *cp2 == '.') {
1441 /* A single dot usually means an unprintable character, such as a null
1442 * to indicate a zero-length value. Get the actual value to make sure.
1443 */
1444 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1445 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1446 int trnlen;
ff79d39d 1447 strncpy(lnm, key, keylen);
0faef845 1448 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1449 sv = newSVpvn(eqv, strlen(eqv));
1450 }
1451 else {
1452 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1453 }
1454
22be8b3c
CB		 1455 SvTAINTED_on(sv);
1456 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1457 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1458 }
f675dbe5
CB		 1459 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1460 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1461 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1462 char eqv[LNM$C_NAMLENGTH+1];
1463 int trnlen, i;
1464 for (i = 0; ppfs[i]; i++) {
1465 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1466 sv = newSVpv(eqv,trnlen);
1467 SvTAINTED_on(sv);
1468 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1469 }
740ce14c 1470 }
1471 }
f675dbe5
CB		 1472 primed = 1;
1473 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1474 if (buf) Safefree(buf);
1475 if (seenhv) SvREFCNT_dec(seenhv);
1476 MUTEX_UNLOCK(&primenv_mutex);
1477 return;
1478
740ce14c 1479} /* end of prime_env_iter */
1480/*}}}*/
740ce14c 1481
f675dbe5 1482
2c590a56 1483/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1484/* Define or delete an element in the same "environment" as
1485 * vmstrnenv(). If an element is to be deleted, it's removed from
1486 * the first place it's found. If it's to be set, it's set in the
1487 * place designated by the first element of the table vector.
3eeba6fb 1488 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1489 */
f675dbe5 1490int
2c590a56 1491Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1492{
f7ddb74a
JM		 1493 const char *cp1;
1494 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1495 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1496 int nseg = 0, j;
a0d0e21e 1497 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1498 struct itmlst_3 *ile, *ilist;
a0d0e21e 1499 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1500 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1501 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1502 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1503 $DESCRIPTOR(local,"_LOCAL");
1504
ed253963
CB		 1505 if (!lnm) {
1506 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1507 return SS$_IVLOGNAM;
1508 }
1509
f7ddb74a 1510 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
30048647 1511 *cp2 = toUPPER_A(*cp1);
f675dbe5
CB		 1512 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1513 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1514 return SS$_IVLOGNAM;
1515 }
1516 }
a0d0e21e 1517 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1518 if (!tabvec || !*tabvec) tabvec = env_tables;
1519
3eeba6fb 1520 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1521 for (curtab = 0; tabvec[curtab]; curtab++) {
1522 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1523 int i;
299d126a 1524 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1525 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1526 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
a15aa957 1527 strnEQ(environ[i],lnm,cp1 - environ[i])) {
cda27dcf
CB		 1528 unsetenv(lnm);
1529 return 0;
f675dbe5
CB		 1530 }
1531 }
1532 ivenv = 1; retsts = SS$_NOLOGNAM;
f675dbe5
CB		 1533 }
1534 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1535 !str$case_blind_compare(&tmpdsc,&clisym)) {
1536 unsigned int symtype;
1537 if (tabvec[curtab]->dsc$w_length == 12 &&
1538 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1539 !str$case_blind_compare(&tmpdsc,&local))
1540 symtype = LIB$K_CLI_LOCAL_SYM;
1541 else symtype = LIB$K_CLI_GLOBAL_SYM;
1542 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1543 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1544 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1545 break;
1546 }
1547 else if (!ivlnm) {
1548 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1549 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1550 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1551 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1552 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1553 }
a0d0e21e
LW		 1554 }
1555 }
f675dbe5
CB		 1556 else { /* we're defining a value */
1557 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
3eeba6fb 1558 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5
CB		 1559 }
1560 else {
f7ddb74a 1561 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1562 eqvdsc.dsc$w_length = strlen(eqv);
1563 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1564 !str$case_blind_compare(&tmpdsc,&clisym)) {
1565 unsigned int symtype;
1566 if (tabvec[0]->dsc$w_length == 12 &&
1567 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1568 !str$case_blind_compare(&tmpdsc,&local))
1569 symtype = LIB$K_CLI_LOCAL_SYM;
1570 else symtype = LIB$K_CLI_GLOBAL_SYM;
1571 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1572 }
3eeba6fb
CB		 1573 else {
1574 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1575 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1576
1577 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1578 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1579 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1580 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1581 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1582 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1583 }
1584
a02a5408 1585 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1586 ile = ilist;
1587 if (!ile) {
1588 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1589 return SS$_INSFMEM;
a1dfe751 1590 }
fa537f88
CB		 1591 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1592
1593 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1594 ile->itmcode = LNM$_STRING;
1595 ile->bufadr = c;
1596 if ((j+1) == nseg) {
1597 ile->buflen = strlen(c);
1598 /* in case we are truncating one that's too long */
1599 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1600 }
1601 else {
1602 ile->buflen = LNM$C_NAMLENGTH;
1603 }
1604 }
1605
1606 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1607 Safefree (ilist);
1608 }
1609 else {
1610 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1611 }
3eeba6fb 1612 }
f675dbe5
CB		 1613 }
1614 }
1615 if (!(retsts & 1)) {
1616 switch (retsts) {
1617 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1618 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1619 set_errno(EVMSERR); break;
1620 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1621 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1622 set_errno(EINVAL); break;
1623 case SS$_NOPRIV:
7d2497bf 1624 set_errno(EACCES); break;
f675dbe5
CB		 1625 default:
1626 _ckvmssts(retsts);
1627 set_errno(EVMSERR);
1628 }
1629 set_vaxc_errno(retsts);
1630 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1631 }
3eeba6fb
CB		 1632 else {
1633 /* We reset error values on success because Perl does an hv_fetch()
1634 * before each hv_store(), and if the thing we're setting didn't
1635 * previously exist, we've got a leftover error message. (Of course,
1636 * this fails in the face of
1637 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1638 * in that the error reported in $! isn't spurious,
1639 * but it's right more often than not.)
1640 */
f675dbe5
CB		 1641 set_errno(0); set_vaxc_errno(retsts);
1642 return 0;
1643 }
1644
1645} /* end of vmssetenv() */
1646/*}}}*/
a0d0e21e 1647
2c590a56 1648/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1649/* This has to be a function since there's a prototype for it in proto.h */
1650void
2c590a56 1651Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1652{
bc10a425
CB		 1653 if (lnm && *lnm) {
1654 int len = strlen(lnm);
1655 if (len == 7) {
1656 char uplnm[8];
22d4bb9c 1657 int i;
30048647 1658 for (i = 0; lnm[i]; i++) uplnm[i] = toUPPER_A(lnm[i]);
083b2a61 1659 if (strEQ(uplnm,"DEFAULT")) {
7ded3206 1660 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1661 return;
1662 }
1663 }
22d4bb9c 1664 }
f675dbe5
CB		 1665 (void) vmssetenv(lnm,eqv,NULL);
1666}
a0d0e21e
LW		 1667/*}}}*/
1668
27c67b75 1669/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1670/* vmssetuserlnm
1671 * sets a user-mode logical in the process logical name table
1672 * used for redirection of sys$error
1673 */
1674void
0db50132 1675Perl_vmssetuserlnm(const char *name, const char *eqv)
0e06870b
CB		 1676{
1677 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1678 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1679 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1680 unsigned char acmode = PSL$C_USER;
1681 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1682 {0, 0, 0, 0}};
2fbb330f 1683 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1684 d_name.dsc$w_length = strlen(name);
1685
1686 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1687 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1688
1689 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1690 if (!(iss&1)) lib$signal(iss);
1691}
1692/*}}}*/
c07a80fd 1693
f675dbe5 1694
c07a80fd 1695/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1696/* my_crypt - VMS password hashing
1697 * my_crypt() provides an interface compatible with the Unix crypt()
1698 * C library function, and uses sys$hash_password() to perform VMS
1699 * password hashing. The quadword hashed password value is returned
1700 * as a NUL-terminated 8 character string. my_crypt() does not change
1701 * the case of its string arguments; in order to match the behavior
1702 * of LOGINOUT et al., alphabetic characters in both arguments must
1703 * be upcased by the caller.
2497a41f
JM		 1704 *
1705 * - fix me to call ACM services when available
c07a80fd 1706 */
1707char *
fd8cd3a3 1708Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1709{
1710# ifndef UAI$C_PREFERRED_ALGORITHM
1711# define UAI$C_PREFERRED_ALGORITHM 127
1712# endif
1713 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1714 unsigned short int salt = 0;
1715 unsigned long int sts;
1716 struct const_dsc {
1717 unsigned short int dsc$w_length;
1718 unsigned char dsc$b_type;
1719 unsigned char dsc$b_class;
1720 const char * dsc$a_pointer;
1721 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1722 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1723 struct itmlst_3 uailst[3] = {
1724 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1725 { sizeof salt, UAI$_SALT, &salt, 0},
1726 { 0, 0, NULL, NULL}};
1727 static char hash[9];
1728
1729 usrdsc.dsc$w_length = strlen(usrname);
1730 usrdsc.dsc$a_pointer = usrname;
1731 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1732 switch (sts) {
f282b18d 1733 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1734 set_errno(EACCES);
1735 break;
1736 case RMS$_RNF:
1737 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1738 break;
1739 default:
1740 set_errno(EVMSERR);
1741 }
1742 set_vaxc_errno(sts);
1743 if (sts != RMS$_RNF) return NULL;
1744 }
1745
1746 txtdsc.dsc$w_length = strlen(textpasswd);
1747 txtdsc.dsc$a_pointer = textpasswd;
1748 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1749 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1750 }
1751
1752 return (char *) hash;
1753
1754} /* end of my_crypt() */
1755/*}}}*/
1756
1757
360732b5
JM		 1758static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1759static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1760static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1761
e0e5e8d6
JM		 1762/* 8.3, remove() is now broken on symbolic links */
1763static int rms_erase(const char * vmsname);
1764
1765
2497a41f 1766/* mp_do_kill_file
94ae10c0 1767 * A little hack to get around a bug in some implementation of remove()
2497a41f
JM		 1768 * that do not know how to delete a directory
1769 *
1770 * Delete any file to which user has control access, regardless of whether
1771 * delete access is explicitly allowed.
1772 * Limitations: User must have write access to parent directory.
1773 * Does not block signals or ASTs; if interrupted in midstream
1774 * may leave file with an altered ACL.
1775 * HANDLE WITH CARE!
1776 */
1777/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1778static int
1779mp_do_kill_file(pTHX_ const char *name, int dirflag)
1780{
e0e5e8d6
JM		 1781 char *vmsname;
1782 char *rslt;
2497a41f 1783 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
81d2d377
CB		 1784 unsigned long int cxt = 0, aclsts, fndsts;
1785 int rmsts = -1;
2497a41f
JM		 1786 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1787 struct myacedef {
1788 unsigned char myace$b_length;
1789 unsigned char myace$b_type;
1790 unsigned short int myace$w_flags;
1791 unsigned long int myace$l_access;
1792 unsigned long int myace$l_ident;
1793 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1794 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1795 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1796 struct itmlst_3
1797 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1798 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1799 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1800 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1801 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1802 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1803
1804 /* Expand the input spec using RMS, since the CRTL remove() and
1805 * system services won't do this by themselves, so we may miss
1806 * a file "hiding" behind a logical name or search list. */
c11536f5 1807 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1808 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1809
6fb6c614 1810 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1811 if (rslt == NULL) {
c5375c28 1812 PerlMem_free(vmsname);
2497a41f
JM		 1813 return -1;
1814 }
c5375c28 1815
e0e5e8d6
JM		 1816 /* Erase the file */
1817 rmsts = rms_erase(vmsname);
2497a41f 1818
e0e5e8d6
JM		 1819 /* Did it succeed */
1820 if ($VMS_STATUS_SUCCESS(rmsts)) {
1821 PerlMem_free(vmsname);
1822 return 0;
2497a41f
JM		 1823 }
1824
1825 /* If not, can changing protections help? */
e0e5e8d6
JM		 1826 if (rmsts != RMS$_PRV) {
1827 set_vaxc_errno(rmsts);
1828 PerlMem_free(vmsname);
2497a41f
JM		 1829 return -1;
1830 }
1831
1832 /* No, so we get our own UIC to use as a rights identifier,
1833 * and the insert an ACE at the head of the ACL which allows us
1834 * to delete the file.
1835 */
ebd4d70b 1836 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1837 fildsc.dsc$w_length = strlen(vmsname);
1838 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1839 cxt = 0;
1840 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1841 rmsts = -1;
2497a41f
JM		 1842 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1843 switch (aclsts) {
1844 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1845 set_errno(ENOENT); break;
1846 case RMS$_DIR:
1847 set_errno(ENOTDIR); break;
1848 case RMS$_DEV:
1849 set_errno(ENODEV); break;
1850 case RMS$_SYN: case SS$_INVFILFOROP:
1851 set_errno(EINVAL); break;
1852 case RMS$_PRV:
1853 set_errno(EACCES); break;
1854 default:
ebd4d70b 1855 _ckvmssts_noperl(aclsts);
2497a41f
JM		 1856 }
1857 set_vaxc_errno(aclsts);
e0e5e8d6 1858 PerlMem_free(vmsname);
2497a41f
JM		 1859 return -1;
1860 }
1861 /* Grab any existing ACEs with this identifier in case we fail */
1862 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1863 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1864 || fndsts == SS$_NOMOREACE ) {
1865 /* Add the new ACE . . . */
1866 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1867 goto yourroom;
1868
e0e5e8d6
JM		 1869 rmsts = rms_erase(vmsname);
1870 if ($VMS_STATUS_SUCCESS(rmsts)) {
1871 rmsts = 0;
2497a41f
JM		 1872 }
1873 else {
e0e5e8d6 1874 rmsts = -1;
2497a41f
JM		 1875 /* We blew it - dir with files in it, no write priv for
1876 * parent directory, etc. Put things back the way they were. */
1877 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1878 goto yourroom;
1879 if (fndsts & 1) {
1880 addlst[0].bufadr = &oldace;
1881 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1882 goto yourroom;
1883 }
1884 }
1885 }
1886
1887 yourroom:
1888 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1889 /* We just deleted it, so of course it's not there. Some versions of
1890 * VMS seem to return success on the unlock operation anyhow (after all
1891 * the unlock is successful), but others don't.
1892 */
1893 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1894 if (aclsts & 1) aclsts = fndsts;
1895 if (!(aclsts & 1)) {
1896 set_errno(EVMSERR);
1897 set_vaxc_errno(aclsts);
2497a41f
JM		 1898 }
1899
e0e5e8d6 1900 PerlMem_free(vmsname);
2497a41f
JM		 1901 return rmsts;
1902
1903} /* end of kill_file() */
1904/*}}}*/
1905
1906
a0d0e21e
LW		 1907/*{{{int do_rmdir(char *name)*/
1908int
b8ffc8df 1909Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1910{
e0e5e8d6 1911 char * dirfile;
a0d0e21e 1912 int retval;
61bb5906 1913 Stat_t st;
a0d0e21e 1914
d94c5a78
JM		 1915 /* lstat returns a VMS fileified specification of the name */
1916 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 1917
46c05374 1918 retval = flex_lstat(name, &st);
d94c5a78
JM		 1919 if (retval != 0) {
1920 char * ret_spec;
1921
1922 /* Due to a historical feature, flex_stat/lstat can not see some */
1923 /* Unix format file names that the rest of the CRTL can see */
1924 /* Fixing that feature will cause some perl tests to fail */
1925 /* So try this one more time. */
1926
1927 retval = lstat(name, &st.crtl_stat);
1928 if (retval != 0)
1929 return -1;
1930
1931 /* force it to a file spec for the kill file to work. */
1932 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1933 if (ret_spec == NULL) {
1934 errno = EIO;
1935 return -1;
1936 }
e0e5e8d6 1937 }
d94c5a78
JM		 1938
1939 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1940 errno = ENOTDIR;
1941 retval = -1;
1942 }
d94c5a78
JM		 1943 else {
1944 dirfile = st.st_devnam;
1945
1946 /* It may be possible for flex_stat to find a file and vmsify() to */
1947 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1948 /* with that case, so fail it */
1949 if (dirfile[0] == 0) {
1950 errno = EIO;
1951 return -1;
1952 }
1953
e0e5e8d6 1954 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 1955 }
e0e5e8d6 1956
a0d0e21e
LW		 1957 return retval;
1958
1959} /* end of do_rmdir */
1960/*}}}*/
1961
1962/* kill_file
1963 * Delete any file to which user has control access, regardless of whether
1964 * delete access is explicitly allowed.
1965 * Limitations: User must have write access to parent directory.
1966 * Does not block signals or ASTs; if interrupted in midstream
1967 * may leave file with an altered ACL.
1968 * HANDLE WITH CARE!
1969 */
1970/*{{{int kill_file(char *name)*/
1971int
b8ffc8df 1972Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1973{
d94c5a78 1974 char * vmsfile;
e0e5e8d6
JM		 1975 Stat_t st;
1976 int rmsts;
a0d0e21e 1977
d94c5a78
JM		 1978 /* Convert the filename to VMS format and see if it is a directory */
1979 /* flex_lstat returns a vmsified file specification */
46c05374 1980 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 1981 if (rmsts != 0) {
1982
1983 /* Due to a historical feature, flex_stat/lstat can not see some */
1984 /* Unix format file names that the rest of the CRTL can see when */
1985 /* ODS-2 file specifications are in use. */
1986 /* Fixing that feature will cause some perl tests to fail */
1987 /* [.lib.ExtUtils.t]Manifest.t is one of them */
1988 st.st_mode = 0;
1989 vmsfile = (char *) name; /* cast ok */
1990
1991 } else {
1992 vmsfile = st.st_devnam;
1993 if (vmsfile[0] == 0) {
1994 /* It may be possible for flex_stat to find a file and vmsify() */
1995 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
1996 /* deal with that case, so fail it */
1997 errno = EIO;
1998 return -1;
1999 }
2000 }
2001
2002 /* Remove() is allowed to delete directories, according to the X/Open
2003 * specifications.
2004 * This may need special handling to work with the ACL hacks.
a0d0e21e 2005 */
d94c5a78
JM		 2006 if (S_ISDIR(st.st_mode)) {
2007 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2008 return rmsts;
a0d0e21e
LW		 2009 }
2010
d94c5a78
JM		 2011 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2012
2013 /* Need to delete all versions ? */
2014 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2015 int i = 0;
2016
2017 /* Just use lstat() here as do not need st_dev */
2018 /* and we know that the file is in VMS format or that */
2019 /* because of a historical bug, flex_stat can not see the file */
2020 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2021 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2022 if (rmsts != 0)
2023 break;
2024 i++;
2025
2026 /* Make sure that we do not loop forever */
2027 if (i > 32767) {
2028 errno = EIO;
2029 rmsts = -1;
2030 break;
2031 }
2032 }
2033 }
a0d0e21e
LW		 2034
2035 return rmsts;
2036
2037} /* end of kill_file() */
2038/*}}}*/
2039
8cc95fdb 2040
84902520 2041/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2042int
b8ffc8df 2043Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2044{
2045 STRLEN dirlen = strlen(dir);
2046
a2a90019
CB		 2047 /* zero length string sometimes gives ACCVIO */
2048 if (dirlen == 0) return -1;
2049
8cc95fdb 2050 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2051 * null file name/type. However, it's commonplace under Unix,
2052 * so we'll allow it for a gain in portability.
2053 */
2054 if (dir[dirlen-1] == '/') {
2055 char *newdir = savepvn(dir,dirlen-1);
2056 int ret = mkdir(newdir,mode);
2057 Safefree(newdir);
2058 return ret;
2059 }
2060 else return mkdir(dir,mode);
2061} /* end of my_mkdir */
2062/*}}}*/
2063
ee8c7f54
CB		 2064/*{{{int my_chdir(char *)*/
2065int
b8ffc8df 2066Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2067{
2068 STRLEN dirlen = strlen(dir);
09f253ec 2069 const char *dir1 = dir;
ee8c7f54 2070
0fd91152 2071 /* POSIX says we should set ENOENT for zero length string. */
09f253ec 2072 if (dirlen == 0) {
0fd91152 2073 SETERRNO(ENOENT, RMS$_DNF);
09f253ec
CB		 2074 return -1;
2075 }
f7ddb74a
JM		 2076
2077 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2079 * so that existing scripts do not need to be changed.
2080 */
f7ddb74a
JM		 2081 while ((dirlen > 0) && (*dir1 == ' ')) {
2082 dir1++;
2083 dirlen--;
2084 }
ee8c7f54
CB		 2085
2086 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2087 * that implies
2088 * null file name/type. However, it's commonplace under Unix,
2089 * so we'll allow it for a gain in portability.
f7ddb74a 2090 *
4d9538c1 2091 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2092 */
f7ddb74a 2093 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2094 char *newdir;
2095 int ret;
c11536f5 2096 newdir = (char *)PerlMem_malloc(dirlen);
4d9538c1
JM		 2097 if (newdir ==NULL)
2098 _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 2099 memcpy(newdir, dir1, dirlen-1);
4d9538c1
JM		 2100 newdir[dirlen-1] = '\0';
2101 ret = chdir(newdir);
2102 PerlMem_free(newdir);
2103 return ret;
ee8c7f54 2104 }
dca5a913 2105 else return chdir(dir1);
ee8c7f54
CB		 2106} /* end of my_chdir */
2107/*}}}*/
8cc95fdb 2108
674d6c38 2109
f1db9cda
JM		 2110/*{{{int my_chmod(char *, mode_t)*/
2111int
2112Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2113{
4d9538c1
JM		 2114 Stat_t st;
2115 int ret = -1;
2116 char * changefile;
f1db9cda
JM		 2117 STRLEN speclen = strlen(file_spec);
2118
2119 /* zero length string sometimes gives ACCVIO */
2120 if (speclen == 0) return -1;
2121
2122 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2123 * that implies null file name/type. However, it's commonplace under Unix,
2124 * so we'll allow it for a gain in portability.
2125 *
2126 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2127 * in VMS file.dir notation.
2128 */
4d9538c1
JM		 2129 changefile = (char *) file_spec; /* cast ok */
2130 ret = flex_lstat(file_spec, &st);
2131 if (ret != 0) {
f1db9cda 2132
4d9538c1
JM		 2133 /* Due to a historical feature, flex_stat/lstat can not see some */
2134 /* Unix format file names that the rest of the CRTL can see when */
2135 /* ODS-2 file specifications are in use. */
2136 /* Fixing that feature will cause some perl tests to fail */
2137 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2138 st.st_mode = 0;
f1db9cda 2139
4d9538c1
JM		 2140 } else {
2141 /* It may be possible to get here with nothing in st_devname */
2142 /* chmod still may work though */
2143 if (st.st_devnam[0] != 0) {
2144 changefile = st.st_devnam;
2145 }
f1db9cda 2146 }
4d9538c1
JM		 2147 ret = chmod(changefile, mode);
2148 return ret;
f1db9cda
JM		 2149} /* end of my_chmod */
2150/*}}}*/
2151
2152
674d6c38
CB		 2153/*{{{FILE *my_tmpfile()*/
2154FILE *
2155my_tmpfile(void)
2156{
2157 FILE *fp;
2158 char *cp;
674d6c38
CB		 2159
2160 if ((fp = tmpfile())) return fp;
2161
c11536f5 2162 cp = (char *)PerlMem_malloc(L_tmpnam+24);
c5375c28
JM		 2163 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2164
1d60dc3f 2165 if (DECC_FILENAME_UNIX_ONLY == 0)
2497a41f
JM		 2166 strcpy(cp,"Sys$Scratch:");
2167 else
2168 strcpy(cp,"/tmp/");
674d6c38
CB		 2169 tmpnam(cp+strlen(cp));
2170 strcat(cp,".Perltmp");
2171 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2172 PerlMem_free(cp);
674d6c38
CB		 2173 return fp;
2174}
2175/*}}}*/
2176
5c2d7af2 2177
5c2d7af2
CB		 2178/*
2179 * The C RTL's sigaction fails to check for invalid signal numbers so we
2180 * help it out a bit. The docs are correct, but the actual routine doesn't
2181 * do what the docs say it will.
2182 */
2183/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2184int
2185Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2186 struct sigaction* oact)
2187{
2188 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2189 SETERRNO(EINVAL, SS$_INVARG);
2190 return -1;
2191 }
2192 return sigaction(sig, act, oact);
2193}
2194/*}}}*/
5c2d7af2 2195
f2610a60
CL		 2196#include <errnodef.h>
2197
05c058bc
CB		 2198/* We implement our own kill() using the undocumented system service
2199 sys$sigprc for one of two reasons:
2200
2201 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2202 target process to do a sys$exit, which usually can't be handled
2203 gracefully...certainly not by Perl and the %SIG{} mechanism.
2204
05c058bc
CB		 2205 2.) If the kill() in the CRTL can't be called from a signal
2206 handler without disappearing into the ether, i.e., the signal
2207 it purportedly sends is never trapped. Still true as of VMS 7.3.
2208
2209 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2210 in the target process rather than calling sys$exit.
2211
2212 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2213 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2214 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2215 with condition codes C$_SIG0+nsig*8, catching the exception on the
2216 target process and resignaling with appropriate arguments.
2217
2218 But we don't have that VMS 7.0+ exception handler, so if you
2219 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2220
2221 Also note that SIGTERM is listed in the docs as being "unimplemented",
2222 yet always seems to be signaled with a VMS condition code of 4 (and
2223 correctly handled for that code). So we hardwire it in.
2224
2225 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2226 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2227 than signalling with an unrecognized (and unhandled by CRTL) code.
2228*/
2229
fe1de8ce 2230#define _MY_SIG_MAX 28
f2610a60 2231
9c1171d1
JM		 2232static unsigned int
2233Perl_sig_to_vmscondition_int(int sig)
f2610a60 2234{
2e34cc90 2235 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2236 {
2237 0, /* 0 ZERO */
2238 SS$_HANGUP, /* 1 SIGHUP */
2239 SS$_CONTROLC, /* 2 SIGINT */
2240 SS$_CONTROLY, /* 3 SIGQUIT */
2241 SS$_RADRMOD, /* 4 SIGILL */
2242 SS$_BREAK, /* 5 SIGTRAP */
2243 SS$_OPCCUS, /* 6 SIGABRT */
2244 SS$_COMPAT, /* 7 SIGEMT */
f2610a60 2245 SS$_HPARITH, /* 8 SIGFPE AXP */
f2610a60
CL		 2246 SS$_ABORT, /* 9 SIGKILL */
2247 SS$_ACCVIO, /* 10 SIGBUS */
2248 SS$_ACCVIO, /* 11 SIGSEGV */
2249 SS$_BADPARAM, /* 12 SIGSYS */
2250 SS$_NOMBX, /* 13 SIGPIPE */
2251 SS$_ASTFLT, /* 14 SIGALRM */
2252 4, /* 15 SIGTERM */
2253 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2254 0, /* 17 SIGUSR2 */
2255 0, /* 18 */
2256 0, /* 19 */
2257 0, /* 20 SIGCHLD */
2258 0, /* 21 SIGCONT */
2259 0, /* 22 SIGSTOP */
2260 0, /* 23 SIGTSTP */
2261 0, /* 24 SIGTTIN */
2262 0, /* 25 SIGTTOU */
2263 0, /* 26 */
2264 0, /* 27 */
2265 0 /* 28 SIGWINCH */
f2610a60
CL		 2266 };
2267
f2610a60
CL		 2268 static int initted = 0;
2269 if (!initted) {
2270 initted = 1;
2271 sig_code[16] = C$_SIGUSR1;
2272 sig_code[17] = C$_SIGUSR2;
fe1de8ce 2273 sig_code[20] = C$_SIGCHLD;
fe1de8ce 2274 sig_code[28] = C$_SIGWINCH;
f2610a60 2275 }
f2610a60 2276
2e34cc90
CL		 2277 if (sig < _SIG_MIN) return 0;
2278 if (sig > _MY_SIG_MAX) return 0;
2279 return sig_code[sig];
2280}
2281
9c1171d1
JM		 2282unsigned int
2283Perl_sig_to_vmscondition(int sig)
2284{
2285#ifdef SS$_DEBUG
2286 if (vms_debug_on_exception != 0)
2287 lib$signal(SS$_DEBUG);
2288#endif
2289 return Perl_sig_to_vmscondition_int(sig);
2290}
2291
2292
96f902ff 2293#ifdef KILL_BY_SIGPRC
c11536f5
CB		 2294#define sys$sigprc SYS$SIGPRC
2295#ifdef __cplusplus
2296extern "C" {
2297#endif
2298int sys$sigprc(unsigned int *pidadr,
2299 struct dsc$descriptor_s *prcname,
2300 unsigned int code);
2301#ifdef __cplusplus
2302}
2303#endif
2304
2e34cc90
CL		 2305int
2306Perl_my_kill(int pid, int sig)
2307{
2308 int iss;
2309 unsigned int code;
2e34cc90 2310
7a7fd8e0
JM		 2311 /* sig 0 means validate the PID */
2312 /*------------------------------*/
2313 if (sig == 0) {
2314 const unsigned long int jpicode = JPI$_PID;
2315 pid_t ret_pid;
2316 int status;
2317 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2318 if ($VMS_STATUS_SUCCESS(status))
2319 return 0;
2320 switch (status) {
2321 case SS$_NOSUCHNODE:
2322 case SS$_UNREACHABLE:
2323 case SS$_NONEXPR:
2324 errno = ESRCH;
2325 break;
2326 case SS$_NOPRIV:
2327 errno = EPERM;
2328 break;
2329 default:
2330 errno = EVMSERR;
2331 }
2332 vaxc$errno=status;
2333 return -1;
2334 }
2335
9c1171d1 2336 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2337
7a7fd8e0
JM		 2338 if (!code) {
2339 SETERRNO(EINVAL, SS$_BADPARAM);
2340 return -1;
2341 }
2342
96f902ff 2343 /* Per official UNIX specification: If pid = 0, or negative then
7a7fd8e0
JM		 2344 * signals are to be sent to multiple processes.
2345 * pid = 0 - all processes in group except ones that the system exempts
2346 * pid = -1 - all processes except ones that the system exempts
2347 * pid = -n - all processes in group (abs(n)) except ...
96f902ff
CB		 2348 *
2349 * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2350 * in doio.c already does that. killpg currently does not support the -1 case.
7a7fd8e0
JM		 2351 */
2352
2353 if (pid <= 0) {
96f902ff 2354 return killpg(-pid, sig);
f2610a60
CL		 2355 }
2356
2e34cc90 2357 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2358 if (iss&1) return 0;
2359
2360 switch (iss) {
2361 case SS$_NOPRIV:
2362 set_errno(EPERM); break;
2363 case SS$_NONEXPR:
2364 case SS$_NOSUCHNODE:
2365 case SS$_UNREACHABLE:
2366 set_errno(ESRCH); break;
2367 case SS$_INSFMEM:
2368 set_errno(ENOMEM); break;
2369 default:
ebd4d70b 2370 _ckvmssts_noperl(iss);
f2610a60
CL		 2371 set_errno(EVMSERR);
2372 }
2373 set_vaxc_errno(iss);
2374
2375 return -1;
2376}
2377#endif
2378
96f902ff
CB		 2379int
2380Perl_my_killpg(pid_t master_pid, int signum)
2381{
2382 int pid, status, i;
2383 unsigned long int jpi_context;
2384 unsigned short int iosb[4];
2385 struct itmlst_3 il3[3];
2386
2387 /* All processes on the system? Seems dangerous, but it looks
2388 * like we could implement this pretty easily with a wildcard
2389 * input to sys$process_scan.
2390 */
2391 if (master_pid == -1) {
2392 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2393 return -1;
2394 }
2395
2396 /* All processes in the current process group; find the master
2397 * pid for the current process.
2398 */
2399 if (master_pid == 0) {
2400 i = 0;
2401 il3[i].buflen = sizeof( int );
2402 il3[i].itmcode = JPI$_MASTER_PID;
2403 il3[i].bufadr = &master_pid;
2404 il3[i++].retlen = NULL;
2405
2406 il3[i].buflen = 0;
2407 il3[i].itmcode = 0;
2408 il3[i].bufadr = NULL;
2409 il3[i++].retlen = NULL;
2410
2411 status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2412 if ($VMS_STATUS_SUCCESS(status))
2413 status = iosb[0];
2414
2415 switch (status) {
2416 case SS$_NORMAL:
2417 break;
2418 case SS$_NOPRIV:
2419 case SS$_SUSPENDED:
2420 SETERRNO(EPERM, status);
2421 break;
2422 case SS$_NOMOREPROC:
2423 case SS$_NONEXPR:
2424 case SS$_NOSUCHNODE:
2425 case SS$_UNREACHABLE:
2426 SETERRNO(ESRCH, status);
2427 break;
2428 case SS$_ACCVIO:
2429 case SS$_BADPARAM:
2430 SETERRNO(EINVAL, status);
2431 break;
2432 default:
2433 SETERRNO(EVMSERR, status);
2434 }
2435 if (!$VMS_STATUS_SUCCESS(status))
2436 return -1;
2437 }
2438
2439 /* Set up a process context for those processes we will scan
2440 * with sys$getjpiw. Ask for all processes belonging to the
2441 * master pid.
2442 */
2443
2444 i = 0;
2445 il3[i].buflen = 0;
2446 il3[i].itmcode = PSCAN$_MASTER_PID;
2447 il3[i].bufadr = (void *)master_pid;
2448 il3[i++].retlen = NULL;
2449
2450 il3[i].buflen = 0;
2451 il3[i].itmcode = 0;
2452 il3[i].bufadr = NULL;
2453 il3[i++].retlen = NULL;
2454
2455 status = sys$process_scan(&jpi_context, il3);
2456 switch (status) {
2457 case SS$_NORMAL:
2458 break;
2459 case SS$_ACCVIO:
2460 case SS$_BADPARAM:
2461 case SS$_IVBUFLEN:
2462 case SS$_IVSSRQ:
2463 SETERRNO(EINVAL, status);
2464 break;
2465 default:
2466 SETERRNO(EVMSERR, status);
2467 }
2468 if (!$VMS_STATUS_SUCCESS(status))
2469 return -1;
2470
2471 i = 0;
2472 il3[i].buflen = sizeof(int);
2473 il3[i].itmcode = JPI$_PID;
2474 il3[i].bufadr = &pid;
2475 il3[i++].retlen = NULL;
2476
2477 il3[i].buflen = 0;
2478 il3[i].itmcode = 0;
2479 il3[i].bufadr = NULL;
2480 il3[i++].retlen = NULL;
2481
2482 /* Loop through the processes matching our specified criteria
2483 */
2484
2485 while (1) {
2486 /* Find the next process...
2487 */
2488 status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2489 if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2490
2491 switch (status) {
2492 case SS$_NORMAL:
2493 if (kill(pid, signum) == -1)
2494 break;
2495
2496 continue; /* next process */
2497 case SS$_NOPRIV:
2498 case SS$_SUSPENDED:
2499 SETERRNO(EPERM, status);
2500 break;
2501 case SS$_NOMOREPROC:
2502 break;
2503 case SS$_NONEXPR:
2504 case SS$_NOSUCHNODE:
2505 case SS$_UNREACHABLE:
2506 SETERRNO(ESRCH, status);
2507 break;
2508 case SS$_ACCVIO:
2509 case SS$_BADPARAM:
2510 SETERRNO(EINVAL, status);
2511 break;
2512 default:
2513 SETERRNO(EVMSERR, status);
2514 }
2515
2516 if (!$VMS_STATUS_SUCCESS(status))
2517 break;
2518 }
2519
2520 /* Release context-related resources.
2521 */
2522 (void) sys$process_scan(&jpi_context);
2523
2524 if (status != SS$_NOMOREPROC)
2525 return -1;
2526
2527 return 0;
2528}
2529
2fbb330f
JM		 2530/* Routine to convert a VMS status code to a UNIX status code.
2531** More tricky than it appears because of conflicting conventions with
2532** existing code.
2533**
2534** VMS status codes are a bit mask, with the least significant bit set for
2535** success.
2536**
2537** Special UNIX status of EVMSERR indicates that no translation is currently
2538** available, and programs should check the VMS status code.
2539**
2540** Programs compiled with _POSIX_EXIT have a special encoding that requires
2541** decoding.
2542*/
2543
2544#ifndef C_FACILITY_NO
2545#define C_FACILITY_NO 0x350000
2546#endif
2547#ifndef DCL_IVVERB
2548#define DCL_IVVERB 0x38090
2549#endif
2550
ce12d4b7
CB		 2551int
2552Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f 2553{
ce12d4b7
CB		 2554 int facility;
2555 int fac_sp;
2556 int msg_no;
2557 int msg_status;
2558 int unix_status;
2fbb330f
JM		 2559
2560 /* Assume the best or the worst */
2561 if (vms_status & STS$M_SUCCESS)
2562 unix_status = 0;
2563 else
2564 unix_status = EVMSERR;
2565
2566 msg_status = vms_status & ~STS$M_CONTROL;
2567
2568 facility = vms_status & STS$M_FAC_NO;
2569 fac_sp = vms_status & STS$M_FAC_SP;
2570 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2571
0968cdad 2572 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2573 switch(msg_no) {
2574 case SS$_NORMAL:
2575 unix_status = 0;
2576 break;
2577 case SS$_ACCVIO:
2578 unix_status = EFAULT;
2579 break;
7a7fd8e0
JM		 2580 case SS$_DEVOFFLINE:
2581 unix_status = EBUSY;
2582 break;
2583 case SS$_CLEARED:
2584 unix_status = ENOTCONN;
2585 break;
2586 case SS$_IVCHAN:
2fbb330f
JM		 2587 case SS$_IVLOGNAM:
2588 case SS$_BADPARAM:
2589 case SS$_IVLOGTAB:
2590 case SS$_NOLOGNAM:
2591 case SS$_NOLOGTAB:
2592 case SS$_INVFILFOROP:
2593 case SS$_INVARG:
2594 case SS$_NOSUCHID:
2595 case SS$_IVIDENT:
2596 unix_status = EINVAL;
2597 break;
7a7fd8e0
JM		 2598 case SS$_UNSUPPORTED:
2599 unix_status = ENOTSUP;
2600 break;
2fbb330f
JM		 2601 case SS$_FILACCERR:
2602 case SS$_NOGRPPRV:
2603 case SS$_NOSYSPRV:
2604 unix_status = EACCES;
2605 break;
2606 case SS$_DEVICEFULL:
2607 unix_status = ENOSPC;
2608 break;
2609 case SS$_NOSUCHDEV:
2610 unix_status = ENODEV;
2611 break;
2612 case SS$_NOSUCHFILE:
2613 case SS$_NOSUCHOBJECT:
2614 unix_status = ENOENT;
2615 break;
fb38d079
JM		 2616 case SS$_ABORT: /* Fatal case */
2617 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2618 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2619 unix_status = EINTR;
2620 break;
2621 case SS$_BUFFEROVF:
2622 unix_status = E2BIG;
2623 break;
2624 case SS$_INSFMEM:
2625 unix_status = ENOMEM;
2626 break;
2627 case SS$_NOPRIV:
2628 unix_status = EPERM;
2629 break;
2630 case SS$_NOSUCHNODE:
2631 case SS$_UNREACHABLE:
2632 unix_status = ESRCH;
2633 break;
2634 case SS$_NONEXPR:
2635 unix_status = ECHILD;
2636 break;
2637 default:
2638 if ((facility == 0) && (msg_no < 8)) {
2639 /* These are not real VMS status codes so assume that they are
2640 ** already UNIX status codes
2641 */
2642 unix_status = msg_no;
2643 break;
2644 }
2645 }
2646 }
2647 else {
2648 /* Translate a POSIX exit code to a UNIX exit code */
2649 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2650 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2651 }
2652 else {
7a7fd8e0
JM		 2653
2654 /* Documented traditional behavior for handling VMS child exits */
2655 /*--------------------------------------------------------------*/
2656 if (child_flag != 0) {
2657
2658 /* Success / Informational return 0 */
2659 /*----------------------------------*/
2660 if (msg_no & STS$K_SUCCESS)
2661 return 0;
2662
2663 /* Warning returns 1 */
2664 /*-------------------*/
2665 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2666 return 1;
2667
2668 /* Everything else pass through the severity bits */
2669 /*------------------------------------------------*/
2670 return (msg_no & STS$M_SEVERITY);
2671 }
2672
2673 /* Normal VMS status to ERRNO mapping attempt */
2674 /*--------------------------------------------*/
2fbb330f
JM		 2675 switch(msg_status) {
2676 /* case RMS$_EOF: */ /* End of File */
2677 case RMS$_FNF: /* File Not Found */
2678 case RMS$_DNF: /* Dir Not Found */
2679 unix_status = ENOENT;
2680 break;
2681 case RMS$_RNF: /* Record Not Found */
2682 unix_status = ESRCH;
2683 break;
2684 case RMS$_DIR:
2685 unix_status = ENOTDIR;
2686 break;
2687 case RMS$_DEV:
2688 unix_status = ENODEV;
2689 break;
7a7fd8e0
JM		 2690 case RMS$_IFI:
2691 case RMS$_FAC:
2692 case RMS$_ISI:
2693 unix_status = EBADF;
2694 break;
2695 case RMS$_FEX:
2696 unix_status = EEXIST;
2697 break;
2fbb330f
JM		 2698 case RMS$_SYN:
2699 case RMS$_FNM:
2700 case LIB$_INVSTRDES:
2701 case LIB$_INVARG:
2702 case LIB$_NOSUCHSYM:
2703 case LIB$_INVSYMNAM:
2704 case DCL_IVVERB:
2705 unix_status = EINVAL;
2706 break;
2707 case CLI$_BUFOVF:
2708 case RMS$_RTB:
2709 case CLI$_TKNOVF:
2710 case CLI$_RSLOVF:
2711 unix_status = E2BIG;
2712 break;
2713 case RMS$_PRV: /* No privilege */
2714 case RMS$_ACC: /* ACP file access failed */
2715 case RMS$_WLK: /* Device write locked */
2716 unix_status = EACCES;
2717 break;
ed1b9de0
JM		 2718 case RMS$_MKD: /* Failed to mark for delete */
2719 unix_status = EPERM;
2720 break;
2fbb330f
JM		 2721 /* case RMS$_NMF: */ /* No more files */
2722 }
2723 }
2724 }
2725
2726 return unix_status;
2727}
2728
7a7fd8e0
JM		 2729/* Try to guess at what VMS error status should go with a UNIX errno
2730 * value. This is hard to do as there could be many possible VMS
2731 * error statuses that caused the errno value to be set.
2732 */
2733
ce12d4b7
CB		 2734int
2735Perl_unix_status_to_vms(int unix_status)
7a7fd8e0 2736{
ce12d4b7 2737 int test_unix_status;
7a7fd8e0
JM		 2738
2739 /* Trivial cases first */
2740 /*---------------------*/
2741 if (unix_status == EVMSERR)
2742 return vaxc$errno;
2743
2744 /* Is vaxc$errno sane? */
2745 /*---------------------*/
2746 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2747 if (test_unix_status == unix_status)
2748 return vaxc$errno;
2749
2750 /* If way out of range, must be VMS code already */
2751 /*-----------------------------------------------*/
2752 if (unix_status > EVMSERR)
2753 return unix_status;
2754
2755 /* If out of range, punt */
2756 /*-----------------------*/
2757 if (unix_status > __ERRNO_MAX)
2758 return SS$_ABORT;
2759
2760
2761 /* Ok, now we have to do it the hard way. */
2762 /*----------------------------------------*/
2763 switch(unix_status) {
2764 case 0: return SS$_NORMAL;
2765 case EPERM: return SS$_NOPRIV;
2766 case ENOENT: return SS$_NOSUCHOBJECT;
2767 case ESRCH: return SS$_UNREACHABLE;
2768 case EINTR: return SS$_ABORT;
2769 /* case EIO: */
2770 /* case ENXIO: */
2771 case E2BIG: return SS$_BUFFEROVF;
2772 /* case ENOEXEC */
2773 case EBADF: return RMS$_IFI;
2774 case ECHILD: return SS$_NONEXPR;
2775 /* case EAGAIN */
2776 case ENOMEM: return SS$_INSFMEM;
2777 case EACCES: return SS$_FILACCERR;
2778 case EFAULT: return SS$_ACCVIO;
2779 /* case ENOTBLK */
0968cdad 2780 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2781 case EEXIST: return RMS$_FEX;
2782 /* case EXDEV */
2783 case ENODEV: return SS$_NOSUCHDEV;
2784 case ENOTDIR: return RMS$_DIR;
2785 /* case EISDIR */
2786 case EINVAL: return SS$_INVARG;
2787 /* case ENFILE */
2788 /* case EMFILE */
2789 /* case ENOTTY */
2790 /* case ETXTBSY */
2791 /* case EFBIG */
2792 case ENOSPC: return SS$_DEVICEFULL;
2793 case ESPIPE: return LIB$_INVARG;
2794 /* case EROFS: */
2795 /* case EMLINK: */
2796 /* case EPIPE: */
2797 /* case EDOM */
2798 case ERANGE: return LIB$_INVARG;
2799 /* case EWOULDBLOCK */
2800 /* case EINPROGRESS */
2801 /* case EALREADY */
2802 /* case ENOTSOCK */
2803 /* case EDESTADDRREQ */
2804 /* case EMSGSIZE */
2805 /* case EPROTOTYPE */
2806 /* case ENOPROTOOPT */
2807 /* case EPROTONOSUPPORT */
2808 /* case ESOCKTNOSUPPORT */
2809 /* case EOPNOTSUPP */
2810 /* case EPFNOSUPPORT */
2811 /* case EAFNOSUPPORT */
2812 /* case EADDRINUSE */
2813 /* case EADDRNOTAVAIL */
2814 /* case ENETDOWN */
2815 /* case ENETUNREACH */
2816 /* case ENETRESET */
2817 /* case ECONNABORTED */
2818 /* case ECONNRESET */
2819 /* case ENOBUFS */
2820 /* case EISCONN */
2821 case ENOTCONN: return SS$_CLEARED;
2822 /* case ESHUTDOWN */
2823 /* case ETOOMANYREFS */
2824 /* case ETIMEDOUT */
2825 /* case ECONNREFUSED */
2826 /* case ELOOP */
2827 /* case ENAMETOOLONG */
2828 /* case EHOSTDOWN */
2829 /* case EHOSTUNREACH */
2830 /* case ENOTEMPTY */
2831 /* case EPROCLIM */
2832 /* case EUSERS */
2833 /* case EDQUOT */
2834 /* case ENOMSG */
2835 /* case EIDRM */
2836 /* case EALIGN */
2837 /* case ESTALE */
2838 /* case EREMOTE */
2839 /* case ENOLCK */
2840 /* case ENOSYS */
2841 /* case EFTYPE */
2842 /* case ECANCELED */
2843 /* case EFAIL */
2844 /* case EINPROG */
2845 case ENOTSUP:
2846 return SS$_UNSUPPORTED;
2847 /* case EDEADLK */
2848 /* case ENWAIT */
2849 /* case EILSEQ */
2850 /* case EBADCAT */
2851 /* case EBADMSG */
2852 /* case EABANDONED */
2853 default:
2854 return SS$_ABORT; /* punt */
2855 }
7a7fd8e0 2856}
2fbb330f
JM		 2857
2858
22d4bb9c 2859/* default piping mailbox size */
054a3baf 2860#define PERL_BUFSIZ 8192
22d4bb9c 2861
674d6c38 2862
a0d0e21e 2863static void
8a646e0b 2864create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2865{
22d4bb9c
CB		 2866 unsigned long int mbxbufsiz;
2867 static unsigned long int syssize = 0;
2868 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2869 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2870 int sts;
2871
22d4bb9c
CB		 2872 if (!syssize) {
2873 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2874 /*
22d4bb9c
CB		 2875 * Get the SYSGEN parameter MAXBUF
2876 *
2877 * If the logical 'PERL_MBX_SIZE' is defined
2878 * use the value of the logical instead of PERL_BUFSIZ, but
2879 * keep the size between 128 and MAXBUF.
2880 *
a0d0e21e 2881 */
ebd4d70b 2882 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2883 }
2884
2885 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2886 mbxbufsiz = atoi(csize);
2887 } else {
2888 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2889 }
22d4bb9c
CB		 2890 if (mbxbufsiz < 128) mbxbufsiz = 128;
2891 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2892
ebd4d70b 2893 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2894
ebd4d70b
JM		 2895 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2896 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2897 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2898
2899} /* end of create_mbx() */
2900
22d4bb9c 2901
a0d0e21e 2902/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2903
2904typedef struct _iosb IOSB;
2905typedef struct _iosb* pIOSB;
2906typedef struct _pipe Pipe;
2907typedef struct _pipe* pPipe;
2908typedef struct pipe_details Info;
2909typedef struct pipe_details* pInfo;
2910typedef struct _srqp RQE;
2911typedef struct _srqp* pRQE;
2912typedef struct _tochildbuf CBuf;
2913typedef struct _tochildbuf* pCBuf;
2914
2915struct _iosb {
2916 unsigned short status;
2917 unsigned short count;
2918 unsigned long dvispec;
2919};
2920
2921#pragma member_alignment save
2922#pragma nomember_alignment quadword
2923struct _srqp { /* VMS self-relative queue entry */
2924 unsigned long qptr[2];
2925};
2926#pragma member_alignment restore
2927static RQE RQE_ZERO = {0,0};
2928
2929struct _tochildbuf {
2930 RQE q;
2931 int eof;
2932 unsigned short size;
2933 char *buf;
2934};
2935
2936struct _pipe {
2937 RQE free;
2938 RQE wait;
2939 int fd_out;
2940 unsigned short chan_in;
2941 unsigned short chan_out;
2942 char *buf;
2943 unsigned int bufsize;
2944 IOSB iosb;
2945 IOSB iosb2;
2946 int *pipe_done;
2947 int retry;
2948 int type;
2949 int shut_on_empty;
2950 int need_wake;
2951 pPipe *home;
2952 pInfo info;
2953 pCBuf curr;
2954 pCBuf curr2;
fd8cd3a3
DS		 2955#if defined(PERL_IMPLICIT_CONTEXT)
2956 void *thx; /* Either a thread or an interpreter */
2957 /* pointer, depending on how we're built */
2958#endif
22d4bb9c
CB		 2959};
2960
2961
a0d0e21e
LW		 2962struct pipe_details
2963{
22d4bb9c 2964 pInfo next;
ff7adb52
CL		 2965 PerlIO *fp; /* file pointer to pipe mailbox */
2966 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2967 int pid; /* PID of subprocess */
2968 int mode; /* == 'r' if pipe open for reading */
2969 int done; /* subprocess has completed */
ff7adb52 2970 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2971 int closing; /* my_pclose is closing this pipe */
2972 unsigned long completion; /* termination status of subprocess */
2973 pPipe in; /* pipe in to sub */
2974 pPipe out; /* pipe out of sub */
2975 pPipe err; /* pipe of sub's sys$error */
2976 int in_done; /* true when in pipe finished */
2977 int out_done;
2978 int err_done;
cd1191f1
CB		 2979 unsigned short xchan; /* channel to debug xterm */
2980 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2981};
2982
748a9306
LW		 2983struct exit_control_block
2984{
2985 struct exit_control_block *flink;
f7c699a0 2986 unsigned long int (*exit_routine)(void);
748a9306
LW		 2987 unsigned long int arg_count;
2988 unsigned long int *status_address;
2989 unsigned long int exit_status;
2990};
2991
d85f548a
JH		 2992typedef struct _closed_pipes Xpipe;
2993typedef struct _closed_pipes* pXpipe;
2994
2995struct _closed_pipes {
2996 int pid; /* PID of subprocess */
2997 unsigned long completion; /* termination status of subprocess */
2998};
2999#define NKEEPCLOSED 50
3000static Xpipe closed_list[NKEEPCLOSED];
3001static int closed_index = 0;
3002static int closed_num = 0;
3003
22d4bb9c
CB		 3004#define RETRY_DELAY "0 ::0.20"
3005#define MAX_RETRY 50
a0d0e21e 3006
22d4bb9c
CB		 3007static int pipe_ef = 0; /* first call to safe_popen inits these*/
3008static unsigned long mypid;
3009static unsigned long delaytime[2];
3010
3011static pInfo open_pipes = NULL;
3012static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 3013
ff7adb52
CL		 3014#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
3015
3016
3eeba6fb 3017
748a9306 3018static unsigned long int
f7c699a0 3019pipe_exit_routine(void)
748a9306 3020{
22d4bb9c 3021 pInfo info;
1e422769 3022 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
4e0c9737 3023 int sts, did_stuff, j;
ff7adb52 3024
5ce486e0
CB		 3025 /*
3026 * Flush any pending i/o, but since we are in process run-down, be
3027 * careful about referencing PerlIO structures that may already have
3028 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 3029 */
3030 info = open_pipes;
3031 while (info) {
3032 if (info->fp) {
ebd4d70b
JM		 3033#if defined(PERL_IMPLICIT_CONTEXT)
3034 /* We need to use the Perl context of the thread that created */
3035 /* the pipe. */
3036 pTHX;
3037 if (info->err)
3038 aTHX = info->err->thx;
3039 else if (info->out)
3040 aTHX = info->out->thx;
3041 else if (info->in)
3042 aTHX = info->in->thx;
3043#endif
5ce486e0
CB		 3044 if (!info->useFILE
3045#if defined(USE_ITHREADS)
3046 && my_perl
3047#endif
a24c654f
CB		 3048#ifdef USE_PERLIO
3049 && PL_perlio_fd_refcnt
3050#endif
3051 )
5ce486e0 3052 PerlIO_flush(info->fp);
ff7adb52
CL		 3053 else
3054 fflush((FILE *)info->fp);
3055 }
3056 info = info->next;
3057 }
3eeba6fb
CB		 3058
3059 /*
ff7adb52 3060 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 3061 don't hang
3062 */
3063 did_stuff = 0;
3064 info = open_pipes;
748a9306 3065
3eeba6fb 3066 while (info) {
d4c83939 3067 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 3068 if (info->in && !info->in->shut_on_empty) {
d4c83939 3069 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 3070 0, 0, 0, 0, 0, 0));
ff7adb52 3071 info->waiting = 1;
22d4bb9c 3072 did_stuff = 1;
748a9306 3073 }
d4c83939 3074 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3075 info = info->next;
3076 }
ff7adb52
CL		 3077
3078 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3079
3080 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3081 int nwait = 0;
3082
3083 info = open_pipes;
3084 while (info) {
d4c83939 3085 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3086 if (info->waiting && info->done)
3087 info->waiting = 0;
3088 nwait += info->waiting;
d4c83939 3089 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3090 info = info->next;
3091 }
3092 if (!nwait) break;
3093 sleep(1);
3094 }
3eeba6fb
CB		 3095
3096 did_stuff = 0;
3097 info = open_pipes;
3098 while (info) {
d4c83939 3099 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3100 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3101 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3102 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3103 did_stuff = 1;
3104 }
d4c83939 3105 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3106 info = info->next;
3107 }
ff7adb52
CL		 3108
3109 /* again, wait for effect */
3110
3111 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3112 int nwait = 0;
3113
3114 info = open_pipes;
3115 while (info) {
d4c83939 3116 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3117 if (info->waiting && info->done)
3118 info->waiting = 0;
3119 nwait += info->waiting;
d4c83939 3120 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3121 info = info->next;
3122 }
3123 if (!nwait) break;
3124 sleep(1);
3125 }
3eeba6fb
CB		 3126
3127 info = open_pipes;
3128 while (info) {
d4c83939 3129 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3130 if (!info->done) { /* We tried to be nice . . . */
3131 sts = sys$delprc(&info->pid,0);
d4c83939 3132 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3133 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3134 }
d4c83939 3135 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3136 info = info->next;
3137 }
3138
3139 while(open_pipes) {
ebd4d70b
JM		 3140
3141#if defined(PERL_IMPLICIT_CONTEXT)
3142 /* We need to use the Perl context of the thread that created */
3143 /* the pipe. */
3144 pTHX;
36b6faa8
CB		 3145 if (open_pipes->err)
3146 aTHX = open_pipes->err->thx;
3147 else if (open_pipes->out)
3148 aTHX = open_pipes->out->thx;
3149 else if (open_pipes->in)
3150 aTHX = open_pipes->in->thx;
ebd4d70b 3151#endif
1e422769 3152 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3153 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3154 }
3155 return retsts;
3156}
3157
3158static struct exit_control_block pipe_exitblock =
3159 {(struct exit_control_block *) 0,
3160 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3161
22d4bb9c
CB		 3162static void pipe_mbxtofd_ast(pPipe p);
3163static void pipe_tochild1_ast(pPipe p);
3164static void pipe_tochild2_ast(pPipe p);
748a9306 3165
a0d0e21e 3166static void
22d4bb9c 3167popen_completion_ast(pInfo info)
a0d0e21e 3168{
22d4bb9c
CB		 3169 pInfo i = open_pipes;
3170 int iss;
d85f548a
JH		 3171
3172 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3173 closed_list[closed_index].pid = info->pid;
3174 closed_list[closed_index].completion = info->completion;
3175 closed_index++;
3176 if (closed_index == NKEEPCLOSED)
3177 closed_index = 0;
3178 closed_num++;
22d4bb9c
CB		 3179
3180 while (i) {
3181 if (i == info) break;
3182 i = i->next;
3183 }
3184 if (!i) return; /* unlinked, probably freed too */
3185
22d4bb9c
CB		 3186 info->done = TRUE;
3187
3188/*
3189 Writing to subprocess ...
3190 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3191
3192 chan_out may be waiting for "done" flag, or hung waiting
3193 for i/o completion to child...cancel the i/o. This will
3194 put it into "snarf mode" (done but no EOF yet) that discards
3195 input.
3196
3197 Output from subprocess (stdout, stderr) needs to be flushed and
3198 shut down. We try sending an EOF, but if the mbx is full the pipe
3199 routine should still catch the "shut_on_empty" flag, telling it to
3200 use immediate-style reads so that "mbx empty" -> EOF.
3201
3202
3203*/
3204 if (info->in && !info->in_done) { /* only for mode=w */
3205 if (info->in->shut_on_empty && info->in->need_wake) {
3206 info->in->need_wake = FALSE;
fd8cd3a3 3207 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3208 } else {
fd8cd3a3 3209 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3210 }
3211 }
3212
3213 if (info->out && !info->out_done) { /* were we also piping output? */
3214 info->out->shut_on_empty = TRUE;
3215 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3216 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3217 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3218 }
3219
3220 if (info->err && !info->err_done) { /* we were piping stderr */
3221 info->err->shut_on_empty = TRUE;
3222 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3223 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3224 _ckvmssts_noperl(iss);
a0d0e21e 3225 }
fd8cd3a3 3226 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3227
a0d0e21e
LW		 3228}
3229
2fbb330f 3230static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3231static void vms_execfree(struct dsc$descriptor_s *vmscmd);
22d4bb9c
CB		 3232static void pipe_infromchild_ast(pPipe p);
3233
3234/*
3235 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3236 inside an AST routine without worrying about reentrancy and which Perl
3237 memory allocator is being used.
3238
3239 We read data and queue up the buffers, then spit them out one at a
3240 time to the output mailbox when the output mailbox is ready for one.
3241
3242*/
3243#define INITIAL_TOCHILDQUEUE 2
3244
3245static pPipe
fd8cd3a3 3246pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3247{
22d4bb9c
CB		 3248 pPipe p;
3249 pCBuf b;
3250 char mbx1[64], mbx2[64];
3251 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3252 DSC$K_CLASS_S, mbx1},
3253 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3254 DSC$K_CLASS_S, mbx2};
3255 unsigned int dviitm = DVI$_DEVBUFSIZ;
3256 int j, n;
3257
d4c83939 3258 n = sizeof(Pipe);
ebd4d70b 3259 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3260
8a646e0b
JM		 3261 create_mbx(&p->chan_in , &d_mbx1);
3262 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3263 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3264
3265 p->buf = 0;
3266 p->shut_on_empty = FALSE;
3267 p->need_wake = FALSE;
3268 p->type = 0;
3269 p->retry = 0;
3270 p->iosb.status = SS$_NORMAL;
3271 p->iosb2.status = SS$_NORMAL;
3272 p->free = RQE_ZERO;
3273 p->wait = RQE_ZERO;
3274 p->curr = 0;
3275 p->curr2 = 0;
3276 p->info = 0;
fd8cd3a3
DS		 3277#ifdef PERL_IMPLICIT_CONTEXT
3278 p->thx = aTHX;
3279#endif
22d4bb9c
CB		 3280
3281 n = sizeof(CBuf) + p->bufsize;
3282
3283 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3284 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3285 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3286 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3287 }
3288
3289 pipe_tochild2_ast(p);
3290 pipe_tochild1_ast(p);
3291 strcpy(wmbx, mbx1);
3292 strcpy(rmbx, mbx2);
3293 return p;
3294}
3295
3296/* reads the MBX Perl is writing, and queues */
3297
3298static void
3299pipe_tochild1_ast(pPipe p)
3300{
22d4bb9c
CB		 3301 pCBuf b = p->curr;
3302 int iss = p->iosb.status;
3303 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3304 int sts;
fd8cd3a3
DS		 3305#ifdef PERL_IMPLICIT_CONTEXT
3306 pTHX = p->thx;
3307#endif
22d4bb9c
CB		 3308
3309 if (p->retry) {
3310 if (eof) {
3311 p->shut_on_empty = TRUE;
3312 b->eof = TRUE;
ebd4d70b 3313 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3314 } else {
ebd4d70b 3315 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3316 }
3317
3318 b->eof = eof;
3319 b->size = p->iosb.count;
ebd4d70b 3320 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3321 if (p->need_wake) {
3322 p->need_wake = FALSE;
ebd4d70b 3323 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3324 }
3325 } else {
3326 p->retry = 1; /* initial call */
3327 }
3328
3329 if (eof) { /* flush the free queue, return when done */
3330 int n = sizeof(CBuf) + p->bufsize;
3331 while (1) {
3332 iss = lib$remqti(&p->free, &b);
3333 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3334 _ckvmssts_noperl(iss);
3335 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3336 }
3337 }
3338
3339 iss = lib$remqti(&p->free, &b);
3340 if (iss == LIB$_QUEWASEMP) {
3341 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3342 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3343 b->buf = (char *) b + sizeof(CBuf);
3344 } else {
ebd4d70b 3345 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3346 }
3347
3348 p->curr = b;
3349 iss = sys$qio(0,p->chan_in,
3350 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3351 &p->iosb,
3352 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3353 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3354 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3355}
3356
3357
3358/* writes queued buffers to output, waits for each to complete before
3359 doing the next */
3360
3361static void
3362pipe_tochild2_ast(pPipe p)
3363{
22d4bb9c
CB		 3364 pCBuf b = p->curr2;
3365 int iss = p->iosb2.status;
3366 int n = sizeof(CBuf) + p->bufsize;
3367 int done = (p->info && p->info->done) ||
3368 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3369#if defined(PERL_IMPLICIT_CONTEXT)
3370 pTHX = p->thx;
3371#endif
22d4bb9c
CB		 3372
3373 do {
3374 if (p->type) { /* type=1 has old buffer, dispose */
3375 if (p->shut_on_empty) {
ebd4d70b 3376 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3377 } else {
ebd4d70b 3378 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3379 }
3380 p->type = 0;
3381 }
3382
3383 iss = lib$remqti(&p->wait, &b);
3384 if (iss == LIB$_QUEWASEMP) {
3385 if (p->shut_on_empty) {
3386 if (done) {
ebd4d70b 3387 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3388 *p->pipe_done = TRUE;
ebd4d70b 3389 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3390 } else {
ebd4d70b 3391 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3392 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3393 }
3394 return;
3395 }
3396 p->need_wake = TRUE;
3397 return;
3398 }
ebd4d70b 3399 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3400 p->type = 1;
3401 } while (done);
3402
3403
3404 p->curr2 = b;
3405 if (b->eof) {
ebd4d70b 3406 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3407 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3408 } else {
ebd4d70b 3409 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3410 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3411 }
3412
3413 return;
3414
3415}
3416
3417
3418static pPipe
fd8cd3a3 3419pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3420{
22d4bb9c
CB		 3421 pPipe p;
3422 char mbx1[64], mbx2[64];
3423 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3424 DSC$K_CLASS_S, mbx1},
3425 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3426 DSC$K_CLASS_S, mbx2};
3427 unsigned int dviitm = DVI$_DEVBUFSIZ;
3428
d4c83939 3429 int n = sizeof(Pipe);
ebd4d70b 3430 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3431 create_mbx(&p->chan_in , &d_mbx1);
3432 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3433
ebd4d70b 3434 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3435 n = p->bufsize * sizeof(char);
ebd4d70b 3436 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3437 p->shut_on_empty = FALSE;
3438 p->info = 0;
3439 p->type = 0;
3440 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3441#if defined(PERL_IMPLICIT_CONTEXT)
3442 p->thx = aTHX;
3443#endif
22d4bb9c
CB		 3444 pipe_infromchild_ast(p);
3445
3446 strcpy(wmbx, mbx1);
3447 strcpy(rmbx, mbx2);
3448 return p;
3449}
3450
3451static void
3452pipe_infromchild_ast(pPipe p)
3453{
22d4bb9c
CB		 3454 int iss = p->iosb.status;
3455 int eof = (iss == SS$_ENDOFFILE);
3456 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3457 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3458#if defined(PERL_IMPLICIT_CONTEXT)
3459 pTHX = p->thx;
3460#endif
22d4bb9c
CB		 3461
3462 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3463 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3464 p->chan_out = 0;
3465 }
3466
3467 /* read completed:
3468 input shutdown if EOF from self (done or shut_on_empty)
3469 output shutdown if closing flag set (my_pclose)
3470 send data/eof from child or eof from self
3471 otherwise, re-read (snarf of data from child)
3472 */
3473
3474 if (p->type == 1) {
3475 p->type = 0;
3476 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3477 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3478 p->chan_in = 0;
3479 }
3480
3481 if (p->chan_out) {
3482 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3483 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3484 pipe_infromchild_ast, p,
3485 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3486 return;
3487 } else if (eof) { /* eat EOF --- fall through to read*/
3488
3489 } else { /* transmit data */
ebd4d70b
JM		 3490 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3491 pipe_infromchild_ast,p,
3492 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3493 return;
3494 }
3495 }
3496 }
3497
3498 /* everything shut? flag as done */
3499
3500 if (!p->chan_in && !p->chan_out) {
3501 *p->pipe_done = TRUE;
ebd4d70b 3502 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3503 return;
3504 }
3505
3506 /* write completed (or read, if snarfing from child)
3507 if still have input active,
3508 queue read...immediate mode if shut_on_empty so we get EOF if empty
3509 otherwise,
3510 check if Perl reading, generate EOFs as needed
3511 */
3512
3513 if (p->type == 0) {
3514 p->type = 1;
3515 if (p->chan_in) {
3516 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3517 pipe_infromchild_ast,p,
3518 p->buf, p->bufsize, 0, 0, 0, 0);
3519 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3520 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3521 } else { /* send EOFs for extra reads */
3522 p->iosb.status = SS$_ENDOFFILE;
3523 p->iosb.dvispec = 0;
ebd4d70b
JM		 3524 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3525 0, 0, 0,
3526 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3527 }
3528 }
3529}
3530
3531static pPipe
fd8cd3a3 3532pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3533{
22d4bb9c
CB		 3534 pPipe p;
3535 char mbx[64];
3536 unsigned long dviitm = DVI$_DEVBUFSIZ;
3537 struct stat s;
3538 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3539 DSC$K_CLASS_S, mbx};
a480973c 3540 int n = sizeof(Pipe);
22d4bb9c
CB		 3541
3542 /* things like terminals and mbx's don't need this filter */
3543 if (fd && fstat(fd,&s) == 0) {
4e0c9737 3544 unsigned long devchar;
cfcfe586
JM		 3545 char device[65];
3546 unsigned short dev_len;
3547 struct dsc$descriptor_s d_dev;
3548 char * cptr;
3549 struct item_list_3 items[3];
3550 int status;
3551 unsigned short dvi_iosb[4];
3552
3553 cptr = getname(fd, out, 1);
ebd4d70b 3554 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3555 d_dev.dsc$a_pointer = out;
3556 d_dev.dsc$w_length = strlen(out);
3557 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3558 d_dev.dsc$b_class = DSC$K_CLASS_S;
3559
3560 items[0].len = 4;
3561 items[0].code = DVI$_DEVCHAR;
3562 items[0].bufadr = &devchar;
3563 items[0].retadr = NULL;
3564 items[1].len = 64;
3565 items[1].code = DVI$_FULLDEVNAM;
3566 items[1].bufadr = device;
3567 items[1].retadr = &dev_len;
3568 items[2].len = 0;
3569 items[2].code = 0;
3570
3571 status = sys$getdviw
3572 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3573 _ckvmssts_noperl(status);
cfcfe586
JM		 3574 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3575 device[dev_len] = 0;
3576
3577 if (!(devchar & DEV$M_DIR)) {
3578 strcpy(out, device);
3579 return 0;
3580 }
3581 }
22d4bb9c
CB		 3582 }
3583
ebd4d70b 3584 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3585 p->fd_out = dup(fd);
8a646e0b 3586 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3587 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3588 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3589 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3590 p->shut_on_empty = FALSE;
3591 p->retry = 0;
3592 p->info = 0;
3593 strcpy(out, mbx);
3594
ebd4d70b
JM		 3595 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3596 pipe_mbxtofd_ast, p,
3597 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3598
3599 return p;
3600}
3601
3602static void
3603pipe_mbxtofd_ast(pPipe p)
3604{
22d4bb9c
CB		 3605 int iss = p->iosb.status;
3606 int done = p->info->done;
3607 int iss2;
3608 int eof = (iss == SS$_ENDOFFILE);
3609 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3610 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3611#if defined(PERL_IMPLICIT_CONTEXT)
3612 pTHX = p->thx;
3613#endif
22d4bb9c
CB		 3614
3615 if (done && myeof) { /* end piping */
3616 close(p->fd_out);
3617 sys$dassgn(p->chan_in);
3618 *p->pipe_done = TRUE;
ebd4d70b 3619 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3620 return;
3621 }
3622
3623 if (!err && !eof) { /* good data to send to file */
3624 p->buf[p->iosb.count] = '\n';
3625 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3626 if (iss2 < 0) {
3627 p->retry++;
3628 if (p->retry < MAX_RETRY) {
ebd4d70b 3629 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3630 return;
3631 }
3632 }
3633 p->retry = 0;
3634 } else if (err) {
ebd4d70b 3635 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3636 }
3637
3638
3639 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3640 pipe_mbxtofd_ast, p,
3641 p->buf, p->bufsize, 0, 0, 0, 0);
3642 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3643 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3644}
3645
3646
3647typedef struct _pipeloc PLOC;
3648typedef struct _pipeloc* pPLOC;
3649
3650struct _pipeloc {
3651 pPLOC next;
3652 char dir[NAM$C_MAXRSS+1];
3653};
3654static pPLOC head_PLOC = 0;
3655
5c0ae288 3656void
fd8cd3a3 3657free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3658{
3659 pPLOC p, pnext;
ff7adb52 3660 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3661
ff7adb52 3662 p = *pHead;
5c0ae288
CL		 3663 while (p) {
3664 pnext = p->next;
e0ef6b43 3665 PerlMem_free(p);
5c0ae288
CL		 3666 p = pnext;
3667 }
ff7adb52 3668 *pHead = 0;
5c0ae288 3669}
22d4bb9c
CB		 3670
3671static void
fd8cd3a3 3672store_pipelocs(pTHX)
22d4bb9c
CB		 3673{
3674 int i;
3675 pPLOC p;
ff7adb52 3676 AV *av = 0;
22d4bb9c 3677 SV *dirsv;
22d4bb9c
CB		 3678 char *dir, *x;
3679 char *unixdir;
3680 char temp[NAM$C_MAXRSS+1];
3681 STRLEN n_a;
3682
ff7adb52 3683 if (head_PLOC)
218fdd94 3684 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3685
22d4bb9c
CB		 3686/* the . directory from @INC comes last */
3687
e0ef6b43 3688 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3689 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3690 p->next = head_PLOC;
3691 head_PLOC = p;
3692 strcpy(p->dir,"./");
3693
3694/* get the directory from $^X */
3695
c11536f5 3696 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3697 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3698
218fdd94
CL		 3699#ifdef PERL_IMPLICIT_CONTEXT
3700 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3701#else
22d4bb9c 3702 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3703#endif
a35dcc95 3704 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
22d4bb9c 3705 x = strrchr(temp,']');
2497a41f
JM		 3706 if (x == NULL) {
3707 x = strrchr(temp,'>');
3708 if (x == NULL) {
3709 /* It could be a UNIX path */
3710 x = strrchr(temp,'/');
3711 }
3712 }
3713 if (x)
3714 x[1] = '\0';
3715 else {
3716 /* Got a bare name, so use default directory */
3717 temp[0] = '.';
3718 temp[1] = '\0';
3719 }
22d4bb9c 3720
4e205ed6 3721 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3722 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3723 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3724 p->next = head_PLOC;
3725 head_PLOC = p;
a35dcc95 3726 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
c5375c28 3727 }
22d4bb9c
CB		 3728 }
3729
3730/* reverse order of @INC entries, skip "." since entered above */
3731
218fdd94
CL		 3732#ifdef PERL_IMPLICIT_CONTEXT
3733 if (aTHX)
3734#endif
ff7adb52
CL		 3735 if (PL_incgv) av = GvAVn(PL_incgv);
3736
3737 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3738 dirsv = *av_fetch(av,i,TRUE);
3739
3740 if (SvROK(dirsv)) continue;
3741 dir = SvPVx(dirsv,n_a);
083b2a61 3742 if (strEQ(dir,".")) continue;
4e205ed6 3743 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3744 continue;
3745
e0ef6b43 3746 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3747 p->next = head_PLOC;
3748 head_PLOC = p;
a35dcc95 3749 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3750 }
3751
3752/* most likely spot (ARCHLIB) put first in the list */
3753
3754#ifdef ARCHLIB_EXP
4e205ed6 3755 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3756 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3757 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3758 p->next = head_PLOC;
3759 head_PLOC = p;
a35dcc95 3760 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3761 }
3762#endif
c5375c28 3763 PerlMem_free(unixdir);
22d4bb9c
CB		 3764}
3765
ce12d4b7
CB		 3766static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3767 const char *fname, int opts);
a1887106
JM		 3768#if !defined(PERL_IMPLICIT_CONTEXT)
3769#define cando_by_name_int Perl_cando_by_name_int
3770#else
3771#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3772#endif
22d4bb9c
CB		 3773
3774static char *
fd8cd3a3 3775find_vmspipe(pTHX)
22d4bb9c
CB		 3776{
3777 static int vmspipe_file_status = 0;
3778 static char vmspipe_file[NAM$C_MAXRSS+1];
3779
3780 /* already found? Check and use ... need read+execute permission */
3781
3782 if (vmspipe_file_status == 1) {
a1887106
JM		 3783 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3784 && cando_by_name_int
3785 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3786 return vmspipe_file;
3787 }
3788 vmspipe_file_status = 0;
3789 }
3790
3791 /* scan through stored @INC, $^X */
3792
3793 if (vmspipe_file_status == 0) {
3794 char file[NAM$C_MAXRSS+1];
3795 pPLOC p = head_PLOC;
3796
3797 while (p) {
2f4077ca 3798 char * exp_res;
4d743a9b 3799 int dirlen;
a35dcc95
CB		 3800 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3801 my_strlcat(file, "vmspipe.com", sizeof(file));
22d4bb9c
CB		 3802 p = p->next;
3803
6fb6c614 3804 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3805 if (!exp_res) continue;
22d4bb9c 3806
a1887106
JM		 3807 if (cando_by_name_int
3808 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3809 && cando_by_name_int
3810 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3811 vmspipe_file_status = 1;
3812 return vmspipe_file;
3813 }
3814 }
3815 vmspipe_file_status = -1; /* failed, use tempfiles */
3816 }
3817
3818 return 0;
3819}
3820
3821static FILE *
fd8cd3a3 3822vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3823{
3824 char file[NAM$C_MAXRSS+1];
3825 FILE *fp;
3826 static int index = 0;
2497a41f
JM		 3827 Stat_t s0, s1;
3828 int cmp_result;
22d4bb9c
CB		 3829
3830 /* create a tempfile */
3831
3832 /* we can't go from W, shr=get to R, shr=get without
3833 an intermediate vulnerable state, so don't bother trying...
3834
3835 and lib$spawn doesn't shr=put, so have to close the write
3836
3837 So... match up the creation date/time and the FID to
3838 make sure we're dealing with the same file
3839
3840 */
3841
3842 index++;
1d60dc3f 3843 if (!DECC_FILENAME_UNIX_ONLY) {
2497a41f
JM		 3844 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3845 fp = fopen(file,"w");
3846 if (!fp) {
22d4bb9c
CB		 3847 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3848 fp = fopen(file,"w");
3849 if (!fp) {
3850 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3851 fp = fopen(file,"w");
2497a41f
JM		 3852 }
3853 }
3854 }
3855 else {
3856 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3857 fp = fopen(file,"w");
3858 if (!fp) {
3859 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3860 fp = fopen(file,"w");
3861 if (!fp) {
3862 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3863 fp = fopen(file,"w");
3864 }
3865 }
22d4bb9c
CB		 3866 }
3867 if (!fp) return 0; /* we're hosed */
3868
f9ecfa39 3869 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3870 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3871 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3872 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3873 fprintf(fp,"$ perl_on = \"set noon\"\n");
3874 fprintf(fp,"$ perl_exit = \"exit\"\n");
3875 fprintf(fp,"$ perl_del = \"delete\"\n");
3876 fprintf(fp,"$ pif = \"if\"\n");
3877 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3878 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3879 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3880 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3881 fprintf(fp,"$! --- build command line to get max possible length\n");
3882 fprintf(fp,"$c=perl_popen_cmd0\n");
3883 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3884 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3885 fprintf(fp,"$x=perl_popen_cmd3\n");
3886 fprintf(fp,"$c=c+x\n");
22d4bb9c 3887 fprintf(fp,"$ perl_on\n");
f9ecfa39 3888 fprintf(fp,"$ 'c'\n");
22d4bb9c 3889 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3890 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3891 fprintf(fp,"$ perl_exit 'perl_status'\n");
3892 fsync(fileno(fp));
3893
3894 fgetname(fp, file, 1);
312ac60b 3895 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3896 fclose(fp);
3897
1d60dc3f 3898 if (DECC_FILENAME_UNIX_ONLY)
0e5ce2c7 3899 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3900 fp = fopen(file,"r","shr=get");
3901 if (!fp) return 0;
312ac60b 3902 fstat(fileno(fp), &s1.crtl_stat);
2497a41f 3903
682e4b71 3904 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3905 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3906 fclose(fp);
3907 return 0;
3908 }
3909
3910 return fp;
3911}
3912
3913
ce12d4b7
CB		 3914static int
3915vms_is_syscommand_xterm(void)
cd1191f1
CB		 3916{
3917 const static struct dsc$descriptor_s syscommand_dsc =
3918 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3919
3920 const static struct dsc$descriptor_s decwdisplay_dsc =
3921 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3922
3923 struct item_list_3 items[2];
3924 unsigned short dvi_iosb[4];
3925 unsigned long devchar;
3926 unsigned long devclass;
3927 int status;
3928
3929 /* Very simple check to guess if sys$command is a decterm? */
3930 /* First see if the DECW$DISPLAY: device exists */
3931 items[0].len = 4;
3932 items[0].code = DVI$_DEVCHAR;
3933 items[0].bufadr = &devchar;
3934 items[0].retadr = NULL;
3935 items[1].len = 0;
3936 items[1].code = 0;
3937
3938 status = sys$getdviw
3939 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3940
3941 if ($VMS_STATUS_SUCCESS(status)) {
3942 status = dvi_iosb[0];
3943 }
3944
3945 if (!$VMS_STATUS_SUCCESS(status)) {
3946 SETERRNO(EVMSERR, status);
3947 return -1;
3948 }
3949
3950 /* If it does, then for now assume that we are on a workstation */
3951 /* Now verify that SYS$COMMAND is a terminal */
3952 /* for creating the debugger DECTerm */
3953
3954 items[0].len = 4;
3955 items[0].code = DVI$_DEVCLASS;
3956 items[0].bufadr = &devclass;
3957 items[0].retadr = NULL;
3958 items[1].len = 0;
3959 items[1].code = 0;
3960
3961 status = sys$getdviw
3962 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3963
3964 if ($VMS_STATUS_SUCCESS(status)) {
3965 status = dvi_iosb[0];
3966 }
3967
3968 if (!$VMS_STATUS_SUCCESS(status)) {
3969 SETERRNO(EVMSERR, status);
3970 return -1;
3971 }
3972 else {
3973 if (devclass == DC$_TERM) {
3974 return 0;
3975 }
3976 }
3977 return -1;
3978}
3979
3980/* If we are on a DECTerm, we can pretend to fork xterms when requested */
ce12d4b7
CB		 3981static PerlIO*
3982create_forked_xterm(pTHX_ const char *cmd, const char *mode)
cd1191f1
CB		 3983{
3984 int status;
3985 int ret_stat;
3986 char * ret_char;
3987 char device_name[65];
3988 unsigned short device_name_len;
3989 struct dsc$descriptor_s customization_dsc;
3990 struct dsc$descriptor_s device_name_dsc;
3991 const char * cptr;
cd1191f1
CB		 3992 char customization[200];
3993 char title[40];
3994 pInfo info = NULL;
3995 char mbx1[64];
3996 unsigned short p_chan;
3997 int n;
3998 unsigned short iosb[4];
cd1191f1
CB		 3999 const char * cust_str =
4000 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4001 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4002 DSC$K_CLASS_S, mbx1};
4003
8cb5d3d5
JM		 4004 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4005 /*---------------------------------------*/
d30c1055 4006 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 4007
4008
4009 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 4010 ret_char = strstr(cmd," xterm ");
4011 if (ret_char == NULL)
4012 return NULL;
4013 cptr = ret_char + 7;
4014 ret_char = strstr(cmd,"tty");
4015 if (ret_char == NULL)
4016 return NULL;
4017 ret_char = strstr(cmd,"sleep");
4018 if (ret_char == NULL)
4019 return NULL;
4020
8cb5d3d5
JM		 4021 if (decw_term_port == 0) {
4022 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4023 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4024 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4025
d30c1055 4026 status = lib$find_image_symbol
8cb5d3d5
JM		 4027 (&filename1_dsc,
4028 &decw_term_port_dsc,
4029 (void *)&decw_term_port,
4030 NULL,
4031 0);
4032
4033 /* Try again with the other image name */
4034 if (!$VMS_STATUS_SUCCESS(status)) {
4035
d30c1055 4036 status = lib$find_image_symbol
8cb5d3d5
JM		 4037 (&filename2_dsc,
4038 &decw_term_port_dsc,
4039 (void *)&decw_term_port,
4040 NULL,
4041 0);
4042
4043 }
4044
4045 }
4046
4047
4048 /* No decw$term_port, give it up */
4049 if (!$VMS_STATUS_SUCCESS(status))
4050 return NULL;
4051
cd1191f1
CB		 4052 /* Are we on a workstation? */
4053 /* to do: capture the rows / columns and pass their properties */
4054 ret_stat = vms_is_syscommand_xterm();
4055 if (ret_stat < 0)
4056 return NULL;
4057
4058 /* Make the title: */
4059 ret_char = strstr(cptr,"-title");
4060 if (ret_char != NULL) {
4061 while ((*cptr != 0) && (*cptr != '\"')) {
4062 cptr++;
4063 }
4064 if (*cptr == '\"')
4065 cptr++;
4066 n = 0;
4067 while ((*cptr != 0) && (*cptr != '\"')) {
4068 title[n] = *cptr;
4069 n++;
4070 if (n == 39) {
07bee079 4071 title[39] = 0;
cd1191f1
CB		 4072 break;
4073 }
4074 cptr++;
4075 }
4076 title[n] = 0;
4077 }
4078 else {
4079 /* Default title */
4080 strcpy(title,"Perl Debug DECTerm");
4081 }
4082 sprintf(customization, cust_str, title);
4083
4084 customization_dsc.dsc$a_pointer = customization;
4085 customization_dsc.dsc$w_length = strlen(customization);
4086 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4087 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4088
4089 device_name_dsc.dsc$a_pointer = device_name;
4090 device_name_dsc.dsc$w_length = sizeof device_name -1;
4091 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4092 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4093
4094 device_name_len = 0;
4095
4096 /* Try to create the window */
8cb5d3d5 4097 status = (*decw_term_port)
cd1191f1
CB		 4098 (NULL,
4099 NULL,
4100 &customization_dsc,
4101 &device_name_dsc,
4102 &device_name_len,
4103 NULL,
4104 NULL,
4105 NULL);
4106 if (!$VMS_STATUS_SUCCESS(status)) {
4107 SETERRNO(EVMSERR, status);
4108 return NULL;
4109 }
4110
4111 device_name[device_name_len] = '\0';
4112
4113 /* Need to set this up to look like a pipe for cleanup */
4114 n = sizeof(Info);
4115 status = lib$get_vm(&n, &info);
4116 if (!$VMS_STATUS_SUCCESS(status)) {
4117 SETERRNO(ENOMEM, status);
4118 return NULL;
4119 }
4120
4121 info->mode = *mode;
4122 info->done = FALSE;
4123 info->completion = 0;
4124 info->closing = FALSE;
4125 info->in = 0;
4126 info->out = 0;
4127 info->err = 0;
4e205ed6 4128 info->fp = NULL;
cd1191f1
CB		 4129 info->useFILE = 0;
4130 info->waiting = 0;
4131 info->in_done = TRUE;
4132 info->out_done = TRUE;
4133 info->err_done = TRUE;
4134
4135 /* Assign a channel on this so that it will persist, and not login */
4136 /* We stash this channel in the info structure for reference. */
4137 /* The created xterm self destructs when the last channel is removed */
4138 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4139 /* So leave this assigned. */
4140 device_name_dsc.dsc$w_length = device_name_len;
4141 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4142 if (!$VMS_STATUS_SUCCESS(status)) {
4143 SETERRNO(EVMSERR, status);
4144 return NULL;
4145 }
4146 info->xchan_valid = 1;
4147
4148 /* Now create a mailbox to be read by the application */
4149
8a646e0b 4150 create_mbx(&p_chan, &d_mbx1);
cd1191f1
CB		 4151
4152 /* write the name of the created terminal to the mailbox */
4153 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4154 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4155
4156 if (!$VMS_STATUS_SUCCESS(status)) {
4157 SETERRNO(EVMSERR, status);
4158 return NULL;
4159 }
4160
4161 info->fp = PerlIO_open(mbx1, mode);
4162
4163 /* Done with this channel */
4164 sys$dassgn(p_chan);
4165
4166 /* If any errors, then clean up */
4167 if (!info->fp) {
4168 n = sizeof(Info);
ebd4d70b 4169 _ckvmssts_noperl(lib$free_vm(&n, &info));
cd1191f1
CB		 4170 return NULL;
4171 }
4172
4173 /* All done */
4174 return info->fp;
4175}
22d4bb9c 4176
ebd4d70b
JM		 4177static I32 my_pclose_pinfo(pTHX_ pInfo info);
4178
8fde5078 4179static PerlIO *
2fbb330f 4180safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4181{
748a9306 4182 static int handler_set_up = FALSE;
ebd4d70b 4183 PerlIO * ret_fp;
55f2b99c 4184 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4185 /* The use of a GLOBAL table (as was done previously) rendered
4186 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4187 * environment. Hence we've switched to LOCAL symbol table.
4188 */
4189 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4190 int j, wait = 0, n;
ff7adb52 4191 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4192 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4193 FILE *tpipe = 0;
4194 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4195 pInfo info = NULL;
48b5a746 4196 char cmd_sym_name[20];
22d4bb9c
CB		 4197 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4198 DSC$K_CLASS_S, symbol};
22d4bb9c 4199 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4200 DSC$K_CLASS_S, 0};
48b5a746
CL		 4201 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4202 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4203 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4204 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4205 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4206 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4207
cd1191f1
CB		 4208 /* Check here for Xterm create request. This means looking for
4209 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4210 * is possible to create an xterm.
4211 */
4212 if (*in_mode == 'r') {
4213 PerlIO * xterm_fd;
4214
4d9538c1
JM		 4215#if defined(PERL_IMPLICIT_CONTEXT)
4216 /* Can not fork an xterm with a NULL context */
4217 /* This probably could never happen */
4218 xterm_fd = NULL;
4219 if (aTHX != NULL)
4220#endif
cd1191f1 4221 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4e205ed6 4222 if (xterm_fd != NULL)
cd1191f1
CB		 4223 return xterm_fd;
4224 }
cd1191f1 4225
afd8f436
JH		 4226 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4227
22d4bb9c
CB		 4228 /* once-per-program initialization...
4229 note that the SETAST calls and the dual test of pipe_ef
4230 makes sure that only the FIRST thread through here does
4231 the initialization...all other threads wait until it's
4232 done.
4233
4234 Yeah, uglier than a pthread call, it's got all the stuff inline
4235 rather than in a separate routine.
4236 */
4237
4238 if (!pipe_ef) {
ebd4d70b 4239 _ckvmssts_noperl(sys$setast(0));
22d4bb9c
CB		 4240 if (!pipe_ef) {
4241 unsigned long int pidcode = JPI$_PID;
4242 $DESCRIPTOR(d_delay, RETRY_DELAY);
ebd4d70b
JM		 4243 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4244 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4245 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
22d4bb9c
CB		 4246 }
4247 if (!handler_set_up) {
ebd4d70b 4248 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
22d4bb9c
CB		 4249 handler_set_up = TRUE;
4250 }
ebd4d70b 4251 _ckvmssts_noperl(sys$setast(1));
22d4bb9c
CB		 4252 }
4253
4254 /* see if we can find a VMSPIPE.COM */
4255
4256 tfilebuf[0] = '@';
fd8cd3a3 4257 vmspipe = find_vmspipe(aTHX);
22d4bb9c 4258 if (vmspipe) {
a35dcc95 4259 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
22d4bb9c 4260 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4261 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4262 if (!tpipe) { /* a fish popular in Boston */
4263 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4264 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c 4265 }
4e205ed6 4266 return NULL;
22d4bb9c
CB		 4267 }
4268 fgetname(tpipe,tfilebuf+1,1);
a35dcc95 4269 vmspipedsc.dsc$w_length = strlen(tfilebuf);
22d4bb9c
CB		 4270 }
4271 vmspipedsc.dsc$a_pointer = tfilebuf;
a0d0e21e 4272
218fdd94 4273 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4274 if (!(sts & 1)) {
4275 switch (sts) {
4276 case RMS$_FNF: case RMS$_DNF:
4277 set_errno(ENOENT); break;
4278 case RMS$_DIR:
4279 set_errno(ENOTDIR); break;
4280 case RMS$_DEV:
4281 set_errno(ENODEV); break;
4282 case RMS$_PRV:
4283 set_errno(EACCES); break;
4284 case RMS$_SYN:
4285 set_errno(EINVAL); break;
4286 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4287 set_errno(E2BIG); break;
4288 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 4289 _ckvmssts_noperl(sts); /* fall through */
a2669cfc
JH		 4290 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4291 set_errno(EVMSERR);
4292 }
4293 set_vaxc_errno(sts);
cd1191f1 4294 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4295 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4296 }
ff7adb52 4297 *psts = sts;
4e205ed6 4298 return NULL;
a2669cfc 4299 }
d4c83939 4300 n = sizeof(Info);
ebd4d70b 4301 _ckvmssts_noperl(lib$get_vm(&n, &info));
22d4bb9c 4302
a35dcc95 4303 my_strlcpy(mode, in_mode, sizeof(mode));
22d4bb9c
CB		 4304 info->mode = *mode;
4305 info->done = FALSE;
4306 info->completion = 0;
4307 info->closing = FALSE;
4308 info->in = 0;
4309 info->out = 0;
4310 info->err = 0;
4e205ed6 4311 info->fp = NULL;
ff7adb52
CL		 4312 info->useFILE = 0;
4313 info->waiting = 0;
22d4bb9c
CB		 4314 info->in_done = TRUE;
4315 info->out_done = TRUE;
4316 info->err_done = TRUE;
cd1191f1
CB		 4317 info->xchan = 0;
4318 info->xchan_valid = 0;
cfcfe586 4319
c11536f5 4320 in = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4321 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4322 out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4323 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4324 err = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4325 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4326
0e06870b 4327 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4328
ff7adb52
CL		 4329 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4330 info->useFILE = 1;
4331 strcpy(p,p+1);
4332 }
4333 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4334 wait = 1;
4335 strcpy(p,p+1);
4336 }
4337
22d4bb9c 4338 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4339
fd8cd3a3 4340 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4341 if (info->out) {
4342 info->out->pipe_done = &info->out_done;
4343 info->out_done = FALSE;
4344 info->out->info = info;
4345 }
ff7adb52 4346 if (!info->useFILE) {
cd1191f1 4347 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4348 } else {
4349 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
0db50132 4350 vmssetuserlnm("SYS$INPUT", mbx);
ff7adb52
CL		 4351 }
4352
22d4bb9c
CB		 4353 if (!info->fp && info->out) {
4354 sys$cancel(info->out->chan_out);
4355
4356 while (!info->out_done) {
4357 int done;
ebd4d70b 4358 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4359 done = info->out_done;
ebd4d70b
JM		 4360 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4361 _ckvmssts_noperl(sys$setast(1));
4362 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
0e06870b 4363 }
22d4bb9c 4364
d4c83939
CB		 4365 if (info->out->buf) {
4366 n = info->out->bufsize * sizeof(char);
ebd4d70b 4367 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
d4c83939
CB		 4368 }
4369 n = sizeof(Pipe);
ebd4d70b 4370 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
d4c83939 4371 n = sizeof(Info);
ebd4d70b 4372 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4373 *psts = RMS$_FNF;
4e205ed6 4374 return NULL;
0e06870b 4375 }
22d4bb9c 4376
fd8cd3a3 4377 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4378 if (info->err) {
4379 info->err->pipe_done = &info->err_done;
4380 info->err_done = FALSE;
4381 info->err->info = info;
4382 }
a0d0e21e 4383
ff7adb52
CL		 4384 } else if (*mode == 'w') { /* piping to subroutine */
4385
4386 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4387 if (info->out) {
4388 info->out->pipe_done = &info->out_done;
4389 info->out_done = FALSE;
4390 info->out->info = info;
4391 }
4392
4393 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4394 if (info->err) {
4395 info->err->pipe_done = &info->err_done;
4396 info->err_done = FALSE;
4397 info->err->info = info;
4398 }
a0d0e21e 4399
fd8cd3a3 4400 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4401 if (!info->useFILE) {
a480973c 4402 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4403 } else {
4404 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
0db50132 4405 vmssetuserlnm("SYS$OUTPUT", mbx);
ff7adb52
CL		 4406 }
4407
22d4bb9c
CB		 4408 if (info->in) {
4409 info->in->pipe_done = &info->in_done;
4410 info->in_done = FALSE;
4411 info->in->info = info;
4412 }
a0d0e21e 4413
22d4bb9c
CB		 4414 /* error cleanup */
4415 if (!info->fp && info->in) {
4416 info->done = TRUE;
ebd4d70b
JM		 4417 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4418 0, 0, 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 4419
4420 while (!info->in_done) {
4421 int done;
ebd4d70b 4422 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4423 done = info->in_done;
ebd4d70b
JM		 4424 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4425 _ckvmssts_noperl(sys$setast(1));
4426 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
22d4bb9c 4427 }
a0d0e21e 4428
d4c83939
CB		 4429 if (info->in->buf) {
4430 n = info->in->bufsize * sizeof(char);
ebd4d70b 4431 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
d4c83939
CB		 4432 }
4433 n = sizeof(Pipe);
ebd4d70b 4434 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
d4c83939 4435 n = sizeof(Info);
ebd4d70b 4436 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4437 *psts = RMS$_FNF;
4e205ed6 4438 return NULL;
22d4bb9c 4439 }
a0d0e21e 4440
22d4bb9c 4441
ff7adb52 4442 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
e2d6c6fb
CB		 4443 /* Let the child inherit standard input, unless it's a directory. */
4444 Stat_t st;
3f80905d
CB		 4445 if (my_trnlnm("SYS$INPUT", in, 0)) {
4446 if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4447 *in = '\0';
4448 }
e2d6c6fb 4449
fd8cd3a3 4450 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4451 if (info->out) {
4452 info->out->pipe_done = &info->out_done;
4453 info->out_done = FALSE;
4454 info->out->info = info;
4455 }
0e06870b 4456
fd8cd3a3 4457 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4458 if (info->err) {
4459 info->err->pipe_done = &info->err_done;
4460 info->err_done = FALSE;
4461 info->err->info = info;
4462 }
748a9306 4463 }
22d4bb9c 4464
a35dcc95 4465 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
ebd4d70b 4466 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
22d4bb9c 4467
a35dcc95 4468 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
ebd4d70b 4469 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
22d4bb9c 4470
a35dcc95 4471 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
ebd4d70b 4472 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4473
cfcfe586
JM		 4474 /* Done with the names for the pipes */
4475 PerlMem_free(err);
4476 PerlMem_free(out);
4477 PerlMem_free(in);
4478
218fdd94 4479 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4480 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4481 if (*p == '$') p++; /* remove leading $ */
4482 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4483
4484 for (j = 0; j < 4; j++) {
4485 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4486 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4487
a35dcc95 4488 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
ebd4d70b 4489 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
22d4bb9c 4490
48b5a746
CL		 4491 if (strlen(p) > MAX_DCL_SYMBOL) {
4492 p += MAX_DCL_SYMBOL;
4493 } else {
4494 p += strlen(p);
4495 }
4496 }
ebd4d70b 4497 _ckvmssts_noperl(sys$setast(0));
a0d0e21e
LW		 4498 info->next=open_pipes; /* prepend to list */
4499 open_pipes=info;
ebd4d70b 4500 _ckvmssts_noperl(sys$setast(1));
55f2b99c
CB		 4501 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4502 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4503 * have SYS$COMMAND if we need it.
4504 */
ebd4d70b 4505 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4506 0, &info->pid, &info->completion,
4507 0, popen_completion_ast,info,0,0,0));
4508
4509 /* if we were using a tempfile, close it now */
4510
4511 if (tpipe) fclose(tpipe);
4512
ff7adb52 4513 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4514 we can get rid of ours */
4515
48b5a746
CL		 4516 for (j = 0; j < 4; j++) {
4517 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4518 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
ebd4d70b 4519 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4520 }
ebd4d70b
JM		 4521 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4522 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4523 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4524 vms_execfree(vmscmd);
a0d0e21e 4525
218fdd94
CL		 4526#ifdef PERL_IMPLICIT_CONTEXT
4527 if (aTHX)
4528#endif
6b88bc9c 4529 PL_forkprocess = info->pid;
218fdd94 4530
ebd4d70b 4531 ret_fp = info->fp;
ff7adb52 4532 if (wait) {
ebd4d70b 4533 dSAVEDERRNO;
ff7adb52
CL		 4534 int done = 0;
4535 while (!done) {
ebd4d70b 4536 _ckvmssts_noperl(sys$setast(0));
ff7adb52 4537 done = info->done;
ebd4d70b
JM		 4538 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4539 _ckvmssts_noperl(sys$setast(1));
4540 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
ff7adb52
CL		 4541 }
4542 *psts = info->completion;
2fbb330f
JM		 4543/* Caller thinks it is open and tries to close it. */
4544/* This causes some problems, as it changes the error status */
4545/* my_pclose(info->fp); */
ebd4d70b
JM		 4546
4547 /* If we did not have a file pointer open, then we have to */
4548 /* clean up here or eventually we will run out of something */
4549 SAVE_ERRNO;
4550 if (info->fp == NULL) {
4551 my_pclose_pinfo(aTHX_ info);
4552 }
4553 RESTORE_ERRNO;
4554
ff7adb52 4555 } else {
eed5d6a1 4556 *psts = info->pid;
ff7adb52 4557 }
ebd4d70b 4558 return ret_fp;
1e422769 4559} /* end of safe_popen */
4560
4561
a15cef0c
CB		 4562/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4563PerlIO *
2fbb330f 4564Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4565{
ff7adb52 4566 int sts;
1e422769 4567 TAINT_ENV();
4568 TAINT_PROPER("popen");
45bc9206 4569 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4570 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4571}
1e422769 4572
a0d0e21e
LW		 4573/*}}}*/
4574
ebd4d70b
JM		 4575
4576/* Routine to close and cleanup a pipe info structure */
4577
ce12d4b7
CB		 4578static I32
4579my_pclose_pinfo(pTHX_ pInfo info) {
ebd4d70b 4580
748a9306 4581 unsigned long int retsts;
4e0c9737 4582 int done, n;
ebd4d70b 4583 pInfo next, last;
748a9306 4584
bbce6d69 4585 /* If we were writing to a subprocess, insure that someone reading from
4586 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4587 * produce an EOF record in the mailbox.
4588 *
4589 * well, at least sometimes it *does*, so we have to watch out for
4590 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4591 */
ff7adb52 4592 if (info->fp) {
5ce486e0
CB		 4593 if (!info->useFILE
4594#if defined(USE_ITHREADS)
4595 && my_perl
4596#endif
a24c654f
CB		 4597#ifdef USE_PERLIO
4598 && PL_perlio_fd_refcnt
4599#endif
4600 )
5ce486e0 4601 PerlIO_flush(info->fp);
ff7adb52
CL		 4602 else
4603 fflush((FILE *)info->fp);
4604 }
22d4bb9c 4605
b08af3f0 4606 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4607 info->closing = TRUE;
4608 done = info->done && info->in_done && info->out_done && info->err_done;
4609 /* hanging on write to Perl's input? cancel it */
4610 if (info->mode == 'r' && info->out && !info->out_done) {
4611 if (info->out->chan_out) {
4612 _ckvmssts(sys$cancel(info->out->chan_out));
4613 if (!info->out->chan_in) { /* EOF generation, need AST */
4614 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4615 }
4616 }
4617 }
4618 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4619 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4620 0, 0, 0, 0, 0, 0));
b08af3f0 4621 _ckvmssts(sys$setast(1));
ff7adb52 4622 if (info->fp) {
5ce486e0
CB		 4623 if (!info->useFILE
4624#if defined(USE_ITHREADS)
4625 && my_perl
4626#endif
a24c654f
CB		 4627#ifdef USE_PERLIO
4628 && PL_perlio_fd_refcnt
4629#endif
4630 )
d4c83939 4631 PerlIO_close(info->fp);
ff7adb52
CL		 4632 else
4633 fclose((FILE *)info->fp);
4634 }
22d4bb9c
CB		 4635 /*
4636 we have to wait until subprocess completes, but ALSO wait until all
4637 the i/o completes...otherwise we'll be freeing the "info" structure
4638 that the i/o ASTs could still be using...
4639 */
4640
4641 while (!done) {
4642 _ckvmssts(sys$setast(0));
4643 done = info->done && info->in_done && info->out_done && info->err_done;
4644 if (!done) _ckvmssts(sys$clref(pipe_ef));
4645 _ckvmssts(sys$setast(1));
4646 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4647 }
4648 retsts = info->completion;
a0d0e21e 4649
a0d0e21e 4650 /* remove from list of open pipes */
b08af3f0 4651 _ckvmssts(sys$setast(0));
ebd4d70b
JM		 4652 last = NULL;
4653 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4654 if (next == info)
4655 break;
4656 }
4657
4658 if (last)
4659 last->next = info->next;
4660 else
4661 open_pipes = info->next;
b08af3f0 4662 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4663
4664 /* free buffers and structures */
4665
4666 if (info->in) {
d4c83939
CB		 4667 if (info->in->buf) {
4668 n = info->in->bufsize * sizeof(char);
4669 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4670 }
4671 n = sizeof(Pipe);
4672 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4673 }
4674 if (info->out) {
d4c83939
CB		 4675 if (info->out->buf) {
4676 n = info->out->bufsize * sizeof(char);
4677 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4678 }
4679 n = sizeof(Pipe);
4680 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4681 }
4682 if (info->err) {
d4c83939
CB		 4683 if (info->err->buf) {
4684 n = info->err->bufsize * sizeof(char);
4685 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4686 }
4687 n = sizeof(Pipe);
4688 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4689 }
d4c83939
CB		 4690 n = sizeof(Info);
4691 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4692
4693 return retsts;
ebd4d70b
JM		 4694}
4695
4696
4697/*{{{ I32 my_pclose(PerlIO *fp)*/
4698I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4699{
4700 pInfo info, last = NULL;
4701 I32 ret_status;
4702
4703 /* Fixme - need ast and mutex protection here */
4704 for (info = open_pipes; info != NULL; last = info, info = info->next)
4705 if (info->fp == fp) break;
4706
4707 if (info == NULL) { /* no such pipe open */
4708 set_errno(ECHILD); /* quoth POSIX */
4709 set_vaxc_errno(SS$_NONEXPR);
4710 return -1;
4711 }
4712
4713 ret_status = my_pclose_pinfo(aTHX_ info);
4714
4715 return ret_status;
748a9306 4716
a0d0e21e
LW		 4717} /* end of my_pclose() */
4718
aeb5cf3c
CB		 4719 /* Roll our own prototype because we want this regardless of whether
4720 * _VMS_WAIT is defined.
4721 */
c11536f5
CB		 4722
4723#ifdef __cplusplus
4724extern "C" {
4725#endif
aeb5cf3c 4726 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
c11536f5
CB		 4727#ifdef __cplusplus
4728}
4729#endif
4730
aeb5cf3c
CB		 4731/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4732 created with popen(); otherwise partially emulate waitpid() unless
4733 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4734 Also check processes not considered by the CRTL waitpid().
4735 */
4fdae800 4736/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4737Pid_t
fd8cd3a3 4738Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4739{
22d4bb9c
CB		 4740 pInfo info;
4741 int done;
aeb5cf3c 4742 int sts;
d85f548a 4743 int j;
aeb5cf3c
CB		 4744
4745 if (statusp) *statusp = 0;
a0d0e21e
LW		 4746
4747 for (info = open_pipes; info != NULL; info = info->next)
4748 if (info->pid == pid) break;
4749
4750 if (info != NULL) { /* we know about this child */
748a9306 4751 while (!info->done) {
22d4bb9c
CB		 4752 _ckvmssts(sys$setast(0));
4753 done = info->done;
4754 if (!done) _ckvmssts(sys$clref(pipe_ef));
4755 _ckvmssts(sys$setast(1));
4756 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4757 }
4758
aeb5cf3c 4759 if (statusp) *statusp = info->completion;
a0d0e21e 4760 return pid;
d85f548a
JH		 4761 }
4762
4763 /* child that already terminated? */
aeb5cf3c 4764
d85f548a
JH		 4765 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4766 if (closed_list[j].pid == pid) {
4767 if (statusp) *statusp = closed_list[j].completion;
4768 return pid;
4769 }
a0d0e21e 4770 }
d85f548a
JH		 4771
4772 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4773
aeb5cf3c
CB		 4774 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4775 * in 7.2 did we get a version that fills in the VMS completion
4776 * status as Perl has always tried to do.
4777 */
4778
4779 sts = __vms_waitpid( pid, statusp, flags );
4780
4781 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4782 return sts;
4783
4784 /* If the real waitpid tells us the child does not exist, we
4785 * fall through here to implement waiting for a child that
4786 * was created by some means other than exec() (say, spawned
4787 * from DCL) or to wait for a process that is not a subprocess
4788 * of the current process.
4789 */
4790
21bc9d50 4791 {
a0d0e21e 4792 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4793 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4794 unsigned long int pidcode = JPI$_PID, mypid;
4795 unsigned long int interval[2];
aeb5cf3c 4796 unsigned int jpi_iosb[2];
d85f548a 4797 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4798 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4799 { 0, 0, 0, 0}
4800 };
aeb5cf3c
CB		 4801
4802 if (pid <= 0) {
4803 /* Sorry folks, we don't presently implement rooting around for
4804 the first child we can find, and we definitely don't want to
4805 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4806 */
4807 set_errno(ENOTSUP);
4808 return -1;
4809 }
4810
d85f548a
JH		 4811 /* Get the owner of the child so I can warn if it's not mine. If the
4812 * process doesn't exist or I don't have the privs to look at it,
4813 * I can go home early.
aeb5cf3c
CB		 4814 */
4815 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4816 if (sts & 1) sts = jpi_iosb[0];
4817 if (!(sts & 1)) {
4818 switch (sts) {
4819 case SS$_NONEXPR:
4820 set_errno(ECHILD);
4821 break;
4822 case SS$_NOPRIV:
4823 set_errno(EACCES);
4824 break;
4825 default:
4826 _ckvmssts(sts);
4827 }
4828 set_vaxc_errno(sts);
4829 return -1;
4830 }
a0d0e21e 4831
3eeba6fb 4832 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4833 /* remind folks they are asking for non-standard waitpid behavior */
4834 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4835 if (ownerpid != mypid)
f98bc0c6 4836 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4837 "waitpid: process %x is not a child of process %x",
4838 pid,mypid);
748a9306 4839 }
a0d0e21e 4840
d85f548a
JH		 4841 /* simply check on it once a second until it's not there anymore. */
4842
4843 _ckvmssts(sys$bintim(&intdsc,interval));
4844 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4845 _ckvmssts(sys$schdwk(0,0,interval,0));
4846 _ckvmssts(sys$hiber());
d85f548a
JH		 4847 }
4848 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4849
4850 _ckvmssts(sts);
a0d0e21e 4851 return pid;
21bc9d50 4852 }
a0d0e21e 4853} /* end of waitpid() */
a0d0e21e
LW		 4854/*}}}*/
4855/*}}}*/
4856/*}}}*/
4857
4858/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4859char *
4860my_gconvert(double val, int ndig, int trail, char *buf)
4861{
4862 static char __gcvtbuf[DBL_DIG+1];
4863 char *loc;
4864
4865 loc = buf ? buf : __gcvtbuf;
71be2cbc 4866
a0d0e21e
LW		 4867 if (val) {
4868 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4869 return gcvt(val,ndig,loc);
4870 }
4871 else {
4872 loc[0] = '0'; loc[1] = '\0';
4873 return loc;
4874 }
4875
4876}
4877/*}}}*/
4878
054a3baf 4879#if !defined(NAML$C_MAXRSS)
ce12d4b7
CB		 4880static int
4881rms_free_search_context(struct FAB * fab)
a480973c 4882{
ce12d4b7 4883 struct NAM * nam;
a480973c
JM		 4884
4885 nam = fab->fab$l_nam;
4886 nam->nam$b_nop |= NAM$M_SYNCHK;
4887 nam->nam$l_rlf = NULL;
4888 fab->fab$b_dns = 0;
4889 return sys$parse(fab, NULL, NULL);
4890}
4891
4892#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4893#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4894#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4895#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4896#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4897#define rms_nam_esll(nam) nam.nam$b_esl
4898#define rms_nam_esl(nam) nam.nam$b_esl
4899#define rms_nam_name(nam) nam.nam$l_name
4900#define rms_nam_namel(nam) nam.nam$l_name
4901#define rms_nam_type(nam) nam.nam$l_type
4902#define rms_nam_typel(nam) nam.nam$l_type
4903#define rms_nam_ver(nam) nam.nam$l_ver
4904#define rms_nam_verl(nam) nam.nam$l_ver
4905#define rms_nam_rsll(nam) nam.nam$b_rsl
4906#define rms_nam_rsl(nam) nam.nam$b_rsl
4907#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4908#define rms_set_fna(fab, nam, name, size) \
a1887106 4909 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4910#define rms_get_fna(fab, nam) fab.fab$l_fna
4911#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4912 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4913#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4914#define rms_set_esa(nam, name, size) \
a1887106 4915 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4916#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4917 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4918#define rms_set_rsa(nam, name, size) \
a1887106 4919 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4920#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4921 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4922#define rms_nam_name_type_l_size(nam) \
4923 (nam.nam$b_name + nam.nam$b_type)
a480973c 4924#else
ce12d4b7
CB		 4925static int
4926rms_free_search_context(struct FAB * fab)
a480973c 4927{
ce12d4b7 4928 struct NAML * nam;
a480973c
JM		 4929
4930 nam = fab->fab$l_naml;
4931 nam->naml$b_nop |= NAM$M_SYNCHK;
4932 nam->naml$l_rlf = NULL;
4933 nam->naml$l_long_defname_size = 0;
988c775c 4934
a480973c
JM		 4935 fab->fab$b_dns = 0;
4936 return sys$parse(fab, NULL, NULL);
4937}
4938
4939#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4940#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4941#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4942#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4943#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4944#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4945#define rms_nam_esl(nam) nam.naml$b_esl
4946#define rms_nam_name(nam) nam.naml$l_name
4947#define rms_nam_namel(nam) nam.naml$l_long_name
4948#define rms_nam_type(nam) nam.naml$l_type
4949#define rms_nam_typel(nam) nam.naml$l_long_type
4950#define rms_nam_ver(nam) nam.naml$l_ver
4951#define rms_nam_verl(nam) nam.naml$l_long_ver
4952#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4953#define rms_nam_rsl(nam) nam.naml$b_rsl
4954#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4955#define rms_set_fna(fab, nam, name, size) \
a1887106 4956 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4957 nam.naml$l_long_filename_size = size; \
a1887106 4958 nam.naml$l_long_filename = name;}
a480973c
JM		 4959#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4960#define rms_set_dna(fab, nam, name, size) \
a1887106 4961 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4962 nam.naml$l_long_defname_size = size; \
a1887106 4963 nam.naml$l_long_defname = name; }
a480973c 4964#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4965#define rms_set_esa(nam, name, size) \
a1887106 4966 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4967 nam.naml$l_long_expand_alloc = size; \
a1887106 4968 nam.naml$l_long_expand = name; }
a480973c 4969#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4970 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4971 nam.naml$l_long_expand = l_name; \
a1887106 4972 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4973#define rms_set_rsa(nam, name, size) \
a1887106 4974 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4975 nam.naml$l_long_result = name; \
a1887106 4976 nam.naml$l_long_result_alloc = size; }
a480973c 4977#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4978 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4979 nam.naml$l_long_result = l_name; \
a1887106
JM		 4980 nam.naml$l_long_result_alloc = l_size; }
4981#define rms_nam_name_type_l_size(nam) \
4982 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4983#endif
4984
4fdf8f88 4985
e0e5e8d6
JM		 4986/* rms_erase
4987 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4988 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4989 * them if one of the PCP modes is active.
e0e5e8d6 4990 */
ce12d4b7
CB		 4991static int
4992rms_erase(const char * vmsname)
e0e5e8d6
JM		 4993{
4994 int status;
4995 struct FAB myfab = cc$rms_fab;
4996 rms_setup_nam(mynam);
4997
4998 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4999 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 5000
e0e5e8d6
JM		 5001#ifdef NAML$M_OPEN_SPECIAL
5002 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5003#endif
5004
d30c1055 5005 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 5006
5007 return status;
5008}
5009
bbce6d69 5010
4fdf8f88
JM		 5011static int
5012vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5013 const struct dsc$descriptor_s * vms_dst_dsc,
5014 unsigned long flags)
5015{
5016 /* VMS and UNIX handle file permissions differently and the
5017 * the same ACL trick may be needed for renaming files,
5018 * especially if they are directories.
5019 */
5020
5021 /* todo: get kill_file and rename to share common code */
5022 /* I can not find online documentation for $change_acl
5023 * it appears to be replaced by $set_security some time ago */
5024
ce12d4b7
CB		 5025 const unsigned int access_mode = 0;
5026 $DESCRIPTOR(obj_file_dsc,"FILE");
5027 char *vmsname;
5028 char *rslt;
5029 unsigned long int jpicode = JPI$_UIC;
5030 int aclsts, fndsts, rnsts = -1;
5031 unsigned int ctx = 0;
5032 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5033 struct dsc$descriptor_s * clean_dsc;
5034
5035 struct myacedef {
5036 unsigned char myace$b_length;
5037 unsigned char myace$b_type;
5038 unsigned short int myace$w_flags;
5039 unsigned long int myace$l_access;
5040 unsigned long int myace$l_ident;
5041 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5042 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5043 0},
5044 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5045
5046 struct item_list_3
4fdf8f88
JM		 5047 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5048 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5049 {0,0,0,0}},
5050 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5051 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5052 {0,0,0,0}};
5053
5054
5055 /* Expand the input spec using RMS, since we do not want to put
5056 * ACLs on the target of a symbolic link */
c11536f5 5057 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4fdf8f88
JM		 5058 if (vmsname == NULL)
5059 return SS$_INSFMEM;
5060
6fb6c614 5061 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4fdf8f88 5062 vmsname,
6fb6c614 5063 PERL_RMSEXPAND_M_SYMLINK);
4fdf8f88
JM		 5064 if (rslt == NULL) {
5065 PerlMem_free(vmsname);
5066 return SS$_INSFMEM;
5067 }
5068
5069 /* So we get our own UIC to use as a rights identifier,
5070 * and the insert an ACE at the head of the ACL which allows us
5071 * to delete the file.
5072 */
ebd4d70b 5073 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4fdf8f88
JM		 5074
5075 fildsc.dsc$w_length = strlen(vmsname);
5076 fildsc.dsc$a_pointer = vmsname;
5077 ctx = 0;
5078 newace.myace$l_ident = oldace.myace$l_ident;
5079 rnsts = SS$_ABORT;
5080
5081 /* Grab any existing ACEs with this identifier in case we fail */
5082 clean_dsc = &fildsc;
5083 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5084 &fildsc,
5085 NULL,
5086 OSS$M_WLOCK,
5087 findlst,
5088 &ctx,
5089 &access_mode);
5090
5091 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5092 /* Add the new ACE . . . */
5093
5094 /* if the sys$get_security succeeded, then ctx is valid, and the
5095 * object/file descriptors will be ignored. But otherwise they
5096 * are needed
5097 */
5098 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5099 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5100 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5101 set_errno(EVMSERR);
5102 set_vaxc_errno(aclsts);
5103 PerlMem_free(vmsname);
5104 return aclsts;
5105 }
5106
5107 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5108 NULL, NULL,
5109 &flags,
5110 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5111
5112 if ($VMS_STATUS_SUCCESS(rnsts)) {
5113 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5114 }
5115
5116 /* Put things back the way they were. */
5117 ctx = 0;
5118 aclsts = sys$get_security(&obj_file_dsc,
5119 clean_dsc,
5120 NULL,
5121 OSS$M_WLOCK,
5122 findlst,
5123 &ctx,
5124 &access_mode);
5125
5126 if ($VMS_STATUS_SUCCESS(aclsts)) {
5127 int sec_flags;
5128
5129 sec_flags = 0;
5130 if (!$VMS_STATUS_SUCCESS(fndsts))
5131 sec_flags = OSS$M_RELCTX;
5132
5133 /* Get rid of the new ACE */
5134 aclsts = sys$set_security(NULL, NULL, NULL,
5135 sec_flags, dellst, &ctx, &access_mode);
5136
5137 /* If there was an old ACE, put it back */
5138 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5139 addlst[0].bufadr = &oldace;
5140 aclsts = sys$set_security(NULL, NULL, NULL,
5141 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5142 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5143 set_errno(EVMSERR);
5144 set_vaxc_errno(aclsts);
5145 rnsts = aclsts;
5146 }
5147 } else {
5148 int aclsts2;
5149
5150 /* Try to clear the lock on the ACL list */
5151 aclsts2 = sys$set_security(NULL, NULL, NULL,
5152 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5153
5154 /* Rename errors are most important */
5155 if (!$VMS_STATUS_SUCCESS(rnsts))
5156 aclsts = rnsts;
5157 set_errno(EVMSERR);
5158 set_vaxc_errno(aclsts);
5159 rnsts = aclsts;
5160 }
5161 }
5162 else {
5163 if (aclsts != SS$_ACLEMPTY)
5164 rnsts = aclsts;
5165 }
5166 }
5167 else
5168 rnsts = fndsts;
5169
5170 PerlMem_free(vmsname);
5171 return rnsts;
5172}
5173
5174
5175/*{{{int rename(const char *, const char * */
5176/* Not exactly what X/Open says to do, but doing it absolutely right
5177 * and efficiently would require a lot more work. This should be close
5178 * enough to pass all but the most strict X/Open compliance test.
5179 */
5180int
5181Perl_rename(pTHX_ const char *src, const char * dst)
5182{
ce12d4b7
CB		 5183 int retval;
5184 int pre_delete = 0;
5185 int src_sts;
5186 int dst_sts;
5187 Stat_t src_st;
5188 Stat_t dst_st;
4fdf8f88
JM		 5189
5190 /* Validate the source file */
46c05374 5191 src_sts = flex_lstat(src, &src_st);
4fdf8f88
JM		 5192 if (src_sts != 0) {
5193
5194 /* No source file or other problem */
5195 return src_sts;
5196 }
b94a8c49
JM		 5197 if (src_st.st_devnam[0] == 0) {
5198 /* This may be possible so fail if it is seen. */
5199 errno = EIO;
5200 return -1;
5201 }
4fdf8f88 5202
46c05374 5203 dst_sts = flex_lstat(dst, &dst_st);
4fdf8f88
JM		 5204 if (dst_sts == 0) {
5205
5206 if (dst_st.st_dev != src_st.st_dev) {
5207 /* Must be on the same device */
5208 errno = EXDEV;
5209 return -1;
5210 }
5211
5212 /* VMS_INO_T_COMPARE is true if the inodes are different
5213 * to match the output of memcmp
5214 */
5215
5216 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5217 /* That was easy, the files are the same! */
5218 return 0;
5219 }
5220
5221 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5222 /* If source is a directory, so must be dest */
5223 errno = EISDIR;
5224 return -1;
5225 }
5226
5227 }
5228
5229
5230 if ((dst_sts == 0) &&
5231 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5232
5233 /* We have issues here if vms_unlink_all_versions is set
5234 * If the destination exists, and is not a directory, then
5235 * we must delete in advance.
5236 *
5237 * If the src is a directory, then we must always pre-delete
5238 * the destination.
5239 *
5240 * If we successfully delete the dst in advance, and the rename fails
5241 * X/Open requires that errno be EIO.
5242 *
5243 */
5244
5245 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5246 int d_sts;
46c05374 5247 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
b94a8c49
JM		 5248 S_ISDIR(dst_st.st_mode));
5249
5250 /* Need to delete all versions ? */
5251 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5252 int i = 0;
5253
5254 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
46c05374 5255 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
b94a8c49
JM		 5256 if (d_sts != 0)
5257 break;
5258 i++;
5259
5260 /* Make sure that we do not loop forever */
5261 if (i > 32767) {
5262 errno = EIO;
5263 d_sts = -1;
5264 break;
5265 }
5266 }
5267 }
5268
4fdf8f88
JM		 5269 if (d_sts != 0)
5270 return d_sts;
5271
5272 /* We killed the destination, so only errno now is EIO */
5273 pre_delete = 1;
5274 }
5275 }
5276
5277 /* Originally the idea was to call the CRTL rename() and only
5278 * try the lib$rename_file if it failed.
5279 * It turns out that there are too many variants in what the
5280 * the CRTL rename might do, so only use lib$rename_file
5281 */
5282 retval = -1;
5283
5284 {
5285 /* Is the source and dest both in VMS format */
5286 /* if the source is a directory, then need to fileify */
94ae10c0 5287 /* and dest must be a directory or non-existent. */
4fdf8f88 5288
4fdf8f88
JM		 5289 char * vms_dst;
5290 int sts;
5291 char * ret_str;
5292 unsigned long flags;
5293 struct dsc$descriptor_s old_file_dsc;
5294 struct dsc$descriptor_s new_file_dsc;
5295
5296 /* We need to modify the src and dst depending
5297 * on if one or more of them are directories.
5298 */
5299
c11536f5 5300 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5301 if (vms_dst == NULL)
ebd4d70b 5302 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5303
5304 if (S_ISDIR(src_st.st_mode)) {
5305 char * ret_str;
5306 char * vms_dir_file;
5307
c11536f5 5308 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5309 if (vms_dir_file == NULL)
ebd4d70b 5310 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88 5311
29475144 5312 /* If the dest is a directory, we must remove it */
4fdf8f88
JM		 5313 if (dst_sts == 0) {
5314 int d_sts;
46c05374 5315 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
4fdf8f88 5316 if (d_sts != 0) {
4fdf8f88
JM		 5317 PerlMem_free(vms_dst);
5318 errno = EIO;
29475144 5319 return d_sts;
4fdf8f88
JM		 5320 }
5321
5322 pre_delete = 1;
5323 }
5324
5325 /* The dest must be a VMS file specification */
df278665 5326 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5327 if (ret_str == NULL) {
4fdf8f88
JM		 5328 PerlMem_free(vms_dst);
5329 errno = EIO;
5330 return -1;
5331 }
5332
5333 /* The source must be a file specification */
4fdf8f88
JM		 5334 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5335 if (ret_str == NULL) {
4fdf8f88
JM		 5336 PerlMem_free(vms_dst);
5337 PerlMem_free(vms_dir_file);
5338 errno = EIO;
5339 return -1;
5340 }
5341 PerlMem_free(vms_dst);
5342 vms_dst = vms_dir_file;
5343
5344 } else {
5345 /* File to file or file to new dir */
5346
5347 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5348 /* VMS pathify a dir target */
4846f1d7 5349 ret_str = int_tovmspath(dst, vms_dst, NULL);
4fdf8f88 5350 if (ret_str == NULL) {
4fdf8f88
JM		 5351 PerlMem_free(vms_dst);
5352 errno = EIO;
5353 return -1;
5354 }
5355 } else {
b94a8c49
JM		 5356 char * v_spec, * r_spec, * d_spec, * n_spec;
5357 char * e_spec, * vs_spec;
5358 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
4fdf8f88
JM		 5359
5360 /* fileify a target VMS file specification */
df278665 5361 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5362 if (ret_str == NULL) {
4fdf8f88
JM		 5363 PerlMem_free(vms_dst);
5364 errno = EIO;
5365 return -1;
5366 }
b94a8c49
JM		 5367
5368 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5369 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5370 &e_len, &vs_spec, &vs_len);
5371 if (sts == 0) {
5372 if (e_len == 0) {
5373 /* Get rid of the version */
5374 if (vs_len != 0) {
5375 *vs_spec = '\0';
5376 }
5377 /* Need to specify a '.' so that the extension */
5378 /* is not inherited */
5379 strcat(vms_dst,".");
5380 }
5381 }
4fdf8f88
JM		 5382 }
5383 }
5384
b94a8c49
JM		 5385 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5386 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
4fdf8f88
JM		 5387 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5388 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5389
5390 new_file_dsc.dsc$a_pointer = vms_dst;
5391 new_file_dsc.dsc$w_length = strlen(vms_dst);
5392 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5393 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5394
5395 flags = 0;
054a3baf 5396#if defined(NAML$C_MAXRSS)
449de3c2 5397 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
4fdf8f88
JM		 5398#endif
5399
5400 sts = lib$rename_file(&old_file_dsc,
5401 &new_file_dsc,
5402 NULL, NULL,
5403 &flags,
5404 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5405 if (!$VMS_STATUS_SUCCESS(sts)) {
5406
5407 /* We could have failed because VMS style permissions do not
5408 * permit renames that UNIX will allow. Just like the hack
5409 * in for kill_file.
5410 */
5411 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5412 }
5413
4fdf8f88
JM		 5414 PerlMem_free(vms_dst);
5415 if (!$VMS_STATUS_SUCCESS(sts)) {
5416 errno = EIO;
5417 return -1;
5418 }
5419 retval = 0;
5420 }
5421
5422 if (vms_unlink_all_versions) {
5423 /* Now get rid of any previous versions of the source file that
5424 * might still exist
5425 */
b94a8c49
JM		 5426 int i = 0;
5427 dSAVEDERRNO;
5428 SAVE_ERRNO;
46c05374 5429 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5430 S_ISDIR(src_st.st_mode));
5431 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
46c05374 5432 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5433 S_ISDIR(src_st.st_mode));
5434 if (src_sts != 0)
5435 break;
5436 i++;
5437
5438 /* Make sure that we do not loop forever */
5439 if (i > 32767) {
5440 src_sts = -1;
5441 break;
5442 }
5443 }
5444 RESTORE_ERRNO;
4fdf8f88
JM		 5445 }
5446
5447 /* We deleted the destination, so must force the error to be EIO */
5448 if ((retval != 0) && (pre_delete != 0))
5449 errno = EIO;
5450
5451 return retval;
5452}
5453/*}}}*/
5454
5455
bbce6d69 5456/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5457/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5458 * to expand file specification. Allows for a single default file
5459 * specification and a simple mask of options. If outbuf is non-NULL,
5460 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5461 * the resultant file specification is placed. If outbuf is NULL, the
5462 * resultant file specification is placed into a static buffer.
5463 * The third argument, if non-NULL, is taken to be a default file
5464 * specification string. The fourth argument is unused at present.
5465 * rmesexpand() returns the address of the resultant string if
5466 * successful, and NULL on error.
e886094b
JM		 5467 *
5468 * New functionality for previously unused opts value:
5469 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5470 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5471 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5472 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5473 */
360732b5 5474static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5475
bbce6d69 5476static char *
6fb6c614
JM		 5477int_rmsexpand
5478 (const char *filespec,
360732b5 5479 char *outbuf,
360732b5
JM		 5480 const char *defspec,
5481 unsigned opts,
5482 int * fs_utf8,
5483 int * dfs_utf8)
bbce6d69 5484{
6fb6c614
JM		 5485 char * ret_spec;
5486 const char * in_spec;
5487 char * spec_buf;
5488 const char * def_spec;
5489 char * vmsfspec, *vmsdefspec;
5490 char * esa;
7566800d 5491 char * esal = NULL;
18a3d61e
JM		 5492 char * outbufl;
5493 struct FAB myfab = cc$rms_fab;
a480973c 5494 rms_setup_nam(mynam);
18a3d61e
JM		 5495 STRLEN speclen;
5496 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5497 int sts;
5498
360732b5
JM		 5499 /* temp hack until UTF8 is actually implemented */
5500 if (fs_utf8 != NULL)
5501 *fs_utf8 = 0;
5502
18a3d61e
JM		 5503 if (!filespec || !*filespec) {
5504 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5505 return NULL;
5506 }
18a3d61e
JM		 5507
5508 vmsfspec = NULL;
6fb6c614 5509 vmsdefspec = NULL;
18a3d61e 5510 outbufl = NULL;
a1887106 5511
6fb6c614 5512 in_spec = filespec;
a1887106
JM		 5513 isunix = 0;
5514 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
6fb6c614
JM		 5515 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5516 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5517
5518 /* If this is a UNIX file spec, convert it to VMS */
5519 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5520 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5521 &e_len, &vs_spec, &vs_len);
5522 if (sts != 0) {
5523 isunix = 1;
5524 char * ret_spec;
5525
c11536f5 5526 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5527 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5528 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5529 if (ret_spec == NULL) {
5530 PerlMem_free(vmsfspec);
5531 return NULL;
5532 }
5533 in_spec = (const char *)vmsfspec;
18a3d61e 5534
6fb6c614
JM		 5535 /* Unless we are forcing to VMS format, a UNIX input means
5536 * UNIX output, and that requires long names to be used
5537 */
5538 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
054a3baf 5539#if defined(NAML$C_MAXRSS)
6fb6c614 5540 opts |= PERL_RMSEXPAND_M_LONG;
778e045f
CB		 5541#else
5542 NOOP;
b1a8dcd7 5543#endif
6fb6c614
JM		 5544 else
5545 isunix = 0;
a1887106 5546 }
18a3d61e 5547
6fb6c614
JM		 5548 }
5549
5550 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
a480973c 5551 rms_bind_fab_nam(myfab, mynam);
18a3d61e 5552
6fb6c614
JM		 5553 /* Process the default file specification if present */
5554 def_spec = defspec;
18a3d61e
JM		 5555 if (defspec && *defspec) {
5556 int t_isunix;
5557 t_isunix = is_unix_filespec(defspec);
5558 if (t_isunix) {
c11536f5 5559 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5560 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5561 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5562
5563 if (ret_spec == NULL) {
5564 /* Clean up and bail */
5565 PerlMem_free(vmsdefspec);
5566 if (vmsfspec != NULL)
5567 PerlMem_free(vmsfspec);
5568 return NULL;
5569 }
5570 def_spec = (const char *)vmsdefspec;
18a3d61e 5571 }
6fb6c614
JM		 5572 rms_set_dna(myfab, mynam,
5573 (char *)def_spec, strlen(def_spec)); /* cast ok */
18a3d61e
JM		 5574 }
5575
6fb6c614 5576 /* Now we need the expansion buffers */
c11536f5 5577 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 5578 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
054a3baf 5579#if defined(NAML$C_MAXRSS)
c11536f5 5580 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5581 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5582#endif
a1887106 5583 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5584
d584a1c6
JM		 5585 /* If a NAML block is used RMS always writes to the long and short
5586 * addresses unless you suppress the short name.
5587 */
054a3baf 5588#if defined(NAML$C_MAXRSS)
c11536f5 5589 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5590 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5591#endif
d584a1c6 5592 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5593
f7ddb74a 5594#ifdef NAM$M_NO_SHORT_UPCASE
1d60dc3f 5595 if (DECC_EFS_CASE_PRESERVE)
a480973c 5596 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5597#endif
18a3d61e 5598
e0e5e8d6
JM		 5599 /* We may not want to follow symbolic links */
5600#ifdef NAML$M_OPEN_SPECIAL
5601 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5602 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5603#endif
5604
18a3d61e
JM		 5605 /* First attempt to parse as an existing file */
5606 retsts = sys$parse(&myfab,0,0);
5607 if (!(retsts & STS$K_SUCCESS)) {
5608
5609 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5610 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
6fb6c614
JM		 5611 if (retsts == RMS$_DNF ||
5612 retsts == RMS$_DIR ||
5613 retsts == RMS$_DEV ||
5614 retsts == RMS$_PRV) {
18a3d61e 5615 retsts = sys$parse(&myfab,0,0);
6fb6c614 5616 if (retsts & STS$K_SUCCESS) goto int_expanded;
18a3d61e
JM		 5617 }
5618
5619 /* Still could not parse the file specification */
5620 /*----------------------------------------------*/
a480973c 5621 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5622 if (vmsdefspec != NULL)
5623 PerlMem_free(vmsdefspec);
18a3d61e 5624 if (vmsfspec != NULL)
c5375c28
JM		 5625 PerlMem_free(vmsfspec);
5626 if (outbufl != NULL)
5627 PerlMem_free(outbufl);
5628 PerlMem_free(esa);
7566800d
CB		 5629 if (esal != NULL)
5630 PerlMem_free(esal);
18a3d61e
JM		 5631 set_vaxc_errno(retsts);
5632 if (retsts == RMS$_PRV) set_errno(EACCES);
5633 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5634 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5635 else set_errno(EVMSERR);
5636 return NULL;
5637 }
5638 retsts = sys$search(&myfab,0,0);
5639 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5640 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5641 if (vmsdefspec != NULL)
5642 PerlMem_free(vmsdefspec);
18a3d61e 5643 if (vmsfspec != NULL)
c5375c28
JM		 5644 PerlMem_free(vmsfspec);
5645 if (outbufl != NULL)
5646 PerlMem_free(outbufl);
5647 PerlMem_free(esa);
7566800d
CB		 5648 if (esal != NULL)
5649 PerlMem_free(esal);
18a3d61e
JM		 5650 set_vaxc_errno(retsts);
5651 if (retsts == RMS$_PRV) set_errno(EACCES);
5652 else set_errno(EVMSERR);
5653 return NULL;
5654 }
5655
5656 /* If the input filespec contained any lowercase characters,
5657 * downcase the result for compatibility with Unix-minded code. */
6fb6c614 5658int_expanded:
1d60dc3f 5659 if (!DECC_EFS_CASE_PRESERVE) {
6fb6c614 5660 char * tbuf;
c5375c28
JM		 5661 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5662 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5663 }
5664
5665 /* Is a long or a short name expected */
5666 /*------------------------------------*/
6fb6c614 5667 spec_buf = NULL;
054a3baf 5668#if defined(NAML$C_MAXRSS)
18a3d61e 5669 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5670 if (rms_nam_rsll(mynam)) {
6fb6c614 5671 spec_buf = outbufl;
a480973c 5672 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5673 }
5674 else {
6fb6c614 5675 spec_buf = esal; /* Not esa */
a480973c 5676 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5677 }
5678 }
5679 else {
778e045f 5680#endif
a480973c 5681 if (rms_nam_rsl(mynam)) {
6fb6c614 5682 spec_buf = outbuf;
a480973c 5683 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5684 }
5685 else {
6fb6c614 5686 spec_buf = esa; /* Not esal */
a480973c 5687 speclen = rms_nam_esl(mynam);
18a3d61e 5688 }
054a3baf 5689#if defined(NAML$C_MAXRSS)
18a3d61e 5690 }
778e045f 5691#endif
6fb6c614 5692 spec_buf[speclen] = '\0';
4d743a9b 5693
18a3d61e
JM		 5694 /* Trim off null fields added by $PARSE
5695 * If type > 1 char, must have been specified in original or default spec
5696 * (not true for version; $SEARCH may have added version of existing file).
5697 */
a480973c 5698 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5699 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5700 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5701 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5702 }
5703 else {
a480973c
JM		 5704 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5705 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5706 }
5707 if (trimver || trimtype) {
5708 if (defspec && *defspec) {
5709 char *defesal = NULL;
d584a1c6 5710 char *defesa = NULL;
c11536f5 5711 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
d584a1c6 5712 if (defesa != NULL) {
6fb6c614 5713 struct FAB deffab = cc$rms_fab;
054a3baf 5714#if defined(NAML$C_MAXRSS)
c11536f5 5715 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5716 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 5717#endif
a480973c 5718 rms_setup_nam(defnam);
18a3d61e 5719
a480973c
JM		 5720 rms_bind_fab_nam(deffab, defnam);
5721
5722 /* Cast ok */
5723 rms_set_fna
5724 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5725
d584a1c6
JM		 5726 /* RMS needs the esa/esal as a work area if wildcards are involved */
5727 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5728
4d743a9b 5729 rms_clear_nam_nop(defnam);
a480973c 5730 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e 5731#ifdef NAM$M_NO_SHORT_UPCASE
1d60dc3f 5732 if (DECC_EFS_CASE_PRESERVE)
a480973c 5733 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5734#endif
e0e5e8d6
JM		 5735#ifdef NAML$M_OPEN_SPECIAL
5736 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5737 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5738#endif
18a3d61e
JM		 5739 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5740 if (trimver) {
a480973c 5741 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5742 }
5743 if (trimtype) {
a480973c 5744 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5745 }
5746 }
d584a1c6
JM		 5747 if (defesal != NULL)
5748 PerlMem_free(defesal);
5749 PerlMem_free(defesa);
6fb6c614
JM		 5750 } else {
5751 _ckvmssts_noperl(SS$_INSFMEM);
18a3d61e
JM		 5752 }
5753 }
5754 if (trimver) {
5755 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5756 if (*(rms_nam_verl(mynam)) != '\"')
6fb6c614 5757 speclen = rms_nam_verl(mynam) - spec_buf;
18a3d61e
JM		 5758 }
5759 else {
a480973c 5760 if (*(rms_nam_ver(mynam)) != '\"')
6fb6c614 5761 speclen = rms_nam_ver(mynam) - spec_buf;
18a3d61e
JM		 5762 }
5763 }
5764 if (trimtype) {
5765 /* If we didn't already trim version, copy down */
5766 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
6fb6c614 5767 if (speclen > rms_nam_verl(mynam) - spec_buf)
18a3d61e 5768 memmove
a480973c
JM		 5769 (rms_nam_typel(mynam),
5770 rms_nam_verl(mynam),
6fb6c614 5771 speclen - (rms_nam_verl(mynam) - spec_buf));
a480973c 5772 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5773 }
5774 else {
6fb6c614 5775 if (speclen > rms_nam_ver(mynam) - spec_buf)
18a3d61e 5776 memmove
a480973c
JM		 5777 (rms_nam_type(mynam),
5778 rms_nam_ver(mynam),
6fb6c614 5779 speclen - (rms_nam_ver(mynam) - spec_buf));
a480973c 5780 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5781 }
5782 }
5783 }
5784
5785 /* Done with these copies of the input files */
5786 /*-------------------------------------------*/
5787 if (vmsfspec != NULL)
c5375c28 5788 PerlMem_free(vmsfspec);
6fb6c614
JM		 5789 if (vmsdefspec != NULL)
5790 PerlMem_free(vmsdefspec);
18a3d61e
JM		 5791
5792 /* If we just had a directory spec on input, $PARSE "helpfully"
5793 * adds an empty name and type for us */
054a3baf 5794#if defined(NAML$C_MAXRSS)
18a3d61e 5795 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5796 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5797 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5798 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5799 speclen = rms_nam_namel(mynam) - spec_buf;
18a3d61e 5800 }
d584a1c6
JM		 5801 else
5802#endif
5803 {
a480973c
JM		 5804 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5805 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5806 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5807 speclen = rms_nam_name(mynam) - spec_buf;
18a3d61e
JM		 5808 }
5809
5810 /* Posix format specifications must have matching quotes */
4d743a9b 5811 if (speclen < (VMS_MAXRSS - 1)) {
1d60dc3f 5812 if (DECC_POSIX_COMPLIANT_PATHNAMES && (spec_buf[0] == '\"')) {
6fb6c614
JM		 5813 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5814 spec_buf[speclen] = '\"';
4d743a9b
JM		 5815 speclen++;
5816 }
18a3d61e
JM		 5817 }
5818 }
6fb6c614 5819 spec_buf[speclen] = '\0';
1d60dc3f 5820 if (haslower && !DECC_EFS_CASE_PRESERVE) __mystrtolower(spec_buf);
18a3d61e
JM		 5821
5822 /* Have we been working with an expanded, but not resultant, spec? */
5823 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5824 {
5825 int rsl;
18a3d61e 5826
054a3baf 5827#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 5828 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5829 rsl = rms_nam_rsll(mynam);
5830 } else
5831#endif
5832 {
5833 rsl = rms_nam_rsl(mynam);
5834 }
5835 if (!rsl) {
6fb6c614
JM		 5836 /* rsl is not present, it means that spec_buf is either */
5837 /* esa or esal, and needs to be copied to outbuf */
5838 /* convert to Unix if desired */
d584a1c6 5839 if (isunix) {
6fb6c614
JM		 5840 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5841 } else {
5842 /* VMS file specs are not in UTF-8 */
5843 if (fs_utf8 != NULL)
5844 *fs_utf8 = 0;
a35dcc95 5845 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5846 ret_spec = outbuf;
18a3d61e
JM		 5847 }
5848 }
6fb6c614
JM		 5849 else {
5850 /* Now spec_buf is either outbuf or outbufl */
5851 /* We need the result into outbuf */
5852 if (isunix) {
5853 /* If we need this in UNIX, then we need another buffer */
5854 /* to keep things in order */
5855 char * src;
5856 char * new_src = NULL;
5857 if (spec_buf == outbuf) {
c11536f5 5858 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 5859 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
6fb6c614
JM		 5860 } else {
5861 src = spec_buf;
5862 }
5863 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5864 if (new_src) {
5865 PerlMem_free(new_src);
5866 }
5867 } else {
5868 /* VMS file specs are not in UTF-8 */
5869 if (fs_utf8 != NULL)
5870 *fs_utf8 = 0;
5871
5872 /* Copy the buffer if needed */
5873 if (outbuf != spec_buf)
a35dcc95 5874 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5875 ret_spec = outbuf;
d584a1c6 5876 }
18a3d61e 5877 }
18a3d61e 5878 }
6fb6c614
JM		 5879
5880 /* Need to clean up the search context */
a480973c
JM		 5881 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5882 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5883
5884 /* Clean up the extra buffers */
7566800d 5885 if (esal != NULL)
6fb6c614
JM		 5886 PerlMem_free(esal);
5887 PerlMem_free(esa);
c5375c28
JM		 5888 if (outbufl != NULL)
5889 PerlMem_free(outbufl);
6fb6c614
JM		 5890
5891 /* Return the result */
5892 return ret_spec;
5893}
5894
5895/* Common simple case - Expand an already VMS spec */
5896static char *
5897int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5898 opts |= PERL_RMSEXPAND_M_VMS_IN;
5899 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5900}
5901
5902/* Common simple case - Expand to a VMS spec */
5903static char *
5904int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5905 opts |= PERL_RMSEXPAND_M_VMS;
5906 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5907}
5908
5909
5910/* Entry point used by perl routines */
5911static char *
5912mp_do_rmsexpand
5913 (pTHX_ const char *filespec,
5914 char *outbuf,
5915 int ts,
5916 const char *defspec,
5917 unsigned opts,
5918 int * fs_utf8,
5919 int * dfs_utf8)
5920{
5921 static char __rmsexpand_retbuf[VMS_MAXRSS];
5922 char * expanded, *ret_spec, *ret_buf;
5923
5924 expanded = NULL;
5925 ret_buf = outbuf;
5926 if (ret_buf == NULL) {
5927 if (ts) {
5928 Newx(expanded, VMS_MAXRSS, char);
5929 if (expanded == NULL)
5930 _ckvmssts(SS$_INSFMEM);
5931 ret_buf = expanded;
5932 } else {
5933 ret_buf = __rmsexpand_retbuf;
5934 }
5935 }
5936
5937
5938 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5939 opts, fs_utf8, dfs_utf8);
5940
5941 if (ret_spec == NULL) {
5942 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5943 if (expanded)
5944 Safefree(expanded);
5945 }
5946
5947 return ret_spec;
bbce6d69 5948}
5949/*}}}*/
5950/* External entry points */
ce12d4b7
CB		 5951char *
5952Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5953{
5954 return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5955}
5956
5957char *
5958Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5959{
5960 return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5961}
5962
5963char *
5964Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5965 unsigned opt, int * fs_utf8, int * dfs_utf8)
5966{
5967 return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5968}
5969
5970char *
5971Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5972 unsigned opt, int * fs_utf8, int * dfs_utf8)
5973{
5974 return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5975}
bbce6d69 5976
5977
a0d0e21e
LW		 5978/*
5979** The following routines are provided to make life easier when
5980** converting among VMS-style and Unix-style directory specifications.
5981** All will take input specifications in either VMS or Unix syntax. On
5982** failure, all return NULL. If successful, the routines listed below
748a9306 5983** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5984** reformatted spec (and, therefore, subsequent calls to that routine
5985** will clobber the result), while the routines of the same names with
5986** a _ts suffix appended will return a pointer to a mallocd string
5987** containing the appropriately reformatted spec.
5988** In all cases, only explicit syntax is altered; no check is made that
5989** the resulting string is valid or that the directory in question
5990** actually exists.
5991**
5992** fileify_dirspec() - convert a directory spec into the name of the
5993** directory file (i.e. what you can stat() to see if it's a dir).
5994** The style (VMS or Unix) of the result is the same as the style
5995** of the parameter passed in.
5996** pathify_dirspec() - convert a directory spec into a path (i.e.
5997** what you prepend to a filename to indicate what directory it's in).
5998** The style (VMS or Unix) of the result is the same as the style
5999** of the parameter passed in.
6000** tounixpath() - convert a directory spec into a Unix-style path.
6001** tovmspath() - convert a directory spec into a VMS-style path.
6002** tounixspec() - convert any file spec into a Unix-style file spec.
6003** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 6004** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 6005**
bd3fa61c 6006** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 6007** Permission is given to distribute this code as part of the Perl
6008** standard distribution under the terms of the GNU General Public
6009** License or the Perl Artistic License. Copies of each may be
6010** found in the Perl standard distribution.
a0d0e21e
LW		 6011 */
6012
a979ce91
JM		 6013/*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6014static char *
6015int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
a0d0e21e 6016{
4e0c9737 6017 unsigned long int dirlen, retlen, hasfilename = 0;
a979ce91 6018 char *cp1, *cp2, *lastdir;
a480973c 6019 char *trndir, *vmsdir;
2d9f3838 6020 unsigned short int trnlnm_iter_count;
f7ddb74a 6021 int sts;
360732b5
JM		 6022 if (utf8_fl != NULL)
6023 *utf8_fl = 0;
a0d0e21e 6024
c07a80fd 6025 if (!dir || !*dir) {
6026 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6027 }
a0d0e21e 6028 dirlen = strlen(dir);
a2a90019 6029 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 6030 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1d60dc3f 6031 if (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT) {
f7ddb74a
JM		 6032 dir = "/sys$disk";
6033 dirlen = 9;
6034 }
6035 else
6036 dirlen = 1;
61bb5906 6037 }
a480973c
JM		 6038 if (dirlen > (VMS_MAXRSS - 1)) {
6039 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6040 return NULL;
c07a80fd 6041 }
c11536f5 6042 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6043 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a 6044 if (!strpbrk(dir+1,"/]>:") &&
1d60dc3f 6045 (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT)) {
e518068a 6046 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 6047 trnlnm_iter_count = 0;
b8486b9d 6048 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 6049 trnlnm_iter_count++;
6050 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6051 }
b8ffc8df 6052 dirlen = strlen(trndir);
e518068a 6053 }
01b8edb6 6054 else {
a35dcc95 6055 memcpy(trndir, dir, dirlen);
01b8edb6 6056 trndir[dirlen] = '\0';
01b8edb6 6057 }
b8ffc8df
RGS		 6058
6059 /* At this point we are done with *dir and use *trndir which is a
6060 * copy that can be modified. *dir must not be modified.
6061 */
6062
c07a80fd 6063 /* If we were handed a rooted logical name or spec, treat it like a
6064 * simple directory, so that
6065 * $ Define myroot dev:[dir.]
6066 * ... do_fileify_dirspec("myroot",buf,1) ...
6067 * does something useful.
6068 */
083b2a61 6069 if (dirlen >= 2 && strEQ(trndir+dirlen-2,".]")) {
b8ffc8df
RGS		 6070 trndir[--dirlen] = '\0';
6071 trndir[dirlen-1] = ']';
c07a80fd 6072 }
083b2a61 6073 if (dirlen >= 2 && strEQ(trndir+dirlen-2,".>")) {
b8ffc8df
RGS		 6074 trndir[--dirlen] = '\0';
6075 trndir[dirlen-1] = '>';
46112e17 6076 }
e518068a 6077
b8ffc8df 6078 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 6079 /* If we've got an explicit filename, we can just shuffle the string. */
6080 if (*(cp1+1)) hasfilename = 1;
6081 /* Similarly, we can just back up a level if we've got multiple levels
6082 of explicit directories in a VMS spec which ends with directories. */
6083 else {
b8ffc8df 6084 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 6085 if (*cp2 == '.') {
6086 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 6087/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 6088 *cp2 = *cp1; *cp1 = '\0';
6089 hasfilename = 1;
6090 break;
6091 }
b7ae7a0d 6092 }
6093 if (*cp2 == '[' || *cp2 == '<') break;
6094 }
6095 }
6096 }
6097
c11536f5 6098 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6099 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 6100 cp1 = strpbrk(trndir,"]:>");
60e5a54b
CB		 6101 if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
6102 cp1 = strpbrk(cp1+2,"]:>");
6103
a979ce91
JM		 6104 if (hasfilename || !cp1) { /* filename present or not VMS */
6105
b8ffc8df 6106 if (trndir[0] == '.') {
a480973c 6107 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 6108 PerlMem_free(trndir);
6109 PerlMem_free(vmsdir);
a979ce91 6110 return int_fileify_dirspec("[]", buf, NULL);
a480973c 6111 }
b8ffc8df 6112 else if (trndir[1] == '.' &&
a480973c 6113 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 6114 PerlMem_free(trndir);
6115 PerlMem_free(vmsdir);
a979ce91 6116 return int_fileify_dirspec("[-]", buf, NULL);
a480973c 6117 }
748a9306 6118 }
b8ffc8df 6119 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 6120 dirlen -= 1; /* to last element */
b8ffc8df 6121 lastdir = strrchr(trndir,'/');
a0d0e21e 6122 }
b8ffc8df 6123 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 6124 /* If we have "/." or "/..", VMSify it and let the VMS code
6125 * below expand it, rather than repeating the code to handle
6126 * relative components of a filespec here */
4633a7c4
LW		 6127 do {
6128 if (*(cp1+2) == '.') cp1++;
6129 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 6130 char * ret_chr;
df278665 6131 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
c5375c28
JM		 6132 PerlMem_free(trndir);
6133 PerlMem_free(vmsdir);
a480973c
JM		 6134 return NULL;
6135 }
fc1ce8cc 6136 if (strchr(vmsdir,'/') != NULL) {
df278665 6137 /* If int_tovmsspec() returned it, it must have VMS syntax
fc1ce8cc
CB		 6138 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6139 * the time to check this here only so we avoid a recursion
6140 * loop; otherwise, gigo.
6141 */
c5375c28
JM		 6142 PerlMem_free(trndir);
6143 PerlMem_free(vmsdir);
a480973c
JM		 6144 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6145 return NULL;
fc1ce8cc 6146 }
a979ce91 6147 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6148 PerlMem_free(trndir);
6149 PerlMem_free(vmsdir);
a480973c
JM		 6150 return NULL;
6151 }
0e5ce2c7 6152 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6153 PerlMem_free(trndir);
6154 PerlMem_free(vmsdir);
a480973c 6155 return ret_chr;
4633a7c4
LW		 6156 }
6157 cp1++;
6158 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 6159 lastdir = strrchr(trndir,'/');
748a9306 6160 }
083b2a61 6161 else if (dirlen >= 7 && strEQ(&trndir[dirlen-7],"/000000")) {
a480973c 6162 char * ret_chr;
61bb5906
CB		 6163 /* Ditto for specs that end in an MFD -- let the VMS code
6164 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 6165
6166 /* This should not happen any more. Allowing the fake /000000
6167 * in a UNIX pathname causes all sorts of problems when trying
6168 * to run in UNIX emulation. So the VMS to UNIX conversions
6169 * now remove the fake /000000 directories.
6170 */
6171
b8ffc8df 6172 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
df278665 6173 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
c5375c28
JM		 6174 PerlMem_free(trndir);
6175 PerlMem_free(vmsdir);
a480973c
JM		 6176 return NULL;
6177 }
a979ce91 6178 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6179 PerlMem_free(trndir);
6180 PerlMem_free(vmsdir);
a480973c
JM		 6181 return NULL;
6182 }
0e5ce2c7 6183 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6184 PerlMem_free(trndir);
6185 PerlMem_free(vmsdir);
a480973c 6186 return ret_chr;
61bb5906 6187 }
a0d0e21e 6188 else {
f7ddb74a 6189
b8ffc8df
RGS		 6190 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6191 !(lastdir = cp1 = strrchr(trndir,']')) &&
6192 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
f7ddb74a 6193
a979ce91
JM		 6194 cp2 = strrchr(cp1,'.');
6195 if (cp2) {
6196 int e_len, vs_len = 0;
6197 int is_dir = 0;
6198 char * cp3;
6199 cp3 = strchr(cp2,';');
6200 e_len = strlen(cp2);
6201 if (cp3) {
6202 vs_len = strlen(cp3);
6203 e_len = e_len - vs_len;
6204 }
6205 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6206 if (!is_dir) {
1d60dc3f 6207 if (!DECC_EFS_CHARSET) {
a979ce91
JM		 6208 /* If this is not EFS, then not a directory */
6209 PerlMem_free(trndir);
6210 PerlMem_free(vmsdir);
6211 set_errno(ENOTDIR);
6212 set_vaxc_errno(RMS$_DIR);
6213 return NULL;
6214 }
6215 } else {
6216 /* Ok, here we have an issue, technically if a .dir shows */
6217 /* from inside a directory, then we should treat it as */
6218 /* xxx^.dir.dir. But we do not have that context at this */
6219 /* point unless this is totally restructured, so we remove */
6220 /* The .dir for now, and fix this better later */
6221 dirlen = cp2 - trndir;
6222 }
1d60dc3f 6223 if (DECC_EFS_CHARSET && !strchr(trndir,'/')) {
37769287 6224 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
a9fac63d
CB		 6225 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6226
6227 for (; cp4 > cp1; cp4--) {
6228 if (*cp4 == '.') {
6229 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6230 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6231 *cp4 = '^';
6232 dirlen++;
6233 }
6234 }
6235 }
6236 }
a0d0e21e 6237 }
a979ce91 6238
748a9306 6239 }
f7ddb74a
JM		 6240
6241 retlen = dirlen + 6;
a979ce91
JM		 6242 memcpy(buf, trndir, dirlen);
6243 buf[dirlen] = '\0';
f7ddb74a 6244
a0d0e21e
LW		 6245 /* We've picked up everything up to the directory file name.
6246 Now just add the type and version, and we're set. */
1d60dc3f 6247 if ((!DECC_EFS_CASE_PRESERVE) && vms_process_case_tolerant)
6e2e048b 6248 strcat(buf,".dir");
839e16da 6249 else
6e2e048b 6250 strcat(buf,".DIR");
1d60dc3f 6251 if (!DECC_FILENAME_UNIX_NO_VERSION)
6e2e048b 6252 strcat(buf,";1");
c5375c28
JM		 6253 PerlMem_free(trndir);
6254 PerlMem_free(vmsdir);
a979ce91 6255 return buf;
a0d0e21e
LW		 6256 }
6257 else { /* VMS-style directory spec */
a480973c 6258
d584a1c6
JM		 6259 char *esa, *esal, term, *cp;
6260 char *my_esa;
6261 int my_esa_len;
4e0c9737 6262 unsigned long int cmplen, haslower = 0;
a0d0e21e 6263 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6264 rms_setup_nam(savnam);
6265 rms_setup_nam(dirnam);
6266
c11536f5 6267 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 6268 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6269 esal = NULL;
054a3baf 6270#if defined(NAML$C_MAXRSS)
c11536f5 6271 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6272 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6273#endif
a480973c
JM		 6274 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6275 rms_bind_fab_nam(dirfab, dirnam);
6276 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 6277 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a 6278#ifdef NAM$M_NO_SHORT_UPCASE
1d60dc3f 6279 if (DECC_EFS_CASE_PRESERVE)
a480973c 6280 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6281#endif
01b8edb6 6282
b8ffc8df 6283 for (cp = trndir; *cp; cp++)
01b8edb6 6284 if (islower(*cp)) { haslower = 1; break; }
a480973c 6285 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
a979ce91
JM		 6286 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6287 (dirfab.fab$l_sts == RMS$_DNF) ||
6288 (dirfab.fab$l_sts == RMS$_PRV)) {
6289 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6290 sts = sys$parse(&dirfab);
e518068a 6291 }
6292 if (!sts) {
c5375c28 6293 PerlMem_free(esa);
d584a1c6
JM		 6294 if (esal != NULL)
6295 PerlMem_free(esal);
c5375c28
JM		 6296 PerlMem_free(trndir);
6297 PerlMem_free(vmsdir);
748a9306
LW		 6298 set_errno(EVMSERR);
6299 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6300 return NULL;
6301 }
e518068a 6302 }
6303 else {
6304 savnam = dirnam;
a480973c
JM		 6305 /* Does the file really exist? */
6306 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6307 /* Yes; fake the fnb bits so we'll check type below */
a979ce91 6308 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6309 }
752635ea 6310 else { /* No; just work with potential name */
60e5a54b
CB		 6311 if (dirfab.fab$l_sts == RMS$_FNF
6312 || dirfab.fab$l_sts == RMS$_DNF
6313 || dirfab.fab$l_sts == RMS$_FND)
6314 dirnam = savnam;
752635ea 6315 else {
2623a4a6
JM		 6316 int fab_sts;
6317 fab_sts = dirfab.fab$l_sts;
6318 sts = rms_free_search_context(&dirfab);
c5375c28 6319 PerlMem_free(esa);
d584a1c6
JM		 6320 if (esal != NULL)
6321 PerlMem_free(esal);
c5375c28
JM		 6322 PerlMem_free(trndir);
6323 PerlMem_free(vmsdir);
2623a4a6 6324 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6325 return NULL;
6326 }
e518068a 6327 }
a0d0e21e 6328 }
d584a1c6
JM		 6329
6330 /* Make sure we are using the right buffer */
054a3baf 6331#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 6332 if (esal != NULL) {
6333 my_esa = esal;
6334 my_esa_len = rms_nam_esll(dirnam);
6335 } else {
778e045f 6336#endif
d584a1c6
JM		 6337 my_esa = esa;
6338 my_esa_len = rms_nam_esl(dirnam);
054a3baf 6339#if defined(NAML$C_MAXRSS)
d584a1c6 6340 }
778e045f 6341#endif
d584a1c6 6342 my_esa[my_esa_len] = '\0';
a480973c 6343 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6344 cp1 = strchr(my_esa,']');
6345 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6346 if (cp1) { /* Should always be true */
d584a1c6
JM		 6347 my_esa_len -= cp1 - my_esa - 1;
6348 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6349 }
6350 }
a480973c 6351 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6352 /* Yep; check version while we're at it, if it's there. */
a480973c 6353 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
a15aa957 6354 if (strnNE(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6355 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6356 sts = rms_free_search_context(&dirfab);
c5375c28 6357 PerlMem_free(esa);
d584a1c6
JM		 6358 if (esal != NULL)
6359 PerlMem_free(esal);
c5375c28
JM		 6360 PerlMem_free(trndir);
6361 PerlMem_free(vmsdir);
748a9306
LW		 6362 set_errno(ENOTDIR);
6363 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6364 return NULL;
6365 }
748a9306 6366 }
ae6d78fe 6367
a480973c 6368 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306 6369 /* They provided at least the name; we added the type, if necessary, */
a35dcc95 6370 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a480973c 6371 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6372 PerlMem_free(trndir);
6373 PerlMem_free(esa);
d584a1c6
JM		 6374 if (esal != NULL)
6375 PerlMem_free(esal);
c5375c28 6376 PerlMem_free(vmsdir);
a979ce91 6377 return buf;
748a9306 6378 }
c07a80fd 6379 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6380 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6381 *cp1 = '\0';
d584a1c6 6382 my_esa_len -= 9;
c07a80fd 6383 }
d584a1c6 6384 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6385 if (cp1 == NULL) { /* should never happen */
a480973c 6386 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6387 PerlMem_free(trndir);
6388 PerlMem_free(esa);
d584a1c6
JM		 6389 if (esal != NULL)
6390 PerlMem_free(esal);
c5375c28 6391 PerlMem_free(vmsdir);
752635ea
CB		 6392 return NULL;
6393 }
748a9306
LW		 6394 term = *cp1;
6395 *cp1 = '\0';
d584a1c6
JM		 6396 retlen = strlen(my_esa);
6397 cp1 = strrchr(my_esa,'.');
f7ddb74a 6398 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6399 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6400 while (cp1 != NULL) {
d584a1c6 6401 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6402 break;
6403 else {
6404 cp1--;
d584a1c6 6405 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6406 cp1--;
6407 }
d584a1c6 6408 if (cp1 == my_esa)
f7ddb74a
JM		 6409 cp1 = NULL;
6410 }
6411
6412 if ((cp1) != NULL) {
748a9306
LW		 6413 /* There's more than one directory in the path. Just roll back. */
6414 *cp1 = term;
a35dcc95 6415 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a0d0e21e
LW		 6416 }
6417 else {
a480973c 6418 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6419 /* Go back and expand rooted logical name */
a480973c 6420 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a 6421#ifdef NAM$M_NO_SHORT_UPCASE
1d60dc3f 6422 if (DECC_EFS_CASE_PRESERVE)
a480973c 6423 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6424#endif
a480973c
JM		 6425 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6426 sts = rms_free_search_context(&dirfab);
c5375c28 6427 PerlMem_free(esa);
d584a1c6
JM		 6428 if (esal != NULL)
6429 PerlMem_free(esal);
c5375c28
JM		 6430 PerlMem_free(trndir);
6431 PerlMem_free(vmsdir);
748a9306
LW		 6432 set_errno(EVMSERR);
6433 set_vaxc_errno(dirfab.fab$l_sts);
6434 return NULL;
6435 }
d584a1c6
JM		 6436
6437 /* This changes the length of the string of course */
6438 if (esal != NULL) {
6439 my_esa_len = rms_nam_esll(dirnam);
6440 } else {
6441 my_esa_len = rms_nam_esl(dirnam);
6442 }
6443
6444 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
d584a1c6
JM		 6445 cp1 = strstr(my_esa,"][");
6446 if (!cp1) cp1 = strstr(my_esa,"]<");
6447 dirlen = cp1 - my_esa;
a979ce91 6448 memcpy(buf, my_esa, dirlen);
f55ac4a4 6449 if (strBEGINs(cp1+2,"000000]")) {
a979ce91 6450 buf[dirlen-1] = '\0';
657054d4 6451 /* fix-me Not full ODS-5, just extra dots in directories for now */
a979ce91
JM		 6452 cp1 = buf + dirlen - 1;
6453 while (cp1 > buf)
f7ddb74a
JM		 6454 {
6455 if (*cp1 == '[')
6456 break;
6457 if (*cp1 == '.') {
6458 if (*(cp1-1) != '^')
6459 break;
6460 }
6461 cp1--;
6462 }
4633a7c4
LW		 6463 if (*cp1 == '.') *cp1 = ']';
6464 else {
a979ce91 6465 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6466 memmove(cp1+1,"000000]",7);
4633a7c4 6467 }
748a9306
LW		 6468 }
6469 else {
a979ce91
JM		 6470 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6471 buf[retlen] = '\0';
748a9306 6472 /* Convert last '.' to ']' */
a979ce91 6473 cp1 = buf+retlen-1;
f7ddb74a
JM		 6474 while (*cp != '[') {
6475 cp1--;
6476 if (*cp1 == '.') {
6477 /* Do not trip on extra dots in ODS-5 directories */
a979ce91 6478 if ((cp1 == buf) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6479 break;
6480 }
6481 }
4633a7c4
LW		 6482 if (*cp1 == '.') *cp1 = ']';
6483 else {
a979ce91 6484 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6485 memmove(cp1+1,"000000]",7);
4633a7c4 6486 }
748a9306 6487 }
a0d0e21e 6488 }
748a9306 6489 else { /* This is a top-level dir. Add the MFD to the path. */
60e5a54b
CB		 6490 cp1 = strrchr(my_esa, ':');
6491 assert(cp1);
6492 memmove(buf, my_esa, cp1 - my_esa + 1);
6493 memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6494 memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6495 buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
a0d0e21e 6496 }
748a9306 6497 }
a480973c 6498 sts = rms_free_search_context(&dirfab);
748a9306 6499 /* We've set up the string up through the filename. Add the
a0d0e21e 6500 type and version, and we're done. */
a979ce91 6501 strcat(buf,".DIR;1");
01b8edb6 6502
6503 /* $PARSE may have upcased filespec, so convert output to lower
6504 * case if input contained any lowercase characters. */
1d60dc3f 6505 if (haslower && !DECC_EFS_CASE_PRESERVE) __mystrtolower(buf);
c5375c28
JM		 6506 PerlMem_free(trndir);
6507 PerlMem_free(esa);
d584a1c6
JM		 6508 if (esal != NULL)
6509 PerlMem_free(esal);
c5375c28 6510 PerlMem_free(vmsdir);
a979ce91 6511 return buf;
a0d0e21e 6512 }
a979ce91
JM		 6513} /* end of int_fileify_dirspec() */
6514
6515
6516/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 6517static char *
6518mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a979ce91
JM		 6519{
6520 static char __fileify_retbuf[VMS_MAXRSS];
6521 char * fileified, *ret_spec, *ret_buf;
6522
6523 fileified = NULL;
6524 ret_buf = buf;
6525 if (ret_buf == NULL) {
6526 if (ts) {
6527 Newx(fileified, VMS_MAXRSS, char);
6528 if (fileified == NULL)
6529 _ckvmssts(SS$_INSFMEM);
6530 ret_buf = fileified;
6531 } else {
6532 ret_buf = __fileify_retbuf;
6533 }
6534 }
6535
6536 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6537
6538 if (ret_spec == NULL) {
6539 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6540 if (fileified)
6541 Safefree(fileified);
6542 }
6543
6544 return ret_spec;
a0d0e21e
LW		 6545} /* end of do_fileify_dirspec() */
6546/*}}}*/
a979ce91 6547
a0d0e21e 6548/* External entry points */
ce12d4b7
CB		 6549char *
6550Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6551{
6552 return do_fileify_dirspec(dir, buf, 0, NULL);
6553}
6554
6555char *
6556Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6557{
6558 return do_fileify_dirspec(dir, buf, 1, NULL);
6559}
6560
6561char *
6562Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6563{
6564 return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6565}
6566
6567char *
6568Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6569{
6570 return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6571}
6572
6573static char *
6574int_pathify_dirspec_simple(const char * dir, char * buf,
1fe570cc
JM		 6575 char * v_spec, int v_len, char * r_spec, int r_len,
6576 char * d_spec, int d_len, char * n_spec, int n_len,
ce12d4b7
CB		 6577 char * e_spec, int e_len, char * vs_spec, int vs_len)
6578{
1fe570cc
JM		 6579
6580 /* VMS specification - Try to do this the simple way */
6581 if ((v_len + r_len > 0) || (d_len > 0)) {
6582 int is_dir;
6583
6584 /* No name or extension component, already a directory */
6585 if ((n_len + e_len + vs_len) == 0) {
6586 strcpy(buf, dir);
6587 return buf;
6588 }
6589
6590 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6591 /* This results from catfile() being used instead of catdir() */
6592 /* So even though it should not work, we need to allow it */
6593
6594 /* If this is .DIR;1 then do a simple conversion */
6595 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6596 if (is_dir || (e_len == 0) && (d_len > 0)) {
6597 int len;
6598 len = v_len + r_len + d_len - 1;
6599 char dclose = d_spec[d_len - 1];
a35dcc95 6600 memcpy(buf, dir, len);
1fe570cc
JM		 6601 buf[len] = '.';
6602 len++;
a35dcc95 6603 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6604 len += n_len;
6605 buf[len] = dclose;
6606 buf[len + 1] = '\0';
6607 return buf;
6608 }
6609
6610#ifdef HAS_SYMLINK
6611 else if (d_len > 0) {
6612 /* In the olden days, a directory needed to have a .DIR */
6613 /* extension to be a valid directory, but now it could */
6614 /* be a symbolic link */
6615 int len;
6616 len = v_len + r_len + d_len - 1;
6617 char dclose = d_spec[d_len - 1];
a35dcc95 6618 memcpy(buf, dir, len);
1fe570cc
JM		 6619 buf[len] = '.';
6620 len++;
a35dcc95 6621 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6622 len += n_len;
6623 if (e_len > 0) {
1d60dc3f 6624 if (DECC_EFS_CHARSET) {
07531283 6625 if (e_len == 4
30048647
CB		 6626 && (toUPPER_A(e_spec[1]) == 'D')
6627 && (toUPPER_A(e_spec[2]) == 'I')
6628 && (toUPPER_A(e_spec[3]) == 'R')) {
07531283
CB		 6629
6630 /* Corner case: directory spec with invalid version.
6631 * Valid would have followed is_dir path above.
6632 */
6633 SETERRNO(ENOTDIR, RMS$_DIR);
6634 return NULL;
6635 }
6636 else {
6637 buf[len] = '^';
6638 len++;
6639 memcpy(&buf[len], e_spec, e_len);
6640 len += e_len;
6641 }
6642 }
6643 else {
6644 SETERRNO(ENOTDIR, RMS$_DIR);
1fe570cc
JM		 6645 return NULL;
6646 }
6647 }
6648 buf[len] = dclose;
6649 buf[len + 1] = '\0';
6650 return buf;
6651 }
6652#else
6653 else {
6654 set_vaxc_errno(RMS$_DIR);
6655 set_errno(ENOTDIR);
6656 return NULL;
6657 }
6658#endif
6659 }
6660 set_vaxc_errno(RMS$_DIR);
6661 set_errno(ENOTDIR);
6662 return NULL;
6663}
6664
6665
6666/* Internal routine to make sure or convert a directory to be in a */
6667/* path specification. No utf8 flag because it is not changed or used */
ce12d4b7
CB		 6668static char *
6669int_pathify_dirspec(const char *dir, char *buf)
a0d0e21e 6670{
1fe570cc
JM		 6671 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6672 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6673 char * exp_spec, *ret_spec;
6674 char * trndir;
2d9f3838 6675 unsigned short int trnlnm_iter_count;
baf3cf9c 6676 STRLEN trnlen;
1fe570cc
JM		 6677 int need_to_lower;
6678
6679 if (vms_debug_fileify) {
6680 if (dir == NULL)
6681 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6682 else
6683 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6684 }
6685
6686 /* We may need to lower case the result if we translated */
6687 /* a logical name or got the current working directory */
6688 need_to_lower = 0;
a0d0e21e 6689
c07a80fd 6690 if (!dir || !*dir) {
1fe570cc
JM		 6691 set_errno(EINVAL);
6692 set_vaxc_errno(SS$_BADPARAM);
6693 return NULL;
c07a80fd 6694 }
6695
c11536f5 6696 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6697 if (trndir == NULL)
6698 _ckvmssts_noperl(SS$_INSFMEM);
c07a80fd 6699
1fe570cc
JM		 6700 /* If no directory specified use the current default */
6701 if (*dir)
a35dcc95 6702 my_strlcpy(trndir, dir, VMS_MAXRSS);
1fe570cc
JM		 6703 else {
6704 getcwd(trndir, VMS_MAXRSS - 1);
6705 need_to_lower = 1;
6706 }
6707
6708 /* now deal with bare names that could be logical names */
2d9f3838 6709 trnlnm_iter_count = 0;
93948341 6710 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1fe570cc
JM		 6711 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6712 trnlnm_iter_count++;
6713 need_to_lower = 1;
6714 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6715 break;
6716 trnlen = strlen(trndir);
6717
6718 /* Trap simple rooted lnms, and return lnm:[000000] */
083b2a61 6719 if (strEQ(trndir+trnlen-2,".]")) {
a35dcc95 6720 my_strlcpy(buf, dir, VMS_MAXRSS);
1fe570cc
JM		 6721 strcat(buf, ":[000000]");
6722 PerlMem_free(trndir);
6723
6724 if (vms_debug_fileify) {
6725 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6726 }
6727 return buf;
6728 }
c07a80fd 6729 }
748a9306 6730
1fe570cc 6731 /* At this point we do not work with *dir, but the copy in *trndir */
b8ffc8df 6732
1d60dc3f 6733 if (need_to_lower && !DECC_EFS_CASE_PRESERVE) {
1fe570cc
JM		 6734 /* Legacy mode, lower case the returned value */
6735 __mystrtolower(trndir);
6736 }
f7ddb74a 6737
1fe570cc
JM		 6738
6739 /* Some special cases, '..', '.' */
6740 sts = 0;
6741 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6742 /* Force UNIX filespec */
6743 sts = 1;
6744
6745 } else {
6746 /* Is this Unix or VMS format? */
6747 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6748 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6749 &e_len, &vs_spec, &vs_len);
6750 if (sts == 0) {
6751
6752 /* Just a filename? */
6753 if ((v_len + r_len + d_len) == 0) {
6754
6755 /* Now we have a problem, this could be Unix or VMS */
6756 /* We have to guess. .DIR usually means VMS */
6757
6758 /* In UNIX report mode, the .DIR extension is removed */
6759 /* if one shows up, it is for a non-directory or a directory */
6760 /* in EFS charset mode */
6761
6762 /* So if we are in Unix report mode, assume that this */
6763 /* is a relative Unix directory specification */
6764
6765 sts = 1;
1d60dc3f 6766 if (!DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
1fe570cc
JM		 6767 int is_dir;
6768 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6769
6770 if (is_dir) {
6771 /* Traditional mode, assume .DIR is directory */
6772 buf[0] = '[';
6773 buf[1] = '.';
a35dcc95 6774 memcpy(&buf[2], n_spec, n_len);
1fe570cc
JM		 6775 buf[n_len + 2] = ']';
6776 buf[n_len + 3] = '\0';
6777 PerlMem_free(trndir);
6778 if (vms_debug_fileify) {
6779 fprintf(stderr,
6780 "int_pathify_dirspec: buf = %s\n",
6781 buf);
6782 }
6783 return buf;
6784 }
6785 }
6786 }
a0d0e21e 6787 }
a0d0e21e 6788 }
1fe570cc
JM		 6789 if (sts == 0) {
6790 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6791 v_spec, v_len, r_spec, r_len,
6792 d_spec, d_len, n_spec, n_len,
6793 e_spec, e_len, vs_spec, vs_len);
a0d0e21e 6794
1fe570cc
JM		 6795 if (ret_spec != NULL) {
6796 PerlMem_free(trndir);
6797 if (vms_debug_fileify) {
6798 fprintf(stderr,
6799 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6800 }
6801 return ret_spec;
b7ae7a0d 6802 }
1fe570cc
JM		 6803
6804 /* Simple way did not work, which means that a logical name */
6805 /* was present for the directory specification. */
6806 /* Need to use an rmsexpand variant to decode it completely */
c11536f5 6807 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6808 if (exp_spec == NULL)
6809 _ckvmssts_noperl(SS$_INSFMEM);
6810
6811 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6812 if (ret_spec != NULL) {
6813 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6814 &r_spec, &r_len, &d_spec, &d_len,
6815 &n_spec, &n_len, &e_spec,
6816 &e_len, &vs_spec, &vs_len);
6817 if (sts == 0) {
6818 ret_spec = int_pathify_dirspec_simple(
6819 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6820 d_spec, d_len, n_spec, n_len,
6821 e_spec, e_len, vs_spec, vs_len);
6822
1d60dc3f 6823 if ((ret_spec != NULL) && (!DECC_EFS_CASE_PRESERVE)) {
1fe570cc
JM		 6824 /* Legacy mode, lower case the returned value */
6825 __mystrtolower(ret_spec);
6826 }
6827 } else {
6828 set_vaxc_errno(RMS$_DIR);
6829 set_errno(ENOTDIR);
6830 ret_spec = NULL;
6831 }
b7ae7a0d 6832 }
1fe570cc
JM		 6833 PerlMem_free(exp_spec);
6834 PerlMem_free(trndir);
6835 if (vms_debug_fileify) {
6836 if (ret_spec == NULL)
6837 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6838 else
6839 fprintf(stderr,
6840 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6841 }
6842 return ret_spec;
a480973c 6843
1fe570cc 6844 } else {
bd1901c6
CB		 6845 /* Unix specification, Could be trivial conversion, */
6846 /* but have to deal with trailing '.dir' or extra '.' */
1fe570cc 6847
bd1901c6
CB		 6848 char * lastdot;
6849 char * lastslash;
6850 int is_dir;
6851 STRLEN dir_len = strlen(trndir);
1fe570cc 6852
bd1901c6
CB		 6853 lastslash = strrchr(trndir, '/');
6854 if (lastslash == NULL)
6855 lastslash = trndir;
6856 else
6857 lastslash++;
6858
6859 lastdot = NULL;
6860
6861 /* '..' or '.' are valid directory components */
6862 is_dir = 0;
6863 if (lastslash[0] == '.') {
6864 if (lastslash[1] == '\0') {
6865 is_dir = 1;
6866 } else if (lastslash[1] == '.') {
6867 if (lastslash[2] == '\0') {
6868 is_dir = 1;
6869 } else {
6870 /* And finally allow '...' */
6871 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
1fe570cc 6872 is_dir = 1;
1fe570cc
JM		 6873 }
6874 }
6875 }
bd1901c6 6876 }
01b8edb6 6877
bd1901c6
CB		 6878 if (!is_dir) {
6879 lastdot = strrchr(lastslash, '.');
6880 }
6881 if (lastdot != NULL) {
6882 STRLEN e_len;
6883 /* '.dir' is discarded, and any other '.' is invalid */
6884 e_len = strlen(lastdot);
1fe570cc 6885
bd1901c6 6886 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
1fe570cc 6887
bd1901c6
CB		 6888 if (is_dir) {
6889 dir_len = dir_len - 4;
1fe570cc 6890 }
e518068a 6891 }
1fe570cc 6892
a35dcc95 6893 my_strlcpy(buf, trndir, VMS_MAXRSS);
1fe570cc
JM		 6894 if (buf[dir_len - 1] != '/') {
6895 buf[dir_len] = '/';
6896 buf[dir_len + 1] = '\0';
a0d0e21e 6897 }
1fe570cc
JM		 6898
6899 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
1d60dc3f 6900 if (!DECC_EFS_CHARSET) {
1fe570cc
JM		 6901 int dir_start = 0;
6902 char * str = buf;
6903 if (str[0] == '.') {
6904 char * dots = str;
6905 int cnt = 1;
6906 while ((dots[cnt] == '.') && (cnt < 3))
6907 cnt++;
6908 if (cnt <= 3) {
6909 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6910 dir_start = 1;
6911 str += cnt;
6912 }
6913 }
6914 }
6915 for (; *str; ++str) {
6916 while (*str == '/') {
6917 dir_start = 1;
6918 *str++;
6919 }
6920 if (dir_start) {
6921
6922 /* Have to skip up to three dots which could be */
6923 /* directories, 3 dots being a VMS extension for Perl */
6924 char * dots = str;
6925 int cnt = 0;
6926 while ((dots[cnt] == '.') && (cnt < 3)) {
6927 cnt++;
6928 }
6929 if (dots[cnt] == '\0')
6930 break;
6931 if ((cnt > 1) && (dots[cnt] != '/')) {
6932 dir_start = 0;
6933 } else {
6934 str += cnt;
6935 }
6936
6937 /* too many dots? */
6938 if ((cnt == 0) || (cnt > 3)) {
6939 dir_start = 0;
6940 }
6941 }
6942 if (!dir_start && (*str == '.')) {
6943 *str = '_';
6944 }
6945 }
e518068a 6946 }
1fe570cc
JM		 6947 PerlMem_free(trndir);
6948 ret_spec = buf;
6949 if (vms_debug_fileify) {
6950 if (ret_spec == NULL)
6951 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6952 else
6953 fprintf(stderr,
6954 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
a0d0e21e 6955 }
1fe570cc
JM		 6956 return ret_spec;
6957 }
6958}
d584a1c6 6959
1fe570cc 6960/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
ce12d4b7
CB		 6961static char *
6962mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
1fe570cc
JM		 6963{
6964 static char __pathify_retbuf[VMS_MAXRSS];
6965 char * pathified, *ret_spec, *ret_buf;
6966
6967 pathified = NULL;
6968 ret_buf = buf;
6969 if (ret_buf == NULL) {
6970 if (ts) {
6971 Newx(pathified, VMS_MAXRSS, char);
6972 if (pathified == NULL)
6973 _ckvmssts(SS$_INSFMEM);
6974 ret_buf = pathified;
6975 } else {
6976 ret_buf = __pathify_retbuf;
6977 }
6978 }
d584a1c6 6979
1fe570cc
JM		 6980 ret_spec = int_pathify_dirspec(dir, ret_buf);
6981
6982 if (ret_spec == NULL) {
6983 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6984 if (pathified)
6985 Safefree(pathified);
a0d0e21e
LW		 6986 }
6987
1fe570cc
JM		 6988 return ret_spec;
6989
a0d0e21e 6990} /* end of do_pathify_dirspec() */
1fe570cc
JM		 6991
6992
a0d0e21e 6993/* External entry points */
ce12d4b7
CB		 6994char *
6995Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6996{
6997 return do_pathify_dirspec(dir, buf, 0, NULL);
6998}
6999
7000char *
7001Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7002{
7003 return do_pathify_dirspec(dir, buf, 1, NULL);
7004}
7005
7006char *
7007Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7008{
7009 return do_pathify_dirspec(dir, buf, 0, utf8_fl);
7010}
7011
7012char *
7013Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7014{
7015 return do_pathify_dirspec(dir, buf, 1, utf8_fl);
7016}
a0d0e21e 7017
0e5ce2c7
JM		 7018/* Internal tounixspec routine that does not use a thread context */
7019/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7020static char *
7021int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
a0d0e21e 7022{
0e5ce2c7 7023 char *dirend, *cp1, *cp3, *tmp;
b8ffc8df 7024 const char *cp2;
4e0c9737 7025 int dirlen;
2d9f3838 7026 unsigned short int trnlnm_iter_count;
b7ac4551 7027 int cmp_rslt, outchars_added;
360732b5
JM		 7028 if (utf8_fl != NULL)
7029 *utf8_fl = 0;
a0d0e21e 7030
0e5ce2c7
JM		 7031 if (vms_debug_fileify) {
7032 if (spec == NULL)
7033 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7034 else
7035 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7036 }
7037
7038
7039 if (spec == NULL) {
7040 set_errno(EINVAL);
7041 set_vaxc_errno(SS$_BADPARAM);
7042 return NULL;
7043 }
7044 if (strlen(spec) > (VMS_MAXRSS-1)) {
7045 set_errno(E2BIG);
7046 set_vaxc_errno(SS$_BUFFEROVF);
7047 return NULL;
e518068a 7048 }
f7ddb74a 7049
2497a41f
JM		 7050 /* New VMS specific format needs translation
7051 * glob passes filenames with trailing '\n' and expects this preserved.
7052 */
1d60dc3f 7053 if (DECC_POSIX_COMPLIANT_PATHNAMES) {
f55ac4a4 7054 if (! strBEGINs(spec, "\"^UP^")) {
2497a41f
JM		 7055 char * uspec;
7056 char *tunix;
7057 int tunix_len;
7058 int nl_flag;
7059
c11536f5 7060 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7061 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 7062 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
2497a41f
JM		 7063 nl_flag = 0;
7064 if (tunix[tunix_len - 1] == '\n') {
7065 tunix[tunix_len - 1] = '\"';
7066 tunix[tunix_len] = '\0';
7067 tunix_len--;
7068 nl_flag = 1;
7069 }
7070 uspec = decc$translate_vms(tunix);
367e4b85 7071 PerlMem_free(tunix);
2497a41f 7072 if ((int)uspec > 0) {
a35dcc95 7073 my_strlcpy(rslt, uspec, VMS_MAXRSS);
2497a41f
JM		 7074 if (nl_flag) {
7075 strcat(rslt,"\n");
7076 }
7077 else {
7078 /* If we can not translate it, makemaker wants as-is */
a35dcc95 7079 my_strlcpy(rslt, spec, VMS_MAXRSS);
2497a41f
JM		 7080 }
7081 return rslt;
7082 }
7083 }
7084 }
7085
f7ddb74a
JM		 7086 cmp_rslt = 0; /* Presume VMS */
7087 cp1 = strchr(spec, '/');
7088 if (cp1 == NULL)
7089 cmp_rslt = 0;
7090
7091 /* Look for EFS ^/ */
1d60dc3f 7092 if (DECC_EFS_CHARSET) {
f7ddb74a
JM		 7093 while (cp1 != NULL) {
7094 cp2 = cp1 - 1;
7095 if (*cp2 != '^') {
7096 /* Found illegal VMS, assume UNIX */
7097 cmp_rslt = 1;
7098 break;
7099 }
7100 cp1++;
7101 cp1 = strchr(cp1, '/');
7102 }
7103 }
7104
7105 /* Look for "." and ".." */
1d60dc3f 7106 if (DECC_FILENAME_UNIX_REPORT) {
f7ddb74a
JM		 7107 if (spec[0] == '.') {
7108 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7109 cmp_rslt = 1;
7110 }
7111 else {
7112 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7113 cmp_rslt = 1;
7114 }
7115 }
7116 }
7117 }
b7ac4551
CB		 7118
7119 cp1 = rslt;
7120 cp2 = spec;
7121
7122 /* This is already UNIX or at least nothing VMS understands,
7123 * so all we can reasonably do is unescape extended chars.
7124 */
f7ddb74a 7125 if (cmp_rslt) {
b7ac4551
CB		 7126 while (*cp2) {
7127 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7128 cp1 += outchars_added;
7129 }
7130 *cp1 = '\0';
0e5ce2c7
JM		 7131 if (vms_debug_fileify) {
7132 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7133 }
a0d0e21e
LW		 7134 return rslt;
7135 }
7136
a0d0e21e
LW		 7137 dirend = strrchr(spec,']');
7138 if (dirend == NULL) dirend = strrchr(spec,'>');
7139 if (dirend == NULL) dirend = strchr(spec,':');
7140 if (dirend == NULL) {
09c9c44c 7141 while (*cp2) {
812e68ff
CB		 7142 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7143 cp1 += outchars_added;
09c9c44c
CB		 7144 }
7145 *cp1 = '\0';
0e5ce2c7
JM		 7146 if (vms_debug_fileify) {
7147 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7148 }
a0d0e21e
LW		 7149 return rslt;
7150 }
f7ddb74a
JM		 7151
7152 /* Special case 1 - sys$posix_root = / */
1d60dc3f 7153 if (!DECC_DISABLE_POSIX_ROOT) {
f7ddb74a
JM		 7154 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7155 *cp1 = '/';
7156 cp1++;
7157 cp2 = cp2 + 15;
7158 }
7159 }
f7ddb74a
JM		 7160
7161 /* Special case 2 - Convert NLA0: to /dev/null */
f7ddb74a 7162 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
f7ddb74a
JM		 7163 if (cmp_rslt == 0) {
7164 strcpy(rslt, "/dev/null");
7165 cp1 = cp1 + 9;
7166 cp2 = cp2 + 5;
7167 if (spec[6] != '\0') {
07bee079 7168 cp1[9] = '/';
f7ddb74a
JM		 7169 cp1++;
7170 cp2++;
7171 }
7172 }
7173
7174 /* Also handle special case "SYS$SCRATCH:" */
f7ddb74a 7175 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
c11536f5 7176 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7177 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 7178 if (cmp_rslt == 0) {
7179 int islnm;
7180
b8486b9d 7181 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
f7ddb74a
JM		 7182 if (!islnm) {
7183 strcpy(rslt, "/tmp");
7184 cp1 = cp1 + 4;
7185 cp2 = cp2 + 12;
7186 if (spec[12] != '\0') {
07bee079 7187 cp1[4] = '/';
f7ddb74a
JM		 7188 cp1++;
7189 cp2++;
7190 }
7191 }
7192 }
7193
a5f75d66 7194 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 7195 *(cp1++) = '/';
7196 }
7197 else { /* the VMS spec begins with directories */
7198 cp2++;
a5f75d66 7199 if (*cp2 == ']' || *cp2 == '>') {
f401ac15
CB		 7200 *(cp1++) = '.';
7201 *(cp1++) = '/';
a5f75d66 7202 }
f7ddb74a 7203 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 7204 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
367e4b85 7205 PerlMem_free(tmp);
0e5ce2c7
JM		 7206 if (vms_debug_fileify) {
7207 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7208 }
a0d0e21e
LW		 7209 return NULL;
7210 }
2d9f3838 7211 trnlnm_iter_count = 0;
a0d0e21e
LW		 7212 do {
7213 cp3 = tmp;
7214 while (*cp3 != ':' && *cp3) cp3++;
7215 *(cp3++) = '\0';
7216 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 7217 trnlnm_iter_count++;
7218 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 7219 } while (vmstrnenv(tmp,tmp,0,fildev,0));
0e5ce2c7 7220 cp1 = rslt;
f86702cc 7221 cp3 = tmp;
7222 *(cp1++) = '/';
7223 while (*cp3) {
7224 *(cp1++) = *(cp3++);
0e5ce2c7 7225 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
367e4b85 7226 PerlMem_free(tmp);
0e5ce2c7
JM		 7227 set_errno(ENAMETOOLONG);
7228 set_vaxc_errno(SS$_BUFFEROVF);
7229 if (vms_debug_fileify) {
7230 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7231 }
2f4077ca
JM		 7232 return NULL; /* No room */
7233 }
a0d0e21e 7234 }
f86702cc 7235 *(cp1++) = '/';
7236 }
f7ddb74a 7237 if ((*cp2 == '^')) {
812e68ff
CB		 7238 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7239 cp1 += outchars_added;
f7ddb74a 7240 }
f86702cc 7241 else if ( *cp2 == '.') {
7242 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7243 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7244 cp2 += 3;
7245 }
7246 else cp2++;
a0d0e21e 7247 }
a0d0e21e 7248 }
367e4b85 7249 PerlMem_free(tmp);
a0d0e21e 7250 for (; cp2 <= dirend; cp2++) {
f7ddb74a 7251 if ((*cp2 == '^')) {
9b2457c1
CB		 7252 /* EFS file escape -- unescape it. */
7253 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7254 cp1 += outchars_added;
f7ddb74a 7255 }
9b2457c1 7256 else if (*cp2 == ':') {
a0d0e21e 7257 *(cp1++) = '/';
5ad5b34c 7258 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
a0d0e21e 7259 }
f86702cc 7260 else if (*cp2 == ']' || *cp2 == '>') {
7261 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7262 }
f7ddb74a 7263 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 7264 *(cp1++) = '/';
e518068a 7265 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7266 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7267 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
c1b0c181 7268 if (memEQs(cp2,7,"[000000") && (*(cp2+7) == ']' ||
e518068a 7269 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7270 }
f86702cc 7271 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7272 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7273 cp2 += 2;
7274 }
a0d0e21e
LW		 7275 }
7276 else if (*cp2 == '-') {
7277 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7278 while (*cp2 == '-') {
7279 cp2++;
7280 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7281 }
7282 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
0e5ce2c7 7283 /* filespecs like */
01b8edb6 7284 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
0e5ce2c7
JM		 7285 if (vms_debug_fileify) {
7286 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7287 }
a0d0e21e
LW		 7288 return NULL;
7289 }
a0d0e21e
LW		 7290 }
7291 else *(cp1++) = *cp2;
7292 }
7293 else *(cp1++) = *cp2;
7294 }
0e5ce2c7 7295 /* Translate the rest of the filename. */
42cd432e 7296 while (*cp2) {
b7ac4551 7297 int dot_seen = 0;
0e5ce2c7
JM		 7298 switch(*cp2) {
7299 /* Fixme - for compatibility with the CRTL we should be removing */
7300 /* spaces from the file specifications, but this may show that */
7301 /* some tests that were appearing to pass are not really passing */
7302 case '%':
7303 cp2++;
7304 *(cp1++) = '?';
7305 break;
7306 case '^':
812e68ff
CB		 7307 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7308 cp1 += outchars_added;
0e5ce2c7
JM		 7309 break;
7310 case ';':
1d60dc3f 7311 if (DECC_FILENAME_UNIX_NO_VERSION) {
0e5ce2c7
JM		 7312 /* Easy, drop the version */
7313 while (*cp2)
7314 cp2++;
7315 break;
7316 } else {
7317 /* Punt - passing the version as a dot will probably */
7318 /* break perl in weird ways, but so did passing */
7319 /* through the ; as a version. Follow the CRTL and */
7320 /* hope for the best. */
7321 cp2++;
7322 *(cp1++) = '.';
7323 }
7324 break;
7325 case '.':
7326 if (dot_seen) {
7327 /* We will need to fix this properly later */
7328 /* As Perl may be installed on an ODS-5 volume, but not */
7329 /* have the EFS_CHARSET enabled, it still may encounter */
7330 /* filenames with extra dots in them, and a precedent got */
7331 /* set which allowed them to work, that we will uphold here */
7332 /* If extra dots are present in a name and no ^ is on them */
7333 /* VMS assumes that the first one is the extension delimiter */
7334 /* the rest have an implied ^. */
7335
7336 /* this is also a conflict as the . is also a version */
7337 /* delimiter in VMS, */
7338
7339 *(cp1++) = *(cp2++);
7340 break;
7341 }
7342 dot_seen = 1;
7343 /* This is an extension */
1d60dc3f 7344 if (DECC_READDIR_DROPDOTNOTYPE) {
0e5ce2c7
JM		 7345 cp2++;
7346 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7347 /* Drop the dot for the extension */
7348 break;
7349 } else {
7350 *(cp1++) = '.';
7351 }
7352 break;
7353 }
7354 default:
7355 *(cp1++) = *(cp2++);
7356 }
42cd432e 7357 }
a0d0e21e
LW		 7358 *cp1 = '\0';
7359
f7ddb74a
JM		 7360 /* This still leaves /000000/ when working with a
7361 * VMS device root or concealed root.
7362 */
7363 {
ce12d4b7
CB		 7364 int ulen;
7365 char * zeros;
f7ddb74a
JM		 7366
7367 ulen = strlen(rslt);
7368
7369 /* Get rid of "000000/ in rooted filespecs */
7370 if (ulen > 7) {
7371 zeros = strstr(rslt, "/000000/");
7372 if (zeros != NULL) {
7373 int mlen;
7374 mlen = ulen - (zeros - rslt) - 7;
7375 memmove(zeros, &zeros[7], mlen);
7376 ulen = ulen - 7;
7377 rslt[ulen] = '\0';
7378 }
7379 }
7380 }
7381
0e5ce2c7
JM		 7382 if (vms_debug_fileify) {
7383 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7384 }
a0d0e21e
LW		 7385 return rslt;
7386
0e5ce2c7
JM		 7387} /* end of int_tounixspec() */
7388
7389
7390/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7391static char *
7392mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
0e5ce2c7
JM		 7393{
7394 static char __tounixspec_retbuf[VMS_MAXRSS];
7395 char * unixspec, *ret_spec, *ret_buf;
7396
7397 unixspec = NULL;
7398 ret_buf = buf;
7399 if (ret_buf == NULL) {
7400 if (ts) {
7401 Newx(unixspec, VMS_MAXRSS, char);
7402 if (unixspec == NULL)
7403 _ckvmssts(SS$_INSFMEM);
7404 ret_buf = unixspec;
7405 } else {
7406 ret_buf = __tounixspec_retbuf;
7407 }
7408 }
7409
7410 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7411
7412 if (ret_spec == NULL) {
7413 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7414 if (unixspec)
7415 Safefree(unixspec);
7416 }
7417
7418 return ret_spec;
7419
a0d0e21e
LW		 7420} /* end of do_tounixspec() */
7421/*}}}*/
7422/* External entry points */
ce12d4b7
CB		 7423char *
7424Perl_tounixspec(pTHX_ const char *spec, char *buf)
7425{
7426 return do_tounixspec(spec, buf, 0, NULL);
7427}
7428
7429char *
7430Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7431{
7432 return do_tounixspec(spec,buf,1, NULL);
7433}
7434
7435char *
7436Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7437{
7438 return do_tounixspec(spec,buf,0, utf8_fl);
7439}
7440
7441char *
7442Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7443{
7444 return do_tounixspec(spec,buf,1, utf8_fl);
7445}
a0d0e21e 7446
360732b5
JM		 7447/*
7448 This procedure is used to identify if a path is based in either
7449 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7450 it returns the OpenVMS format directory for it.
7451
7452 It is expecting specifications of only '/' or '/xxxx/'
7453
7454 If a posix root does not exist, or 'xxxx' is not a directory
7455 in the posix root, it returns a failure.
7456
7457 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7458
7459 It is used only internally by posix_to_vmsspec_hardway().
7460 */
7461
ce12d4b7
CB		 7462static int
7463posix_root_to_vms(char *vmspath, int vmspath_len,
7464 const char *unixpath, const int * utf8_fl)
7465{
7466 int sts;
7467 struct FAB myfab = cc$rms_fab;
7468 rms_setup_nam(mynam);
7469 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7470 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7471 char * esa, * esal, * rsa, * rsal;
7472 int dir_flag;
7473 int unixlen;
7474
7475 dir_flag = 0;
7476 vmspath[0] = '\0';
7477 unixlen = strlen(unixpath);
7478 if (unixlen == 0) {
7479 return RMS$_FNF;
7480 }
360732b5
JM		 7481
7482#if __CRTL_VER >= 80200000
2497a41f 7483 /* If not a posix spec already, convert it */
1d60dc3f 7484 if (DECC_POSIX_COMPLIANT_PATHNAMES) {
f55ac4a4 7485 if (! strBEGINs(unixpath,"\"^UP^")) {
360732b5
JM		 7486 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7487 }
7488 else {
7489 /* This is already a VMS specification, no conversion */
7490 unixlen--;
a35dcc95 7491 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
360732b5 7492 }
2497a41f 7493 }
360732b5
JM		 7494 else
7495#endif
7496 {
ce12d4b7
CB		 7497 int path_len;
7498 int i,j;
360732b5
JM		 7499
7500 /* Check to see if this is under the POSIX root */
1d60dc3f 7501 if (DECC_DISABLE_POSIX_ROOT) {
360732b5
JM		 7502 return RMS$_FNF;
7503 }
7504
7505 /* Skip leading / */
7506 if (unixpath[0] == '/') {
7507 unixpath++;
7508 unixlen--;
7509 }
7510
7511
7512 strcpy(vmspath,"SYS$POSIX_ROOT:");
7513
7514 /* If this is only the / , or blank, then... */
7515 if (unixpath[0] == '\0') {
7516 /* by definition, this is the answer */
7517 return SS$_NORMAL;
7518 }
7519
7520 /* Need to look up a directory */
7521 vmspath[15] = '[';
7522 vmspath[16] = '\0';
7523
7524 /* Copy and add '^' escape characters as needed */
7525 j = 16;
7526 i = 0;
7527 while (unixpath[i] != 0) {
7528 int k;
7529
7530 j += copy_expand_unix_filename_escape
7531 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7532 i += k;
7533 }
7534
7535 path_len = strlen(vmspath);
7536 if (vmspath[path_len - 1] == '/')
7537 path_len--;
7538 vmspath[path_len] = ']';
7539 path_len++;
7540 vmspath[path_len] = '\0';
7541
2497a41f
JM		 7542 }
7543 vmspath[vmspath_len] = 0;
7544 if (unixpath[unixlen - 1] == '/')
7545 dir_flag = 1;
c11536f5 7546 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7547 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7548 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 7549 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7550 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7551 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7552 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
d584a1c6
JM		 7553 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7554 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7555 rms_bind_fab_nam(myfab, mynam);
7556 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7557 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
1d60dc3f 7558 if (DECC_EFS_CASE_PRESERVE)
2497a41f 7559 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 7560#ifdef NAML$M_OPEN_SPECIAL
2497a41f 7561 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 7562#endif
2497a41f
JM		 7563
7564 /* Set up the remaining naml fields */
7565 sts = sys$parse(&myfab);
7566
7567 /* It failed! Try again as a UNIX filespec */
7568 if (!(sts & 1)) {
d584a1c6 7569 PerlMem_free(esal);
367e4b85 7570 PerlMem_free(esa);
d584a1c6
JM		 7571 PerlMem_free(rsal);
7572 PerlMem_free(rsa);
2497a41f
JM		 7573 return sts;
7574 }
7575
7576 /* get the Device ID and the FID */
7577 sts = sys$search(&myfab);
d584a1c6
JM		 7578
7579 /* These are no longer needed */
7580 PerlMem_free(esa);
7581 PerlMem_free(rsal);
7582 PerlMem_free(rsa);
7583
2497a41f
JM		 7584 /* on any failure, returned the POSIX ^UP^ filespec */
7585 if (!(sts & 1)) {
d584a1c6 7586 PerlMem_free(esal);
2497a41f
JM		 7587 return sts;
7588 }
7589 specdsc.dsc$a_pointer = vmspath;
7590 specdsc.dsc$w_length = vmspath_len;
7591
7592 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7593 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7594 sts = lib$fid_to_name
7595 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7596
7597 /* on any failure, returned the POSIX ^UP^ filespec */
7598 if (!(sts & 1)) {
7599 /* This can happen if user does not have permission to read directories */
f55ac4a4 7600 if (! strBEGINs(unixpath,"\"^UP^"))
2497a41f
JM		 7601 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7602 else
a35dcc95 7603 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
2497a41f
JM		 7604 }
7605 else {
7606 vmspath[specdsc.dsc$w_length] = 0;
7607
7608 /* Are we expecting a directory? */
7609 if (dir_flag != 0) {
7610 int i;
7611 char *eptr;
7612
7613 eptr = NULL;
7614
7615 i = specdsc.dsc$w_length - 1;
7616 while (i > 0) {
7617 int zercnt;
7618 zercnt = 0;
7619 /* Version must be '1' */
7620 if (vmspath[i--] != '1')
7621 break;
7622 /* Version delimiter is one of ".;" */
7623 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7624 break;
7625 i--;
7626 if (vmspath[i--] != 'R')
7627 break;
7628 if (vmspath[i--] != 'I')
7629 break;
7630 if (vmspath[i--] != 'D')
7631 break;
7632 if (vmspath[i--] != '.')
7633 break;
7634 eptr = &vmspath[i+1];
7635 while (i > 0) {
7636 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7637 if (vmspath[i-1] != '^') {
7638 if (zercnt != 6) {
7639 *eptr = vmspath[i];
7640 eptr[1] = '\0';
7641 vmspath[i] = '.';
7642 break;
7643 }
7644 else {
7645 /* Get rid of 6 imaginary zero directory filename */
7646 vmspath[i+1] = '\0';
7647 }
7648 }
7649 }
7650 if (vmspath[i] == '0')
7651 zercnt++;
7652 else
7653 zercnt = 10;
7654 i--;
7655 }
7656 break;
7657 }
7658 }
7659 }
d584a1c6 7660 PerlMem_free(esal);
2497a41f
JM		 7661 return sts;
7662}
7663
360732b5
JM		 7664/* /dev/mumble needs to be handled special.
7665 /dev/null becomes NLA0:, And there is the potential for other stuff
7666 like /dev/tty which may need to be mapped to something.
7667*/
7668
7669static int
ce12d4b7 7670slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
360732b5 7671{
ce12d4b7
CB		 7672 char * nextslash;
7673 int len;
360732b5
JM		 7674
7675 unixptr += 4;
7676 nextslash = strchr(unixptr, '/');
7677 len = strlen(unixptr);
7678 if (nextslash != NULL)
7679 len = nextslash - unixptr;
a15aa957 7680 if (strEQ(unixptr, "null")) {
360732b5
JM		 7681 if (vmspath_len >= 6) {
7682 strcpy(vmspath, "_NLA0:");
7683 return SS$_NORMAL;
7684 }
7685 }
c5193628 7686 return 0;
360732b5
JM		 7687}
7688
7689
7690/* The built in routines do not understand perl's special needs, so
7691 doing a manual conversion from UNIX to VMS
7692
7693 If the utf8_fl is not null and points to a non-zero value, then
7694 treat 8 bit characters as UTF-8.
7695
7696 The sequence starting with '$(' and ending with ')' will be passed
7697 through with out interpretation instead of being escaped.
7698
7699 */
ce12d4b7
CB		 7700static int
7701posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7702 int dir_flag, int * utf8_fl)
7703{
7704
7705 char *esa;
7706 const char *unixptr;
7707 const char *unixend;
7708 char *vmsptr;
7709 const char *lastslash;
7710 const char *lastdot;
7711 int unixlen;
7712 int vmslen;
7713 int dir_start;
7714 int dir_dot;
7715 int quoted;
7716 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7717 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7718
360732b5
JM		 7719 if (utf8_fl != NULL)
7720 *utf8_fl = 0;
2497a41f
JM		 7721
7722 unixptr = unixpath;
7723 dir_dot = 0;
7724
7725 /* Ignore leading "/" characters */
7726 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7727 unixptr++;
7728 }
7729 unixlen = strlen(unixptr);
7730
7731 /* Do nothing with blank paths */
7732 if (unixlen == 0) {
7733 vmspath[0] = '\0';
7734 return SS$_NORMAL;
7735 }
7736
360732b5
JM		 7737 quoted = 0;
7738 /* This could have a "^UP^ on the front */
f55ac4a4 7739 if (strBEGINs(unixptr,"\"^UP^")) {
360732b5
JM		 7740 quoted = 1;
7741 unixptr+= 5;
7742 unixlen-= 5;
7743 }
7744
2497a41f
JM		 7745 lastslash = strrchr(unixptr,'/');
7746 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7747 unixend = strrchr(unixptr,'\"');
7748 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7749 unixend = unixptr + unixlen;
7750 }
2497a41f
JM		 7751
7752 /* last dot is last dot or past end of string */
7753 if (lastdot == NULL)
7754 lastdot = unixptr + unixlen;
7755
7756 /* if no directories, set last slash to beginning of string */
7757 if (lastslash == NULL) {
7758 lastslash = unixptr;
7759 }
7760 else {
7761 /* Watch out for trailing "." after last slash, still a directory */
7762 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7763 lastslash = unixptr + unixlen;
7764 }
7765
94ae10c0 7766 /* Watch out for trailing ".." after last slash, still a directory */
2497a41f
JM		 7767 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7768 lastslash = unixptr + unixlen;
7769 }
7770
7771 /* dots in directories are aways escaped */
7772 if (lastdot < lastslash)
7773 lastdot = unixptr + unixlen;
7774 }
7775
7776 /* if (unixptr < lastslash) then we are in a directory */
7777
7778 dir_start = 0;
2497a41f
JM		 7779
7780 vmsptr = vmspath;
7781 vmslen = 0;
7782
2497a41f
JM		 7783 /* Start with the UNIX path */
7784 if (*unixptr != '/') {
7785 /* relative paths */
360732b5
JM		 7786
7787 /* If allowing logical names on relative pathnames, then handle here */
1d60dc3f
CB		 7788 if ((unixptr[0] != '.') && !DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION &&
7789 !DECC_POSIX_COMPLIANT_PATHNAMES) {
360732b5
JM		 7790 char * nextslash;
7791 int seg_len;
7792 char * trn;
7793 int islnm;
7794
7795 /* Find the next slash */
7796 nextslash = strchr(unixptr,'/');
7797
c11536f5 7798 esa = (char *)PerlMem_malloc(vmspath_len);
360732b5
JM		 7799 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7800
c11536f5 7801 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
360732b5
JM		 7802 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7803
7804 if (nextslash != NULL) {
7805
7806 seg_len = nextslash - unixptr;
a35dcc95 7807 memcpy(esa, unixptr, seg_len);
360732b5
JM		 7808 esa[seg_len] = 0;
7809 }
7810 else {
a35dcc95 7811 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
360732b5
JM		 7812 }
7813 /* trnlnm(section) */
7814 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7815
7816 if (islnm) {
7817 /* Now fix up the directory */
7818
7819 /* Split up the path to find the components */
7820 sts = vms_split_path
7821 (trn,
7822 &v_spec,
7823 &v_len,
7824 &r_spec,
7825 &r_len,
7826 &d_spec,
7827 &d_len,
7828 &n_spec,
7829 &n_len,
7830 &e_spec,
7831 &e_len,
7832 &vs_spec,
7833 &vs_len);
7834
7835 while (sts == 0) {
360732b5
JM		 7836
7837 /* A logical name must be a directory or the full
7838 specification. It is only a full specification if
7839 it is the only component */
7840 if ((unixptr[seg_len] == '\0') ||
7841 (unixptr[seg_len+1] == '\0')) {
7842
7843 /* Is a directory being required? */
7844 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7845 /* Not a logical name */
7846 break;
7847 }
7848
7849
7850 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7851 /* This must be a directory */
7852 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
a35dcc95 7853 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
360732b5
JM		 7854 vmsptr[vmslen] = ':';
7855 vmslen++;
7856 vmsptr[vmslen] = '\0';
7857 return SS$_NORMAL;
7858 }
7859 }
7860
7861 }
7862
7863
7864 /* must be dev/directory - ignore version */
7865 if ((n_len + e_len) != 0)
7866 break;
7867
7868 /* transfer the volume */
7869 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
a35dcc95 7870 memcpy(vmsptr, v_spec, v_len);
360732b5
JM		 7871 vmsptr += v_len;
7872 vmsptr[0] = '\0';
7873 vmslen += v_len;
7874 }
7875
7876 /* unroot the rooted directory */
7877 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7878 r_spec[0] = '[';
7879 r_spec[r_len - 1] = ']';
7880
7881 /* This should not be there, but nothing is perfect */
7882 if (r_len > 9) {
083b2a61 7883 if (strEQ(&r_spec[1], "000000.")) {
360732b5
JM		 7884 r_spec += 7;
7885 r_spec[7] = '[';
7886 r_len -= 7;
7887 if (r_len == 2)
7888 r_len = 0;
7889 }
7890 }
7891 if (r_len > 0) {
a35dcc95 7892 memcpy(vmsptr, r_spec, r_len);
360732b5
JM		 7893 vmsptr += r_len;
7894 vmslen += r_len;
7895 vmsptr[0] = '\0';
7896 }
7897 }
7898 /* Bring over the directory. */
7899 if ((d_len > 0) &&
7900 ((d_len + vmslen) < vmspath_len)) {
7901 d_spec[0] = '[';
7902 d_spec[d_len - 1] = ']';
7903 if (d_len > 9) {
083b2a61 7904 if (strEQ(&d_spec[1], "000000.")) {
360732b5
JM		 7905 d_spec += 7;
7906 d_spec[7] = '[';
7907 d_len -= 7;
7908 if (d_len == 2)
7909 d_len = 0;
7910 }
7911 }
7912
7913 if (r_len > 0) {
7914 /* Remove the redundant root */
7915 if (r_len > 0) {
7916 /* remove the ][ */
7917 vmsptr--;
7918 vmslen--;
7919 d_spec++;
7920 d_len--;
7921 }
a35dcc95 7922 memcpy(vmsptr, d_spec, d_len);
360732b5
JM		 7923 vmsptr += d_len;
7924 vmslen += d_len;
7925 vmsptr[0] = '\0';
7926 }
7927 }
7928 break;
7929 }
7930 }
7931
7932 PerlMem_free(esa);
7933 PerlMem_free(trn);
7934 }
7935
2497a41f
JM		 7936 if (lastslash > unixptr) {
7937 int dotdir_seen;
7938
7939 /* skip leading ./ */
7940 dotdir_seen = 0;
7941 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7942 dotdir_seen = 1;
7943 unixptr++;
7944 unixptr++;
7945 }
7946
7947 /* Are we still in a directory? */
7948 if (unixptr <= lastslash) {
7949 *vmsptr++ = '[';
7950 vmslen = 1;
7951 dir_start = 1;
7952
7953 /* if not backing up, then it is relative forward. */
7954 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7955 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7956 *vmsptr++ = '.';
7957 vmslen++;
7958 dir_dot = 1;
360732b5 7959 }
2497a41f
JM		 7960 }
7961 else {
7962 if (dotdir_seen) {
7963 /* Perl wants an empty directory here to tell the difference
94ae10c0 7964 * between a DCL command and a filename
2497a41f
JM		 7965 */
7966 *vmsptr++ = '[';
7967 *vmsptr++ = ']';
7968 vmslen = 2;
7969 }
7970 }
7971 }
7972 else {
7973 /* Handle two special files . and .. */
7974 if (unixptr[0] == '.') {
360732b5 7975 if (&unixptr[1] == unixend) {
2497a41f
JM		 7976 *vmsptr++ = '[';
7977 *vmsptr++ = ']';
7978 vmslen += 2;
7979 *vmsptr++ = '\0';
7980 return SS$_NORMAL;
7981 }
360732b5 7982 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7983 *vmsptr++ = '[';
7984 *vmsptr++ = '-';
7985 *vmsptr++ = ']';
7986 vmslen += 3;
7987 *vmsptr++ = '\0';
7988 return SS$_NORMAL;
7989 }
7990 }
7991 }
7992 }
7993 else { /* Absolute PATH handling */
7994 int sts;
7995 char * nextslash;
7996 int seg_len;
7997 /* Need to find out where root is */
7998
7999 /* In theory, this procedure should never get an absolute POSIX pathname
8000 * that can not be found on the POSIX root.
8001 * In practice, that can not be relied on, and things will show up
8002 * here that are a VMS device name or concealed logical name instead.
8003 * So to make things work, this procedure must be tolerant.
8004 */
c11536f5 8005 esa = (char *)PerlMem_malloc(vmspath_len);
c5375c28 8006 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 8007
8008 sts = SS$_NORMAL;
8009 nextslash = strchr(&unixptr[1],'/');
8010 seg_len = 0;
8011 if (nextslash != NULL) {
8012 seg_len = nextslash - &unixptr[1];
db4c2905 8013 my_strlcpy(vmspath, unixptr, seg_len + 2);
b59bf0b2 8014 if (memEQs(vmspath, seg_len, "dev")) {
360732b5 8015 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
07bee079 8016 if (sts == SS$_NORMAL)
360732b5 8017 return SS$_NORMAL;
360732b5
JM		 8018 }
8019 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 8020 }
8021
360732b5 8022 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 8023 /* This is verified to be a real path */
8024
360732b5
JM		 8025 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8026 if ($VMS_STATUS_SUCCESS(sts)) {
a35dcc95 8027 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
360732b5
JM		 8028 vmsptr = vmspath + vmslen;
8029 unixptr++;
8030 if (unixptr < lastslash) {
8031 char * rptr;
8032 vmsptr--;
8033 *vmsptr++ = '.';
8034 dir_start = 1;
8035 dir_dot = 1;
8036 if (vmslen > 7) {
360732b5 8037 rptr = vmsptr - 7;
083b2a61 8038 if (strEQ(rptr,"000000.")) {
360732b5
JM		 8039 vmslen -= 7;
8040 vmsptr -= 7;
8041 vmsptr[1] = '\0';
8042 } /* removing 6 zeros */
8043 } /* vmslen < 7, no 6 zeros possible */
8044 } /* Not in a directory */
8045 } /* Posix root found */
8046 else {
8047 /* No posix root, fall back to default directory */
8048 strcpy(vmspath, "SYS$DISK:[");
8049 vmsptr = &vmspath[10];
8050 vmslen = 10;
8051 if (unixptr > lastslash) {
8052 *vmsptr = ']';
8053 vmsptr++;
8054 vmslen++;
8055 }
8056 else {
8057 dir_start = 1;
8058 }
8059 }
2497a41f
JM		 8060 } /* end of verified real path handling */
8061 else {
8062 int add_6zero;
8063 int islnm;
8064
8065 /* Ok, we have a device or a concealed root that is not in POSIX
8066 * or we have garbage. Make the best of it.
8067 */
8068
8069 /* Posix to VMS destroyed this, so copy it again */
db4c2905
CB		 8070 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8071 vmslen = strlen(vmspath); /* We know we're truncating. */
2497a41f
JM		 8072 vmsptr = &vmsptr[vmslen];
8073 islnm = 0;
8074
8075 /* Now do we need to add the fake 6 zero directory to it? */
8076 add_6zero = 1;
8077 if ((*lastslash == '/') && (nextslash < lastslash)) {
8078 /* No there is another directory */
8079 add_6zero = 0;
8080 }
8081 else {
8082 int trnend;
8083
8084 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 8085 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5 8086
1d60dc3f 8087 if (!islnm && !DECC_POSIX_COMPLIANT_PATHNAMES) {
a15aa957 8088 if (strEQ(vmspath, "bin")) {
360732b5
JM		 8089 /* bin => SYS$SYSTEM: */
8090 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8091 }
8092 else {
8093 /* tmp => SYS$SCRATCH: */
a15aa957 8094 if (strEQ(vmspath, "tmp")) {
360732b5
JM		 8095 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8096 }
8097 }
8098 }
8099
7ded3206 8100 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 8101
8102 /* if this was a logical name, ']' or '>' must be present */
8103 /* if not a logical name, then assume a device and hope. */
8104 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8105
8106 /* if log name and trailing '.' then rooted - treat as device */
8107 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8108
8109 /* Fix me, if not a logical name, a device lookup should be
8110 * done to see if the device is file structured. If the device
8111 * is not file structured, the 6 zeros should not be put on.
8112 *
8113 * As it is, perl is occasionally looking for dev:[000000]tty.
8114 * which looks a little strange.
360732b5
JM		 8115 *
8116 * Not that easy to detect as "/dev" may be file structured with
8117 * special device files.
2497a41f
JM		 8118 */
8119
30e68285 8120 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
360732b5 8121 (&nextslash[1] == unixend)) {
2497a41f
JM		 8122 /* No real directory present */
8123 add_6zero = 1;
8124 }
8125 }
8126
8127 /* Put the device delimiter on */
8128 *vmsptr++ = ':';
8129 vmslen++;
8130 unixptr = nextslash;
8131 unixptr++;
8132
8133 /* Start directory if needed */
8134 if (!islnm || add_6zero) {
8135 *vmsptr++ = '[';
8136 vmslen++;
8137 dir_start = 1;
8138 }
8139
8140 /* add fake 000000] if needed */
8141 if (add_6zero) {
8142 *vmsptr++ = '0';
8143 *vmsptr++ = '0';
8144 *vmsptr++ = '0';
8145 *vmsptr++ = '0';
8146 *vmsptr++ = '0';
8147 *vmsptr++ = '0';
8148 *vmsptr++ = ']';
8149 vmslen += 7;
8150 dir_start = 0;
8151 }
8152
8153 } /* non-POSIX translation */
367e4b85 8154 PerlMem_free(esa);
2497a41f
JM		 8155 } /* End of relative/absolute path handling */
8156
360732b5 8157 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
ce12d4b7
CB		 8158 int dash_flag;
8159 int in_cnt;
8160 int out_cnt;
2497a41f
JM		 8161
8162 dash_flag = 0;
8163
8164 if (dir_start != 0) {
8165
8166 /* First characters in a directory are handled special */
8167 while ((*unixptr == '/') ||
8168 ((*unixptr == '.') &&
360732b5
JM		 8169 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8170 (&unixptr[1]==unixend)))) {
2497a41f
JM		 8171 int loop_flag;
8172
8173 loop_flag = 0;
8174
8175 /* Skip redundant / in specification */
8176 while ((*unixptr == '/') && (dir_start != 0)) {
8177 loop_flag = 1;
8178 unixptr++;
8179 if (unixptr == lastslash)
8180 break;
8181 }
8182 if (unixptr == lastslash)
8183 break;
8184
8185 /* Skip redundant ./ characters */
8186 while ((*unixptr == '.') &&
360732b5 8187 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 8188 loop_flag = 1;
8189 unixptr++;
8190 if (unixptr == lastslash)
8191 break;
8192 if (*unixptr == '/')
8193 unixptr++;
8194 }
8195 if (unixptr == lastslash)
8196 break;
8197
8198 /* Skip redundant ../ characters */
8199 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 8200 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 8201 /* Set the backing up flag */
8202 loop_flag = 1;
8203 dir_dot = 0;
8204 dash_flag = 1;
8205 *vmsptr++ = '-';
8206 vmslen++;
8207 unixptr++; /* first . */
8208 unixptr++; /* second . */
8209 if (unixptr == lastslash)
8210 break;
8211 if (*unixptr == '/') /* The slash */
8212 unixptr++;
8213 }
8214 if (unixptr == lastslash)
8215 break;
8216
8217 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8218 /* Not needed when VMS is pretending to be UNIX. */
8219
8220 /* Is this loop stuck because of too many dots? */
8221 if (loop_flag == 0) {
8222 /* Exit the loop and pass the rest through */
8223 break;
8224 }
8225 }
8226
8227 /* Are we done with directories yet? */
8228 if (unixptr >= lastslash) {
8229
8230 /* Watch out for trailing dots */
8231 if (dir_dot != 0) {
8232 vmslen --;
8233 vmsptr--;
8234 }
8235 *vmsptr++ = ']';
8236 vmslen++;
8237 dash_flag = 0;
8238 dir_start = 0;
8239 if (*unixptr == '/')
8240 unixptr++;
8241 }
8242 else {
8243 /* Have we stopped backing up? */
8244 if (dash_flag) {
8245 *vmsptr++ = '.';
8246 vmslen++;
8247 dash_flag = 0;
8248 /* dir_start continues to be = 1 */
8249 }
8250 if (*unixptr == '-') {
8251 *vmsptr++ = '^';
8252 *vmsptr++ = *unixptr++;
8253 vmslen += 2;
8254 dir_start = 0;
8255
8256 /* Now are we done with directories yet? */
8257 if (unixptr >= lastslash) {
8258
8259 /* Watch out for trailing dots */
8260 if (dir_dot != 0) {
8261 vmslen --;
8262 vmsptr--;
8263 }
8264
8265 *vmsptr++ = ']';
8266 vmslen++;
8267 dash_flag = 0;
8268 dir_start = 0;
8269 }
8270 }
8271 }
8272 }
8273
8274 /* All done? */
360732b5 8275 if (unixptr >= unixend)
2497a41f
JM		 8276 break;
8277
8278 /* Normal characters - More EFS work probably needed */
8279 dir_start = 0;
8280 dir_dot = 0;
8281
8282 switch(*unixptr) {
8283 case '/':
8284 /* remove multiple / */
8285 while (unixptr[1] == '/') {
8286 unixptr++;
8287 }
8288 if (unixptr == lastslash) {
8289 /* Watch out for trailing dots */
8290 if (dir_dot != 0) {
8291 vmslen --;
8292 vmsptr--;
8293 }
8294 *vmsptr++ = ']';
8295 }
8296 else {
8297 dir_start = 1;
8298 *vmsptr++ = '.';
8299 dir_dot = 1;
8300
8301 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8302 /* Not needed when VMS is pretending to be UNIX. */
8303
8304 }
8305 dash_flag = 0;
360732b5 8306 if (unixptr != unixend)
2497a41f
JM		 8307 unixptr++;
8308 vmslen++;
8309 break;
2497a41f 8310 case '.':
360732b5
JM		 8311 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8312 (&unixptr[1] == unixend)) {
2497a41f
JM		 8313 *vmsptr++ = '^';
8314 *vmsptr++ = '.';
8315 vmslen += 2;
8316 unixptr++;
8317
8318 /* trailing dot ==> '^..' on VMS */
360732b5 8319 if (unixptr == unixend) {
2497a41f
JM		 8320 *vmsptr++ = '.';
8321 vmslen++;
360732b5 8322 unixptr++;
2497a41f 8323 }
2497a41f
JM		 8324 break;
8325 }
360732b5 8326
2497a41f 8327 *vmsptr++ = *unixptr++;
360732b5
JM		 8328 vmslen ++;
8329 break;
8330 case '"':
8331 if (quoted && (&unixptr[1] == unixend)) {
8332 unixptr++;
8333 break;
8334 }
8335 in_cnt = copy_expand_unix_filename_escape
8336 (vmsptr, unixptr, &out_cnt, utf8_fl);
8337 vmsptr += out_cnt;
8338 unixptr += in_cnt;
2497a41f 8339 break;
2497a41f
JM		 8340 case ';':
8341 case '\\':
360732b5
JM		 8342 case '?':
8343 case ' ':
2497a41f 8344 default:
360732b5
JM		 8345 in_cnt = copy_expand_unix_filename_escape
8346 (vmsptr, unixptr, &out_cnt, utf8_fl);
8347 vmsptr += out_cnt;
8348 unixptr += in_cnt;
2497a41f
JM		 8349 break;
8350 }
8351 }
8352
8353 /* Make sure directory is closed */
8354 if (unixptr == lastslash) {
8355 char *vmsptr2;
8356 vmsptr2 = vmsptr - 1;
8357
8358 if (*vmsptr2 != ']') {
8359 *vmsptr2--;
8360
8361 /* directories do not end in a dot bracket */
8362 if (*vmsptr2 == '.') {
8363 vmsptr2--;
8364
8365 /* ^. is allowed */
8366 if (*vmsptr2 != '^') {
8367 vmsptr--; /* back up over the dot */
8368 }
8369 }
8370 *vmsptr++ = ']';
8371 }
8372 }
8373 else {
8374 char *vmsptr2;
8375 /* Add a trailing dot if a file with no extension */
8376 vmsptr2 = vmsptr - 1;
360732b5
JM		 8377 if ((vmslen > 1) &&
8378 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
30e68285 8379 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
2497a41f
JM		 8380 *vmsptr++ = '.';
8381 vmslen++;
8382 }
8383 }
8384
8385 *vmsptr = '\0';
8386 return SS$_NORMAL;
8387}
2497a41f 8388
b7bc7afb
CB		 8389/* A convenience macro for copying dots in filenames and escaping
8390 * them when they haven't already been escaped, with guards to
8391 * avoid checking before the start of the buffer or advancing
8392 * beyond the end of it (allowing room for the NUL terminator).
c1abd561 8393 */
b7bc7afb 8394#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
c1abd561
CB		 8395 if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8396 || ((vmsefsdot) == (vmsefsbuf))) \
b7bc7afb 8397 && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
c1abd561
CB		 8398 ) { \
8399 *((vmsefsdot)++) = '^'; \
c1abd561 8400 } \
b7bc7afb
CB		 8401 if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8402 *((vmsefsdot)++) = '.'; \
c1abd561 8403} STMT_END
df278665 8404
360732b5 8405/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8406static char *
8407int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8408{
df278665 8409 char *dirend;
f7ddb74a 8410 char *lastdot;
eb578fdb 8411 char *cp1;
b8ffc8df 8412 const char *cp2;
e518068a 8413 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 8414 int rslt_len;
8415 int no_type_seen;
360732b5
JM		 8416 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8417 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 8418
df278665
JM		 8419 if (vms_debug_fileify) {
8420 if (path == NULL)
8421 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8422 else
8423 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8424 }
8425
8426 if (path == NULL) {
8427 /* If we fail, we should be setting errno */
8428 set_errno(EINVAL);
8429 set_vaxc_errno(SS$_BADPARAM);
8430 return NULL;
8431 }
4d743a9b 8432 rslt_len = VMS_MAXRSS-1;
360732b5
JM		 8433
8434 /* '.' and '..' are "[]" and "[-]" for a quick check */
8435 if (path[0] == '.') {
8436 if (path[1] == '\0') {
8437 strcpy(rslt,"[]");
8438 if (utf8_flag != NULL)
8439 *utf8_flag = 0;
8440 return rslt;
8441 }
8442 else {
8443 if (path[1] == '.' && path[2] == '\0') {
8444 strcpy(rslt,"[-]");
8445 if (utf8_flag != NULL)
8446 *utf8_flag = 0;
8447 return rslt;
8448 }
8449 }
a0d0e21e 8450 }
f7ddb74a 8451
2497a41f
JM		 8452 /* Posix specifications are now a native VMS format */
8453 /*--------------------------------------------------*/
054a3baf 8454#if __CRTL_VER >= 80200000
1d60dc3f 8455 if (DECC_POSIX_COMPLIANT_PATHNAMES) {
f55ac4a4 8456 if (strBEGINs(path,"\"^UP^")) {
360732b5 8457 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 8458 return rslt;
8459 }
8460 }
8461#endif
8462
360732b5
JM		 8463 /* This is really the only way to see if this is already in VMS format */
8464 sts = vms_split_path
8465 (path,
8466 &v_spec,
8467 &v_len,
8468 &r_spec,
8469 &r_len,
8470 &d_spec,
8471 &d_len,
8472 &n_spec,
8473 &n_len,
8474 &e_spec,
8475 &e_len,
8476 &vs_spec,
8477 &vs_len);
8478 if (sts == 0) {
8479 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8480 replacement, because the above parse just took care of most of
8481 what is needed to do vmspath when the specification is already
8482 in VMS format.
8483
8484 And if it is not already, it is easier to do the conversion as
8485 part of this routine than to call this routine and then work on
8486 the result.
8487 */
2497a41f 8488
360732b5
JM		 8489 /* If VMS punctuation was found, it is already VMS format */
8490 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8491 if (utf8_flag != NULL)
8492 *utf8_flag = 0;
a35dcc95 8493 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8494 if (vms_debug_fileify) {
8495 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8496 }
360732b5
JM		 8497 return rslt;
8498 }
8499 /* Now, what to do with trailing "." cases where there is no
8500 extension? If this is a UNIX specification, and EFS characters
8501 are enabled, then the trailing "." should be converted to a "^.".
8502 But if this was already a VMS specification, then it should be
8503 left alone.
2497a41f 8504
360732b5
JM		 8505 So in the case of ambiguity, leave the specification alone.
8506 */
2497a41f 8507
2497a41f 8508
360732b5
JM		 8509 /* If there is a possibility of UTF8, then if any UTF8 characters
8510 are present, then they must be converted to VTF-7
8511 */
8512 if (utf8_flag != NULL)
8513 *utf8_flag = 0;
a35dcc95 8514 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8515 if (vms_debug_fileify) {
8516 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8517 }
2497a41f
JM		 8518 return rslt;
8519 }
8520
360732b5
JM		 8521 dirend = strrchr(path,'/');
8522
8523 if (dirend == NULL) {
db2284bc
CB		 8524 /* If we get here with no Unix directory delimiters, then this is an
8525 * ambiguous file specification, such as a Unix glob specification, a
8526 * shell or make macro, or a filespec that would be valid except for
8527 * unescaped extended characters. The safest thing if it's a macro
8528 * is to pass it through as-is.
360732b5 8529 */
db2284bc
CB		 8530 if (strstr(path, "$(")) {
8531 my_strlcpy(rslt, path, VMS_MAXRSS);
8532 if (vms_debug_fileify) {
8533 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8534 }
8535 return rslt;
df278665 8536 }
db2284bc 8537 hasdir = 0;
360732b5 8538 }
e645f6f8 8539 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 8540 if (!*(dirend+2)) dirend +=2;
8541 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
06099f79 8542 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 8543 }
f7ddb74a 8544
a0d0e21e
LW		 8545 cp1 = rslt;
8546 cp2 = path;
f7ddb74a 8547 lastdot = strrchr(cp2,'.');
a0d0e21e 8548 if (*cp2 == '/') {
a480973c 8549 char *trndev;
e518068a 8550 int islnm, rooted;
8551 STRLEN trnend;
8552
b7ae7a0d 8553 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 8554 if (!*(cp2+1)) {
1d60dc3f 8555 if (DECC_DISABLE_POSIX_ROOT) {
f7ddb74a
JM		 8556 strcpy(rslt,"sys$disk:[000000]");
8557 }
8558 else {
8559 strcpy(rslt,"sys$posix_root:[000000]");
8560 }
360732b5
JM		 8561 if (utf8_flag != NULL)
8562 *utf8_flag = 0;
df278665
JM		 8563 if (vms_debug_fileify) {
8564 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8565 }
61bb5906
CB		 8566 return rslt;
8567 }
a0d0e21e 8568 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 8569 *cp1 = '\0';
c11536f5 8570 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 8571 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
b8486b9d 8572 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8573
8574 /* DECC special handling */
8575 if (!islnm) {
083b2a61 8576 if (strEQ(rslt,"bin")) {
f7ddb74a
JM		 8577 strcpy(rslt,"sys$system");
8578 cp1 = rslt + 10;
8579 *cp1 = 0;
b8486b9d 8580 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a 8581 }
083b2a61 8582 else if (strEQ(rslt,"tmp")) {
f7ddb74a
JM		 8583 strcpy(rslt,"sys$scratch");
8584 cp1 = rslt + 11;
8585 *cp1 = 0;
b8486b9d 8586 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a 8587 }
1d60dc3f 8588 else if (!DECC_DISABLE_POSIX_ROOT) {
f7ddb74a 8589 strcpy(rslt, "sys$posix_root");
b8486b9d 8590 cp1 = rslt + 14;
f7ddb74a
JM		 8591 *cp1 = 0;
8592 cp2 = path;
8593 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
b8486b9d 8594 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a 8595 }
083b2a61 8596 else if (strEQ(rslt,"dev")) {
f55ac4a4 8597 if (strBEGINs(cp2,"/null")) {
f7ddb74a
JM		 8598 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8599 strcpy(rslt,"NLA0");
8600 cp1 = rslt + 4;
8601 *cp1 = 0;
8602 cp2 = cp2 + 5;
b8486b9d 8603 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8604 }
8605 }
8606 }
8607 }
8608
e518068a 8609 trnend = islnm ? strlen(trndev) - 1 : 0;
8610 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8611 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8612 /* If the first element of the path is a logical name, determine
8613 * whether it has to be translated so we can add more directories. */
8614 if (!islnm || rooted) {
8615 *(cp1++) = ':';
8616 *(cp1++) = '[';
8617 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8618 else cp2++;
8619 }
8620 else {
8621 if (cp2 != dirend) {
a35dcc95 8622 my_strlcpy(rslt, trndev, VMS_MAXRSS);
e518068a 8623 cp1 = rslt + trnend;
755b3d5d
JM		 8624 if (*cp2 != 0) {
8625 *(cp1++) = '.';
8626 cp2++;
8627 }
e518068a 8628 }
8629 else {
1d60dc3f 8630 if (DECC_DISABLE_POSIX_ROOT) {
f7ddb74a
JM		 8631 *(cp1++) = ':';
8632 hasdir = 0;
8633 }
e518068a 8634 }
8635 }
367e4b85 8636 PerlMem_free(trndev);
748a9306 8637 }
59247333 8638 else if (hasdir) {
a0d0e21e 8639 *(cp1++) = '[';
748a9306
LW		 8640 if (*cp2 == '.') {
8641 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8642 cp2 += 2; /* skip over "./" - it's redundant */
8643 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8644 }
8645 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8646 *(cp1++) = '-'; /* "../" --> "-" */
8647 cp2 += 3;
8648 }
f86702cc 8649 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8650 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8651 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8652 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8653 cp2 += 4;
8654 }
f7ddb74a
JM		 8655 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8656 /* Escape the extra dots in EFS file specifications */
8657 *(cp1++) = '^';
8658 }
748a9306
LW		 8659 if (cp2 > dirend) cp2 = dirend;
8660 }
8661 else *(cp1++) = '.';
8662 }
8663 for (; cp2 < dirend; cp2++) {
8664 if (*cp2 == '/') {
01b8edb6 8665 if (*(cp2-1) == '/') continue;
59247333 8666 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
748a9306
LW		 8667 infront = 0;
8668 }
8669 else if (!infront && *cp2 == '.') {
01b8edb6 8670 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8671 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9 8672 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
59247333
CB		 8673 if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8674 else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
4ab1eb56
CB		 8675 else {
8676 *(cp1++) = '-';
748a9306
LW		 8677 }
8678 cp2 += 2;
01b8edb6 8679 if (cp2 == dirend) break;
748a9306 8680 }
f86702cc 8681 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8682 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
59247333 8683 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
f86702cc 8684 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8685 if (!*(cp2+3)) {
8686 *(cp1++) = '.'; /* Simulate trailing '/' */
8687 cp2 += 2; /* for loop will incr this to == dirend */
8688 }
8689 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8690 }
f7ddb74a 8691 else {
1d60dc3f 8692 if (DECC_EFS_CHARSET == 0) {
59247333 8693 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8694 cp1--; /* remove the escape, if any */
f7ddb74a 8695 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
b7bc7afb 8696 }
f7ddb74a 8697 else {
b7bc7afb 8698 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8699 }
8700 }
748a9306
LW		 8701 }
8702 else {
59247333 8703 if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a 8704 if (*cp2 == '.') {
1d60dc3f 8705 if (DECC_EFS_CHARSET == 0) {
59247333 8706 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8707 cp1--; /* remove the escape, if any */
f7ddb74a 8708 *(cp1++) = '_';
b7bc7afb 8709 }
f7ddb74a 8710 else {
b7bc7afb 8711 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8712 }
8713 }
e283d9f3
CB		 8714 else {
8715 int out_cnt;
8716 cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8717 cp2--; /* we're in a loop that will increment this */
8718 cp1 += out_cnt;
8719 }
748a9306
LW		 8720 infront = 1;
8721 }
a0d0e21e 8722 }
59247333 8723 if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8724 if (hasdir) *(cp1++) = ']';
2e82b6ce 8725 if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
f7ddb74a
JM		 8726 no_type_seen = 0;
8727 if (cp2 > lastdot)
8728 no_type_seen = 1;
8729 while (*cp2) {
8730 switch(*cp2) {
8731 case '?':
1d60dc3f 8732 if (DECC_EFS_CHARSET == 0)
360732b5
JM		 8733 *(cp1++) = '%';
8734 else
8735 *(cp1++) = '?';
f7ddb74a 8736 cp2++;
774e4634 8737 break;
f7ddb74a 8738 case ' ':
2e82b6ce 8739 if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
c434e88d 8740 *(cp1)++ = '^';
f7ddb74a
JM		 8741 *(cp1)++ = '_';
8742 cp2++;
8743 break;
8744 case '.':
8745 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
1d60dc3f 8746 DECC_READDIR_DROPDOTNOTYPE) {
b7bc7afb 8747 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8748 cp2++;
8749
8750 /* trailing dot ==> '^..' on VMS */
8751 if (*cp2 == '\0') {
8752 *(cp1++) = '.';
8753 no_type_seen = 0;
8754 }
8755 }
8756 else {
8757 *(cp1++) = *(cp2++);
8758 no_type_seen = 0;
8759 }
8760 break;
360732b5
JM		 8761 case '$':
8762 /* This could be a macro to be passed through */
8763 *(cp1++) = *(cp2++);
8764 if (*cp2 == '(') {
8765 const char * save_cp2;
8766 char * save_cp1;
8767 int is_macro;
8768
8769 /* paranoid check */
8770 save_cp2 = cp2;
8771 save_cp1 = cp1;
8772 is_macro = 0;
8773
8774 /* Test through */
8775 *(cp1++) = *(cp2++);
30048647 8776 if (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
360732b5 8777 *(cp1++) = *(cp2++);
30048647 8778 while (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
360732b5
JM		 8779 *(cp1++) = *(cp2++);
8780 }
8781 if (*cp2 == ')') {
8782 *(cp1++) = *(cp2++);
8783 is_macro = 1;
8784 }
8785 }
8786 if (is_macro == 0) {
8787 /* Not really a macro - never mind */
8788 cp2 = save_cp2;
8789 cp1 = save_cp1;
8790 }
8791 }
8792 break;
f7ddb74a 8793 case '\"':
f7ddb74a
JM		 8794 case '`':
8795 case '!':
8796 case '#':
8797 case '%':
8798 case '^':
adc11f0b
CB		 8799 /* Don't escape again if following character is
8800 * already something we escape.
8801 */
1d86dd2f 8802 if (strchr("\"`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
adc11f0b
CB		 8803 *(cp1++) = *(cp2++);
8804 break;
8805 }
8806 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8807 case '&':
8808 case '(':
8809 case ')':
8810 case '=':
8811 case '+':
8812 case '\'':
8813 case '@':
8814 case '[':
8815 case ']':
8816 case '{':
8817 case '}':
8818 case ':':
8819 case '\\':
8820 case '|':
8821 case '<':
8822 case '>':
676447f9 8823 if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
c434e88d 8824 *(cp1++) = '^';
f7ddb74a
JM		 8825 *(cp1++) = *(cp2++);
8826 break;
8827 case ';':
d5e61aaf 8828 /* If it doesn't look like the beginning of a version number,
6e2e048b 8829 * or we've been promised there are no version numbers, then
d5e61aaf
CB		 8830 * escape it.
8831 */
1d60dc3f 8832 if (DECC_FILENAME_UNIX_NO_VERSION) {
f7ddb74a
JM		 8833 *(cp1++) = '^';
8834 }
6e2e048b
CB		 8835 else {
8836 size_t all_nums = strspn(cp2+1, "0123456789");
8837 if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8838 *(cp1++) = '^';
8839 }
f7ddb74a
JM		 8840 *(cp1++) = *(cp2++);
8841 break;
8842 default:
8843 *(cp1++) = *(cp2++);
8844 }
8845 }
1d60dc3f 8846 if ((no_type_seen == 1) && DECC_READDIR_DROPDOTNOTYPE) {
f7ddb74a
JM		 8847 char *lcp1;
8848 lcp1 = cp1;
8849 lcp1--;
8850 /* Fix me for "^]", but that requires making sure that you do
8851 * not back up past the start of the filename
8852 */
8853 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8854 *cp1++ = '.';
8855 }
a0d0e21e
LW		 8856 *cp1 = '\0';
8857
360732b5
JM		 8858 if (utf8_flag != NULL)
8859 *utf8_flag = 0;
df278665
JM		 8860 if (vms_debug_fileify) {
8861 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8862 }
a0d0e21e
LW		 8863 return rslt;
8864
df278665
JM		 8865} /* end of int_tovmsspec() */
8866
8867
8868/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8869static char *
8870mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8871{
8872 static char __tovmsspec_retbuf[VMS_MAXRSS];
df278665
JM		 8873 char * vmsspec, *ret_spec, *ret_buf;
8874
8875 vmsspec = NULL;
8876 ret_buf = buf;
8877 if (ret_buf == NULL) {
8878 if (ts) {
8879 Newx(vmsspec, VMS_MAXRSS, char);
8880 if (vmsspec == NULL)
8881 _ckvmssts(SS$_INSFMEM);
8882 ret_buf = vmsspec;
8883 } else {
8884 ret_buf = __tovmsspec_retbuf;
8885 }
8886 }
8887
8888 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8889
8890 if (ret_spec == NULL) {
8891 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8892 if (vmsspec)
8893 Safefree(vmsspec);
8894 }
8895
8896 return ret_spec;
8897
8898} /* end of mp_do_tovmsspec() */
a0d0e21e
LW		 8899/*}}}*/
8900/* External entry points */
ce12d4b7
CB		 8901char *
8902Perl_tovmsspec(pTHX_ const char *path, char *buf)
8903{
8904 return do_tovmsspec(path, buf, 0, NULL);
8905}
8906
8907char *
8908Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8909{
8910 return do_tovmsspec(path, buf, 1, NULL);
8911}
8912
8913char *
8914Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8915{
8916 return do_tovmsspec(path, buf, 0, utf8_fl);
8917}
8918
8919char *
8920Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8921{
8922 return do_tovmsspec(path, buf, 1, utf8_fl);
8923}
360732b5 8924
4846f1d7 8925/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
94ae10c0 8926/* Internal routine for use with out an explicit context present */
ce12d4b7
CB		 8927static char *
8928int_tovmspath(const char *path, char *buf, int * utf8_fl)
8929{
4846f1d7
JM		 8930 char * ret_spec, *pathified;
8931
8932 if (path == NULL)
8933 return NULL;
8934
c11536f5 8935 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
4846f1d7
JM		 8936 if (pathified == NULL)
8937 _ckvmssts_noperl(SS$_INSFMEM);
8938
8939 ret_spec = int_pathify_dirspec(path, pathified);
8940
8941 if (ret_spec == NULL) {
8942 PerlMem_free(pathified);
8943 return NULL;
8944 }
8945
8946 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8947
8948 PerlMem_free(pathified);
8949 return ret_spec;
8950
8951}
8952
360732b5 8953/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
ce12d4b7
CB		 8954static char *
8955mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8956{
a480973c 8957 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8958 int vmslen;
a480973c 8959 char *pathified, *vmsified, *cp;
a0d0e21e 8960
748a9306 8961 if (path == NULL) return NULL;
c11536f5 8962 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 8963 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 8964 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 8965 PerlMem_free(pathified);
a480973c
JM		 8966 return NULL;
8967 }
c5375c28
JM		 8968
8969 vmsified = NULL;
8970 if (buf == NULL)
8971 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8972 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8973 PerlMem_free(pathified);
8974 if (vmsified) Safefree(vmsified);
a480973c
JM		 8975 return NULL;
8976 }
c5375c28 8977 PerlMem_free(pathified);
a480973c 8978 if (buf) {
a480973c
JM		 8979 return buf;
8980 }
a0d0e21e
LW		 8981 else if (ts) {
8982 vmslen = strlen(vmsified);
a02a5408 8983 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8984 memcpy(cp,vmsified,vmslen);
8985 cp[vmslen] = '\0';
a480973c 8986 Safefree(vmsified);
a0d0e21e
LW		 8987 return cp;
8988 }
8989 else {
a35dcc95 8990 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
a480973c 8991 Safefree(vmsified);
a0d0e21e
LW		 8992 return __tovmspath_retbuf;
8993 }
8994
8995} /* end of do_tovmspath() */
8996/*}}}*/
8997/* External entry points */
ce12d4b7
CB		 8998char *
8999Perl_tovmspath(pTHX_ const char *path, char *buf)
9000{
9001 return do_tovmspath(path, buf, 0, NULL);
9002}
9003
9004char *
9005Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9006{
9007 return do_tovmspath(path, buf, 1, NULL);
9008}
9009
9010char *
9011Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9012{
9013 return do_tovmspath(path, buf, 0, utf8_fl);
9014}
9015
9016char *
9017Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9018{
9019 return do_tovmspath(path, buf, 1, utf8_fl);
9020}
360732b5
JM		 9021
9022
9023/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 9024static char *
9025mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9026{
a480973c 9027 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 9028 int unixlen;
a480973c 9029 char *pathified, *unixified, *cp;
a0d0e21e 9030
748a9306 9031 if (path == NULL) return NULL;
c11536f5 9032 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9033 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 9034 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 9035 PerlMem_free(pathified);
a480973c
JM		 9036 return NULL;
9037 }
c5375c28
JM		 9038
9039 unixified = NULL;
9040 if (buf == NULL) {
9041 Newx(unixified, VMS_MAXRSS, char);
9042 }
360732b5 9043 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 9044 PerlMem_free(pathified);
9045 if (unixified) Safefree(unixified);
a480973c
JM		 9046 return NULL;
9047 }
c5375c28 9048 PerlMem_free(pathified);
a480973c 9049 if (buf) {
a480973c
JM		 9050 return buf;
9051 }
a0d0e21e
LW		 9052 else if (ts) {
9053 unixlen = strlen(unixified);
a02a5408 9054 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 9055 memcpy(cp,unixified,unixlen);
9056 cp[unixlen] = '\0';
a480973c 9057 Safefree(unixified);
a0d0e21e
LW		 9058 return cp;
9059 }
9060 else {
a35dcc95 9061 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
a480973c 9062 Safefree(unixified);
a0d0e21e
LW		 9063 return __tounixpath_retbuf;
9064 }
9065
9066} /* end of do_tounixpath() */
9067/*}}}*/
9068/* External entry points */
ce12d4b7
CB		 9069char *
9070Perl_tounixpath(pTHX_ const char *path, char *buf)
9071{
9072 return do_tounixpath(path, buf, 0, NULL);
9073}
9074
9075char *
9076Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9077{
9078 return do_tounixpath(path, buf, 1, NULL);
9079}
9080
9081char *
9082Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9083{
9084 return do_tounixpath(path, buf, 0, utf8_fl);
9085}
9086
9087char *
9088Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9089{
9090 return do_tounixpath(path, buf, 1, utf8_fl);
9091}
a0d0e21e
LW		 9092
9093/*
cbb8049c 9094 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9095 *
9096 *****************************************************************************
9097 * *
cbb8049c 9098 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 9099 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9100 * *
cbb8049c
MP		 9101 * Permission is hereby granted for the reproduction of this software *
9102 * on condition that this copyright notice is included in source *
9103 * distributions of the software. The code may be modified and *
9104 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 9105 * *
9106 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 9107 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 9108 *****************************************************************************
9109 */
9110
9111/*
9112 * getredirection() is intended to aid in porting C programs
9113 * to VMS (Vax-11 C). The native VMS environment does not support
9114 * '>' and '<' I/O redirection, or command line wild card expansion,
9115 * or a command line pipe mechanism using the '|' AND background
9116 * command execution '&'. All of these capabilities are provided to any
9117 * C program which calls this procedure as the first thing in the
9118 * main program.
9119 * The piping mechanism will probably work with almost any 'filter' type
9120 * of program. With suitable modification, it may useful for other
9121 * portability problems as well.
9122 *
cbb8049c 9123 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9124 */
9125struct list_item
9126 {
9127 struct list_item *next;
9128 char *value;
9129 };
9130
9131static void add_item(struct list_item **head,
9132 struct list_item **tail,
9133 char *value,
9134 int *count);
9135
4b19af01
CB		 9136static void mp_expand_wild_cards(pTHX_ char *item,
9137 struct list_item **head,
9138 struct list_item **tail,
9139 int *count);
a0d0e21e 9140
8df869cb 9141static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 9142
fd8cd3a3 9143static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 9144
9145/*{{{ void getredirection(int *ac, char ***av)*/
84902520 9146static void
4b19af01 9147mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 9148/*
9149 * Process vms redirection arg's. Exit if any error is seen.
9150 * If getredirection() processes an argument, it is erased
9151 * from the vector. getredirection() returns a new argc and argv value.
9152 * In the event that a background command is requested (by a trailing "&"),
9153 * this routine creates a background subprocess, and simply exits the program.
9154 *
9155 * Warning: do not try to simplify the code for vms. The code
9156 * presupposes that getredirection() is called before any data is
9157 * read from stdin or written to stdout.
9158 *
9159 * Normal usage is as follows:
9160 *
9161 * main(argc, argv)
9162 * int argc;
9163 * char *argv[];
9164 * {
9165 * getredirection(&argc, &argv);
9166 * }
9167 */
9168{
9169 int argc = *ac; /* Argument Count */
9170 char **argv = *av; /* Argument Vector */
9171 char *ap; /* Argument pointer */
9172 int j; /* argv[] index */
9173 int item_count = 0; /* Count of Items in List */
9174 struct list_item *list_head = 0; /* First Item in List */
9175 struct list_item *list_tail; /* Last Item in List */
9176 char *in = NULL; /* Input File Name */
9177 char *out = NULL; /* Output File Name */
9178 char *outmode = "w"; /* Mode to Open Output File */
9179 char *err = NULL; /* Error File Name */
9180 char *errmode = "w"; /* Mode to Open Error File */
9181 int cmargc = 0; /* Piped Command Arg Count */
9182 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 9183
9184 /*
9185 * First handle the case where the last thing on the line ends with
9186 * a '&'. This indicates the desire for the command to be run in a
9187 * subprocess, so we satisfy that desire.
9188 */
9189 ap = argv[argc-1];
083b2a61 9190 if (strEQ(ap, "&"))
8c3eed29 9191 exit(background_process(aTHX_ --argc, argv));
e518068a 9192 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 9193 {
9194 ap[strlen(ap)-1] = '\0';
8c3eed29 9195 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 9196 }
9197 /*
9198 * Now we handle the general redirection cases that involve '>', '>>',
9199 * '<', and pipes '|'.
9200 */
9201 for (j = 0; j < argc; ++j)
9202 {
083b2a61 9203 if (strEQ(argv[j], "<"))
a0d0e21e
LW		 9204 {
9205 if (j+1 >= argc)
9206 {
fd71b04b 9207 fprintf(stderr,"No input file after < on command line");
748a9306 9208 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9209 }
9210 in = argv[++j];
9211 continue;
9212 }
9213 if ('<' == *(ap = argv[j]))
9214 {
9215 in = 1 + ap;
9216 continue;
9217 }
083b2a61 9218 if (strEQ(ap, ">"))
a0d0e21e
LW		 9219 {
9220 if (j+1 >= argc)
9221 {
fd71b04b 9222 fprintf(stderr,"No output file after > on command line");
748a9306 9223 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9224 }
9225 out = argv[++j];
9226 continue;
9227 }
9228 if ('>' == *ap)
9229 {
9230 if ('>' == ap[1])
9231 {
9232 outmode = "a";
9233 if ('\0' == ap[2])
9234 out = argv[++j];
9235 else
9236 out = 2 + ap;
9237 }
9238 else
9239 out = 1 + ap;
9240 if (j >= argc)
9241 {
fd71b04b 9242 fprintf(stderr,"No output file after > or >> on command line");
748a9306 9243 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9244 }
9245 continue;
9246 }
9247 if (('2' == *ap) && ('>' == ap[1]))
9248 {
9249 if ('>' == ap[2])
9250 {
9251 errmode = "a";
9252 if ('\0' == ap[3])
9253 err = argv[++j];
9254 else
9255 err = 3 + ap;
9256 }
9257 else
9258 if ('\0' == ap[2])
9259 err = argv[++j];
9260 else
748a9306 9261 err = 2 + ap;
a0d0e21e
LW		 9262 if (j >= argc)
9263 {
fd71b04b 9264 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 9265 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9266 }
9267 continue;
9268 }
083b2a61 9269 if (strEQ(argv[j], "|"))
a0d0e21e
LW		 9270 {
9271 if (j+1 >= argc)
9272 {
fd71b04b 9273 fprintf(stderr,"No command into which to pipe on command line");
748a9306 9274 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9275 }
9276 cmargc = argc-(j+1);
9277 cmargv = &argv[j+1];
9278 argc = j;
9279 continue;
9280 }
9281 if ('|' == *(ap = argv[j]))
9282 {
9283 ++argv[j];
9284 cmargc = argc-j;
9285 cmargv = &argv[j];
9286 argc = j;
9287 continue;
9288 }
9289 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9290 }
9291 /*
9292 * Allocate and fill in the new argument vector, Some Unix's terminate
9293 * the list with an extra null pointer.
9294 */
e0ef6b43 9295 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 9296 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9297 *av = argv;
9298 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9299 argv[j] = list_head->value;
9300 *ac = item_count;
9301 if (cmargv != NULL)
9302 {
9303 if (out != NULL)
9304 {
fd71b04b 9305 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 9306 exit(LIB$_INVARGORD);
a0d0e21e 9307 }
fd8cd3a3 9308 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 9309 }
9310
9311 /* Check for input from a pipe (mailbox) */
9312
a5f75d66 9313 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 9314 {
9315 char mbxname[L_tmpnam];
9316 long int bufsize;
9317 long int dvi_item = DVI$_DEVBUFSIZ;
9318 $DESCRIPTOR(mbxnam, "");
9319 $DESCRIPTOR(mbxdevnam, "");
9320
9321 /* Input from a pipe, reopen it in binary mode to disable */
9322 /* carriage control processing. */
9323
bf8d1304 9324 fgetname(stdin, mbxname, 1);
a0d0e21e
LW		 9325 mbxnam.dsc$a_pointer = mbxname;
9326 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9327 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9328 mbxdevnam.dsc$a_pointer = mbxname;
9329 mbxdevnam.dsc$w_length = sizeof(mbxname);
9330 dvi_item = DVI$_DEVNAM;
9331 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9332 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 9333 set_errno(0);
9334 set_vaxc_errno(1);
a0d0e21e
LW		 9335 freopen(mbxname, "rb", stdin);
9336 if (errno != 0)
9337 {
fd71b04b 9338 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 9339 exit(vaxc$errno);
a0d0e21e
LW		 9340 }
9341 }
9342 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9343 {
fd71b04b 9344 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 9345 exit(vaxc$errno);
a0d0e21e
LW		 9346 }
9347 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9348 {
fd71b04b 9349 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 9350 exit(vaxc$errno);
a0d0e21e 9351 }
0db50132 9352 if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
0e06870b 9353
748a9306 9354 if (err != NULL) {
083b2a61 9355 if (strEQ(err, "&1")) {
a15cef0c 9356 dup2(fileno(stdout), fileno(stderr));
0db50132 9357 vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
71d7ec5d 9358 } else {
748a9306
LW		 9359 FILE *tmperr;
9360 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9361 {
fd71b04b 9362 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 9363 exit(vaxc$errno);
9364 }
9365 fclose(tmperr);
a15cef0c 9366 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 9367 {
9368 exit(vaxc$errno);
9369 }
0db50132 9370 vmssetuserlnm("SYS$ERROR", err);
a0d0e21e 9371 }
71d7ec5d 9372 }
a0d0e21e 9373#ifdef ARGPROC_DEBUG
740ce14c 9374 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 9375 for (j = 0; j < *ac; ++j)
740ce14c 9376 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 9377#endif
b7ae7a0d 9378 /* Clear errors we may have hit expanding wildcards, so they don't
9379 show up in Perl's $! later */
9380 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 9381} /* end of getredirection() */
9382/*}}}*/
9383
ce12d4b7
CB		 9384static void
9385add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
a0d0e21e
LW		 9386{
9387 if (*head == 0)
9388 {
e0ef6b43 9389 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9390 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9391 *tail = *head;
9392 }
9393 else {
e0ef6b43 9394 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9395 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9396 *tail = (*tail)->next;
9397 }
9398 (*tail)->value = value;
9399 ++(*count);
9400}
9401
ce12d4b7
CB		 9402static void
9403mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9404 struct list_item **tail, int *count)
9405{
9406 int expcount = 0;
9407 unsigned long int context = 0;
9408 int isunix = 0;
9409 int item_len = 0;
9410 char *had_version;
9411 char *had_device;
9412 int had_directory;
9413 char *devdir,*cp;
9414 char *vmsspec;
9415 $DESCRIPTOR(filespec, "");
9416 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9417 $DESCRIPTOR(resultspec, "");
9418 unsigned long int lff_flags = 0;
9419 int sts;
9420 int rms_sts;
a480973c
JM		 9421
9422#ifdef VMS_LONGNAME_SUPPORT
9423 lff_flags = LIB$M_FIL_LONG_NAMES;
9424#endif
a0d0e21e 9425
f675dbe5 9426 for (cp = item; *cp; cp++) {
30048647 9427 if (*cp == '*' || *cp == '%' || isSPACE_L1(*cp)) break;
f675dbe5
CB		 9428 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9429 }
30048647 9430 if (!*cp || isSPACE_L1(*cp))
a0d0e21e
LW		 9431 {
9432 add_item(head, tail, item, count);
9433 return;
9434 }
773da73d
JH		 9435 else
9436 {
9437 /* "double quoted" wild card expressions pass as is */
9438 /* From DCL that means using e.g.: */
9439 /* perl program """perl.*""" */
9440 item_len = strlen(item);
9441 if ( '"' == *item && '"' == item[item_len-1] )
9442 {
9443 item++;
9444 item[item_len-2] = '\0';
9445 add_item(head, tail, item, count);
9446 return;
9447 }
9448 }
a0d0e21e
LW		 9449 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9450 resultspec.dsc$b_class = DSC$K_CLASS_D;
9451 resultspec.dsc$a_pointer = NULL;
c11536f5 9452 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9453 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 9454 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
df278665 9455 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
a0d0e21e
LW		 9456 if (!isunix || !filespec.dsc$a_pointer)
9457 filespec.dsc$a_pointer = item;
9458 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9459 /*
9460 * Only return version specs, if the caller specified a version
9461 */
9462 had_version = strchr(item, ';');
9463 /*
94ae10c0 9464 * Only return device and directory specs, if the caller specified either.
a0d0e21e
LW		 9465 */
9466 had_device = strchr(item, ':');
9467 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9468
a480973c
JM		 9469 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9470 (&filespec, &resultspec, &context,
dca5a913 9471 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 9472 {
9473 char *string;
9474 char *c;
9475
c11536f5 9476 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
c5375c28 9477 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
db4c2905 9478 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
a0d0e21e 9479 if (NULL == had_version)
f7ddb74a 9480 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 9481 if ((!had_directory) && (had_device == NULL))
9482 {
9483 if (NULL == (devdir = strrchr(string, ']')))
9484 devdir = strrchr(string, '>');
db4c2905 9485 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
a0d0e21e
LW		 9486 }
9487 /*
9488 * Be consistent with what the C RTL has already done to the rest of
9489 * the argv items and lowercase all of these names.
9490 */
1d60dc3f 9491 if (!DECC_EFS_CASE_PRESERVE) {
f7ddb74a 9492 for (c = string; *c; ++c)
a0d0e21e 9493 if (isupper(*c))
30048647 9494 *c = toLOWER_L1(*c);
f7ddb74a 9495 }
f86702cc 9496 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 9497 add_item(head, tail, string, count);
9498 ++expcount;
a480973c 9499 }
367e4b85 9500 PerlMem_free(vmsspec);
c07a80fd 9501 if (sts != RMS$_NMF)
9502 {
9503 set_vaxc_errno(sts);
9504 switch (sts)
9505 {
f282b18d 9506 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9507 set_errno(ENOENT); break;
f282b18d
CB		 9508 case RMS$_DIR:
9509 set_errno(ENOTDIR); break;
c07a80fd 9510 case RMS$_DEV:
9511 set_errno(ENODEV); break;
f282b18d 9512 case RMS$_FNM: case RMS$_SYN:
c07a80fd 9513 set_errno(EINVAL); break;
9514 case RMS$_PRV:
9515 set_errno(EACCES); break;
9516 default:
b7ae7a0d 9517 _ckvmssts_noperl(sts);
c07a80fd 9518 }
9519 }
a0d0e21e
LW		 9520 if (expcount == 0)
9521 add_item(head, tail, item, count);
b7ae7a0d 9522 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9523 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 9524}
9525
a0d0e21e 9526
ff7adb52
CL		 9527static void
9528pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 9529{
ff7adb52 9530 PerlIO *fp;
218fdd94 9531 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 9532 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9533 int sts, j, l, ismcr, quote, tquote = 0;
9534
218fdd94
CL		 9535 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9536 vms_execfree(vmscmd);
ff7adb52
CL		 9537
9538 j = l = 0;
9539 p = subcmd;
9540 q = cmargv[0];
30048647
CB		 9541 ismcr = q && toUPPER_A(*q) == 'M' && toUPPER_A(*(q+1)) == 'C'
9542 && toUPPER_A(*(q+2)) == 'R' && !*(q+3);
ff7adb52
CL		 9543
9544 while (q && l < MAX_DCL_LINE_LENGTH) {
9545 if (!*q) {
9546 if (j > 0 && quote) {
9547 *p++ = '"';
9548 l++;
9549 }
9550 q = cmargv[++j];
9551 if (q) {
9552 if (ismcr && j > 1) quote = 1;
9553 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9554 *p++ = ' ';
9555 l++;
9556 if (quote || tquote) {
9557 *p++ = '"';
9558 l++;
9559 }
988c775c 9560 }
ff7adb52
CL		 9561 } else {
9562 if ((quote||tquote) && *q == '"') {
9563 *p++ = '"';
9564 l++;
988c775c 9565 }
ff7adb52
CL		 9566 *p++ = *q++;
9567 l++;
9568 }
9569 }
9570 *p = '\0';
a0d0e21e 9571
218fdd94 9572 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4e205ed6 9573 if (fp == NULL) {
ff7adb52 9574 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 9575 }
a0d0e21e
LW		 9576}
9577
ce12d4b7
CB		 9578static int
9579background_process(pTHX_ int argc, char **argv)
9580{
9581 char command[MAX_DCL_SYMBOL + 1] = "$";
9582 $DESCRIPTOR(value, "");
9583 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9584 static $DESCRIPTOR(null, "NLA0:");
9585 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9586 char pidstring[80];
9587 $DESCRIPTOR(pidstr, "");
9588 int pid;
9589 unsigned long int flags = 17, one = 1, retsts;
9590 int len;
a0d0e21e 9591
a35dcc95 9592 len = my_strlcat(command, argv[0], sizeof(command));
a480973c 9593 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e 9594 {
a35dcc95
CB		 9595 my_strlcat(command, " \"", sizeof(command));
9596 my_strlcat(command, *(++argv), sizeof(command));
9597 len = my_strlcat(command, "\"", sizeof(command));
a0d0e21e
LW		 9598 }
9599 value.dsc$a_pointer = command;
9600 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 9601 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 9602 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9603 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 9604 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 9605 }
9606 else {
b7ae7a0d 9607 _ckvmssts_noperl(retsts);
748a9306 9608 }
a0d0e21e 9609#ifdef ARGPROC_DEBUG
740ce14c 9610 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 9611#endif
9612 sprintf(pidstring, "%08X", pid);
740ce14c 9613 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 9614 pidstr.dsc$a_pointer = pidstring;
9615 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9616 lib$set_symbol(&pidsymbol, &pidstr);
9617 return(SS$_NORMAL);
9618}
9619/*}}}*/
9620/***** End of code taken from Mark Pizzolato's argproc.c package *****/
9621
84902520
TB		 9622
9623/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 9624/* Older VAXC header files lack these constants */
9625#ifndef JPI$_RIGHTS_SIZE
9626# define JPI$_RIGHTS_SIZE 817
9627#endif
9628#ifndef KGB$M_SUBSYSTEM
9629# define KGB$M_SUBSYSTEM 0x8
9630#endif
a480973c 9631
e0ef6b43
CB		 9632/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9633
84902520
TB		 9634/*{{{void vms_image_init(int *, char ***)*/
9635void
9636vms_image_init(int *argcp, char ***argvp)
9637{
b53f3677 9638 int status;
f675dbe5
CB		 9639 char eqv[LNM$C_NAMLENGTH+1] = "";
9640 unsigned int len, tabct = 8, tabidx = 0;
9641 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 9642 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9643 unsigned short int dummy, rlen;
f675dbe5 9644 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 9645#if defined(PERL_IMPLICIT_CONTEXT)
9646 pTHX = NULL;
9647#endif
61bb5906
CB		 9648 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9649 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9650 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9651 { 0, 0, 0, 0} };
84902520 9652
2e34cc90 9653#ifdef KILL_BY_SIGPRC
f7ddb74a 9654 Perl_csighandler_init();
2e34cc90
CL		 9655#endif
9656
fd8cd3a3
DS		 9657 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9658 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9659 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9660 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 9661 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 9662 will_taint = TRUE;
84902520
TB		 9663 break;
9664 }
9665 }
61bb5906 9666 /* Rights identifiers might trigger tainting as well. */
f675dbe5 9667 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 9668 while (rlen < rsz) {
9669 /* We didn't get all the identifiers on the first pass. Allocate a
9670 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9671 * were needed to hold all identifiers at time of last call; we'll
9672 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 9673 * If it gave us less than it wanted to despite ample buffer space,
9674 * something's broken. Is your system missing a system identifier?
61bb5906 9675 */
22d4bb9c
CB		 9676 if (rsz <= jpilist[1].buflen) {
9677 /* Perl_croak accvios when used this early in startup. */
9678 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9679 rsz, (unsigned long) jpilist[1].buflen,
9680 "Check your rights database for corruption.\n");
9681 exit(SS$_ABORT);
9682 }
e0ef6b43
CB		 9683 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9684 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9685 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9686 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9687 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9688 _ckvmssts_noperl(iosb[0]);
61bb5906 9689 }
c11536f5 9690 mask = (unsigned long int *)jpilist[1].bufadr;
61bb5906
CB		 9691 /* Check attribute flags for each identifier (2nd longword); protected
9692 * subsystem identifiers trigger tainting.
9693 */
9694 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9695 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9696 will_taint = TRUE;
61bb5906
CB		 9697 break;
9698 }
9699 }
367e4b85 9700 if (mask != rlst) PerlMem_free(mask);
61bb5906 9701 }
f7ddb74a
JM		 9702
9703 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9704 * logical, some versions of the CRTL will add a phanthom /000000/
9705 * directory. This needs to be removed.
9706 */
1d60dc3f 9707 if (DECC_FILENAME_UNIX_REPORT) {
ce12d4b7
CB		 9708 char * zeros;
9709 int ulen;
f7ddb74a
JM		 9710 ulen = strlen(argvp[0][0]);
9711 if (ulen > 7) {
9712 zeros = strstr(argvp[0][0], "/000000/");
9713 if (zeros != NULL) {
9714 int mlen;
9715 mlen = ulen - (zeros - argvp[0][0]) - 7;
9716 memmove(zeros, &zeros[7], mlen);
9717 ulen = ulen - 7;
9718 argvp[0][0][ulen] = '\0';
9719 }
9720 }
9721 /* It also may have a trailing dot that needs to be removed otherwise
9722 * it will be converted to VMS mode incorrectly.
9723 */
9724 ulen--;
1d60dc3f 9725 if ((argvp[0][0][ulen] == '.') && (DECC_READDIR_DROPDOTNOTYPE))
f7ddb74a
JM		 9726 argvp[0][0][ulen] = '\0';
9727 }
9728
61bb5906 9729 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9730 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9731 * hasn't been allocated when vms_image_init() is called.
9732 */
f675dbe5 9733 if (will_taint) {
ec618cdf
CB		 9734 char **newargv, **oldargv;
9735 oldargv = *argvp;
e0ef6b43 9736 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9737 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9738 newargv[0] = oldargv[0];
c11536f5 9739 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
c5375c28 9740 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9741 strcpy(newargv[1], "-T");
9742 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9743 (*argcp)++;
9744 newargv[*argcp] = NULL;
61bb5906
CB		 9745 /* We orphan the old argv, since we don't know where it's come from,
9746 * so we don't know how to free it.
9747 */
ec618cdf 9748 *argvp = newargv;
61bb5906 9749 }
f675dbe5
CB		 9750 else { /* Did user explicitly request tainting? */
9751 int i;
9752 char *cp, **av = *argvp;
9753 for (i = 1; i < *argcp; i++) {
9754 if (*av[i] != '-') break;
9755 for (cp = av[i]+1; *cp; cp++) {
9756 if (*cp == 'T') { will_taint = 1; break; }
9757 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9758 strchr("DFIiMmx",*cp)) break;
9759 }
9760 if (will_taint) break;
9761 }
9762 }
9763
9764 for (tabidx = 0;
9765 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9766 tabidx++) {
c5375c28
JM		 9767 if (!tabidx) {
9768 tabvec = (struct dsc$descriptor_s **)
9769 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9770 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9771 }
f675dbe5
CB		 9772 else if (tabidx >= tabct) {
9773 tabct += 8;
e0ef6b43 9774 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9775 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9776 }
e0ef6b43 9777 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9778 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
88e3936f 9779 tabvec[tabidx]->dsc$w_length = len;
f675dbe5 9780 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
88e3936f 9781 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
4f119521 9782 tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
88e3936f
CB		 9783 if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9784 my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
f675dbe5
CB		 9785 }
9786 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9787
84902520 9788 getredirection(argcp,argvp);
3bc25146
CB		 9789#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9790 {
9791# include <reentrancy.h>
f7ddb74a 9792 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9793 }
9794#endif
84902520
TB		 9795 return;
9796}
9797/*}}}*/
9798
9799
a0d0e21e
LW		 9800/* trim_unixpath()
9801 * Trim Unix-style prefix off filespec, so it looks like what a shell
9802 * glob expansion would return (i.e. from specified prefix on, not
9803 * full path). Note that returned filespec is Unix-style, regardless
9804 * of whether input filespec was VMS-style or Unix-style.
9805 *
a3e9d8c9 9806 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9807 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9808 * vector of options; at present, only bit 0 is used, and if set tells
9809 * trim unixpath to try the current default directory as a prefix when
9810 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9811 *
9812 * Returns !=0 on success, with trimmed filespec replacing contents of
9813 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9814 */
f86702cc 9815/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9816int
2fbb330f 9817Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9818{
c11536f5 9819 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
eb578fdb 9820 int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9821
a3e9d8c9 9822 if (!wildspec || !fspec) return 0;
ebd4d70b 9823
c11536f5 9824 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9825 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9826 tplate = unixwild;
a3e9d8c9 9827 if (strpbrk(wildspec,"]>:") != NULL) {
0e5ce2c7 9828 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
367e4b85 9829 PerlMem_free(unixwild);
a480973c
JM		 9830 return 0;
9831 }
a3e9d8c9 9832 }
2fbb330f 9833 else {
a35dcc95 9834 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
2fbb330f 9835 }
c11536f5 9836 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9837 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e 9838 if (strpbrk(fspec,"]>:") != NULL) {
0e5ce2c7 9839 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
367e4b85
JM		 9840 PerlMem_free(unixwild);
9841 PerlMem_free(unixified);
a480973c
JM		 9842 return 0;
9843 }
a0d0e21e 9844 else base = unixified;
a3e9d8c9 9845 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9846 * check to see that final result fits into (isn't longer than) fspec */
9847 reslen = strlen(fspec);
a0d0e21e
LW		 9848 }
9849 else base = fspec;
a3e9d8c9 9850
9851 /* No prefix or absolute path on wildcard, so nothing to remove */
c11536f5 9852 if (!*tplate || *tplate == '/') {
367e4b85 9853 PerlMem_free(unixwild);
a480973c 9854 if (base == fspec) {
367e4b85 9855 PerlMem_free(unixified);
a480973c
JM		 9856 return 1;
9857 }
a3e9d8c9 9858 tmplen = strlen(unixified);
a480973c 9859 if (tmplen > reslen) {
367e4b85 9860 PerlMem_free(unixified);
a480973c
JM		 9861 return 0; /* not enough space */
9862 }
a3e9d8c9 9863 /* Copy unixified resultant, including trailing NUL */
9864 memmove(fspec,unixified,tmplen+1);
367e4b85 9865 PerlMem_free(unixified);
a3e9d8c9 9866 return 1;
9867 }
a0d0e21e 9868
f86702cc 9869 for (end = base; *end; end++) ; /* Find end of resultant filespec */
c11536f5
CB		 9870 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9871 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
f86702cc 9872 for (cp1 = end ;cp1 >= base; cp1--)
9873 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9874 { cp1++; break; }
9875 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9876 PerlMem_free(unixified);
9877 PerlMem_free(unixwild);
a3e9d8c9 9878 return 1;
9879 }
f86702cc 9880 else {
a480973c 9881 char *tpl, *lcres;
f86702cc 9882 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9883 int ells = 1, totells, segdirs, match;
a480973c 9884 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9885 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9886
9887 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9888 totells = ells;
9889 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
c11536f5 9890 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9891 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9892 if (ellipsis == tplate && opts & 1) {
f86702cc 9893 /* Template begins with an ellipsis. Since we can't tell how many
9894 * directory names at the front of the resultant to keep for an
9895 * arbitrary starting point, we arbitrarily choose the current
9896 * default directory as a starting point. If it's there as a prefix,
9897 * clip it off. If not, fall through and act as if the leading
9898 * ellipsis weren't there (i.e. return shortest possible path that
9899 * could match template).
9900 */
a480973c 9901 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9902 PerlMem_free(tpl);
9903 PerlMem_free(unixified);
9904 PerlMem_free(unixwild);
a480973c
JM		 9905 return 0;
9906 }
1d60dc3f 9907 if (!DECC_EFS_CASE_PRESERVE) {
f7ddb74a 9908 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
30048647 9909 if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
f7ddb74a 9910 }
f86702cc 9911 segdirs = dirs - totells; /* Min # of dirs we must have left */
9912 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9913 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9914 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9915 PerlMem_free(tpl);
9916 PerlMem_free(unixified);
9917 PerlMem_free(unixwild);
f86702cc 9918 return 1;
a3e9d8c9 9919 }
a3e9d8c9 9920 }
f86702cc 9921 /* First off, back up over constant elements at end of path */
9922 if (dirs) {
9923 for (front = end ; front >= base; front--)
9924 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9925 }
c11536f5 9926 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9927 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9928 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
a480973c 9929 cp1++,cp2++) {
1d60dc3f 9930 if (!DECC_EFS_CASE_PRESERVE) {
30048647 9931 *cp2 = toLOWER_L1(*cp1); /* Make lc copy for match */
a480973c
JM		 9932 }
9933 else {
9934 *cp2 = *cp1;
9935 }
9936 }
9937 if (cp1 != '\0') {
367e4b85
JM		 9938 PerlMem_free(tpl);
9939 PerlMem_free(unixified);
9940 PerlMem_free(unixwild);
c5375c28 9941 PerlMem_free(lcres);
a480973c 9942 return 0; /* Path too long. */
f7ddb74a 9943 }
f86702cc 9944 lcend = cp2;
9945 *cp2 = '\0'; /* Pick up with memcpy later */
9946 lcfront = lcres + (front - base);
9947 /* Now skip over each ellipsis and try to match the path in front of it. */
9948 while (ells--) {
c11536f5 9949 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
f86702cc 9950 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9951 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
c11536f5 9952 if (cp1 < tplate) break; /* template started with an ellipsis */
f86702cc 9953 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9954 ellipsis = cp1; continue;
9955 }
a480973c 9956 wilddsc.dsc$a_pointer = tpl;
f86702cc 9957 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9958 nextell = cp1;
9959 for (segdirs = 0, cp2 = tpl;
a480973c 9960 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9961 cp1++, cp2++) {
9962 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a 9963 else {
1d60dc3f 9964 if (!DECC_EFS_CASE_PRESERVE) {
30048647 9965 *cp2 = toLOWER_L1(*cp1); /* else lowercase for match */
f7ddb74a
JM		 9966 }
9967 else {
9968 *cp2 = *cp1; /* else preserve case for match */
9969 }
9970 }
f86702cc 9971 if (*cp2 == '/') segdirs++;
9972 }
a480973c 9973 if (cp1 != ellipsis - 1) {
367e4b85
JM		 9974 PerlMem_free(tpl);
9975 PerlMem_free(unixified);
9976 PerlMem_free(unixwild);
9977 PerlMem_free(lcres);
a480973c
JM		 9978 return 0; /* Path too long */
9979 }
f86702cc 9980 /* Back up at least as many dirs as in template before matching */
9981 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9982 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9983 for (match = 0; cp1 > lcres;) {
9984 resdsc.dsc$a_pointer = cp1;
9985 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9986 match++;
9987 if (match == 1) lcfront = cp1;
9988 }
9989 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9990 }
a480973c 9991 if (!match) {
367e4b85
JM		 9992 PerlMem_free(tpl);
9993 PerlMem_free(unixified);
9994 PerlMem_free(unixwild);
9995 PerlMem_free(lcres);
a480973c
JM		 9996 return 0; /* Can't find prefix ??? */
9997 }
f86702cc 9998 if (match > 1 && opts & 1) {
9999 /* This ... wildcard could cover more than one set of dirs (i.e.
10000 * a set of similar dir names is repeated). If the template
10001 * contains more than 1 ..., upstream elements could resolve the
10002 * ambiguity, but it's not worth a full backtracking setup here.
10003 * As a quick heuristic, clip off the current default directory
10004 * if it's present to find the trimmed spec, else use the
10005 * shortest string that this ... could cover.
10006 */
10007 char def[NAM$C_MAXRSS+1], *st;
10008
a480973c 10009 if (getcwd(def, sizeof def,0) == NULL) {
827f156d
JM		 10010 PerlMem_free(unixified);
10011 PerlMem_free(unixwild);
10012 PerlMem_free(lcres);
10013 PerlMem_free(tpl);
a480973c
JM		 10014 return 0;
10015 }
1d60dc3f 10016 if (!DECC_EFS_CASE_PRESERVE) {
f7ddb74a 10017 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
30048647 10018 if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
f7ddb74a 10019 }
f86702cc 10020 segdirs = dirs - totells; /* Min # of dirs we must have left */
10021 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10022 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 10023 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 10024 PerlMem_free(tpl);
10025 PerlMem_free(unixified);
10026 PerlMem_free(unixwild);
10027 PerlMem_free(lcres);
f86702cc 10028 return 1;
10029 }
10030 /* Nope -- stick with lcfront from above and keep going. */
10031 }
10032 }
18a3d61e 10033 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 10034 PerlMem_free(tpl);
10035 PerlMem_free(unixified);
10036 PerlMem_free(unixwild);
10037 PerlMem_free(lcres);
a3e9d8c9 10038 return 1;
a0d0e21e 10039 }
a0d0e21e
LW		 10040
10041} /* end of trim_unixpath() */
10042/*}}}*/
10043
a0d0e21e
LW		 10044
10045/*
10046 * VMS readdir() routines.
10047 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 10048 *
bd3fa61c 10049 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 10050 * Minor modifications to original routines.
10051 */
10052
a9852f7c
CB		 10053/* readdir may have been redefined by reentr.h, so make sure we get
10054 * the local version for what we do here.
10055 */
10056#ifdef readdir
10057# undef readdir
10058#endif
10059#if !defined(PERL_IMPLICIT_CONTEXT)
10060# define readdir Perl_readdir
10061#else
10062# define readdir(a) Perl_readdir(aTHX_ a)
10063#endif
10064
a0d0e21e
LW		 10065 /* Number of elements in vms_versions array */
10066#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10067
10068/*
10069 * Open a directory, return a handle for later use.
10070 */
10071/*{{{ DIR *opendir(char*name) */
ddcbaa1c 10072DIR *
b8ffc8df 10073Perl_opendir(pTHX_ const char *name)
a0d0e21e 10074{
ddcbaa1c 10075 DIR *dd;
657054d4 10076 char *dir;
61bb5906 10077 Stat_t sb;
657054d4
JM		 10078
10079 Newx(dir, VMS_MAXRSS, char);
4846f1d7 10080 if (int_tovmspath(name, dir, NULL) == NULL) {
657054d4 10081 Safefree(dir);
61bb5906 10082 return NULL;
a0d0e21e 10083 }
ada67d10
CB		 10084 /* Check access before stat; otherwise stat does not
10085 * accurately report whether it's a directory.
10086 */
0f669c9d
CB		 10087 if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10088 && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 10089 /* cando_by_name has already set errno */
657054d4 10090 Safefree(dir);
ada67d10
CB		 10091 return NULL;
10092 }
61bb5906
CB		 10093 if (flex_stat(dir,&sb) == -1) return NULL;
10094 if (!S_ISDIR(sb.st_mode)) {
657054d4 10095 Safefree(dir);
61bb5906
CB		 10096 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10097 return NULL;
10098 }
61bb5906 10099 /* Get memory for the handle, and the pattern. */
ddcbaa1c 10100 Newx(dd,1,DIR);
a02a5408 10101 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 10102
10103 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 10104 sprintf(dd->pattern, "%s*.*",dir);
657054d4 10105 Safefree(dir);
a0d0e21e
LW		 10106 dd->context = 0;
10107 dd->count = 0;
657054d4 10108 dd->flags = 0;
6d53ee29
CB		 10109 /* By saying we want the result of readdir() in unix format, we are really
10110 * saying we want all the escapes removed, translating characters that
10111 * must be escaped in a VMS-format name to their unescaped form, which is
10112 * presumably allowed in a Unix-format name.
a096370a 10113 */
1d60dc3f 10114 dd->flags = DECC_FILENAME_UNIX_REPORT ? PERL_VMSDIR_M_UNIXSPECS : 0;
a0d0e21e
LW		 10115 dd->pat.dsc$a_pointer = dd->pattern;
10116 dd->pat.dsc$w_length = strlen(dd->pattern);
10117 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10118 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 10119#if defined(USE_ITHREADS)
a02a5408 10120 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 10121 MUTEX_INIT( (perl_mutex *) dd->mutex );
10122#else
10123 dd->mutex = NULL;
10124#endif
a0d0e21e
LW		 10125
10126 return dd;
10127} /* end of opendir() */
10128/*}}}*/
10129
10130/*
10131 * Set the flag to indicate we want versions or not.
10132 */
10133/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10134void
ddcbaa1c 10135vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 10136{
657054d4
JM		 10137 if (flag)
10138 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10139 else
10140 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 10141}
10142/*}}}*/
10143
10144/*
10145 * Free up an opened directory.
10146 */
10147/*{{{ void closedir(DIR *dd)*/
10148void
ddcbaa1c 10149Perl_closedir(DIR *dd)
a0d0e21e 10150{
f7ddb74a
JM		 10151 int sts;
10152
10153 sts = lib$find_file_end(&dd->context);
a0d0e21e 10154 Safefree(dd->pattern);
3bc25146 10155#if defined(USE_ITHREADS)
a9852f7c
CB		 10156 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10157 Safefree(dd->mutex);
10158#endif
f7ddb74a 10159 Safefree(dd);
a0d0e21e
LW		 10160}
10161/*}}}*/
10162
10163/*
10164 * Collect all the version numbers for the current file.
10165 */
10166static void
ddcbaa1c 10167collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 10168{
10169 struct dsc$descriptor_s pat;
10170 struct dsc$descriptor_s res;
ddcbaa1c 10171 struct dirent *e;
657054d4 10172 char *p, *text, *buff;
a0d0e21e
LW		 10173 int i;
10174 unsigned long context, tmpsts;
10175
10176 /* Convenient shorthand. */
10177 e = &dd->entry;
10178
10179 /* Add the version wildcard, ignoring the "*.*" put on before */
10180 i = strlen(dd->pattern);
a02a5408 10181 Newx(text,i + e->d_namlen + 3,char);
a35dcc95 10182 my_strlcpy(text, dd->pattern, i + 1);
f7ddb74a 10183 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 10184
10185 /* Set up the pattern descriptor. */
10186 pat.dsc$a_pointer = text;
10187 pat.dsc$w_length = i + e->d_namlen - 1;
10188 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10189 pat.dsc$b_class = DSC$K_CLASS_S;
10190
10191 /* Set up result descriptor. */
657054d4 10192 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10193 res.dsc$a_pointer = buff;
657054d4 10194 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10195 res.dsc$b_dtype = DSC$K_DTYPE_T;
10196 res.dsc$b_class = DSC$K_CLASS_S;
10197
10198 /* Read files, collecting versions. */
10199 for (context = 0, e->vms_verscount = 0;
10200 e->vms_verscount < VERSIZE(e);
10201 e->vms_verscount++) {
657054d4
JM		 10202 unsigned long rsts;
10203 unsigned long flags = 0;
10204
10205#ifdef VMS_LONGNAME_SUPPORT
988c775c 10206 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10207#endif
10208 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 10209 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 10210 _ckvmssts(tmpsts);
657054d4 10211 buff[VMS_MAXRSS - 1] = '\0';
748a9306 10212 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 10213 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10214 else
10215 e->vms_versions[e->vms_verscount] = -1;
10216 }
10217
748a9306 10218 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 10219 Safefree(text);
657054d4 10220 Safefree(buff);
a0d0e21e
LW		 10221
10222} /* end of collectversions() */
10223
10224/*
10225 * Read the next entry from the directory.
10226 */
10227/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 10228struct dirent *
10229Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 10230{
10231 struct dsc$descriptor_s res;
657054d4 10232 char *p, *buff;
a0d0e21e 10233 unsigned long int tmpsts;
657054d4
JM		 10234 unsigned long rsts;
10235 unsigned long flags = 0;
dca5a913 10236 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 10237 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 10238
10239 /* Set up result descriptor, and get next file. */
657054d4 10240 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10241 res.dsc$a_pointer = buff;
657054d4 10242 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10243 res.dsc$b_dtype = DSC$K_DTYPE_T;
10244 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 10245
10246#ifdef VMS_LONGNAME_SUPPORT
988c775c 10247 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10248#endif
10249
10250 tmpsts = lib$find_file
10251 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
66facaa3
CB		 10252 if (dd->context == 0)
10253 tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
10254
4633a7c4 10255 if (!(tmpsts & 1)) {
4633a7c4 10256 switch (tmpsts) {
66facaa3
CB		 10257 case RMS$_NMF:
10258 break; /* no more files considered success */
4633a7c4 10259 case RMS$_PRV:
66facaa3 10260 SETERRNO(EACCES, tmpsts); break;
4633a7c4 10261 case RMS$_DEV:
66facaa3 10262 SETERRNO(ENODEV, tmpsts); break;
4633a7c4 10263 case RMS$_DIR:
66facaa3 10264 SETERRNO(ENOTDIR, tmpsts); break;
f282b18d 10265 case RMS$_FNF: case RMS$_DNF:
66facaa3 10266 SETERRNO(ENOENT, tmpsts); break;
4633a7c4 10267 default:
66facaa3 10268 SETERRNO(EVMSERR, tmpsts);
4633a7c4 10269 }
657054d4 10270 Safefree(buff);
4633a7c4
LW		 10271 return NULL;
10272 }
10273 dd->count++;
a0d0e21e 10274 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
c43a0d1c
CB		 10275 buff[res.dsc$w_length] = '\0';
10276 p = buff + res.dsc$w_length;
30048647 10277 while (--p >= buff) if (!isSPACE_L1(*p)) break;
c43a0d1c 10278 *p = '\0';
1d60dc3f 10279 if (!DECC_EFS_CASE_PRESERVE) {
30048647 10280 for (p = buff; *p; p++) *p = toLOWER_L1(*p);
f7ddb74a 10281 }
a0d0e21e
LW		 10282
10283 /* Skip any directory component and just copy the name. */
657054d4 10284 sts = vms_split_path
360732b5 10285 (buff,
657054d4
JM		 10286 &v_spec,
10287 &v_len,
10288 &r_spec,
10289 &r_len,
10290 &d_spec,
10291 &d_len,
10292 &n_spec,
10293 &n_len,
10294 &e_spec,
10295 &e_len,
10296 &vs_spec,
10297 &vs_len);
10298
0dddfaca
JM		 10299 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10300
10301 /* In Unix report mode, remove the ".dir;1" from the name */
10302 /* if it is a real directory. */
1d60dc3f 10303 if (DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
f785e3a1
JM		 10304 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10305 Stat_t statbuf;
10306 int ret_sts;
10307
10308 ret_sts = flex_lstat(buff, &statbuf);
10309 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10310 e_len = 0;
10311 e_spec[0] = 0;
0dddfaca
JM		 10312 }
10313 }
10314 }
10315
10316 /* Drop NULL extensions on UNIX file specification */
1d60dc3f 10317 if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
0dddfaca
JM		 10318 e_len = 0;
10319 e_spec[0] = '\0';
10320 }
dca5a913
JM		 10321 }
10322
a35dcc95 10323 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
657054d4 10324 dd->entry.d_name[n_len + e_len] = '\0';
a84b1d1f 10325 dd->entry.d_namlen = n_len + e_len;
a0d0e21e 10326
657054d4
JM		 10327 /* Convert the filename to UNIX format if needed */
10328 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10329
10330 /* Translate the encoded characters. */
38a44b82 10331 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 10332 if (strchr(dd->entry.d_name, '^') != NULL) {
10333 char new_name[256];
10334 char * q;
657054d4
JM		 10335 p = dd->entry.d_name;
10336 q = new_name;
10337 while (*p != 0) {
f617045b
CB		 10338 int inchars_read, outchars_added;
10339 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10340 p += inchars_read;
10341 q += outchars_added;
dca5a913 10342 /* fix-me */
f617045b 10343 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 10344 /* Wide file specifications need to be passed in Perl */
38a44b82 10345 /* counted strings apparently with a Unicode flag */
657054d4
JM		 10346 }
10347 *q = 0;
a35dcc95 10348 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
657054d4 10349 }
657054d4 10350 }
a0d0e21e 10351
a0d0e21e 10352 dd->entry.vms_verscount = 0;
657054d4
JM		 10353 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10354 Safefree(buff);
a0d0e21e
LW		 10355 return &dd->entry;
10356
10357} /* end of readdir() */
10358/*}}}*/
10359
10360/*
a9852f7c
CB		 10361 * Read the next entry from the directory -- thread-safe version.
10362 */
10363/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10364int
ddcbaa1c 10365Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 10366{
10367 int retval;
10368
10369 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10370
7ded3206 10371 entry = readdir(dd);
a9852f7c
CB		 10372 *result = entry;
10373 retval = ( *result == NULL ? errno : 0 );
10374
10375 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10376
10377 return retval;
10378
10379} /* end of readdir_r() */
10380/*}}}*/
10381
10382/*
a0d0e21e
LW		 10383 * Return something that can be used in a seekdir later.
10384 */
10385/*{{{ long telldir(DIR *dd)*/
10386long
ddcbaa1c 10387Perl_telldir(DIR *dd)
a0d0e21e
LW		 10388{
10389 return dd->count;
10390}
10391/*}}}*/
10392
10393/*
10394 * Return to a spot where we used to be. Brute force.
10395 */
10396/*{{{ void seekdir(DIR *dd,long count)*/
10397void
ddcbaa1c 10398Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 10399{
657054d4 10400 int old_flags;
a0d0e21e
LW		 10401
10402 /* If we haven't done anything yet... */
10403 if (dd->count == 0)
10404 return;
10405
10406 /* Remember some state, and clear it. */
657054d4
JM		 10407 old_flags = dd->flags;
10408 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 10409 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 10410 dd->context = 0;
10411
10412 /* The increment is in readdir(). */
10413 for (dd->count = 0; dd->count < count; )
f7ddb74a 10414 readdir(dd);
a0d0e21e 10415
657054d4 10416 dd->flags = old_flags;
a0d0e21e
LW		 10417
10418} /* end of seekdir() */
10419/*}}}*/
10420
10421/* VMS subprocess management
10422 *
10423 * my_vfork() - just a vfork(), after setting a flag to record that
10424 * the current script is trying a Unix-style fork/exec.
10425 *
10426 * vms_do_aexec() and vms_do_exec() are called in response to the
10427 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 10428 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 10429 * execvp (for those who really want to try this under VMS).
10430 * Otherwise, they do exactly what the perl docs say exec should
10431 * do - terminate the current script and invoke a new command
10432 * (See below for notes on command syntax.)
10433 *
10434 * do_aspawn() and do_spawn() implement the VMS side of the perl
10435 * 'system' function.
10436 *
10437 * Note on command arguments to perl 'exec' and 'system': When handled
10438 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 10439 * are concatenated to form a DCL command string. If the first non-numeric
10440 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 10441 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 10442 * the first token of the command is taken as the filespec of an image
10443 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 10444 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 10445 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 10446 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 10447 * but I hope it will form a happy medium between what VMS folks expect
10448 * from lib$spawn and what Unix folks expect from exec.
10449 */
10450
10451static int vfork_called;
10452
f7c699a0 10453/*{{{int my_vfork(void)*/
a0d0e21e 10454int
f7c699a0 10455my_vfork(void)
a0d0e21e 10456{
748a9306 10457 vfork_called++;
a0d0e21e
LW		 10458 return vfork();
10459}
10460/*}}}*/
10461
4633a7c4 10462
a0d0e21e 10463static void
218fdd94
CL		 10464vms_execfree(struct dsc$descriptor_s *vmscmd)
10465{
10466 if (vmscmd) {
10467 if (vmscmd->dsc$a_pointer) {
c5375c28 10468 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 10469 }
c5375c28 10470 PerlMem_free(vmscmd);
4633a7c4
LW		 10471 }
10472}
10473
10474static char *
fd8cd3a3 10475setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 10476{
282fc0b3 10477 char *junk, *tmps = NULL, *cmd;
eb578fdb 10478 size_t cmdlen = 0;
a0d0e21e 10479 size_t rlen;
eb578fdb 10480 SV **idx;
2d8e6c8d 10481 STRLEN n_a;
a0d0e21e
LW		 10482
10483 idx = mark;
4633a7c4
LW		 10484 if (really) {
10485 tmps = SvPV(really,rlen);
10486 if (*tmps) {
10487 cmdlen += rlen + 1;
10488 idx++;
10489 }
a0d0e21e
LW		 10490 }
10491
10492 for (idx++; idx <= sp; idx++) {
10493 if (*idx) {
10494 junk = SvPVx(*idx,rlen);
10495 cmdlen += rlen ? rlen + 1 : 0;
10496 }
10497 }
282fc0b3
Z		 10498 Newx(cmd, cmdlen+1, char);
10499 SAVEFREEPV(cmd);
a0d0e21e 10500
4633a7c4 10501 if (tmps && *tmps) {
282fc0b3 10502 my_strlcpy(cmd, tmps, cmdlen + 1);
a0d0e21e
LW		 10503 mark++;
10504 }
282fc0b3 10505 else *cmd = '\0';
a0d0e21e
LW		 10506 while (++mark <= sp) {
10507 if (*mark) {
3eeba6fb
CB		 10508 char *s = SvPVx(*mark,n_a);
10509 if (!*s) continue;
282fc0b3
Z		 10510 if (*cmd) my_strlcat(cmd, " ", cmdlen+1);
10511 my_strlcat(cmd, s, cmdlen+1);
a0d0e21e
LW		 10512 }
10513 }
282fc0b3 10514 return cmd;
a0d0e21e
LW		 10515
10516} /* end of setup_argstr() */
10517
4633a7c4 10518
a0d0e21e 10519static unsigned long int
2fbb330f 10520setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 10521 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 10522{
e919cd19
JM		 10523 char * vmsspec;
10524 char * resspec;
e886094b
JM		 10525 char image_name[NAM$C_MAXRSS+1];
10526 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 10527 $DESCRIPTOR(defdsc,".EXE");
8012a33e 10528 $DESCRIPTOR(defdsc2,".");
e919cd19 10529 struct dsc$descriptor_s resdsc;
218fdd94 10530 struct dsc$descriptor_s *vmscmd;
a0d0e21e 10531 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 10532 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
eb578fdb 10533 char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 10534 char * cmd;
10535 int cmdlen;
eb578fdb 10536 int isdcl;
a0d0e21e 10537
426fe37a 10538 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
ebd4d70b 10539 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 10540
e919cd19 10541 /* vmsspec is a DCL command buffer, not just a filename */
c11536f5 10542 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
e919cd19
JM		 10543 if (vmsspec == NULL)
10544 _ckvmssts_noperl(SS$_INSFMEM);
10545
c11536f5 10546 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
e919cd19
JM		 10547 if (resspec == NULL)
10548 _ckvmssts_noperl(SS$_INSFMEM);
10549
2fbb330f
JM		 10550 /* Make a copy for modification */
10551 cmdlen = strlen(incmd);
c11536f5 10552 cmd = (char *)PerlMem_malloc(cmdlen+1);
ebd4d70b 10553 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 10554 my_strlcpy(cmd, incmd, cmdlen + 1);
e886094b
JM		 10555 image_name[0] = 0;
10556 image_argv[0] = 0;
2fbb330f 10557
e919cd19
JM		 10558 resdsc.dsc$a_pointer = resspec;
10559 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10560 resdsc.dsc$b_class = DSC$K_CLASS_S;
10561 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10562
218fdd94
CL		 10563 vmscmd->dsc$a_pointer = NULL;
10564 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10565 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10566 vmscmd->dsc$w_length = 0;
10567 if (pvmscmd) *pvmscmd = vmscmd;
10568
ff7adb52
CL		 10569 if (suggest_quote) *suggest_quote = 0;
10570
2fbb330f 10571 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 10572 PerlMem_free(cmd);
e919cd19
JM		 10573 PerlMem_free(vmsspec);
10574 PerlMem_free(resspec);
a2669cfc 10575 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 10576 }
10577
a0d0e21e 10578 s = cmd;
2fbb330f 10579
30048647 10580 while (*s && isSPACE_L1(*s)) s++;
aa779de1
CB		 10581
10582 if (*s == '@' || *s == '$') {
10583 vmsspec[0] = *s; rest = s + 1;
30048647 10584 for (cp = &vmsspec[1]; *rest && isSPACE_L1(*rest); rest++,cp++) *cp = *rest;
aa779de1
CB		 10585 }
10586 else { cp = vmsspec; rest = s; }
22831cc5
CB		 10587
10588 /* If the first word is quoted, then we need to unquote it and
10589 * escape spaces within it. We'll expand into the resspec buffer,
10590 * then copy back into the cmd buffer, expanding the latter if
10591 * necessary.
10592 */
10593 if (*rest == '"') {
10594 char *cp2;
10595 char *r = rest;
10596 bool in_quote = 0;
10597 int clen = cmdlen;
10598 int soff = s - cmd;
10599
10600 for (cp2 = resspec;
10601 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10602 rest++) {
10603
10604 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10605 *cp2 = '^';
10606 *(++cp2) = '_';
10607 cp2++;
10608 clen++;
10609 }
10610 else if (*rest == '"') {
10611 clen--;
10612 if (in_quote) { /* Must be closing quote. */
10613 rest++;
10614 break;
10615 }
10616 in_quote = 1;
10617 }
10618 else {
10619 *cp2 = *rest;
10620 cp2++;
10621 }
10622 }
10623 *cp2 = '\0';
10624
10625 /* Expand the command buffer if necessary. */
10626 if (clen > cmdlen) {
223c162b 10627 cmd = (char *)PerlMem_realloc(cmd, clen);
22831cc5
CB		 10628 if (cmd == NULL)
10629 _ckvmssts_noperl(SS$_INSFMEM);
10630 /* Where we are may have changed, so recompute offsets */
10631 r = cmd + (r - s - soff);
10632 rest = cmd + (rest - s - soff);
10633 s = cmd + soff;
10634 }
10635
10636 /* Shift the non-verb portion of the command (if any) up or
10637 * down as necessary.
10638 */
10639 if (*rest)
10640 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10641
10642 /* Copy the unquoted and escaped command verb into place. */
10643 memcpy(r, resspec, cp2 - resspec);
10644 cmd[clen] = '\0';
10645 cmdlen = clen;
10646 rest = r; /* Rewind for subsequent operations. */
10647 }
10648
aa779de1
CB		 10649 if (*rest == '.' || *rest == '/') {
10650 char *cp2;
10651 for (cp2 = resspec;
30048647 10652 *rest && !isSPACE_L1(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
aa779de1
CB		 10653 rest++, cp2++) *cp2 = *rest;
10654 *cp2 = '\0';
df278665 10655 if (int_tovmsspec(resspec, cp, 0, NULL)) {
aa779de1 10656 s = vmsspec;
cfbf46cd
JM		 10657
10658 /* When a UNIX spec with no file type is translated to VMS, */
10659 /* A trailing '.' is appended under ODS-5 rules. */
10660 /* Here we do not want that trailing "." as it prevents */
10661 /* Looking for a implied ".exe" type. */
1d60dc3f 10662 if (DECC_EFS_CHARSET) {
cfbf46cd
JM		 10663 int i;
10664 i = strlen(vmsspec);
10665 if (vmsspec[i-1] == '.') {
10666 vmsspec[i-1] = '\0';
10667 }
10668 }
10669
aa779de1
CB		 10670 if (*rest) {
10671 for (cp2 = vmsspec + strlen(vmsspec);
e919cd19 10672 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
aa779de1
CB		 10673 rest++, cp2++) *cp2 = *rest;
10674 *cp2 = '\0';
a0d0e21e
LW		 10675 }
10676 }
10677 }
aa779de1
CB		 10678 /* Intuit whether verb (first word of cmd) is a DCL command:
10679 * - if first nonspace char is '@', it's a DCL indirection
10680 * otherwise
10681 * - if verb contains a filespec separator, it's not a DCL command
10682 * - if it doesn't, caller tells us whether to default to a DCL
10683 * command, or to a local image unless told it's DCL (by leading '$')
10684 */
ff7adb52
CL		 10685 if (*s == '@') {
10686 isdcl = 1;
10687 if (suggest_quote) *suggest_quote = 1;
10688 } else {
eb578fdb 10689 char *filespec = strpbrk(s,":<[.;");
aa779de1
CB		 10690 rest = wordbreak = strpbrk(s," \"\t/");
10691 if (!wordbreak) wordbreak = s + strlen(s);
10692 if (*s == '$') check_img = 0;
10693 if (filespec && (filespec < wordbreak)) isdcl = 0;
10694 else isdcl = !check_img;
10695 }
10696
3eeba6fb 10697 if (!isdcl) {
dca5a913 10698 int rsts;
aa779de1
CB		 10699 imgdsc.dsc$a_pointer = s;
10700 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 10701 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e 10702 if (!(retsts&1)) {
ebd4d70b 10703 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10704 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f 10705 if (!(retsts & 1) && *s == '$') {
ebd4d70b 10706 _ckvmssts_noperl(lib$find_file_end(&cxt));
2497a41f 10707 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 10708 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f 10709 if (!(retsts&1)) {
ebd4d70b 10710 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10711 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 10712 }
10713 }
aa779de1 10714 }
ebd4d70b 10715 _ckvmssts_noperl(lib$find_file_end(&cxt));
8012a33e 10716
aa779de1 10717 if (retsts & 1) {
8012a33e 10718 FILE *fp;
a0d0e21e 10719 s = resspec;
30048647 10720 while (*s && !isSPACE_L1(*s)) s++;
a0d0e21e 10721 *s = '\0';
8012a33e
CB		 10722
10723 /* check that it's really not DCL with no file extension */
e886094b 10724 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 10725 if (fp) {
2497a41f
JM		 10726 char b[256] = {0,0,0,0};
10727 read(fileno(fp), b, 256);
30048647 10728 isdcl = isPRINT_L1(b[0]) && isPRINT_L1(b[1]) && isPRINT_L1(b[2]) && isPRINT_L1(b[3]);
2497a41f 10729 if (isdcl) {
e886094b
JM		 10730 int shebang_len;
10731
2497a41f 10732 /* Check for script */
e886094b
JM		 10733 shebang_len = 0;
10734 if ((b[0] == '#') && (b[1] == '!'))
10735 shebang_len = 2;
10736#ifdef ALTERNATE_SHEBANG
10737 else {
a15aa957 10738 if (strEQ(b, ALTERNATE_SHEBANG)) {
e886094b
JM		 10739 char * perlstr;
10740 perlstr = strstr("perl",b);
10741 if (perlstr == NULL)
10742 shebang_len = 0;
a15aa957
KW		 10743 else
10744 shebang_len = strlen(ALTERNATE_SHEBANG);
e886094b
JM		 10745 }
10746 else
10747 shebang_len = 0;
10748 }
10749#endif
10750
10751 if (shebang_len > 0) {
10752 int i;
10753 int j;
10754 char tmpspec[NAM$C_MAXRSS + 1];
10755
10756 i = shebang_len;
10757 /* Image is following after white space */
10758 /*--------------------------------------*/
30048647 10759 while (isPRINT_L1(b[i]) && isSPACE_L1(b[i]))
e886094b
JM		 10760 i++;
10761
10762 j = 0;
30048647 10763 while (isPRINT_L1(b[i]) && !isSPACE_L1(b[i])) {
e886094b
JM		 10764 tmpspec[j++] = b[i++];
10765 if (j >= NAM$C_MAXRSS)
10766 break;
10767 }
10768 tmpspec[j] = '\0';
10769
10770 /* There may be some default parameters to the image */
10771 /*---------------------------------------------------*/
10772 j = 0;
30048647 10773 while (isPRINT_L1(b[i])) {
e886094b
JM		 10774 image_argv[j++] = b[i++];
10775 if (j >= NAM$C_MAXRSS)
10776 break;
10777 }
30048647 10778 while ((j > 0) && !isPRINT_L1(image_argv[j-1]))
e886094b
JM		 10779 j--;
10780 image_argv[j] = 0;
10781
2497a41f 10782 /* It will need to be converted to VMS format and validated */
e886094b
JM		 10783 if (tmpspec[0] != '\0') {
10784 char * iname;
10785
10786 /* Try to find the exact program requested to be run */
10787 /*---------------------------------------------------*/
6fb6c614
JM		 10788 iname = int_rmsexpand
10789 (tmpspec, image_name, ".exe",
360732b5 10790 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10791 if (iname != NULL) {
a1887106
JM		 10792 if (cando_by_name_int
10793 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10794 /* MCR prefix needed */
10795 isdcl = 0;
10796 }
10797 else {
10798 /* Try again with a null type */
10799 /*----------------------------*/
6fb6c614
JM		 10800 iname = int_rmsexpand
10801 (tmpspec, image_name, ".",
360732b5 10802 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10803 if (iname != NULL) {
a1887106
JM		 10804 if (cando_by_name_int
10805 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10806 /* MCR prefix needed */
10807 isdcl = 0;
10808 }
10809 }
10810 }
10811
10812 /* Did we find the image to run the script? */
10813 /*------------------------------------------*/
10814 if (isdcl) {
10815 char *tchr;
10816
10817 /* Assume DCL or foreign command exists */
10818 /*--------------------------------------*/
10819 tchr = strrchr(tmpspec, '/');
10820 if (tchr != NULL) {
10821 tchr++;
10822 }
10823 else {
10824 tchr = tmpspec;
10825 }
a35dcc95 10826 my_strlcpy(image_name, tchr, sizeof(image_name));
e886094b
JM		 10827 }
10828 }
10829 }
2497a41f
JM		 10830 }
10831 }
8012a33e
CB		 10832 fclose(fp);
10833 }
e919cd19
JM		 10834 if (check_img && isdcl) {
10835 PerlMem_free(cmd);
10836 PerlMem_free(resspec);
10837 PerlMem_free(vmsspec);
10838 return RMS$_FNF;
10839 }
8012a33e 10840
3eeba6fb 10841 if (cando_by_name(S_IXUSR,0,resspec)) {
c11536f5 10842 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
ebd4d70b 10843 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012a33e 10844 if (!isdcl) {
a35dcc95 10845 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
e886094b 10846 if (image_name[0] != 0) {
a35dcc95
CB		 10847 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10848 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10849 }
10850 } else if (image_name[0] != 0) {
a35dcc95
CB		 10851 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10852 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
8012a33e 10853 } else {
a35dcc95 10854 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
8012a33e 10855 }
e886094b
JM		 10856 if (suggest_quote) *suggest_quote = 1;
10857
10858 /* If there is an image name, use original command */
10859 if (image_name[0] == 0)
a35dcc95 10860 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10861 else {
10862 rest = cmd;
30048647 10863 while (*rest && isSPACE_L1(*rest)) rest++;
e886094b
JM		 10864 }
10865
10866 if (image_argv[0] != 0) {
a35dcc95
CB		 10867 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10868 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10869 }
10870 if (rest) {
10871 int rest_len;
10872 int vmscmd_len;
10873
10874 rest_len = strlen(rest);
10875 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10876 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
a35dcc95 10877 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10878 else
10879 retsts = CLI$_BUFOVF;
10880 }
218fdd94 10881 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10882 PerlMem_free(cmd);
e919cd19
JM		 10883 PerlMem_free(vmsspec);
10884 PerlMem_free(resspec);
218fdd94 10885 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10886 }
c5375c28
JM		 10887 else
10888 retsts = RMS$_PRV;
a0d0e21e
LW		 10889 }
10890 }
3eeba6fb 10891 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10892 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10893
c11536f5 10894 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
a35dcc95 10895 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
c5375c28
JM		 10896
10897 PerlMem_free(cmd);
e919cd19
JM		 10898 PerlMem_free(resspec);
10899 PerlMem_free(vmsspec);
2fbb330f 10900
ff7adb52
CL		 10901 /* check if it's a symbol (for quoting purposes) */
10902 if (suggest_quote && !*suggest_quote) {
10903 int iss;
10904 char equiv[LNM$C_NAMLENGTH];
10905 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10906 eqvdsc.dsc$a_pointer = equiv;
10907
218fdd94 10908 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10909 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10910 }
3eeba6fb
CB		 10911 if (!(retsts & 1)) {
10912 /* just hand off status values likely to be due to user error */
10913 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10914 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10915 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
ebd4d70b 10916 else { _ckvmssts_noperl(retsts); }
3eeba6fb 10917 }
a0d0e21e 10918
218fdd94 10919 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10920
a0d0e21e
LW		 10921} /* end of setup_cmddsc() */
10922
a3e9d8c9 10923
a0d0e21e
LW		 10924/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10925bool
fd8cd3a3 10926Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10927{
ce12d4b7
CB		 10928 bool exec_sts;
10929 char * cmd;
c5375c28 10930
61a08f7e
DIM		 10931 if (vfork_called) { /* this follows a vfork - act Unixish */
10932 vfork_called--;
10933 if (vfork_called < 0) {
10934 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10935 vfork_called = 0;
a0d0e21e 10936 }
61a08f7e
DIM		 10937 else return do_aexec(really,mark,sp);
10938 }
4633a7c4 10939 /* no vfork - act VMSish */
61a08f7e 10940 if (sp > mark) {
282fc0b3 10941 ENTER;
c5375c28
JM		 10942 cmd = setup_argstr(aTHX_ really,mark,sp);
10943 exec_sts = vms_do_exec(cmd);
282fc0b3 10944 LEAVE;
c5375c28 10945 return exec_sts;
a0d0e21e
LW		 10946 }
10947
734a2a8a 10948 SETERRNO(ENOENT, RMS_FNF);
a0d0e21e
LW		 10949 return FALSE;
10950} /* end of vms_do_aexec() */
10951/*}}}*/
10952
10953/* {{{bool vms_do_exec(char *cmd) */
10954bool
2fbb330f 10955Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10956{
218fdd94 10957 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10958
10959 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10960 vfork_called--;
10961 if (vfork_called < 0) {
5c84aa53 10962 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10963 vfork_called = 0;
10964 }
10965 else return do_exec(cmd);
a0d0e21e 10966 }
748a9306
LW		 10967
10968 { /* no vfork - act VMSish */
748a9306 10969 unsigned long int retsts;
a0d0e21e 10970
1e422769 10971 TAINT_ENV();
10972 TAINT_PROPER("exec");
218fdd94
CL		 10973 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10974 retsts = lib$do_command(vmscmd);
a0d0e21e 10975
09b7f37c 10976 switch (retsts) {
f282b18d 10977 case RMS$_FNF: case RMS$_DNF:
09b7f37c 10978 set_errno(ENOENT); break;
f282b18d 10979 case RMS$_DIR:
09b7f37c 10980 set_errno(ENOTDIR); break;
f282b18d
CB		 10981 case RMS$_DEV:
10982 set_errno(ENODEV); break;
09b7f37c
CB		 10983 case RMS$_PRV:
10984 set_errno(EACCES); break;
10985 case RMS$_SYN:
10986 set_errno(EINVAL); break;
a2669cfc 10987 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 10988 set_errno(E2BIG); break;
10989 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 10990 _ckvmssts_noperl(retsts); /* fall through */
09b7f37c
CB		 10991 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10992 set_errno(EVMSERR);
10993 }
748a9306 10994 set_vaxc_errno(retsts);
3eeba6fb 10995 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10996 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 10997 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 10998 }
218fdd94 10999 vms_execfree(vmscmd);
a0d0e21e
LW		 11000 }
11001
11002 return FALSE;
11003
11004} /* end of vms_do_exec() */
11005/*}}}*/
11006
9ec7171b 11007int do_spawn2(pTHX_ const char *, int);
a0d0e21e 11008
9ec7171b
CB		 11009int
11010Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
a0d0e21e 11011{
ce12d4b7
CB		 11012 unsigned long int sts;
11013 char * cmd;
11014 int flags = 0;
a0d0e21e 11015
c5375c28 11016 if (sp > mark) {
eed5d6a1
CB		 11017
11018 /* We'll copy the (undocumented?) Win32 behavior and allow a
11019 * numeric first argument. But the only value we'll support
11020 * through do_aspawn is a value of 1, which means spawn without
11021 * waiting for completion -- other values are ignored.
11022 */
9ec7171b 11023 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
eed5d6a1 11024 ++mark;
9ec7171b 11025 flags = SvIVx(*mark);
eed5d6a1
CB		 11026 }
11027
11028 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11029 flags = CLI$M_NOWAIT;
11030 else
11031 flags = 0;
11032
282fc0b3 11033 ENTER;
9ec7171b 11034 cmd = setup_argstr(aTHX_ really, mark, sp);
eed5d6a1 11035 sts = do_spawn2(aTHX_ cmd, flags);
282fc0b3 11036 LEAVE;
c5375c28
JM		 11037 /* pp_sys will clean up cmd */
11038 return sts;
11039 }
a0d0e21e
LW		 11040 return SS$_ABORT;
11041} /* end of do_aspawn() */
11042/*}}}*/
11043
eed5d6a1 11044
9ec7171b
CB		 11045/* {{{int do_spawn(char* cmd) */
11046int
11047Perl_do_spawn(pTHX_ char* cmd)
a0d0e21e 11048{
7918f24d
NC		 11049 PERL_ARGS_ASSERT_DO_SPAWN;
11050
eed5d6a1
CB		 11051 return do_spawn2(aTHX_ cmd, 0);
11052}
11053/*}}}*/
11054
9ec7171b
CB		 11055/* {{{int do_spawn_nowait(char* cmd) */
11056int
11057Perl_do_spawn_nowait(pTHX_ char* cmd)
11058{
11059 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11060
11061 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11062}
11063/*}}}*/
11064
11065/* {{{int do_spawn2(char *cmd) */
11066int
eed5d6a1
CB		 11067do_spawn2(pTHX_ const char *cmd, int flags)
11068{
209030df 11069 unsigned long int sts, substs;
a0d0e21e 11070
1e422769 11071 TAINT_ENV();
11072 TAINT_PROPER("spawn");
748a9306 11073 if (!cmd || !*cmd) {
eed5d6a1 11074 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 11075 if (!(sts & 1)) {
11076 switch (sts) {
209030df
JH		 11077 case RMS$_FNF: case RMS$_DNF:
11078 set_errno(ENOENT); break;
11079 case RMS$_DIR:
11080 set_errno(ENOTDIR); break;
11081 case RMS$_DEV:
11082 set_errno(ENODEV); break;
11083 case RMS$_PRV:
11084 set_errno(EACCES); break;
11085 case RMS$_SYN:
11086 set_errno(EINVAL); break;
11087 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11088 set_errno(E2BIG); break;
11089 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 11090 _ckvmssts_noperl(sts); /* fall through */
209030df
JH		 11091 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11092 set_errno(EVMSERR);
c8795d8b
JH		 11093 }
11094 set_vaxc_errno(sts);
11095 if (ckWARN(WARN_EXEC)) {
f98bc0c6 11096 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 11097 Strerror(errno));
11098 }
09b7f37c 11099 }
c8795d8b 11100 sts = substs;
48023aa8
CL		 11101 }
11102 else {
eed5d6a1 11103 char mode[3];
2fbb330f 11104 PerlIO * fp;
eed5d6a1
CB		 11105 if (flags & CLI$M_NOWAIT)
11106 strcpy(mode, "n");
11107 else
11108 strcpy(mode, "nW");
11109
11110 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 11111 if (fp != NULL)
11112 my_pclose(fp);
7d78c51a
CB		 11113 /* sts will be the pid in the nowait case, so leave a
11114 * hint saying not to do any bit shifting to it.
11115 */
11116 if (flags & CLI$M_NOWAIT)
11117 PL_statusvalue = -1;
48023aa8 11118 }
48023aa8 11119 return sts;
eed5d6a1 11120} /* end of do_spawn2() */
a0d0e21e
LW		 11121/*}}}*/
11122
bc10a425
CB		 11123
11124static unsigned int *sockflags, sockflagsize;
11125
11126/*
11127 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11128 * routines found in some versions of the CRTL can't deal with sockets.
11129 * We don't shim the other file open routines since a socket isn't
11130 * likely to be opened by a name.
11131 */
275feba9 11132/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
ce12d4b7
CB		 11133FILE *
11134my_fdopen(int fd, const char *mode)
bc10a425 11135{
f7ddb74a 11136 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 11137
11138 if (fp) {
11139 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 11140 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 11141 if (!sockflagsize || fdoff > sockflagsize) {
11142 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 11143 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 11144 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11145 sockflagsize = fdoff + 2;
11146 }
312ac60b 11147 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 11148 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11149 }
11150 return fp;
11151
11152}
11153/*}}}*/
11154
11155
11156/*
11157 * Clear the corresponding bit when the (possibly) socket stream is closed.
11158 * There still a small hole: we miss an implicit close which might occur
11159 * via freopen(). >> Todo
11160 */
11161/*{{{ int my_fclose(FILE *fp)*/
ce12d4b7
CB		 11162int
11163my_fclose(FILE *fp) {
bc10a425
CB		 11164 if (fp) {
11165 unsigned int fd = fileno(fp);
11166 unsigned int fdoff = fd / sizeof(unsigned int);
11167
e0951028 11168 if (sockflagsize && fdoff < sockflagsize)
bc10a425
CB		 11169 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11170 }
11171 return fclose(fp);
11172}
11173/*}}}*/
11174
11175
a0d0e21e
LW		 11176/*
11177 * A simple fwrite replacement which outputs itmsz*nitm chars without
11178 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 11179 * We are using fputs, which depends on a terminating null. We may
11180 * well be writing binary data, so we need to accommodate not only
11181 * data with nulls sprinkled in the middle but also data with no null
11182 * byte at the end.
a0d0e21e 11183 */
a15cef0c 11184/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 11185int
a15cef0c 11186my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 11187{
eb578fdb 11188 char *cp, *end, *cpd;
2e05a54c 11189 char *data;
eb578fdb
KW		 11190 unsigned int fd = fileno(dest);
11191 unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 11192 int retval;
bc10a425
CB		 11193 int bufsize = itmsz * nitm + 1;
11194
11195 if (fdoff < sockflagsize &&
11196 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11197 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11198 return nitm;
11199 }
22d4bb9c 11200
bc10a425 11201 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 11202 memcpy( data, src, itmsz*nitm );
11203 data[itmsz*nitm] = '\0';
a0d0e21e 11204
22d4bb9c
CB		 11205 end = data + itmsz * nitm;
11206 retval = (int) nitm; /* on success return # items written */
a0d0e21e 11207
22d4bb9c
CB		 11208 cpd = data;
11209 while (cpd <= end) {
11210 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11211 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 11212 if (cp < end)
22d4bb9c
CB		 11213 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11214 cpd = cp + 1;
a0d0e21e
LW		 11215 }
11216
bc10a425 11217 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 11218 return retval;
a0d0e21e
LW		 11219
11220} /* end of my_fwrite() */
11221/*}}}*/
11222
d27fe803
JH		 11223/*{{{ int my_flush(FILE *fp)*/
11224int
fd8cd3a3 11225Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 11226{
11227 int res;
93948341 11228 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 11229#ifdef VMS_DO_SOCKETS
61bb5906 11230 Stat_t s;
ed1b9de0 11231 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
d27fe803
JH		 11232#endif
11233 res = fsync(fileno(fp));
11234 }
22d4bb9c
CB		 11235/*
11236 * If the flush succeeded but set end-of-file, we need to clear
11237 * the error because our caller may check ferror(). BTW, this
11238 * probably means we just flushed an empty file.
11239 */
11240 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11241
d27fe803
JH		 11242 return res;
11243}
11244/*}}}*/
11245
bf8d1304
JM		 11246/* fgetname() is not returning the correct file specifications when
11247 * decc_filename_unix_report mode is active. So we have to have it
11248 * aways return filenames in VMS mode and convert it ourselves.
11249 */
11250
11251/*{{{ char * my_fgetname(FILE *fp, buf)*/
11252char *
11253Perl_my_fgetname(FILE *fp, char * buf) {
11254 char * retname;
11255 char * vms_name;
11256
11257 retname = fgetname(fp, buf, 1);
11258
11259 /* If we are in VMS mode, then we are done */
1d60dc3f 11260 if (!DECC_FILENAME_UNIX_REPORT || (retname == NULL)) {
bf8d1304
JM		 11261 return retname;
11262 }
11263
11264 /* Convert this to Unix format */
c11536f5 11265 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 11266 my_strlcpy(vms_name, retname, VMS_MAXRSS);
bf8d1304
JM		 11267 retname = int_tounixspec(vms_name, buf, NULL);
11268 PerlMem_free(vms_name);
11269
11270 return retname;
11271}
11272/*}}}*/
11273
748a9306
LW		 11274/*
11275 * Here are replacements for the following Unix routines in the VMS environment:
11276 * getpwuid Get information for a particular UIC or UID
11277 * getpwnam Get information for a named user
11278 * getpwent Get information for each user in the rights database
11279 * setpwent Reset search to the start of the rights database
11280 * endpwent Finish searching for users in the rights database
11281 *
11282 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11283 * (defined in pwd.h), which contains the following fields:-
11284 * struct passwd {
11285 * char *pw_name; Username (in lower case)
11286 * char *pw_passwd; Hashed password
11287 * unsigned int pw_uid; UIC
11288 * unsigned int pw_gid; UIC group number
11289 * char *pw_unixdir; Default device/directory (VMS-style)
11290 * char *pw_gecos; Owner name
11291 * char *pw_dir; Default device/directory (Unix-style)
11292 * char *pw_shell; Default CLI name (eg. DCL)
11293 * };
11294 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11295 *
11296 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11297 * not the UIC member number (eg. what's returned by getuid()),
11298 * getpwuid() can accept either as input (if uid is specified, the caller's
11299 * UIC group is used), though it won't recognise gid=0.
11300 *
11301 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11302 * information about other users in your group or in other groups, respectively.
11303 * If the required privilege is not available, then these routines fill only
11304 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11305 * string).
11306 *
11307 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11308 */
11309
11310/* sizes of various UAF record fields */
11311#define UAI$S_USERNAME 12
11312#define UAI$S_IDENT 31
11313#define UAI$S_OWNER 31
11314#define UAI$S_DEFDEV 31
11315#define UAI$S_DEFDIR 63
11316#define UAI$S_DEFCLI 31
11317#define UAI$S_PWD 8
11318
11319#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11320 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11321 (uic).uic$v_group != UIC$K_WILD_GROUP)
11322
4633a7c4
LW		 11323static char __empty[]= "";
11324static struct passwd __passwd_empty=
748a9306
LW		 11325 {(char *) __empty, (char *) __empty, 0, 0,
11326 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11327static int contxt= 0;
11328static struct passwd __pwdcache;
11329static char __pw_namecache[UAI$S_IDENT+1];
11330
748a9306
LW		 11331/*
11332 * This routine does most of the work extracting the user information.
11333 */
ce12d4b7
CB		 11334static int
11335fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 11336{
748a9306
LW		 11337 static struct {
11338 unsigned char length;
11339 char pw_gecos[UAI$S_OWNER+1];
11340 } owner;
11341 static union uicdef uic;
11342 static struct {
11343 unsigned char length;
11344 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11345 } defdev;
11346 static struct {
11347 unsigned char length;
11348 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11349 } defdir;
11350 static struct {
11351 unsigned char length;
11352 char pw_shell[UAI$S_DEFCLI+1];
11353 } defcli;
11354 static char pw_passwd[UAI$S_PWD+1];
11355
11356 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11357 struct dsc$descriptor_s name_desc;
c07a80fd 11358 unsigned long int sts;
748a9306 11359
4633a7c4 11360 static struct itmlst_3 itmlst[]= {
748a9306
LW		 11361 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11362 {sizeof(uic), UAI$_UIC, &uic, &luic},
11363 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11364 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11365 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11366 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11367 {0, 0, NULL, NULL}};
11368
11369 name_desc.dsc$w_length= strlen(name);
11370 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11371 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 11372 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 11373
11374/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 11375 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11376 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11377 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11378 }
11379 else { _ckvmssts(sts); }
11380 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 11381
11382 if ((int) owner.length < lowner) lowner= (int) owner.length;
11383 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11384 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11385 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11386 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11387 owner.pw_gecos[lowner]= '\0';
11388 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11389 defcli.pw_shell[ldefcli]= '\0';
11390 if (valid_uic(uic)) {
11391 pwd->pw_uid= uic.uic$l_uic;
11392 pwd->pw_gid= uic.uic$v_group;
11393 }
11394 else
5c84aa53 11395 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 11396 pwd->pw_passwd= pw_passwd;
11397 pwd->pw_gecos= owner.pw_gecos;
11398 pwd->pw_dir= defdev.pw_dir;
360732b5 11399 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 11400 pwd->pw_shell= defcli.pw_shell;
11401 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11402 int ldir;
11403 ldir= strlen(pwd->pw_unixdir) - 1;
11404 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11405 }
11406 else
a35dcc95 11407 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
1d60dc3f 11408 if (!DECC_EFS_CASE_PRESERVE)
f7ddb74a 11409 __mystrtolower(pwd->pw_unixdir);
c07a80fd 11410 return 1;
a0d0e21e 11411}
748a9306
LW		 11412
11413/*
11414 * Get information for a named user.
11415*/
11416/*{{{struct passwd *getpwnam(char *name)*/
ce12d4b7
CB		 11417struct passwd *
11418Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 11419{
11420 struct dsc$descriptor_s name_desc;
11421 union uicdef uic;
4e0c9737 11422 unsigned long int sts;
748a9306
LW		 11423
11424 __pwdcache = __passwd_empty;
fd8cd3a3 11425 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 11426 /* We still may be able to determine pw_uid and pw_gid */
11427 name_desc.dsc$w_length= strlen(name);
11428 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11429 name_desc.dsc$b_class= DSC$K_CLASS_S;
11430 name_desc.dsc$a_pointer= (char *) name;
aa689395 11431 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 11432 __pwdcache.pw_uid= uic.uic$l_uic;
11433 __pwdcache.pw_gid= uic.uic$v_group;
11434 }
c07a80fd 11435 else {
aa689395 11436 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11437 set_vaxc_errno(sts);
11438 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 11439 return NULL;
11440 }
aa689395 11441 else { _ckvmssts(sts); }
c07a80fd 11442 }
748a9306 11443 }
a35dcc95 11444 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
748a9306
LW		 11445 __pwdcache.pw_name= __pw_namecache;
11446 return &__pwdcache;
11447} /* end of my_getpwnam() */
a0d0e21e
LW		 11448/*}}}*/
11449
748a9306
LW		 11450/*
11451 * Get information for a particular UIC or UID.
11452 * Called by my_getpwent with uid=-1 to list all users.
11453*/
11454/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
ce12d4b7
CB		 11455struct passwd *
11456Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 11457{
748a9306
LW		 11458 const $DESCRIPTOR(name_desc,__pw_namecache);
11459 unsigned short lname;
11460 union uicdef uic;
11461 unsigned long int status;
11462
11463 if (uid == (unsigned int) -1) {
11464 do {
11465 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11466 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 11467 set_vaxc_errno(status);
11468 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 11469 my_endpwent();
11470 return NULL;
11471 }
11472 else { _ckvmssts(status); }
11473 } while (!valid_uic (uic));
11474 }
11475 else {
11476 uic.uic$l_uic= uid;
c07a80fd 11477 if (!uic.uic$v_group)
76e3520e 11478 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 11479 if (valid_uic(uic))
11480 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11481 else status = SS$_IVIDENT;
c07a80fd 11482 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11483 status == RMS$_PRV) {
11484 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11485 return NULL;
11486 }
11487 else { _ckvmssts(status); }
748a9306
LW		 11488 }
11489 __pw_namecache[lname]= '\0';
01b8edb6 11490 __mystrtolower(__pw_namecache);
748a9306
LW		 11491
11492 __pwdcache = __passwd_empty;
11493 __pwdcache.pw_name = __pw_namecache;
11494
11495/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11496 The identifier's value is usually the UIC, but it doesn't have to be,
11497 so if we can, we let fillpasswd update this. */
11498 __pwdcache.pw_uid = uic.uic$l_uic;
11499 __pwdcache.pw_gid = uic.uic$v_group;
11500
fd8cd3a3 11501 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 11502 return &__pwdcache;
a0d0e21e 11503
748a9306
LW		 11504} /* end of my_getpwuid() */
11505/*}}}*/
11506
11507/*
11508 * Get information for next user.
11509*/
11510/*{{{struct passwd *my_getpwent()*/
ce12d4b7
CB		 11511struct passwd *
11512Perl_my_getpwent(pTHX)
748a9306
LW		 11513{
11514 return (my_getpwuid((unsigned int) -1));
11515}
11516/*}}}*/
a0d0e21e 11517
748a9306
LW		 11518/*
11519 * Finish searching rights database for users.
11520*/
11521/*{{{void my_endpwent()*/
ce12d4b7
CB		 11522void
11523Perl_my_endpwent(pTHX)
748a9306
LW		 11524{
11525 if (contxt) {
11526 _ckvmssts(sys$finish_rdb(&contxt));
11527 contxt= 0;
11528 }
a0d0e21e
LW		 11529}
11530/*}}}*/
748a9306 11531
ff0cee69 11532/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11533 * my_utime(), and flex_stat(), all of which operate on UTC unless
11534 * VMSISH_TIMES is true.
11535 */
11536/* method used to handle UTC conversions:
11537 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 11538 */
ff0cee69 11539static int gmtime_emulation_type;
11540/* number of secs to add to UTC POSIX-style time to get local time */
11541static long int utc_offset_secs;
e518068a 11542
ff0cee69 11543/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11544 * in vmsish.h. #undef them here so we can call the CRTL routines
11545 * directly.
e518068a 11546 */
11547#undef gmtime
ff0cee69 11548#undef localtime
11549#undef time
11550
61bb5906
CB		 11551
11552static time_t toutc_dst(time_t loc) {
11553 struct tm *rsltmp;
11554
f7c699a0 11555 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
61bb5906
CB		 11556 loc -= utc_offset_secs;
11557 if (rsltmp->tm_isdst) loc -= 3600;
11558 return loc;
11559}
32da55ab 11560#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11561 ((gmtime_emulation_type || my_time(NULL)), \
11562 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11563 ((secs) - utc_offset_secs))))
11564
11565static time_t toloc_dst(time_t utc) {
11566 struct tm *rsltmp;
11567
11568 utc += utc_offset_secs;
f7c699a0 11569 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
61bb5906
CB		 11570 if (rsltmp->tm_isdst) utc += 3600;
11571 return utc;
11572}
32da55ab 11573#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11574 ((gmtime_emulation_type || my_time(NULL)), \
11575 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11576 ((secs) + utc_offset_secs))))
11577
ff0cee69 11578/* my_time(), my_localtime(), my_gmtime()
61bb5906 11579 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11580 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11581 * Note: We need to use these functions even when the CRTL has working
11582 * UTC support, since they also handle C<use vmsish qw(times);>
11583 *
ff0cee69 11584 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11585 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11586 */
11587
11588/*{{{time_t my_time(time_t *timep)*/
ce12d4b7
CB		 11589time_t
11590Perl_my_time(pTHX_ time_t *timep)
e518068a 11591{
e518068a 11592 time_t when;
61bb5906 11593 struct tm *tm_p;
e518068a 11594
11595 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11596 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11597 /* results of calls to gmtime() and localtime() */
11598 /* for same &base */
ff0cee69 11599
e518068a 11600 gmtime_emulation_type++;
ff0cee69 11601 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11602 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11603
e518068a 11604 gmtime_emulation_type++;
f675dbe5 11605 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11606 gmtime_emulation_type++;
22d4bb9c 11607 utc_offset_secs = 0;
5c84aa53 11608 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11609 }
11610 else { utc_offset_secs = atol(off); }
e518068a 11611 }
ff0cee69 11612 else { /* We've got a working gmtime() */
11613 struct tm gmt, local;
e518068a 11614
ff0cee69 11615 gmt = *tm_p;
11616 tm_p = localtime(&base);
11617 local = *tm_p;
11618 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11619 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11620 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11621 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11622 }
e518068a 11623 }
ff0cee69 11624
11625 when = time(NULL);
61bb5906 11626# ifdef VMSISH_TIME
61bb5906 11627 if (VMSISH_TIME) when = _toloc(when);
61bb5906 11628# endif
ff0cee69 11629 if (timep != NULL) *timep = when;
11630 return when;
11631
11632} /* end of my_time() */
11633/*}}}*/
11634
11635
11636/*{{{struct tm *my_gmtime(const time_t *timep)*/
11637struct tm *
fd8cd3a3 11638Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11639{
ff0cee69 11640 time_t when;
61bb5906 11641 struct tm *rsltmp;
ff0cee69 11642
68dc0745 11643 if (timep == NULL) {
11644 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11645 return NULL;
11646 }
11647 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11648
11649 when = *timep;
11650# ifdef VMSISH_TIME
61bb5906
CB		 11651 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11652# endif
61bb5906 11653 return gmtime(&when);
e518068a 11654} /* end of my_gmtime() */
e518068a 11655/*}}}*/
11656
11657
ff0cee69 11658/*{{{struct tm *my_localtime(const time_t *timep)*/
11659struct tm *
fd8cd3a3 11660Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11661{
c11536f5 11662 time_t when;
ff0cee69 11663
68dc0745 11664 if (timep == NULL) {
11665 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11666 return NULL;
11667 }
11668 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11669 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11670
11671 when = *timep;
11672# ifdef VMSISH_TIME
61bb5906 11673 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11674# endif
61bb5906 11675 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11676 return localtime(&when);
ff0cee69 11677} /* end of my_localtime() */
11678/*}}}*/
11679
11680/* Reset definitions for later calls */
11681#define gmtime(t) my_gmtime(t)
11682#define localtime(t) my_localtime(t)
11683#define time(t) my_time(t)
11684
11685
941b3de1
CB		 11686/* my_utime - update modification/access time of a file
11687 *
941b3de1
CB		 11688 * Only the UTC translation is home-grown. The rest is handled by the
11689 * CRTL utime(), which will take into account the relevant feature
11690 * logicals and ODS-5 volume characteristics for true access times.
11691 *
ff0cee69 11692 */
11693
11694/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11695 * to VMS epoch (01-JAN-1858 00:00:00.00)
11696 * in 100 ns intervals.
11697 */
11698static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11699
94a11853 11700/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
ce12d4b7
CB		 11701int
11702Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11703{
941b3de1
CB		 11704 struct utimbuf utc_utimes, *utc_utimesp;
11705
11706 if (utimes != NULL) {
11707 utc_utimes.actime = utimes->actime;
11708 utc_utimes.modtime = utimes->modtime;
11709# ifdef VMSISH_TIME
11710 /* If input was local; convert to UTC for sys svc */
11711 if (VMSISH_TIME) {
11712 utc_utimes.actime = _toutc(utimes->actime);
11713 utc_utimes.modtime = _toutc(utimes->modtime);
11714 }
11715# endif
11716 utc_utimesp = &utc_utimes;
11717 }
11718 else {
11719 utc_utimesp = NULL;
11720 }
11721
11722 return utime(file, utc_utimesp);
11723
ff0cee69 11724} /* end of my_utime() */
11725/*}}}*/
11726
748a9306 11727/*
2497a41f 11728 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11729 * basic stat, but gets it right when asked to stat
11730 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11731 */
11732
2497a41f 11733#ifndef _USE_STD_STAT
748a9306
LW		 11734/* encode_dev packs a VMS device name string into an integer to allow
11735 * simple comparisons. This can be used, for example, to check whether two
11736 * files are located on the same device, by comparing their encoded device
11737 * names. Even a string comparison would not do, because stat() reuses the
11738 * device name buffer for each call; so without encode_dev, it would be
11739 * necessary to save the buffer and use strcmp (this would mean a number of
11740 * changes to the standard Perl code, to say nothing of what a Perl script
11741 * would have to do.
11742 *
11743 * The device lock id, if it exists, should be unique (unless perhaps compared
11744 * with lock ids transferred from other nodes). We have a lock id if the disk is
11745 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11746 * device names. Thus we use the lock id in preference, and only if that isn't
11747 * available, do we try to pack the device name into an integer (flagged by
11748 * the sign bit (LOCKID_MASK) being set).
11749 *
e518068a 11750 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11751 * name and its encoded form, but it seems very unlikely that we will find
11752 * two files on different disks that share the same encoded device names,
11753 * and even more remote that they will share the same file id (if the test
11754 * is to check for the same file).
11755 *
11756 * A better method might be to use sys$device_scan on the first call, and to
11757 * search for the device, returning an index into the cached array.
cb9e088c 11758 * The number returned would be more intelligible.
748a9306
LW		 11759 * This is probably not worth it, and anyway would take quite a bit longer
11760 * on the first call.
11761 */
11762#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
ce12d4b7
CB		 11763static mydev_t
11764encode_dev (pTHX_ const char *dev)
748a9306
LW		 11765{
11766 int i;
11767 unsigned long int f;
aa689395 11768 mydev_t enc;
748a9306
LW		 11769 char c;
11770 const char *q;
11771
11772 if (!dev || !dev[0]) return 0;
11773
11774#if LOCKID_MASK
11775 {
11776 struct dsc$descriptor_s dev_desc;
cb9e088c 11777 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11778
11779 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11780 can try that first. */
11781 dev_desc.dsc$w_length = strlen (dev);
11782 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11783 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11784 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11785 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11786 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11787 switch (status) {
11788 case SS$_NOSUCHDEV:
11789 SETERRNO(ENODEV, status);
11790 return 0;
11791 default:
11792 _ckvmssts(status);
11793 }
11794 }
748a9306
LW		 11795 if (lockid) return (lockid & ~LOCKID_MASK);
11796 }
a0d0e21e 11797#endif
748a9306
LW		 11798
11799 /* Otherwise we try to encode the device name */
11800 enc = 0;
11801 f = 1;
11802 i = 0;
11803 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11804 if (*q == ':')
11805 break;
748a9306
LW		 11806 if (isdigit (*q))
11807 c= (*q) - '0';
30048647 11808 else if (isALPHA_A(toUPPER_A(*q)))
748a9306
LW		 11809 c= toupper (*q) - 'A' + (char)10;
11810 else
11811 continue; /* Skip '$'s */
11812 i++;
11813 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11814 if (i>1) f *= 36;
11815 enc += f * (unsigned long int) c;
11816 }
11817 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11818
11819} /* end of encode_dev() */
cfcfe586
JM		 11820#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11821 device_no = encode_dev(aTHX_ devname)
11822#else
11823#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11824 device_no = new_dev_no
2497a41f 11825#endif
748a9306 11826
748a9306 11827static int
135577da 11828is_null_device(const char *name)
748a9306 11829{
2497a41f 11830 if (decc_bug_devnull != 0) {
f55ac4a4 11831 if (strBEGINs(name, "/dev/null"))
2497a41f
JM		 11832 return 1;
11833 }
748a9306
LW		 11834 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11835 The underscore prefix, controller letter, and unit number are
11836 independently optional; for our purposes, the colon punctuation
11837 is not. The colon can be trailed by optional directory and/or
11838 filename, but two consecutive colons indicates a nodename rather
11839 than a device. [pr] */
11840 if (*name == '_') ++name;
30048647
CB		 11841 if (toLOWER_L1(*name++) != 'n') return 0;
11842 if (toLOWER_L1(*name++) != 'l') return 0;
11843 if (toLOWER_L1(*name) == 'a') ++name;
748a9306
LW		 11844 if (*name == '0') ++name;
11845 return (*name++ == ':') && (*name != ':');
11846}
11847
312ac60b
JM		 11848static int
11849Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
c07a80fd 11850
46c05374
CB		 11851#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11852
a1887106 11853static I32
ce12d4b7 11854Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11855{
e538e23f
CB		 11856 char usrname[L_cuserid];
11857 struct dsc$descriptor_s usrdsc =
748a9306 11858 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11859 char *vmsname = NULL, *fileified = NULL;
597c27e2 11860 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11861 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11862 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11863 union prvdef curprv;
597c27e2
CB		 11864 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11865 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11866 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11867 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11868 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11869 {0,0,0,0}};
11870 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11871 {0,0,0,0}};
ada67d10 11872 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11873 Stat_t st;
6151c65c 11874 static int profile_context = -1;
748a9306
LW		 11875
11876 if (!fname || !*fname) return FALSE;
a1887106 11877
e538e23f 11878 /* Make sure we expand logical names, since sys$check_access doesn't */
c11536f5 11879 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11880 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f 11881 if (!strpbrk(fname,"/]>:")) {
a35dcc95 11882 my_strlcpy(fileified, fname, VMS_MAXRSS);
a1887106 11883 trnlnm_iter_count = 0;
e538e23f 11884 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11885 trnlnm_iter_count++;
11886 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11887 }
11888 fname = fileified;
e538e23f
CB		 11889 }
11890
c11536f5 11891 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11892 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f
CB		 11893 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11894 /* Don't know if already in VMS format, so make sure */
360732b5 11895 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11896 PerlMem_free(fileified);
e538e23f 11897 PerlMem_free(vmsname);
a1887106
JM		 11898 return FALSE;
11899 }
a1887106
JM		 11900 }
11901 else {
a35dcc95 11902 my_strlcpy(vmsname, fname, VMS_MAXRSS);
a5f75d66
AD		 11903 }
11904
858aded6 11905 /* sys$check_access needs a file spec, not a directory spec.
312ac60b 11906 * flex_stat now will handle a null thread context during startup.
858aded6 11907 */
e538e23f
CB		 11908
11909 retlen = namdsc.dsc$w_length = strlen(vmsname);
11910 if (vmsname[retlen-1] == ']'
11911 || vmsname[retlen-1] == '>'
858aded6 11912 || vmsname[retlen-1] == ':'
46c05374 11913 || (!flex_stat_int(vmsname, &st, 1) &&
312ac60b 11914 S_ISDIR(st.st_mode))) {
e538e23f 11915
a979ce91 11916 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
e538e23f
CB		 11917 PerlMem_free(fileified);
11918 PerlMem_free(vmsname);
11919 return FALSE;
11920 }
11921 fname = fileified;
11922 }
858aded6
CB		 11923 else {
11924 fname = vmsname;
11925 }
e538e23f
CB		 11926
11927 retlen = namdsc.dsc$w_length = strlen(fname);
11928 namdsc.dsc$a_pointer = (char *)fname;
11929
748a9306 11930 switch (bit) {
f282b18d 11931 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11932 access = ARM$M_EXECUTE;
597c27e2
CB		 11933 flags = CHP$M_READ;
11934 break;
f282b18d 11935 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11936 access = ARM$M_READ;
597c27e2
CB		 11937 flags = CHP$M_READ | CHP$M_USEREADALL;
11938 break;
f282b18d 11939 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11940 access = ARM$M_WRITE;
597c27e2
CB		 11941 flags = CHP$M_READ | CHP$M_WRITE;
11942 break;
f282b18d 11943 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11944 access = ARM$M_DELETE;
597c27e2
CB		 11945 flags = CHP$M_READ | CHP$M_WRITE;
11946 break;
748a9306 11947 default:
a1887106
JM		 11948 if (fileified != NULL)
11949 PerlMem_free(fileified);
e538e23f
CB		 11950 if (vmsname != NULL)
11951 PerlMem_free(vmsname);
748a9306
LW		 11952 return FALSE;
11953 }
11954
ada67d10
CB		 11955 /* Before we call $check_access, create a user profile with the current
11956 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11957 * UAF and might give false positives or negatives. This only works on
11958 * VMS versions v6.0 and later since that's when sys$create_user_profile
11959 * became available.
ada67d10
CB		 11960 */
11961
11962 /* get current process privs and username */
ebd4d70b
JM		 11963 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11964 _ckvmssts_noperl(iosb[0]);
ada67d10
CB		 11965
11966 /* find out the space required for the profile */
ebd4d70b 11967 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11968 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11969
11970 /* allocate space for the profile and get it filled in */
c11536f5 11971 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
ebd4d70b
JM		 11972 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11973 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 11974 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11975
11976 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 11977 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 11978 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 11979 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c 11980
bbce6d69 11981 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 11982 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 11983 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 11984 set_vaxc_errno(retsts);
11985 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11986 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11987 else set_errno(ENOENT);
a1887106
JM		 11988 if (fileified != NULL)
11989 PerlMem_free(fileified);
e538e23f
CB		 11990 if (vmsname != NULL)
11991 PerlMem_free(vmsname);
a3e9d8c9 11992 return FALSE;
11993 }
ada67d10 11994 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 11995 if (fileified != NULL)
11996 PerlMem_free(fileified);
e538e23f
CB		 11997 if (vmsname != NULL)
11998 PerlMem_free(vmsname);
3a385817
GS		 11999 return TRUE;
12000 }
ebd4d70b 12001 _ckvmssts_noperl(retsts);
748a9306 12002
a1887106
JM		 12003 if (fileified != NULL)
12004 PerlMem_free(fileified);
e538e23f
CB		 12005 if (vmsname != NULL)
12006 PerlMem_free(vmsname);
748a9306
LW		 12007 return FALSE; /* Should never get here */
12008
a1887106
JM		 12009}
12010
bd93adf5 12011/* Do the permissions in *statbufp allow some operation? */
a1887106
JM		 12012/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12013 * subset of the applicable information.
12014 */
12015bool
12016Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12017{
12018 return cando_by_name_int
12019 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12020} /* end of cando() */
12021/*}}}*/
12022
12023
12024/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12025I32
12026Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12027{
12028 return cando_by_name_int(bit, effective, fname, 0);
12029
748a9306
LW		 12030} /* end of cando_by_name() */
12031/*}}}*/
12032
12033
61bb5906 12034/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 12035int
fd8cd3a3 12036Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 12037{
a1027d22 12038 dSAVE_ERRNO; /* fstat may set this even on success */
312ac60b 12039 if (!fstat(fd, &statbufp->crtl_stat)) {
75796008 12040 char *cptr;
988c775c 12041 char *vms_filename;
c11536f5 12042 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
988c775c 12043 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 12044
988c775c
JM		 12045 /* Save name for cando by name in VMS format */
12046 cptr = getname(fd, vms_filename, 1);
75796008 12047
988c775c
JM		 12048 /* This should not happen, but just in case */
12049 if (cptr == NULL) {
12050 statbufp->st_devnam[0] = 0;
12051 }
12052 else {
12053 /* Make sure that the saved name fits in 255 characters */
6fb6c614 12054 cptr = int_rmsexpand_vms
988c775c
JM		 12055 (vms_filename,
12056 statbufp->st_devnam,
6fb6c614 12057 0);
75796008 12058 if (cptr == NULL)
988c775c 12059 statbufp->st_devnam[0] = 0;
75796008 12060 }
988c775c 12061 PerlMem_free(vms_filename);
682e4b71
JM		 12062
12063 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12064 VMS_DEVICE_ENCODE
12065 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 12066
61bb5906
CB		 12067# ifdef VMSISH_TIME
12068 if (VMSISH_TIME) {
12069 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12070 statbufp->st_atime = _toloc(statbufp->st_atime);
12071 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12072 }
12073# endif
a1027d22 12074 RESTORE_ERRNO;
b7ae7a0d 12075 return 0;
12076 }
12077 return -1;
748a9306
LW		 12078
12079} /* end of flex_fstat() */
12080/*}}}*/
12081
2497a41f
JM		 12082static int
12083Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 12084{
9b9f19da
CB		 12085 char *temp_fspec = NULL;
12086 char *fileified = NULL;
312ac60b
JM		 12087 const char *save_spec;
12088 char *ret_spec;
bbce6d69 12089 int retval = -1;
cc5de3bd
CB		 12090 char efs_hack = 0;
12091 char already_fileified = 0;
4ee39169 12092 dSAVEDERRNO;
748a9306 12093
312ac60b
JM		 12094 if (!fspec) {
12095 errno = EINVAL;
12096 return retval;
12097 }
988c775c 12098
2497a41f 12099 if (decc_bug_devnull != 0) {
312ac60b 12100 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2497a41f 12101 memset(statbufp,0,sizeof *statbufp);
cfcfe586 12102 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 12103 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12104 statbufp->st_uid = 0x00010001;
12105 statbufp->st_gid = 0x0001;
12106 time((time_t *)&statbufp->st_mtime);
12107 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12108 return 0;
12109 }
748a9306
LW		 12110 }
12111
9b9f19da
CB		 12112 SAVE_ERRNO;
12113
054a3baf 12114#if __CRTL_VER >= 80200000
9b9f19da
CB		 12115 /*
12116 * If we are in POSIX filespec mode, accept the filename as is.
12117 */
1d60dc3f 12118 if (!DECC_POSIX_COMPLIANT_PATHNAMES) {
9b9f19da
CB		 12119#endif
12120
12121 /* Try for a simple stat first. If fspec contains a filename without
61bb5906 12122 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9b9f19da 12123 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
bbce6d69 12124 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12125 * not sea:[wine.dark]., if the latter exists. If the intended target is
12126 * the file with null type, specify this by calling flex_stat() with
12127 * a '.' at the end of fspec.
12128 */
f36b279d 12129
9b9f19da
CB		 12130 if (lstat_flag == 0)
12131 retval = stat(fspec, &statbufp->crtl_stat);
12132 else
12133 retval = lstat(fspec, &statbufp->crtl_stat);
f36b279d 12134
cc5de3bd
CB		 12135 if (!retval) {
12136 save_spec = fspec;
12137 }
12138 else {
12139 /* In the odd case where we have write but not read access
12140 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12141 */
c11536f5 12142 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
cc5de3bd
CB		 12143 if (fileified == NULL)
12144 _ckvmssts_noperl(SS$_INSFMEM);
12145
12146 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12147 if (ret_spec != NULL) {
12148 if (lstat_flag == 0)
12149 retval = stat(fileified, &statbufp->crtl_stat);
12150 else
12151 retval = lstat(fileified, &statbufp->crtl_stat);
12152 save_spec = fileified;
12153 already_fileified = 1;
12154 }
12155 }
12156
312ac60b
JM		 12157 if (retval && vms_bug_stat_filename) {
12158
c11536f5 12159 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12160 if (temp_fspec == NULL)
12161 _ckvmssts_noperl(SS$_INSFMEM);
12162
12163 /* We should try again as a vmsified file specification. */
312ac60b
JM		 12164
12165 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12166 if (ret_spec != NULL) {
12167 if (lstat_flag == 0)
12168 retval = stat(temp_fspec, &statbufp->crtl_stat);
12169 else
12170 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12171 save_spec = temp_fspec;
12172 }
2497a41f 12173 }
312ac60b 12174
f1db9cda 12175 if (retval) {
9b9f19da 12176 /* Last chance - allow multiple dots without EFS CHARSET */
312ac60b
JM		 12177 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12178 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12179 * enable it if it isn't already.
12180 */
1d60dc3f
CB		 12181 if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
12182 decc$feature_set_value(efs_charset_index, 1, 1);
312ac60b
JM		 12183 if (lstat_flag == 0)
12184 retval = stat(fspec, &statbufp->crtl_stat);
12185 else
12186 retval = lstat(fspec, &statbufp->crtl_stat);
12187 save_spec = fspec;
1d60dc3f
CB		 12188 if (!DECC_EFS_CHARSET && (efs_charset_index > 0)) {
12189 decc$feature_set_value(efs_charset_index, 1, 0);
312ac60b
JM		 12190 efs_hack = 1;
12191 }
f1db9cda 12192 }
312ac60b 12193
054a3baf 12194#if __CRTL_VER >= 80200000
2497a41f
JM		 12195 } else {
12196 if (lstat_flag == 0)
312ac60b 12197 retval = stat(temp_fspec, &statbufp->crtl_stat);
2497a41f 12198 else
312ac60b 12199 retval = lstat(temp_fspec, &statbufp->crtl_stat);
988c775c 12200 save_spec = temp_fspec;
2497a41f
JM		 12201 }
12202#endif
f36b279d 12203
f36b279d 12204 /* As you were... */
1d60dc3f
CB		 12205 if (!DECC_EFS_CHARSET)
12206 decc$feature_set_value(efs_charset_index,1,0);
f36b279d 12207
ff0cee69 12208 if (!retval) {
9b9f19da
CB		 12209 char *cptr;
12210 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
d584a1c6
JM		 12211
12212 /* If this is an lstat, do not follow the link */
12213 if (lstat_flag)
12214 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12215
312ac60b
JM		 12216 /* If we used the efs_hack above, we must also use it here for */
12217 /* perl_cando to work */
1d60dc3f
CB		 12218 if (efs_hack && (efs_charset_index > 0)) {
12219 decc$feature_set_value(efs_charset_index, 1, 1);
312ac60b 12220 }
9b9f19da
CB		 12221
12222 /* If we've got a directory, save a fileified, expanded version of it
12223 * in st_devnam. If not a directory, just an expanded version.
12224 */
cc5de3bd 12225 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
c11536f5 12226 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12227 if (fileified == NULL)
12228 _ckvmssts_noperl(SS$_INSFMEM);
12229
12230 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12231 if (cptr != NULL)
12232 save_spec = fileified;
12233 }
12234
12235 cptr = int_rmsexpand(save_spec,
12236 statbufp->st_devnam,
12237 NULL,
12238 rmsex_flags,
12239 0,
12240 0);
12241
1d60dc3f
CB		 12242 if (efs_hack && (efs_charset_index > 0)) {
12243 decc$feature_set_value(efs_charset_index, 1, 0);
312ac60b 12244 }
312ac60b
JM		 12245
12246 /* Fix me: If this is NULL then stat found a file, and we could */
12247 /* not convert the specification to VMS - Should never happen */
988c775c
JM		 12248 if (cptr == NULL)
12249 statbufp->st_devnam[0] = 0;
12250
682e4b71 12251 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12252 VMS_DEVICE_ENCODE
12253 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 12254# ifdef VMSISH_TIME
12255 if (VMSISH_TIME) {
12256 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12257 statbufp->st_atime = _toloc(statbufp->st_atime);
12258 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12259 }
12260# endif
ff0cee69 12261 }
9543c6b6 12262 /* If we were successful, leave errno where we found it */
4ee39169 12263 if (retval == 0) RESTORE_ERRNO;
9b9f19da
CB		 12264 if (temp_fspec)
12265 PerlMem_free(temp_fspec);
12266 if (fileified)
12267 PerlMem_free(fileified);
748a9306
LW		 12268 return retval;
12269
2497a41f
JM		 12270} /* end of flex_stat_int() */
12271
12272
12273/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12274int
12275Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12276{
7ded3206 12277 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12278}
12279/*}}}*/
12280
12281/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12282int
12283Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12284{
7ded3206 12285 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12286}
748a9306
LW		 12287/*}}}*/
12288
b7ae7a0d 12289
a5f75d66
AD		 12290/* rmscopy - copy a file using VMS RMS routines
12291 *
12292 * Copies contents and attributes of spec_in to spec_out, except owner
12293 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12294 * defaults for spec_out. The third parameter specifies whether rmscopy()
12295 * should try to propagate timestamps from the input file to the output file.
12296 * If it is less than 0, no timestamps are preserved. If it is 0, then
12297 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12298 * propagated to the output file at creation iff the output file specification
12299 * did not contain an explicit name or type, and the revision date is always
12300 * updated at the end of the copy operation. If it is greater than 0, then
12301 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12302 * other than the revision date should be propagated, and bit 1 indicates
12303 * that the revision date should be propagated.
12304 *
12305 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12306 *
bd3fa61c 12307 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12308 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12309 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12310 * as part of the Perl standard distribution under the terms of the
12311 * GNU General Public License or the Perl Artistic License. Copies
12312 * of each may be found in the Perl standard distribution.
a480973c 12313 */ /* FIXME */
a3e9d8c9 12314/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12315int
12316Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12317{
d584a1c6
JM		 12318 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12319 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
4e0c9737 12320 unsigned long int sts;
a1887106 12321 int dna_len;
a480973c
JM		 12322 struct FAB fab_in, fab_out;
12323 struct RAB rab_in, rab_out;
a1887106
JM		 12324 rms_setup_nam(nam);
12325 rms_setup_nam(nam_out);
a480973c
JM		 12326 struct XABDAT xabdat;
12327 struct XABFHC xabfhc;
12328 struct XABRDT xabrdt;
12329 struct XABSUM xabsum;
12330
c11536f5 12331 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12332 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12333 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12334 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665
JM		 12335 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12336 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
c5375c28
JM		 12337 PerlMem_free(vmsin);
12338 PerlMem_free(vmsout);
a480973c
JM		 12339 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12340 return 0;
12341 }
12342
c11536f5 12343 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12344 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12345 esal = NULL;
054a3baf 12346#if defined(NAML$C_MAXRSS)
c11536f5 12347 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12348 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12349#endif
a480973c 12350 fab_in = cc$rms_fab;
a1887106 12351 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12352 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12353 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12354 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12355 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12356 fab_in.fab$l_xab = (void *) &xabdat;
12357
c11536f5 12358 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12359 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12360 rsal = NULL;
054a3baf 12361#if defined(NAML$C_MAXRSS)
c11536f5 12362 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12363 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12364#endif
12365 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12366 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12367 rms_nam_esl(nam) = 0;
12368 rms_nam_rsl(nam) = 0;
12369 rms_nam_esll(nam) = 0;
12370 rms_nam_rsll(nam) = 0;
a480973c 12371#ifdef NAM$M_NO_SHORT_UPCASE
1d60dc3f 12372 if (DECC_EFS_CASE_PRESERVE)
a1887106 12373 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12374#endif
12375
12376 xabdat = cc$rms_xabdat; /* To get creation date */
12377 xabdat.xab$l_nxt = (void *) &xabfhc;
12378
12379 xabfhc = cc$rms_xabfhc; /* To get record length */
12380 xabfhc.xab$l_nxt = (void *) &xabsum;
12381
12382 xabsum = cc$rms_xabsum; /* To get key and area information */
12383
12384 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12385 PerlMem_free(vmsin);
12386 PerlMem_free(vmsout);
12387 PerlMem_free(esa);
d584a1c6
JM		 12388 if (esal != NULL)
12389 PerlMem_free(esal);
c5375c28 12390 PerlMem_free(rsa);
d584a1c6
JM		 12391 if (rsal != NULL)
12392 PerlMem_free(rsal);
a480973c
JM		 12393 set_vaxc_errno(sts);
12394 switch (sts) {
12395 case RMS$_FNF: case RMS$_DNF:
12396 set_errno(ENOENT); break;
12397 case RMS$_DIR:
12398 set_errno(ENOTDIR); break;
12399 case RMS$_DEV:
12400 set_errno(ENODEV); break;
12401 case RMS$_SYN:
12402 set_errno(EINVAL); break;
12403 case RMS$_PRV:
12404 set_errno(EACCES); break;
12405 default:
12406 set_errno(EVMSERR);
12407 }
12408 return 0;
12409 }
12410
12411 nam_out = nam;
12412 fab_out = fab_in;
12413 fab_out.fab$w_ifi = 0;
12414 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12415 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12416 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12417 rms_bind_fab_nam(fab_out, nam_out);
12418 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12419 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12420 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
c11536f5 12421 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12422 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12423 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12424 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12425 esal_out = NULL;
12426 rsal_out = NULL;
054a3baf 12427#if defined(NAML$C_MAXRSS)
c11536f5 12428 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12429 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12430 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12431 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12432#endif
12433 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12434 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12435
12436 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12437 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12438 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12439 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12440 PerlMem_free(vmsin);
12441 PerlMem_free(vmsout);
12442 PerlMem_free(esa);
d584a1c6
JM		 12443 if (esal != NULL)
12444 PerlMem_free(esal);
c5375c28 12445 PerlMem_free(rsa);
d584a1c6
JM		 12446 if (rsal != NULL)
12447 PerlMem_free(rsal);
c5375c28 12448 PerlMem_free(esa_out);
d584a1c6
JM		 12449 if (esal_out != NULL)
12450 PerlMem_free(esal_out);
12451 PerlMem_free(rsa_out);
12452 if (rsal_out != NULL)
12453 PerlMem_free(rsal_out);
a480973c
JM		 12454 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12455 set_vaxc_errno(sts);
12456 return 0;
12457 }
12458 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12459 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12460 preserve_dates = 1;
a480973c
JM		 12461 }
12462 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12463 preserve_dates =0; /* bitmask from this point forward */
12464
12465 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12466 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12467 PerlMem_free(vmsin);
12468 PerlMem_free(vmsout);
12469 PerlMem_free(esa);
d584a1c6
JM		 12470 if (esal != NULL)
12471 PerlMem_free(esal);
c5375c28 12472 PerlMem_free(rsa);
d584a1c6
JM		 12473 if (rsal != NULL)
12474 PerlMem_free(rsal);
c5375c28 12475 PerlMem_free(esa_out);
d584a1c6
JM		 12476 if (esal_out != NULL)
12477 PerlMem_free(esal_out);
12478 PerlMem_free(rsa_out);
12479 if (rsal_out != NULL)
12480 PerlMem_free(rsal_out);
a480973c
JM		 12481 set_vaxc_errno(sts);
12482 switch (sts) {
12483 case RMS$_DNF:
12484 set_errno(ENOENT); break;
12485 case RMS$_DIR:
12486 set_errno(ENOTDIR); break;
12487 case RMS$_DEV:
12488 set_errno(ENODEV); break;
12489 case RMS$_SYN:
12490 set_errno(EINVAL); break;
12491 case RMS$_PRV:
12492 set_errno(EACCES); break;
12493 default:
12494 set_errno(EVMSERR);
12495 }
12496 return 0;
12497 }
12498 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12499 if (preserve_dates & 2) {
12500 /* sys$close() will process xabrdt, not xabdat */
12501 xabrdt = cc$rms_xabrdt;
a480973c 12502 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
a480973c
JM		 12503 fab_out.fab$l_xab = (void *) &xabrdt;
12504 }
12505
c11536f5 12506 ubf = (char *)PerlMem_malloc(32256);
ebd4d70b 12507 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 12508 rab_in = cc$rms_rab;
12509 rab_in.rab$l_fab = &fab_in;
12510 rab_in.rab$l_rop = RAB$M_BIO;
12511 rab_in.rab$l_ubf = ubf;
12512 rab_in.rab$w_usz = 32256;
12513 if (!((sts = sys$connect(&rab_in)) & 1)) {
12514 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12515 PerlMem_free(vmsin);
12516 PerlMem_free(vmsout);
c5375c28 12517 PerlMem_free(ubf);
d584a1c6
JM		 12518 PerlMem_free(esa);
12519 if (esal != NULL)
12520 PerlMem_free(esal);
c5375c28 12521 PerlMem_free(rsa);
d584a1c6
JM		 12522 if (rsal != NULL)
12523 PerlMem_free(rsal);
c5375c28 12524 PerlMem_free(esa_out);
d584a1c6
JM		 12525 if (esal_out != NULL)
12526 PerlMem_free(esal_out);
12527 PerlMem_free(rsa_out);
12528 if (rsal_out != NULL)
12529 PerlMem_free(rsal_out);
a480973c
JM		 12530 set_errno(EVMSERR); set_vaxc_errno(sts);
12531 return 0;
12532 }
12533
12534 rab_out = cc$rms_rab;
12535 rab_out.rab$l_fab = &fab_out;
12536 rab_out.rab$l_rbf = ubf;
12537 if (!((sts = sys$connect(&rab_out)) & 1)) {
12538 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12539 PerlMem_free(vmsin);
12540 PerlMem_free(vmsout);
c5375c28 12541 PerlMem_free(ubf);
d584a1c6
JM		 12542 PerlMem_free(esa);
12543 if (esal != NULL)
12544 PerlMem_free(esal);
c5375c28 12545 PerlMem_free(rsa);
d584a1c6
JM		 12546 if (rsal != NULL)
12547 PerlMem_free(rsal);
c5375c28 12548 PerlMem_free(esa_out);
d584a1c6
JM		 12549 if (esal_out != NULL)
12550 PerlMem_free(esal_out);
12551 PerlMem_free(rsa_out);
12552 if (rsal_out != NULL)
12553 PerlMem_free(rsal_out);
a480973c
JM		 12554 set_errno(EVMSERR); set_vaxc_errno(sts);
12555 return 0;
12556 }
12557
12558 while ((sts = sys$read(&rab_in))) { /* always true */
12559 if (sts == RMS$_EOF) break;
12560 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12561 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12562 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12563 PerlMem_free(vmsin);
12564 PerlMem_free(vmsout);
c5375c28 12565 PerlMem_free(ubf);
d584a1c6
JM		 12566 PerlMem_free(esa);
12567 if (esal != NULL)
12568 PerlMem_free(esal);
c5375c28 12569 PerlMem_free(rsa);
d584a1c6
JM		 12570 if (rsal != NULL)
12571 PerlMem_free(rsal);
c5375c28 12572 PerlMem_free(esa_out);
d584a1c6
JM		 12573 if (esal_out != NULL)
12574 PerlMem_free(esal_out);
12575 PerlMem_free(rsa_out);
12576 if (rsal_out != NULL)
12577 PerlMem_free(rsal_out);
a480973c
JM		 12578 set_errno(EVMSERR); set_vaxc_errno(sts);
12579 return 0;
12580 }
12581 }
12582
12583
12584 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12585 sys$close(&fab_in); sys$close(&fab_out);
12586 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12587
c5375c28
JM		 12588 PerlMem_free(vmsin);
12589 PerlMem_free(vmsout);
c5375c28 12590 PerlMem_free(ubf);
d584a1c6
JM		 12591 PerlMem_free(esa);
12592 if (esal != NULL)
12593 PerlMem_free(esal);
c5375c28 12594 PerlMem_free(rsa);
d584a1c6
JM		 12595 if (rsal != NULL)
12596 PerlMem_free(rsal);
c5375c28 12597 PerlMem_free(esa_out);
d584a1c6
JM		 12598 if (esal_out != NULL)
12599 PerlMem_free(esal_out);
12600 PerlMem_free(rsa_out);
12601 if (rsal_out != NULL)
12602 PerlMem_free(rsal_out);
12603
12604 if (!(sts & 1)) {
12605 set_errno(EVMSERR); set_vaxc_errno(sts);
12606 return 0;
12607 }
12608
a480973c
JM		 12609 return 1;
12610
12611} /* end of rmscopy() */
a5f75d66
AD		 12612/*}}}*/
12613
12614
748a9306
LW		 12615/*** The following glue provides 'hooks' to make some of the routines
12616 * from this file available from Perl. These routines are sufficiently
12617 * basic, and are required sufficiently early in the build process,
12618 * that's it's nice to have them available to miniperl as well as the
12619 * full Perl, so they're set up here instead of in an extension. The
12620 * Perl code which handles importation of these names into a given
12621 * package lives in [.VMS]Filespec.pm in @INC.
12622 */
12623
12624void
5c84aa53 12625rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12626{
12627 dXSARGS;
bbce6d69 12628 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12629 STRLEN n_a;
360732b5 12630 int fs_utf8, dfs_utf8;
01b8edb6 12631
360732b5
JM		 12632 fs_utf8 = 0;
12633 dfs_utf8 = 0;
bbce6d69 12634 if (!items || items > 2)
5c84aa53 12635 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12636 fspec = SvPV(ST(0),n_a);
360732b5 12637 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12638 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12639 if (items == 2) {
12640 defspec = SvPV(ST(1),n_a);
12641 dfs_utf8 = SvUTF8(ST(1));
12642 }
12643 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12644 ST(0) = sv_newmortal();
360732b5
JM		 12645 if (rslt != NULL) {
12646 sv_usepvn(ST(0),rslt,strlen(rslt));
12647 if (fs_utf8) {
12648 SvUTF8_on(ST(0));
12649 }
12650 }
740ce14c 12651 XSRETURN(1);
01b8edb6 12652}
12653
12654void
5c84aa53 12655vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12656{
12657 dXSARGS;
12658 char *vmsified;
2d8e6c8d 12659 STRLEN n_a;
360732b5 12660 int utf8_fl;
748a9306 12661
5c84aa53 12662 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12663 utf8_fl = SvUTF8(ST(0));
12664 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12665 ST(0) = sv_newmortal();
360732b5
JM		 12666 if (vmsified != NULL) {
12667 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12668 if (utf8_fl) {
12669 SvUTF8_on(ST(0));
12670 }
12671 }
748a9306
LW		 12672 XSRETURN(1);
12673}
12674
12675void
5c84aa53 12676unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12677{
12678 dXSARGS;
12679 char *unixified;
2d8e6c8d 12680 STRLEN n_a;
360732b5 12681 int utf8_fl;
748a9306 12682
5c84aa53 12683 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12684 utf8_fl = SvUTF8(ST(0));
12685 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12686 ST(0) = sv_newmortal();
360732b5
JM		 12687 if (unixified != NULL) {
12688 sv_usepvn(ST(0),unixified,strlen(unixified));
12689 if (utf8_fl) {
12690 SvUTF8_on(ST(0));
12691 }
12692 }
748a9306
LW		 12693 XSRETURN(1);
12694}
12695
12696void
5c84aa53 12697fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12698{
12699 dXSARGS;
12700 char *fileified;
2d8e6c8d 12701 STRLEN n_a;
360732b5 12702 int utf8_fl;
748a9306 12703
5c84aa53 12704 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12705 utf8_fl = SvUTF8(ST(0));
12706 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12707 ST(0) = sv_newmortal();
360732b5
JM		 12708 if (fileified != NULL) {
12709 sv_usepvn(ST(0),fileified,strlen(fileified));
12710 if (utf8_fl) {
12711 SvUTF8_on(ST(0));
12712 }
12713 }
748a9306
LW		 12714 XSRETURN(1);
12715}
12716
12717void
5c84aa53 12718pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12719{
12720 dXSARGS;
12721 char *pathified;
2d8e6c8d 12722 STRLEN n_a;
360732b5 12723 int utf8_fl;
748a9306 12724
5c84aa53 12725 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12726 utf8_fl = SvUTF8(ST(0));
12727 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12728 ST(0) = sv_newmortal();
360732b5
JM		 12729 if (pathified != NULL) {
12730 sv_usepvn(ST(0),pathified,strlen(pathified));
12731 if (utf8_fl) {
12732 SvUTF8_on(ST(0));
12733 }
12734 }
748a9306
LW		 12735 XSRETURN(1);
12736}
12737
12738void
5c84aa53 12739vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12740{
12741 dXSARGS;
12742 char *vmspath;
2d8e6c8d 12743 STRLEN n_a;
360732b5 12744 int utf8_fl;
748a9306 12745
5c84aa53 12746 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12747 utf8_fl = SvUTF8(ST(0));
12748 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12749 ST(0) = sv_newmortal();
360732b5
JM		 12750 if (vmspath != NULL) {
12751 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12752 if (utf8_fl) {
12753 SvUTF8_on(ST(0));
12754 }
12755 }
748a9306
LW		 12756 XSRETURN(1);
12757}
12758
12759void
5c84aa53 12760unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12761{
12762 dXSARGS;
12763 char *unixpath;
2d8e6c8d 12764 STRLEN n_a;
360732b5 12765 int utf8_fl;
748a9306 12766
5c84aa53 12767 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12768 utf8_fl = SvUTF8(ST(0));
12769 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12770 ST(0) = sv_newmortal();
360732b5
JM		 12771 if (unixpath != NULL) {
12772 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12773 if (utf8_fl) {
12774 SvUTF8_on(ST(0));
12775 }
12776 }
748a9306
LW		 12777 XSRETURN(1);
12778}
12779
12780void
5c84aa53 12781candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12782{
12783 dXSARGS;
988c775c 12784 char *fspec, *fsp;
a5f75d66
AD		 12785 SV *mysv;
12786 IO *io;
2d8e6c8d 12787 STRLEN n_a;
748a9306 12788
5c84aa53 12789 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12790
12791 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12792 Newx(fspec, VMS_MAXRSS, char);
12793 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
6d24fbd1 12794 if (isGV_with_GP(mysv)) {
a15cef0c 12795 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12796 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12797 ST(0) = &PL_sv_no;
988c775c 12798 Safefree(fspec);
a5f75d66
AD		 12799 XSRETURN(1);
12800 }
12801 fsp = fspec;
12802 }
12803 else {
2d8e6c8d 12804 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 12805 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12806 ST(0) = &PL_sv_no;
988c775c 12807 Safefree(fspec);
a5f75d66
AD		 12808 XSRETURN(1);
12809 }
12810 }
12811
54310121 12812 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12813 Safefree(fspec);
a5f75d66
AD		 12814 XSRETURN(1);
12815}
12816
12817void
5c84aa53 12818rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12819{
12820 dXSARGS;
a480973c 12821 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12822 int date_flag;
a5f75d66
AD		 12823 SV *mysv;
12824 IO *io;
2d8e6c8d 12825 STRLEN n_a;
a5f75d66 12826
a3e9d8c9 12827 if (items < 2 || items > 3)
5c84aa53 12828 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12829
12830 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12831 Newx(inspec, VMS_MAXRSS, char);
6d24fbd1 12832 if (isGV_with_GP(mysv)) {
a15cef0c 12833 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12834 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12835 ST(0) = sv_2mortal(newSViv(0));
a480973c 12836 Safefree(inspec);
a5f75d66
AD		 12837 XSRETURN(1);
12838 }
12839 inp = inspec;
12840 }
12841 else {
2d8e6c8d 12842 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 12843 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12844 ST(0) = sv_2mortal(newSViv(0));
a480973c 12845 Safefree(inspec);
a5f75d66
AD		 12846 XSRETURN(1);
12847 }
12848 }
12849 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12850 Newx(outspec, VMS_MAXRSS, char);
6d24fbd1 12851 if (isGV_with_GP(mysv)) {
a15cef0c 12852 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12853 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12854 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12855 Safefree(inspec);
12856 Safefree(outspec);
a5f75d66
AD		 12857 XSRETURN(1);
12858 }
12859 outp = outspec;
12860 }
12861 else {
2d8e6c8d 12862 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12863 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12864 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12865 Safefree(inspec);
12866 Safefree(outspec);
a5f75d66
AD		 12867 XSRETURN(1);
12868 }
12869 }
a3e9d8c9 12870 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12871
fd188159 12872 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
a480973c
JM		 12873 Safefree(inspec);
12874 Safefree(outspec);
748a9306
LW		 12875 XSRETURN(1);
12876}
12877
a480973c
JM		 12878/* The mod2fname is limited to shorter filenames by design, so it should
12879 * not be modified to support longer EFS pathnames
12880 */
4b19af01 12881void
fd8cd3a3 12882mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12883{
12884 dXSARGS;
12885 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12886 workbuff[NAM$C_MAXRSS*1 + 1];
c70927a6 12887 SSize_t counter, num_entries;
4b19af01
CB		 12888 /* ODS-5 ups this, but we want to be consistent, so... */
12889 int max_name_len = 39;
12890 AV *in_array = (AV *)SvRV(ST(0));
12891
b9f2b683 12892 num_entries = av_tindex(in_array);
4b19af01
CB		 12893
12894 /* All the names start with PL_. */
12895 strcpy(ultimate_name, "PL_");
12896
12897 /* Clean up our working buffer */
12898 Zero(work_name, sizeof(work_name), char);
12899
12900 /* Run through the entries and build up a working name */
12901 for(counter = 0; counter <= num_entries; counter++) {
12902 /* If it's not the first name then tack on a __ */
12903 if (counter) {
a35dcc95 12904 my_strlcat(work_name, "__", sizeof(work_name));
4b19af01 12905 }
a35dcc95 12906 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
4b19af01
CB		 12907 }
12908
12909 /* Check to see if we actually have to bother...*/
12910 if (strlen(work_name) + 3 <= max_name_len) {
a35dcc95 12911 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12912 } else {
12913 /* It's too darned big, so we need to go strip. We use the same */
12914 /* algorithm as xsubpp does. First, strip out doubled __ */
12915 char *source, *dest, last;
12916 dest = workbuff;
12917 last = 0;
12918 for (source = work_name; *source; source++) {
12919 if (last == *source && last == '_') {
12920 continue;
12921 }
12922 *dest++ = *source;
12923 last = *source;
12924 }
12925 /* Go put it back */
a35dcc95 12926 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12927 /* Is it still too big? */
12928 if (strlen(work_name) + 3 > max_name_len) {
12929 /* Strip duplicate letters */
12930 last = 0;
12931 dest = workbuff;
12932 for (source = work_name; *source; source++) {
30048647 12933 if (last == toUPPER_A(*source)) {
4b19af01
CB		 12934 continue;
12935 }
12936 *dest++ = *source;
30048647 12937 last = toUPPER_A(*source);
4b19af01 12938 }
a35dcc95 12939 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12940 }
12941
12942 /* Is it *still* too big? */
12943 if (strlen(work_name) + 3 > max_name_len) {
12944 /* Too bad, we truncate */
12945 work_name[max_name_len - 2] = 0;
12946 }
a35dcc95 12947 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12948 }
12949
12950 /* Okay, return it */
12951 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12952 XSRETURN(1);
12953}
12954
748a9306 12955void
96e176bf
CL		 12956hushexit_fromperl(pTHX_ CV *cv)
12957{
12958 dXSARGS;
12959
12960 if (items > 0) {
12961 VMSISH_HUSHED = SvTRUE(ST(0));
12962 }
12963 ST(0) = boolSV(VMSISH_HUSHED);
12964 XSRETURN(1);
12965}
12966
dca5a913
JM		 12967
12968PerlIO *
ce12d4b7 12969Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
dca5a913
JM		 12970{
12971 PerlIO *fp;
12972 struct vs_str_st *rslt;
12973 char *vmsspec;
12974 char *rstr;
12975 char *begin, *cp;
12976 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12977 PerlIO *tmpfp;
12978 STRLEN i;
12979 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12980 struct dsc$descriptor_vs rsdsc;
12981 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12982 unsigned long hasver = 0, isunix = 0;
12983 unsigned long int lff_flags = 0;
12984 int rms_sts;
85e7c9de 12985 int vms_old_glob = 1;
dca5a913 12986
83b907a4
CB		 12987 if (!SvOK(tmpglob)) {
12988 SETERRNO(ENOENT,RMS$_FNF);
12989 return NULL;
12990 }
12991
1d60dc3f 12992 vms_old_glob = !DECC_FILENAME_UNIX_REPORT;
85e7c9de 12993
dca5a913
JM		 12994#ifdef VMS_LONGNAME_SUPPORT
12995 lff_flags = LIB$M_FIL_LONG_NAMES;
12996#endif
12997 /* The Newx macro will not allow me to assign a smaller array
12998 * to the rslt pointer, so we will assign it to the begin char pointer
12999 * and then copy the value into the rslt pointer.
13000 */
13001 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13002 rslt = (struct vs_str_st *)begin;
13003 rslt->length = 0;
13004 rstr = &rslt->str[0];
13005 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13006 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13007 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13008 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13009
13010 Newx(vmsspec, VMS_MAXRSS, char);
13011
13012 /* We could find out if there's an explicit dev/dir or version
13013 by peeking into lib$find_file's internal context at
13014 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13015 but that's unsupported, so I don't want to do it now and
13016 have it bite someone in the future. */
13017 /* Fix-me: vms_split_path() is the only way to do this, the
13018 existing method will fail with many legal EFS or UNIX specifications
13019 */
13020
13021 cp = SvPV(tmpglob,i);
13022
13023 for (; i; i--) {
13024 if (cp[i] == ';') hasver = 1;
13025 if (cp[i] == '.') {
13026 if (sts) hasver = 1;
13027 else sts = 1;
13028 }
13029 if (cp[i] == '/') {
13030 hasdir = isunix = 1;
13031 break;
13032 }
13033 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13034 hasdir = 1;
13035 break;
13036 }
13037 }
85e7c9de
JM		 13038
13039 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
1d60dc3f 13040 if ((hasdir == 0) && DECC_FILENAME_UNIX_REPORT) {
85e7c9de
JM		 13041 isunix = 1;
13042 }
13043
dca5a913 13044 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
85e7c9de
JM		 13045 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13046 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13047 int wildstar = 0;
13048 int wildquery = 0;
990cad08 13049 int found = 0;
dca5a913
JM		 13050 Stat_t st;
13051 int stat_sts;
13052 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13053 if (!stat_sts && S_ISDIR(st.st_mode)) {
85e7c9de
JM		 13054 char * vms_dir;
13055 const char * fname;
13056 STRLEN fname_len;
13057
13058 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13059 /* path delimiter of ':>]', if so, then the old behavior has */
94ae10c0 13060 /* obviously been specifically requested */
85e7c9de
JM		 13061
13062 fname = SvPVX_const(tmpglob);
13063 fname_len = strlen(fname);
13064 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13065 if (vms_old_glob || (vms_dir != NULL)) {
13066 wilddsc.dsc$a_pointer = tovmspath_utf8(
13067 SvPVX(tmpglob),vmsspec,NULL);
13068 ok = (wilddsc.dsc$a_pointer != NULL);
13069 /* maybe passed 'foo' rather than '[.foo]', thus not
13070 detected above */
13071 hasdir = 1;
13072 } else {
13073 /* Operate just on the directory, the special stat/fstat for */
13074 /* leaves the fileified specification in the st_devnam */
13075 /* member. */
13076 wilddsc.dsc$a_pointer = st.st_devnam;
13077 ok = 1;
13078 }
dca5a913
JM		 13079 }
13080 else {
360732b5 13081 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 13082 ok = (wilddsc.dsc$a_pointer != NULL);
13083 }
13084 if (ok)
13085 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13086
13087 /* If not extended character set, replace ? with % */
13088 /* With extended character set, ? is a wildcard single character */
85e7c9de
JM		 13089 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13090 if (*cp == '?') {
13091 wildquery = 1;
1d60dc3f 13092 if (!DECC_EFS_CHARSET)
85e7c9de
JM		 13093 *cp = '%';
13094 } else if (*cp == '%') {
13095 wildquery = 1;
13096 } else if (*cp == '*') {
13097 wildstar = 1;
13098 }
dca5a913 13099 }
85e7c9de
JM		 13100
13101 if (ok) {
13102 wv_sts = vms_split_path(
13103 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13104 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13105 &wvs_spec, &wvs_len);
13106 } else {
13107 wn_spec = NULL;
13108 wn_len = 0;
13109 we_spec = NULL;
13110 we_len = 0;
13111 }
13112
dca5a913
JM		 13113 sts = SS$_NORMAL;
13114 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13115 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13116 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
85e7c9de 13117 int valid_find;
dca5a913 13118
85e7c9de 13119 valid_find = 0;
dca5a913
JM		 13120 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13121 &dfltdsc,NULL,&rms_sts,&lff_flags);
13122 if (!$VMS_STATUS_SUCCESS(sts))
13123 break;
13124
13125 /* with varying string, 1st word of buffer contains result length */
13126 rstr[rslt->length] = '\0';
13127
13128 /* Find where all the components are */
13129 v_sts = vms_split_path
360732b5 13130 (rstr,
dca5a913
JM		 13131 &v_spec,
13132 &v_len,
13133 &r_spec,
13134 &r_len,
13135 &d_spec,
13136 &d_len,
13137 &n_spec,
13138 &n_len,
13139 &e_spec,
13140 &e_len,
13141 &vs_spec,
13142 &vs_len);
13143
13144 /* If no version on input, truncate the version on output */
13145 if (!hasver && (vs_len > 0)) {
13146 *vs_spec = '\0';
13147 vs_len = 0;
85e7c9de
JM		 13148 }
13149
13150 if (isunix) {
13151
13152 /* In Unix report mode, remove the ".dir;1" from the name */
13153 /* if it is a real directory */
1d60dc3f 13154 if (DECC_FILENAME_UNIX_REPORT && DECC_EFS_CHARSET) {
85e7c9de
JM		 13155 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13156 Stat_t statbuf;
13157 int ret_sts;
13158
13159 ret_sts = flex_lstat(rstr, &statbuf);
13160 if ((ret_sts == 0) &&
13161 S_ISDIR(statbuf.st_mode)) {
13162 e_len = 0;
13163 e_spec[0] = 0;
13164 }
13165 }
13166 }
dca5a913
JM		 13167
13168 /* No version & a null extension on UNIX handling */
1d60dc3f 13169 if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
dca5a913
JM		 13170 e_len = 0;
13171 *e_spec = '\0';
13172 }
13173 }
13174
1d60dc3f 13175 if (!DECC_EFS_CASE_PRESERVE) {
30048647 13176 for (cp = rstr; *cp; cp++) *cp = toLOWER_L1(*cp);
dca5a913
JM		 13177 }
13178
85e7c9de
JM		 13179 /* Find File treats a Null extension as return all extensions */
13180 /* This is contrary to Perl expectations */
13181
13182 if (wildstar || wildquery || vms_old_glob) {
13183 /* really need to see if the returned file name matched */
13184 /* but for now will assume that it matches */
13185 valid_find = 1;
13186 } else {
13187 /* Exact Match requested */
13188 /* How are directories handled? - like a file */
13189 if ((e_len == we_len) && (n_len == wn_len)) {
13190 int t1;
13191 t1 = e_len;
13192 if (t1 > 0)
13193 t1 = strncmp(e_spec, we_spec, e_len);
13194 if (t1 == 0) {
13195 t1 = n_len;
13196 if (t1 > 0)
13197 t1 = strncmp(n_spec, we_spec, n_len);
13198 if (t1 == 0)
13199 valid_find = 1;
13200 }
13201 }
13202 }
13203
13204 if (valid_find) {
13205 found++;
13206
13207 if (hasdir) {
13208 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13209 begin = rstr;
13210 }
13211 else {
13212 /* Start with the name */
13213 begin = n_spec;
13214 }
13215 strcat(begin,"\n");
13216 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13217 }
dca5a913
JM		 13218 }
13219 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 13220
13221 if (!found) {
13222 /* Be POSIXish: return the input pattern when no matches */
a35dcc95 13223 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
2da7a6b5
CB		 13224 strcat(rstr,"\n");
13225 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 13226 }
13227
dca5a913
JM		 13228 if (ok && sts != RMS$_NMF &&
13229 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13230 if (!ok) {
13231 if (!(sts & 1)) {
13232 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13233 }
13234 PerlIO_close(tmpfp);
13235 fp = NULL;
13236 }
13237 else {
13238 PerlIO_rewind(tmpfp);
13239 IoTYPE(io) = IoTYPE_RDONLY;
13240 IoIFP(io) = fp = tmpfp;
13241 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13242 }
13243 }
13244 Safefree(vmsspec);
13245 Safefree(rslt);
13246 return fp;
13247}
13248
cd1191f1 13249
2497a41f 13250static char *
5c4d031a 13251mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 13252 int *utf8_fl);
2497a41f
JM		 13253
13254void
4d8d3a9c 13255unixrealpath_fromperl(pTHX_ CV *cv)
2497a41f 13256{
d584a1c6
JM		 13257 dXSARGS;
13258 char *fspec, *rslt_spec, *rslt;
13259 STRLEN n_a;
2497a41f 13260
d584a1c6 13261 if (!items || items != 1)
4d8d3a9c 13262 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
2497a41f 13263
d584a1c6
JM		 13264 fspec = SvPV(ST(0),n_a);
13265 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 13266
d584a1c6
JM		 13267 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13268 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13269
13270 ST(0) = sv_newmortal();
13271 if (rslt != NULL)
13272 sv_usepvn(ST(0),rslt,strlen(rslt));
13273 else
13274 Safefree(rslt_spec);
13275 XSRETURN(1);
2497a41f 13276}
2ee6e19d 13277
b1a8dcd7
JM		 13278static char *
13279mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13280 int *utf8_fl);
13281
13282void
4d8d3a9c 13283vmsrealpath_fromperl(pTHX_ CV *cv)
b1a8dcd7
JM		 13284{
13285 dXSARGS;
13286 char *fspec, *rslt_spec, *rslt;
13287 STRLEN n_a;
13288
13289 if (!items || items != 1)
4d8d3a9c 13290 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
b1a8dcd7
JM		 13291
13292 fspec = SvPV(ST(0),n_a);
13293 if (!fspec || !*fspec) XSRETURN_UNDEF;
13294
13295 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13296 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13297
13298 ST(0) = sv_newmortal();
13299 if (rslt != NULL)
13300 sv_usepvn(ST(0),rslt,strlen(rslt));
13301 else
13302 Safefree(rslt_spec);
13303 XSRETURN(1);
13304}
13305
13306#ifdef HAS_SYMLINK
2ee6e19d
CB		 13307/*
13308 * A thin wrapper around decc$symlink to make sure we follow the
cc9aafbd
CB		 13309 * standard and do not create a symlink with a zero-length name,
13310 * and convert the target to Unix format, as the CRTL can't handle
13311 * targets in VMS format.
2ee6e19d 13312 */
4148925f 13313/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
cc9aafbd
CB		 13314int
13315Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13316{
13317 int sts;
13318 char * utarget;
4148925f 13319
cc9aafbd
CB		 13320 if (!link_name || !*link_name) {
13321 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13322 return -1;
13323 }
4148925f 13324
c11536f5 13325 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
cc9aafbd
CB		 13326 /* An untranslatable filename should be passed through. */
13327 (void) int_tounixspec(contents, utarget, NULL);
13328 sts = symlink(utarget, link_name);
13329 PerlMem_free(utarget);
13330 return sts;
2ee6e19d
CB		 13331}
13332/*}}}*/
13333
13334#endif /* HAS_SYMLINK */
2497a41f 13335
2497a41f
JM		 13336int do_vms_case_tolerant(void);
13337
13338void
4d8d3a9c 13339case_tolerant_process_fromperl(pTHX_ CV *cv)
2497a41f
JM		 13340{
13341 dXSARGS;
13342 ST(0) = boolSV(do_vms_case_tolerant());
13343 XSRETURN(1);
13344}
2497a41f 13345
9ec7171b
CB		 13346#ifdef USE_ITHREADS
13347
96e176bf
CL		 13348void
13349Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13350 struct interp_intern *dst)
13351{
7918f24d
NC		 13352 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13353
96e176bf
CL		 13354 memcpy(dst,src,sizeof(struct interp_intern));
13355}
13356
9ec7171b
CB		 13357#endif
13358
96e176bf
CL		 13359void
13360Perl_sys_intern_clear(pTHX)
13361{
13362}
13363
13364void
13365Perl_sys_intern_init(pTHX)
13366{
3ff49832
CL		 13367 unsigned int ix = RAND_MAX;
13368 double x;
96e176bf
CL		 13369
13370 VMSISH_HUSHED = 0;
13371
1a3aec58 13372 MY_POSIX_EXIT = vms_posix_exit;
7a7fd8e0 13373
96e176bf
CL		 13374 x = (float)ix;
13375 MY_INV_RAND_MAX = 1./x;
ff7adb52 13376}
96e176bf
CL		 13377
13378void
f7ddb74a 13379init_os_extras(void)
748a9306 13380{
a69a6dba 13381 dTHX;
748a9306 13382 char* file = __FILE__;
1d60dc3f 13383 if (DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION) {
93948341
CB		 13384 no_translate_barewords = TRUE;
13385 } else {
13386 no_translate_barewords = FALSE;
13387 }
748a9306 13388
740ce14c 13389 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13390 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13391 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13392 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13393 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13394 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13395 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13396 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13397 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13398 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13399 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
4d8d3a9c
CB		 13400 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13401 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13402 newXSproto("VMS::Filespec::case_tolerant_process",
13403 case_tolerant_process_fromperl,file,"");
17f28c40 13404
afd8f436 13405 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13406
748a9306
LW		 13407 return;
13408}
13409
f7ddb74a
JM		 13410#if __CRTL_VER == 80200000
13411/* This missed getting in to the DECC SDK for 8.2 */
13412char *realpath(const char *file_name, char * resolved_name, ...);
13413#endif
13414
13415/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13416/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13417 * The perl fallback routine to provide realpath() is not as efficient
13418 * on OpenVMS.
13419 */
d584a1c6 13420
c11536f5
CB		 13421#ifdef __cplusplus
13422extern "C" {
13423#endif
13424
d584a1c6
JM		 13425/* Hack, use old stat() as fastest way of getting ino_t and device */
13426int decc$stat(const char *name, void * statbuf);
054a3baf 13427#if __CRTL_VER >= 80200000
312ac60b
JM		 13428int decc$lstat(const char *name, void * statbuf);
13429#else
13430#define decc$lstat decc$stat
13431#endif
d584a1c6 13432
c11536f5
CB		 13433#ifdef __cplusplus
13434}
13435#endif
13436
d584a1c6
JM		 13437
13438/* Realpath is fragile. In 8.3 it does not work if the feature
13439 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13440 * links are implemented in RMS, not the CRTL. It also can fail if the
13441 * user does not have read/execute access to some of the directories.
13442 * So in order for Do What I Mean mode to work, if realpath() fails,
13443 * fall back to looking up the filename by the device name and FID.
13444 */
13445
312ac60b
JM		 13446int vms_fid_to_name(char * outname, int outlen,
13447 const char * name, int lstat_flag, mode_t * mode)
d584a1c6 13448{
312ac60b
JM		 13449#pragma message save
13450#pragma message disable MISALGNDSTRCT
13451#pragma message disable MISALGNDMEM
13452#pragma member_alignment save
13453#pragma nomember_alignment
ce12d4b7
CB		 13454 struct statbuf_t {
13455 char * st_dev;
13456 unsigned short st_ino[3];
13457 unsigned short old_st_mode;
13458 unsigned long padl[30]; /* plenty of room */
13459 } statbuf;
312ac60b
JM		 13460#pragma message restore
13461#pragma member_alignment restore
13462
13463 int sts;
13464 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13465 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13466 char *fileified;
13467 char *temp_fspec;
13468 char *ret_spec;
13469
13470 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13471 * unexpected answers
13472 */
13473
c11536f5 13474 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13475 if (fileified == NULL)
13476 _ckvmssts_noperl(SS$_INSFMEM);
13477
c11536f5 13478 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13479 if (temp_fspec == NULL)
13480 _ckvmssts_noperl(SS$_INSFMEM);
13481
13482 sts = -1;
13483 /* First need to try as a directory */
13484 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13485 if (ret_spec != NULL) {
13486 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13487 if (ret_spec != NULL) {
13488 if (lstat_flag == 0)
13489 sts = decc$stat(fileified, &statbuf);
13490 else
13491 sts = decc$lstat(fileified, &statbuf);
13492 }
13493 }
13494
13495 /* Then as a VMS file spec */
13496 if (sts != 0) {
13497 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13498 if (ret_spec != NULL) {
13499 if (lstat_flag == 0) {
13500 sts = decc$stat(temp_fspec, &statbuf);
13501 } else {
13502 sts = decc$lstat(temp_fspec, &statbuf);
13503 }
13504 }
13505 }
13506
13507 if (sts) {
13508 /* Next try - allow multiple dots with out EFS CHARSET */
13509 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13510 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13511 * enable it if it isn't already.
13512 */
1d60dc3f
CB		 13513 if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
13514 decc$feature_set_value(efs_charset_index, 1, 1);
312ac60b
JM		 13515 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13516 if (lstat_flag == 0) {
13517 sts = decc$stat(name, &statbuf);
13518 } else {
13519 sts = decc$lstat(name, &statbuf);
13520 }
1d60dc3f
CB		 13521 if (!DECC_EFS_CHARSET && (efs_charset_index > 0))
13522 decc$feature_set_value(efs_charset_index, 1, 0);
312ac60b
JM		 13523 }
13524
13525
13526 /* and then because the Perl Unix to VMS conversion is not perfect */
13527 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13528 /* characters from filenames so we need to try it as-is */
13529 if (sts) {
13530 if (lstat_flag == 0) {
13531 sts = decc$stat(name, &statbuf);
13532 } else {
13533 sts = decc$lstat(name, &statbuf);
13534 }
13535 }
d584a1c6 13536
d584a1c6 13537 if (sts == 0) {
312ac60b 13538 int vms_sts;
d584a1c6
JM		 13539
13540 dvidsc.dsc$a_pointer=statbuf.st_dev;
d94c5a78 13541 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
d584a1c6
JM		 13542
13543 specdsc.dsc$a_pointer = outname;
13544 specdsc.dsc$w_length = outlen-1;
13545
d94c5a78 13546 vms_sts = lib$fid_to_name
d584a1c6 13547 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
d94c5a78 13548 if ($VMS_STATUS_SUCCESS(vms_sts)) {
d584a1c6 13549 outname[specdsc.dsc$w_length] = 0;
312ac60b
JM		 13550
13551 /* Return the mode */
13552 if (mode) {
13553 *mode = statbuf.old_st_mode;
13554 }
d584a1c6
JM		 13555 }
13556 }
9e2bec02
CB		 13557 PerlMem_free(temp_fspec);
13558 PerlMem_free(fileified);
d584a1c6
JM		 13559 return sts;
13560}
13561
13562
13563
f7ddb74a 13564static char *
5c4d031a 13565mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13566 int *utf8_fl)
f7ddb74a 13567{
d584a1c6
JM		 13568 char * rslt = NULL;
13569
b1a8dcd7 13570#ifdef HAS_SYMLINK
1d60dc3f 13571 if (DECC_POSIX_COMPLIANT_PATHNAMES) {
b1a8dcd7
JM		 13572 /* realpath currently only works if posix compliant pathnames are
13573 * enabled. It may start working when they are not, but in that
13574 * case we still want the fallback behavior for backwards compatibility
13575 */
d584a1c6 13576 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13577 }
13578#endif
d584a1c6
JM		 13579
13580 if (rslt == NULL) {
13581 char * vms_spec;
13582 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13583 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
312ac60b 13584 mode_t my_mode;
d584a1c6
JM		 13585
13586 /* Fall back to fid_to_name */
13587
13588 Newx(vms_spec, VMS_MAXRSS + 1, char);
13589
312ac60b 13590 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
4d8d3a9c 13591 if (sts == 0) {
d584a1c6
JM		 13592
13593
13594 /* Now need to trim the version off */
13595 sts = vms_split_path
13596 (vms_spec,
13597 &v_spec,
13598 &v_len,
13599 &r_spec,
13600 &r_len,
13601 &d_spec,
13602 &d_len,
13603 &n_spec,
13604 &n_len,
13605 &e_spec,
13606 &e_len,
13607 &vs_spec,
13608 &vs_len);
13609
13610
4d8d3a9c
CB		 13611 if (sts == 0) {
13612 int haslower = 0;
13613 const char *cp;
d584a1c6 13614
4d8d3a9c
CB		 13615 /* Trim off the version */
13616 int file_len = v_len + r_len + d_len + n_len + e_len;
13617 vms_spec[file_len] = 0;
d584a1c6 13618
f785e3a1
JM		 13619 /* Trim off the .DIR if this is a directory */
13620 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13621 if (S_ISDIR(my_mode)) {
13622 e_len = 0;
13623 e_spec[0] = 0;
13624 }
13625 }
13626
13627 /* Drop NULL extensions on UNIX file specification */
1d60dc3f 13628 if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) {
f785e3a1
JM		 13629 e_len = 0;
13630 e_spec[0] = '\0';
13631 }
13632
4d8d3a9c 13633 /* The result is expected to be in UNIX format */
0e5ce2c7 13634 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
4d8d3a9c
CB		 13635
13636 /* Downcase if input had any lower case letters and
13637 * case preservation is not in effect.
13638 */
1d60dc3f 13639 if (!DECC_EFS_CASE_PRESERVE) {
4d8d3a9c
CB		 13640 for (cp = filespec; *cp; cp++)
13641 if (islower(*cp)) { haslower = 1; break; }
13642
13643 if (haslower) __mystrtolower(rslt);
13644 }
13645 }
643f470b
CB		 13646 } else {
13647
13648 /* Now for some hacks to deal with backwards and forward */
94ae10c0 13649 /* compatibility */
1d60dc3f 13650 if (!DECC_EFS_CHARSET) {
643f470b
CB		 13651
13652 /* 1. ODS-2 mode wants to do a syntax only translation */
6fb6c614
JM		 13653 rslt = int_rmsexpand(filespec, outbuf,
13654 NULL, 0, NULL, utf8_fl);
643f470b
CB		 13655
13656 } else {
1d60dc3f 13657 if (DECC_FILENAME_UNIX_REPORT) {
643f470b
CB		 13658 char * dir_name;
13659 char * vms_dir_name;
13660 char * file_name;
13661
13662 /* 2. ODS-5 / UNIX report mode should return a failure */
13663 /* if the parent directory also does not exist */
13664 /* Otherwise, get the real path for the parent */
29475144 13665 /* and add the child to it. */
643f470b
CB		 13666
13667 /* basename / dirname only available for VMS 7.0+ */
13668 /* So we may need to implement them as common routines */
13669
13670 Newx(dir_name, VMS_MAXRSS + 1, char);
13671 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13672 dir_name[0] = '\0';
13673 file_name = NULL;
13674
13675 /* First try a VMS parse */
13676 sts = vms_split_path
13677 (filespec,
13678 &v_spec,
13679 &v_len,
13680 &r_spec,
13681 &r_len,
13682 &d_spec,
13683 &d_len,
13684 &n_spec,
13685 &n_len,
13686 &e_spec,
13687 &e_len,
13688 &vs_spec,
13689 &vs_len);
13690
13691 if (sts == 0) {
13692 /* This is VMS */
13693
13694 int dir_len = v_len + r_len + d_len + n_len;
13695 if (dir_len > 0) {
a35dcc95 13696 memcpy(dir_name, filespec, dir_len);
643f470b
CB		 13697 dir_name[dir_len] = '\0';
13698 file_name = (char *)&filespec[dir_len + 1];
13699 }
13700 } else {
13701 /* This must be UNIX */
13702 char * tchar;
13703
13704 tchar = strrchr(filespec, '/');
13705
4148925f
JM		 13706 if (tchar != NULL) {
13707 int dir_len = tchar - filespec;
a35dcc95 13708 memcpy(dir_name, filespec, dir_len);
4148925f
JM		 13709 dir_name[dir_len] = '\0';
13710 file_name = (char *) &filespec[dir_len + 1];
13711 }
13712 }
13713
13714 /* Dir name is defaulted */
13715 if (dir_name[0] == 0) {
13716 dir_name[0] = '.';
13717 dir_name[1] = '\0';
13718 }
13719
13720 /* Need realpath for the directory */
13721 sts = vms_fid_to_name(vms_dir_name,
13722 VMS_MAXRSS + 1,
312ac60b 13723 dir_name, 0, NULL);
4148925f
JM		 13724
13725 if (sts == 0) {
29475144 13726 /* Now need to pathify it. */
1fe570cc
JM		 13727 char *tdir = int_pathify_dirspec(vms_dir_name,
13728 outbuf);
4148925f
JM		 13729
13730 /* And now add the original filespec to it */
13731 if (file_name != NULL) {
a35dcc95 13732 my_strlcat(outbuf, file_name, VMS_MAXRSS);
4148925f
JM		 13733 }
13734 return outbuf;
13735 }
13736 Safefree(vms_dir_name);
13737 Safefree(dir_name);
13738 }
13739 }
643f470b 13740 }
d584a1c6
JM		 13741 Safefree(vms_spec);
13742 }
13743 return rslt;
f7ddb74a
JM		 13744}
13745
b1a8dcd7
JM		 13746static char *
13747mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13748 int *utf8_fl)
13749{
13750 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13751 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
b1a8dcd7
JM		 13752
13753 /* Fall back to fid_to_name */
13754
312ac60b 13755 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
cd43acd7
CB		 13756 if (sts != 0) {
13757 return NULL;
13758 }
13759 else {
b1a8dcd7
JM		 13760
13761
13762 /* Now need to trim the version off */
13763 sts = vms_split_path
13764 (outbuf,
13765 &v_spec,
13766 &v_len,
13767 &r_spec,
13768 &r_len,
13769 &d_spec,
13770 &d_len,
13771 &n_spec,
13772 &n_len,
13773 &e_spec,
13774 &e_len,
13775 &vs_spec,
13776 &vs_len);
13777
13778
13779 if (sts == 0) {
4d8d3a9c
CB		 13780 int haslower = 0;
13781 const char *cp;
13782
13783 /* Trim off the version */
13784 int file_len = v_len + r_len + d_len + n_len + e_len;
13785 outbuf[file_len] = 0;
b1a8dcd7 13786
4d8d3a9c
CB		 13787 /* Downcase if input had any lower case letters and
13788 * case preservation is not in effect.
13789 */
1d60dc3f 13790 if (!DECC_EFS_CASE_PRESERVE) {
4d8d3a9c
CB		 13791 for (cp = filespec; *cp; cp++)
13792 if (islower(*cp)) { haslower = 1; break; }
13793
13794 if (haslower) __mystrtolower(outbuf);
13795 }
b1a8dcd7
JM		 13796 }
13797 }
13798 return outbuf;
13799}
13800
13801
f7ddb74a
JM		 13802/*}}}*/
13803/* External entry points */
ce12d4b7
CB		 13804char *
13805Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13806{
13807 return do_vms_realpath(filespec, outbuf, utf8_fl);
13808}
f7ddb74a 13809
ce12d4b7
CB		 13810char *
13811Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13812{
13813 return do_vms_realname(filespec, outbuf, utf8_fl);
13814}
f7ddb74a 13815
f7ddb74a
JM		 13816/* case_tolerant */
13817
13818/*{{{int do_vms_case_tolerant(void)*/
13819/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13820 * controlled by a process setting.
13821 */
ce12d4b7
CB		 13822int
13823do_vms_case_tolerant(void)
f7ddb74a
JM		 13824{
13825 return vms_process_case_tolerant;
13826}
13827/*}}}*/
13828/* External entry points */
ce12d4b7
CB		 13829int
13830Perl_vms_case_tolerant(void)
13831{
ce12d4b7 13832 return do_vms_case_tolerant();
ce12d4b7 13833}
f7ddb74a
JM		 13834
13835 /* Start of DECC RTL Feature handling */
13836
4ddecfe9
CB		 13837static int
13838set_feature_default(const char *name, int value)
13839{
13840 int status;
13841 int index;
25d1c58b
CB		 13842 char val_str[10];
13843
13844 /* If the feature has been explicitly disabled in the environment,
13845 * then don't enable it here.
13846 */
13847 if (value > 0) {
13848 status = simple_trnlnm(name, val_str, sizeof(val_str));
9bd30c63 13849 if (status) {
30048647 13850 val_str[0] = toUPPER_A(val_str[0]);
25d1c58b
CB		 13851 if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13852 return 0;
13853 }
13854 }
4ddecfe9
CB		 13855
13856 index = decc$feature_get_index(name);
13857
13858 status = decc$feature_set_value(index, 1, value);
13859 if (index == -1 || (status == -1)) {
13860 return -1;
13861 }
13862
13863 status = decc$feature_get_value(index, 1);
13864 if (status != value) {
13865 return -1;
13866 }
13867
13868 /* Various things may check for an environment setting
13869 * rather than the feature directly, so set that too.
13870 */
13871 vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13872
13873 return 0;
13874}
4ddecfe9 13875
f7ddb74a 13876
f7ddb74a
JM		 13877/* C RTL Feature settings */
13878
e2367aa8
CB		 13879#if defined(__DECC) || defined(__DECCXX)
13880
13881#ifdef __cplusplus
13882extern "C" {
13883#endif
13884
13885extern void
13886vmsperl_set_features(void)
f7ddb74a 13887{
1d60dc3f 13888 int status, initial;
f7ddb74a 13889 int s;
1d60dc3f 13890 char val_str[LNM$C_NAMLENGTH+1];
054a3baf 13891#if defined(JPI$_CASE_LOOKUP_PERM)
f7ddb74a
JM		 13892 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13893 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13894 unsigned long case_perm;
13895 unsigned long case_image;
3c841f20 13896#endif
f7ddb74a 13897
9c1171d1
JM		 13898 /* Allow an exception to bring Perl into the VMS debugger */
13899 vms_debug_on_exception = 0;
8dc9d339 13900 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
9bd30c63 13901 if (status) {
30048647 13902 val_str[0] = toUPPER_A(val_str[0]);
9c1171d1
JM		 13903 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13904 vms_debug_on_exception = 1;
13905 else
13906 vms_debug_on_exception = 0;
13907 }
13908
b53f3677
JM		 13909 /* Debug unix/vms file translation routines */
13910 vms_debug_fileify = 0;
8dc9d339 13911 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
9bd30c63 13912 if (status) {
30048647 13913 val_str[0] = toUPPER_A(val_str[0]);
b53f3677
JM		 13914 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13915 vms_debug_fileify = 1;
13916 else
13917 vms_debug_fileify = 0;
13918 }
13919
13920
13921 /* Historically PERL has been doing vmsify / stat differently than */
13922 /* the CRTL. In particular, under some conditions the CRTL will */
13923 /* remove some illegal characters like spaces from filenames */
13924 /* resulting in some differences. The stat()/lstat() wrapper has */
13925 /* been reporting such file names as invalid and fails to stat them */
13926 /* fixing this bug so that stat()/lstat() accept these like the */
13927 /* CRTL does will result in several tests failing. */
13928 /* This should really be fixed, but for now, set up a feature to */
13929 /* enable it so that the impact can be studied. */
13930 vms_bug_stat_filename = 0;
8dc9d339 13931 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
9bd30c63 13932 if (status) {
30048647 13933 val_str[0] = toUPPER_A(val_str[0]);
b53f3677
JM		 13934 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13935 vms_bug_stat_filename = 1;
13936 else
13937 vms_bug_stat_filename = 0;
13938 }
13939
13940
38a44b82 13941 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5 13942 vms_vtf7_filenames = 0;
8dc9d339 13943 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
9bd30c63 13944 if (status) {
30048647 13945 val_str[0] = toUPPER_A(val_str[0]);
360732b5
JM		 13946 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13947 vms_vtf7_filenames = 1;
13948 else
13949 vms_vtf7_filenames = 0;
13950 }
13951
e0e5e8d6 13952 /* unlink all versions on unlink() or rename() */
d584a1c6 13953 vms_unlink_all_versions = 0;
9bd30c63
CB		 13954 status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13955 if (status) {
30048647 13956 val_str[0] = toUPPER_A(val_str[0]);
e0e5e8d6
JM		 13957 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13958 vms_unlink_all_versions = 1;
13959 else
13960 vms_unlink_all_versions = 0;
13961 }
13962
483efd0a
CB		 13963 /* The path separator in PERL5LIB is '|' unless running under a Unix shell. */
13964 PL_perllib_sep = '|';
13965
5ca74088 13966 /* Detect running under GNV Bash or other UNIX like shell */
360732b5 13967 gnv_unix_shell = 0;
8dc9d339 13968 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
9bd30c63 13969 if (status) {
360732b5 13970 gnv_unix_shell = 1;
360732b5
JM		 13971 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13972 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13973 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13974 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13975 vms_unlink_all_versions = 1;
1a3aec58 13976 vms_posix_exit = 1;
bc6f2746
CB		 13977 /* Reverse default ordering of PERL_ENV_TABLES. */
13978 defenv[0] = &crtlenvdsc;
13979 defenv[1] = &fildevdsc;
483efd0a 13980 PL_perllib_sep = ':';
360732b5 13981 }
5ca74088
CB		 13982 /* Some reasonable defaults that are not CRTL defaults */
13983 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
c342cf44 13984 set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
012528a9 13985 set_feature_default("DECC$EFS_CHARSET", 1);
9c1171d1 13986
1d60dc3f
CB		 13987 /* If POSIX root doesn't exist or nothing has set it explicitly, we disable it,
13988 * which confusingly means enabling the feature. For some reason only the default
13989 * -- not current -- value can be set, so we cannot use the confusingly-named
13990 * set_feature_default function, which sets the current value.
13991 */
13992 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13993 disable_posix_root_index = s;
13994
13995 status = simple_trnlnm("SYS$POSIX_ROOT", val_str, LNM$C_NAMLENGTH);
13996 initial = decc$feature_get_value(disable_posix_root_index, __FEATURE_MODE_INIT_STATE);
13997 if (!status || !initial) {
13998 decc$feature_set_value(disable_posix_root_index, 0, 1);
13999 }
14000
2497a41f
JM		 14001 /* hacks to see if known bugs are still present for testing */
14002
2497a41f 14003 /* PCP mode requires creating /dev/null special device file */
2623a4a6 14004 decc_bug_devnull = 0;
8dc9d339 14005 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
9bd30c63 14006 if (status) {
30048647 14007 val_str[0] = toUPPER_A(val_str[0]);
2497a41f
JM		 14008 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14009 decc_bug_devnull = 1;
682e4b71
JM		 14010 else
14011 decc_bug_devnull = 0;
2497a41f
JM		 14012 }
14013
f7ddb74a 14014 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
1d60dc3f 14015 disable_to_vms_logname_translation_index = s;
f7ddb74a
JM		 14016
14017 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
1d60dc3f 14018 efs_case_preserve_index = s;
f7ddb74a
JM		 14019
14020 s = decc$feature_get_index("DECC$EFS_CHARSET");
1d60dc3f 14021 efs_charset_index = s;
f7ddb74a
JM		 14022
14023 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
1d60dc3f 14024 filename_unix_report_index = s;
f7ddb74a
JM		 14025
14026 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
1d60dc3f 14027 filename_unix_only_index = s;
f7ddb74a
JM		 14028
14029 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
1d60dc3f 14030 filename_unix_no_version_index = s;
f7ddb74a
JM		 14031
14032 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
1d60dc3f 14033 readdir_dropdotnotype_index = s;
f7ddb74a 14034
f7ddb74a
JM		 14035#if __CRTL_VER >= 80200000
14036 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
1d60dc3f 14037 posix_compliant_pathnames_index = s;
f7ddb74a 14038#endif
f7ddb74a 14039
054a3baf 14040#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
f7ddb74a
JM		 14041
14042 /* Report true case tolerance */
14043 /*----------------------------*/
14044 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14045 if (!$VMS_STATUS_SUCCESS(status))
14046 case_perm = PPROP$K_CASE_BLIND;
14047 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14048 if (!$VMS_STATUS_SUCCESS(status))
14049 case_image = PPROP$K_CASE_BLIND;
14050 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14051 (case_image == PPROP$K_CASE_SENSITIVE))
14052 vms_process_case_tolerant = 0;
14053
14054#endif
14055
1a3aec58 14056 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
94ae10c0 14057 /* for strict backward compatibility */
9bd30c63
CB		 14058 status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14059 if (status) {
30048647 14060 val_str[0] = toUPPER_A(val_str[0]);
1a3aec58
JM		 14061 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14062 vms_posix_exit = 1;
14063 else
14064 vms_posix_exit = 0;
14065 }
c11536f5 14066}
f7ddb74a 14067
e2367aa8
CB		 14068/* Use 32-bit pointers because that's what the image activator
14069 * assumes for the LIB$INITIALZE psect.
14070 */
14071#if __INITIAL_POINTER_SIZE
14072#pragma pointer_size save
14073#pragma pointer_size 32
14074#endif
14075
14076/* Create a reference to the LIB$INITIALIZE function. */
14077extern void LIB$INITIALIZE(void);
14078extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14079
14080/* Create an array of pointers to the init functions in the special
14081 * LIB$INITIALIZE section. In our case, the array only has one entry.
14082 */
14083#pragma extern_model save
2646d7b3 14084#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
e2367aa8
CB		 14085extern void (* const vmsperl_unused_global_2[])() =
14086{
14087 vmsperl_set_features,
14088};
14089#pragma extern_model restore
14090
14091#if __INITIAL_POINTER_SIZE
14092#pragma pointer_size restore
14093#endif
14094
14095#ifdef __cplusplus
14096}
f7ddb74a
JM		 14097#endif
14098
e2367aa8 14099#endif /* defined(__DECC) || defined(__DECCXX) */
748a9306 14100/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.