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
New perldelta
[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{
199 if (str) for (; *str; ++str) *str= tolower(*str);
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
f7ddb74a
JM		 216/* DECC Features that may need to affect how Perl interprets
217 * displays filename information
218 */
219static int decc_disable_to_vms_logname_translation = 1;
220static int decc_disable_posix_root = 1;
221int decc_efs_case_preserve = 0;
222static int decc_efs_charset = 0;
b53f3677 223static int decc_efs_charset_index = -1;
f7ddb74a
JM		 224static int decc_filename_unix_no_version = 0;
225static int decc_filename_unix_only = 0;
226int decc_filename_unix_report = 0;
227int decc_posix_compliant_pathnames = 0;
228int decc_readdir_dropdotnotype = 0;
229static int vms_process_case_tolerant = 1;
360732b5
JM		 230int vms_vtf7_filenames = 0;
231int gnv_unix_shell = 0;
e0e5e8d6 232static int vms_unlink_all_versions = 0;
1a3aec58 233static int vms_posix_exit = 0;
f7ddb74a 234
2497a41f 235/* bug workarounds if needed */
682e4b71 236int decc_bug_devnull = 1;
b53f3677 237int vms_bug_stat_filename = 0;
2497a41f 238
9c1171d1 239static int vms_debug_on_exception = 0;
b53f3677
JM		 240static int vms_debug_fileify = 0;
241
242/* Simple logical name translation */
ce12d4b7
CB		 243static int
244simple_trnlnm(const char * logname, char * value, int value_len)
b53f3677
JM		 245{
246 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
247 const unsigned long attr = LNM$M_CASE_BLIND;
248 struct dsc$descriptor_s name_dsc;
249 int status;
250 unsigned short result;
251 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
252 {0, 0, 0, 0}};
253
254 name_dsc.dsc$w_length = strlen(logname);
255 name_dsc.dsc$a_pointer = (char *)logname;
256 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
257 name_dsc.dsc$b_class = DSC$K_CLASS_S;
258
259 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
260
261 if ($VMS_STATUS_SUCCESS(status)) {
262
263 /* Null terminate and return the string */
264 /*--------------------------------------*/
265 value[result] = 0;
266 return result;
267 }
268
269 return 0;
270}
271
9c1171d1 272
f7ddb74a
JM		 273/* Is this a UNIX file specification?
274 * No longer a simple check with EFS file specs
275 * For now, not a full check, but need to
276 * handle POSIX ^UP^ specifications
277 * Fixing to handle ^/ cases would require
278 * changes to many other conversion routines.
279 */
280
ce12d4b7
CB		 281static int
282is_unix_filespec(const char *path)
f7ddb74a 283{
ce12d4b7
CB		 284 int ret_val;
285 const char * pch1;
f7ddb74a
JM		 286
287 ret_val = 0;
288 if (strncmp(path,"\"^UP^",5) != 0) {
289 pch1 = strchr(path, '/');
290 if (pch1 != NULL)
291 ret_val = 1;
292 else {
293
294 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
295 if (decc_filename_unix_report || decc_filename_unix_only) {
296 if (strcmp(path,".") == 0)
297 ret_val = 1;
298 }
299 }
300 }
301 return ret_val;
302}
303
360732b5
JM		 304/* This routine converts a UCS-2 character to be VTF-7 encoded.
305 */
306
ce12d4b7
CB		 307static void
308ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
360732b5 309{
ce12d4b7
CB		 310 unsigned char * ucs_ptr;
311 int hex;
360732b5
JM		 312
313 ucs_ptr = (unsigned char *)&ucs2_char;
314
315 outspec[0] = '^';
316 outspec[1] = 'U';
317 hex = (ucs_ptr[1] >> 4) & 0xf;
318 if (hex < 0xA)
319 outspec[2] = hex + '0';
320 else
321 outspec[2] = (hex - 9) + 'A';
322 hex = ucs_ptr[1] & 0xF;
323 if (hex < 0xA)
324 outspec[3] = hex + '0';
325 else {
326 outspec[3] = (hex - 9) + 'A';
327 }
328 hex = (ucs_ptr[0] >> 4) & 0xf;
329 if (hex < 0xA)
330 outspec[4] = hex + '0';
331 else
332 outspec[4] = (hex - 9) + 'A';
333 hex = ucs_ptr[1] & 0xF;
334 if (hex < 0xA)
335 outspec[5] = hex + '0';
336 else {
337 outspec[5] = (hex - 9) + 'A';
338 }
339 *output_cnt = 6;
340}
341
342
343/* This handles the conversion of a UNIX extended character set to a ^
344 * escaped VMS character.
345 * in a UNIX file specification.
346 *
347 * The output count variable contains the number of characters added
348 * to the output string.
349 *
350 * The return value is the number of characters read from the input string
351 */
ce12d4b7
CB		 352static int
353copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
360732b5 354{
ce12d4b7
CB		 355 int count;
356 int utf8_flag;
360732b5
JM		 357
358 utf8_flag = 0;
359 if (utf8_fl)
360 utf8_flag = *utf8_fl;
361
362 count = 0;
363 *output_cnt = 0;
364 if (*inspec >= 0x80) {
365 if (utf8_fl && vms_vtf7_filenames) {
366 unsigned long ucs_char;
367
368 ucs_char = 0;
369
370 if ((*inspec & 0xE0) == 0xC0) {
371 /* 2 byte Unicode */
372 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
373 if (ucs_char >= 0x80) {
374 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
375 return 2;
376 }
377 } else if ((*inspec & 0xF0) == 0xE0) {
378 /* 3 byte Unicode */
379 ucs_char = ((inspec[0] & 0xF) << 12) +
380 ((inspec[1] & 0x3f) << 6) +
381 (inspec[2] & 0x3f);
382 if (ucs_char >= 0x800) {
383 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
384 return 3;
385 }
386
387#if 0 /* I do not see longer sequences supported by OpenVMS */
388 /* Maybe some one can fix this later */
389 } else if ((*inspec & 0xF8) == 0xF0) {
390 /* 4 byte Unicode */
391 /* UCS-4 to UCS-2 */
392 } else if ((*inspec & 0xFC) == 0xF8) {
393 /* 5 byte Unicode */
394 /* UCS-4 to UCS-2 */
395 } else if ((*inspec & 0xFE) == 0xFC) {
396 /* 6 byte Unicode */
397 /* UCS-4 to UCS-2 */
398#endif
399 }
400 }
401
38a44b82 402 /* High bit set, but not a Unicode character! */
360732b5
JM		 403
404 /* Non printing DECMCS or ISO Latin-1 character? */
b931d62c
CB		 405 if ((unsigned char)*inspec <= 0x9F) {
406 int hex;
360732b5
JM		 407 outspec[0] = '^';
408 outspec++;
409 hex = (*inspec >> 4) & 0xF;
410 if (hex < 0xA)
411 outspec[1] = hex + '0';
412 else {
413 outspec[1] = (hex - 9) + 'A';
414 }
415 hex = *inspec & 0xF;
416 if (hex < 0xA)
417 outspec[2] = hex + '0';
418 else {
419 outspec[2] = (hex - 9) + 'A';
420 }
421 *output_cnt = 3;
422 return 1;
b931d62c 423 } else if ((unsigned char)*inspec == 0xA0) {
360732b5
JM		 424 outspec[0] = '^';
425 outspec[1] = 'A';
426 outspec[2] = '0';
427 *output_cnt = 3;
428 return 1;
b931d62c 429 } else if ((unsigned char)*inspec == 0xFF) {
360732b5
JM		 430 outspec[0] = '^';
431 outspec[1] = 'F';
432 outspec[2] = 'F';
433 *output_cnt = 3;
434 return 1;
435 }
436 *outspec = *inspec;
437 *output_cnt = 1;
438 return 1;
439 }
440
441 /* Is this a macro that needs to be passed through?
442 * Macros start with $( and an alpha character, followed
443 * by a string of alpha numeric characters ending with a )
444 * If this does not match, then encode it as ODS-5.
445 */
446 if ((inspec[0] == '$') && (inspec[1] == '(')) {
447 int tcnt;
448
449 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
450 tcnt = 3;
451 outspec[0] = inspec[0];
452 outspec[1] = inspec[1];
453 outspec[2] = inspec[2];
454
455 while(isalnum(inspec[tcnt]) ||
456 (inspec[2] == '.') || (inspec[2] == '_')) {
457 outspec[tcnt] = inspec[tcnt];
458 tcnt++;
459 }
460 if (inspec[tcnt] == ')') {
461 outspec[tcnt] = inspec[tcnt];
462 tcnt++;
463 *output_cnt = tcnt;
464 return tcnt;
465 }
466 }
467 }
468
469 switch (*inspec) {
470 case 0x7f:
471 outspec[0] = '^';
472 outspec[1] = '7';
473 outspec[2] = 'F';
474 *output_cnt = 3;
475 return 1;
476 break;
477 case '?':
478 if (decc_efs_charset == 0)
479 outspec[0] = '%';
480 else
481 outspec[0] = '?';
482 *output_cnt = 1;
483 return 1;
484 break;
485 case '.':
486 case '~':
487 case '!':
488 case '#':
489 case '&':
490 case '\'':
491 case '`':
492 case '(':
493 case ')':
494 case '+':
495 case '@':
496 case '{':
497 case '}':
498 case ',':
499 case ';':
500 case '[':
501 case ']':
502 case '%':
503 case '^':
449de3c2 504 case '\\':
adc11f0b
CB		 505 /* Don't escape again if following character is
506 * already something we escape.
507 */
449de3c2 508 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 509 *outspec = *inspec;
510 *output_cnt = 1;
511 return 1;
512 break;
513 }
514 /* But otherwise fall through and escape it. */
360732b5
JM		 515 case '=':
516 /* Assume that this is to be escaped */
517 outspec[0] = '^';
518 outspec[1] = *inspec;
519 *output_cnt = 2;
520 return 1;
521 break;
522 case ' ': /* space */
523 /* Assume that this is to be escaped */
524 outspec[0] = '^';
525 outspec[1] = '_';
526 *output_cnt = 2;
527 return 1;
528 break;
529 default:
530 *outspec = *inspec;
531 *output_cnt = 1;
532 return 1;
533 break;
534 }
c11536f5 535 return 0;
360732b5
JM		 536}
537
538
657054d4
JM		 539/* This handles the expansion of a '^' prefix to the proper character
540 * in a UNIX file specification.
541 *
542 * The output count variable contains the number of characters added
543 * to the output string.
544 *
545 * The return value is the number of characters read from the input
546 * string
547 */
ce12d4b7
CB		 548static int
549copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
657054d4 550{
ce12d4b7
CB		 551 int count;
552 int scnt;
657054d4
JM		 553
554 count = 0;
555 *output_cnt = 0;
556 if (*inspec == '^') {
557 inspec++;
558 switch (*inspec) {
adc11f0b
CB		 559 /* Spaces and non-trailing dots should just be passed through,
560 * but eat the escape character.
561 */
657054d4 562 case '.':
657054d4 563 *outspec = *inspec;
adc11f0b
CB		 564 count += 2;
565 (*output_cnt)++;
657054d4
JM		 566 break;
567 case '_': /* space */
568 *outspec = ' ';
adc11f0b 569 count += 2;
657054d4
JM		 570 (*output_cnt)++;
571 break;
adc11f0b
CB		 572 case '^':
573 /* Hmm. Better leave the escape escaped. */
574 outspec[0] = '^';
575 outspec[1] = '^';
576 count += 2;
577 (*output_cnt) += 2;
578 break;
360732b5 579 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 580 inspec++;
581 count++;
582 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
583 if (scnt == 4) {
2f4077ca
JM		 584 unsigned int c1, c2;
585 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
9960802c
NK		 586 outspec[0] = c1 & 0xff;
587 outspec[1] = c2 & 0xff;
657054d4
JM		 588 if (scnt > 1) {
589 (*output_cnt) += 2;
590 count += 4;
591 }
592 }
593 else {
594 /* Error - do best we can to continue */
595 *outspec = 'U';
596 outspec++;
597 (*output_cnt++);
598 *outspec = *inspec;
599 count++;
600 (*output_cnt++);
601 }
602 break;
603 default:
604 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
605 if (scnt == 2) {
606 /* Hex encoded */
2f4077ca
JM		 607 unsigned int c1;
608 scnt = sscanf(inspec, "%2x", &c1);
609 outspec[0] = c1 & 0xff;
657054d4
JM		 610 if (scnt > 0) {
611 (*output_cnt++);
612 count += 2;
613 }
614 }
615 else {
616 *outspec = *inspec;
617 count++;
618 (*output_cnt++);
619 }
620 }
621 }
622 else {
623 *outspec = *inspec;
624 count++;
625 (*output_cnt)++;
626 }
627 return count;
628}
629
657054d4
JM		 630/* vms_split_path - Verify that the input file specification is a
631 * VMS format file specification, and provide pointers to the components of
632 * it. With EFS format filenames, this is virtually the only way to
633 * parse a VMS path specification into components.
634 *
635 * If the sum of the components do not add up to the length of the
636 * string, then the passed file specification is probably a UNIX style
637 * path.
638 */
ce12d4b7
CB		 639static int
640vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
641 char * * dir, int * dir_len, char * * name, int * name_len,
642 char * * ext, int * ext_len, char * * version, int * ver_len)
643{
644 struct dsc$descriptor path_desc;
645 int status;
646 unsigned long flags;
647 int ret_stat;
648 struct filescan_itmlst_2 item_list[9];
649 const int filespec = 0;
650 const int nodespec = 1;
651 const int devspec = 2;
652 const int rootspec = 3;
653 const int dirspec = 4;
654 const int namespec = 5;
655 const int typespec = 6;
656 const int verspec = 7;
657054d4
JM		 657
658 /* Assume the worst for an easy exit */
659 ret_stat = -1;
660 *volume = NULL;
661 *vol_len = 0;
662 *root = NULL;
663 *root_len = 0;
664 *dir = NULL;
657054d4
JM		 665 *name = NULL;
666 *name_len = 0;
667 *ext = NULL;
668 *ext_len = 0;
669 *version = NULL;
670 *ver_len = 0;
671
672 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
673 path_desc.dsc$w_length = strlen(path);
674 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
675 path_desc.dsc$b_class = DSC$K_CLASS_S;
676
677 /* Get the total length, if it is shorter than the string passed
678 * then this was probably not a VMS formatted file specification
679 */
680 item_list[filespec].itmcode = FSCN$_FILESPEC;
681 item_list[filespec].length = 0;
682 item_list[filespec].component = NULL;
683
684 /* If the node is present, then it gets considered as part of the
685 * volume name to hopefully make things simple.
686 */
687 item_list[nodespec].itmcode = FSCN$_NODE;
688 item_list[nodespec].length = 0;
689 item_list[nodespec].component = NULL;
690
691 item_list[devspec].itmcode = FSCN$_DEVICE;
692 item_list[devspec].length = 0;
693 item_list[devspec].component = NULL;
694
695 /* root is a special case, adding it to either the directory or
94ae10c0 696 * the device components will probably complicate things for the
657054d4
JM		 697 * callers of this routine, so leave it separate.
698 */
699 item_list[rootspec].itmcode = FSCN$_ROOT;
700 item_list[rootspec].length = 0;
701 item_list[rootspec].component = NULL;
702
703 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
704 item_list[dirspec].length = 0;
705 item_list[dirspec].component = NULL;
706
707 item_list[namespec].itmcode = FSCN$_NAME;
708 item_list[namespec].length = 0;
709 item_list[namespec].component = NULL;
710
711 item_list[typespec].itmcode = FSCN$_TYPE;
712 item_list[typespec].length = 0;
713 item_list[typespec].component = NULL;
714
715 item_list[verspec].itmcode = FSCN$_VERSION;
716 item_list[verspec].length = 0;
717 item_list[verspec].component = NULL;
718
719 item_list[8].itmcode = 0;
720 item_list[8].length = 0;
721 item_list[8].component = NULL;
722
7566800d 723 status = sys$filescan
657054d4
JM		 724 ((const struct dsc$descriptor_s *)&path_desc, item_list,
725 &flags, NULL, NULL);
360732b5 726 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 727
728 /* If we parsed it successfully these two lengths should be the same */
729 if (path_desc.dsc$w_length != item_list[filespec].length)
730 return ret_stat;
731
732 /* If we got here, then it is a VMS file specification */
733 ret_stat = 0;
734
735 /* set the volume name */
736 if (item_list[nodespec].length > 0) {
737 *volume = item_list[nodespec].component;
738 *vol_len = item_list[nodespec].length + item_list[devspec].length;
739 }
740 else {
741 *volume = item_list[devspec].component;
742 *vol_len = item_list[devspec].length;
743 }
744
745 *root = item_list[rootspec].component;
746 *root_len = item_list[rootspec].length;
747
748 *dir = item_list[dirspec].component;
749 *dir_len = item_list[dirspec].length;
750
751 /* Now fun with versions and EFS file specifications
752 * The parser can not tell the difference when a "." is a version
753 * delimiter or a part of the file specification.
754 */
755 if ((decc_efs_charset) &&
756 (item_list[verspec].length > 0) &&
757 (item_list[verspec].component[0] == '.')) {
758 *name = item_list[namespec].component;
759 *name_len = item_list[namespec].length + item_list[typespec].length;
760 *ext = item_list[verspec].component;
761 *ext_len = item_list[verspec].length;
762 *version = NULL;
763 *ver_len = 0;
764 }
765 else {
766 *name = item_list[namespec].component;
767 *name_len = item_list[namespec].length;
768 *ext = item_list[typespec].component;
769 *ext_len = item_list[typespec].length;
770 *version = item_list[verspec].component;
771 *ver_len = item_list[verspec].length;
772 }
773 return ret_stat;
774}
775
df278665 776/* Routine to determine if the file specification ends with .dir */
ce12d4b7
CB		 777static int
778is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
779{
df278665
JM		 780
781 /* e_len must be 4, and version must be <= 2 characters */
782 if (e_len != 4 || vs_len > 2)
783 return 0;
784
785 /* If a version number is present, it needs to be one */
786 if ((vs_len == 2) && (vs_spec[1] != '1'))
787 return 0;
788
789 /* Look for the DIR on the extension */
790 if (vms_process_case_tolerant) {
791 if ((toupper(e_spec[1]) == 'D') &&
792 (toupper(e_spec[2]) == 'I') &&
793 (toupper(e_spec[3]) == 'R')) {
794 return 1;
795 }
796 } else {
797 /* Directory extensions are supposed to be in upper case only */
798 /* I would not be surprised if this rule can not be enforced */
799 /* if and when someone fully debugs the case sensitive mode */
800 if ((e_spec[1] == 'D') &&
801 (e_spec[2] == 'I') &&
802 (e_spec[3] == 'R')) {
803 return 1;
804 }
805 }
806 return 0;
807}
808
f7ddb74a 809
fa537f88
CB		 810/* my_maxidx
811 * Routine to retrieve the maximum equivalence index for an input
812 * logical name. Some calls to this routine have no knowledge if
813 * the variable is a logical or not. So on error we return a max
814 * index of zero.
815 */
f7ddb74a 816/*{{{int my_maxidx(const char *lnm) */
fa537f88 817static int
f7ddb74a 818my_maxidx(const char *lnm)
fa537f88
CB		 819{
820 int status;
821 int midx;
822 int attr = LNM$M_CASE_BLIND;
823 struct dsc$descriptor lnmdsc;
824 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
825 {0, 0, 0, 0}};
826
827 lnmdsc.dsc$w_length = strlen(lnm);
828 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
829 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 830 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 831
832 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
833 if ((status & 1) == 0)
834 midx = 0;
835
836 return (midx);
837}
838/*}}}*/
839
bdbc6804
CB		 840/* Routine to remove the 2-byte prefix from the translation of a
841 * process-permanent file (PPF).
842 */
843static inline unsigned short int
844S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
845{
846 if (*((int *)lnm) == *((int *)"SYS$") &&
847 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
848 ( (lnm[4] == 'O' && !strcmp(lnm,"SYS$OUTPUT")) ||
849 (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT")) ||
850 (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR")) ||
851 (lnm[4] == 'C' && !strcmp(lnm,"SYS$COMMAND")) ) ) {
852
853 memmove(eqv, eqv+4, eqvlen-4);
854 eqvlen -= 4;
855 }
856 return eqvlen;
857}
858
f675dbe5 859/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 860int
fd8cd3a3 861Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 862 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 863{
f7ddb74a
JM		 864 const char *cp1;
865 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 866 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
2364b895 867 bool found_in_crtlenv = 0, found_in_clisym = 0;
748a9306 868 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 869 int midx;
f675dbe5
CB		 870 unsigned char acmode;
871 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
872 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
873 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
874 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 875 {0, 0, 0, 0}};
f675dbe5 876 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 877#if defined(PERL_IMPLICIT_CONTEXT)
878 pTHX = NULL;
fd8cd3a3
DS		 879 if (PL_curinterp) {
880 aTHX = PERL_GET_INTERP;
cc077a9f 881 } else {
fd8cd3a3 882 aTHX = NULL;
cc077a9f
HM		 883 }
884#endif
748a9306 885
fa537f88 886 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 887 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
888 }
f7ddb74a 889 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 890 *cp2 = _toupper(*cp1);
891 if (cp1 - lnm > LNM$C_NAMLENGTH) {
892 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
893 return 0;
894 }
895 }
896 lnmdsc.dsc$w_length = cp1 - lnm;
897 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 898 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 899 secure = flags & PERL__TRNENV_SECURE;
900 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
901 if (!tabvec || !*tabvec) tabvec = env_tables;
902
903 for (curtab = 0; tabvec[curtab]; curtab++) {
904 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
905 if (!ivenv && !secure) {
4e0c9737 906 char *eq;
f675dbe5
CB		 907 int i;
908 if (!environ) {
909 ivenv = 1;
ebd4d70b
JM		 910#if defined(PERL_IMPLICIT_CONTEXT)
911 if (aTHX == NULL) {
912 fprintf(stderr,
873f5ddf 913 "Can't read CRTL environ\n");
ebd4d70b
JM		 914 } else
915#endif
916 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 917 continue;
918 }
919 retsts = SS$_NOLOGNAM;
920 for (i = 0; environ[i]; i++) {
921 if ((eq = strchr(environ[i],'=')) &&
299d126a 922 lnmdsc.dsc$w_length == (eq - environ[i]) &&
99b868c1 923 !strncmp(environ[i],lnm,eq - environ[i])) {
f675dbe5
CB		 924 eq++;
925 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
926 if (!eqvlen) continue;
927 retsts = SS$_NORMAL;
928 break;
929 }
930 }
2364b895
CB		 931 if (retsts != SS$_NOLOGNAM) {
932 found_in_crtlenv = 1;
933 break;
934 }
f675dbe5
CB		 935 }
936 }
937 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
938 !str$case_blind_compare(&tmpdsc,&clisym)) {
939 if (!ivsym && !secure) {
940 unsigned short int deflen = LNM$C_NAMLENGTH;
941 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
94ae10c0 942 /* dynamic dsc to accommodate possible long value */
ebd4d70b 943 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 944 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
945 if (retsts & 1) {
2497a41f 946 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 947 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 948 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 949 /* Special hack--we might be called before the interpreter's */
950 /* fully initialized, in which case either thr or PL_curcop */
951 /* might be bogus. We have to check, since ckWARN needs them */
952 /* both to be valid if running threaded */
8a646e0b
JM		 953#if defined(PERL_IMPLICIT_CONTEXT)
954 if (aTHX == NULL) {
955 fprintf(stderr,
873f5ddf 956 "Value of CLI symbol \"%s\" too long",lnm);
8a646e0b
JM		 957 } else
958#endif
cc077a9f 959 if (ckWARN(WARN_MISC)) {
f98bc0c6 960 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 961 }
f675dbe5
CB		 962 }
963 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
964 }
ebd4d70b 965 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 966 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
967 if (retsts == LIB$_NOSUCHSYM) continue;
2364b895 968 found_in_clisym = 1;
f675dbe5
CB		 969 break;
970 }
971 }
972 else if (!ivlnm) {
843027b0 973 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 974 midx = my_maxidx(lnm);
975 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
976 lnmlst[1].bufadr = cp2;
fa537f88
CB		 977 eqvlen = 0;
978 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
979 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
980 if (retsts == SS$_NOLOGNAM) break;
bdbc6804 981 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
f7ddb74a
JM		 982 cp2 += eqvlen;
983 *cp2 = '\0';
fa537f88
CB		 984 }
985 if ((retsts == SS$_IVLOGNAM) ||
986 (retsts == SS$_NOLOGNAM)) { continue; }
bdbc6804 987 eqvlen = strlen(eqv);
fd7385b9 988 }
fa537f88 989 else {
fa537f88
CB		 990 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
991 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
992 if (retsts == SS$_NOLOGNAM) continue;
bdbc6804 993 eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
fa537f88
CB		 994 eqv[eqvlen] = '\0';
995 }
f675dbe5
CB		 996 break;
997 }
c07a80fd 998 }
2364b895
CB		 999 /* An index only makes sense for logical names, so make sure we aren't
1000 * iterating over an index for an environ var or DCL symbol and getting
1001 * the same answer ad infinitum.
1002 */
1003 if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
1004 return 0;
1005 }
1006 else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
998ae67e 1007 else if (retsts == LIB$_NOSUCHSYM ||
f675dbe5 1008 retsts == SS$_NOLOGNAM) {
998ae67e
CB		 1009 /* Unsuccessful lookup is normal -- no need to set errno */
1010 return 0;
1011 }
1012 else if (retsts == LIB$_INVSYMNAM ||
1013 retsts == SS$_IVLOGNAM ||
1014 retsts == SS$_IVLOGTAB) {
f675dbe5 1015 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1016 }
ebd4d70b 1017 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1018 return 0;
1019} /* end of vmstrnenv */
1020/*}}}*/
c07a80fd 1021
f675dbe5
CB		 1022/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1023/* Define as a function so we can access statics. */
ce12d4b7
CB		 1024int
1025Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1026{
8a646e0b
JM		 1027 int flags = 0;
1028
1029#if defined(PERL_IMPLICIT_CONTEXT)
1030 if (aTHX != NULL)
1031#endif
f675dbe5 1032#ifdef SECURE_INTERNAL_GETENV
284167a5 1033 flags = (PL_curinterp ? TAINTING_get : will_taint) ?
8a646e0b 1034 PERL__TRNENV_SECURE : 0;
f675dbe5 1035#endif
8a646e0b
JM		 1036
1037 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1038}
1039/*}}}*/
a0d0e21e
LW		 1040
1041/* my_getenv
61bb5906
CB		 1042 * Note: Uses Perl temp to store result so char * can be returned to
1043 * caller; this pointer will be invalidated at next Perl statement
1044 * transition.
a6c40364 1045 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1046 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1047 * allocate SVs).
a0d0e21e 1048 */
f675dbe5 1049/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1050char *
5c84aa53 1051Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1052{
f7ddb74a 1053 const char *cp1;
fa537f88 1054 static char *__my_getenv_eqv = NULL;
f7ddb74a 1055 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1056 unsigned long int idx = 0;
998ae67e 1057 int success, secure;
843027b0 1058 int midx, flags;
61bb5906 1059 SV *tmpsv;
a0d0e21e 1060
f7ddb74a 1061 midx = my_maxidx(lnm) + 1;
fa537f88 1062
6b88bc9c 1063 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1064 /* Set up a temporary buffer for the return value; Perl will
1065 * clean it up at the next statement transition */
fa537f88 1066 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1067 if (!tmpsv) return NULL;
1068 eqv = SvPVX(tmpsv);
1069 }
fa537f88
CB		 1070 else {
1071 /* Assume no interpreter ==> single thread */
1072 if (__my_getenv_eqv != NULL) {
1073 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1074 }
1075 else {
a02a5408 1076 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1077 }
1078 eqv = __my_getenv_eqv;
1079 }
1080
f7ddb74a 1081 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1082 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1083 int len;
61bb5906 1084 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1085
1086 len = strlen(eqv);
1087
1088 /* Get rid of "000000/ in rooted filespecs */
1089 if (len > 7) {
1090 char * zeros;
1091 zeros = strstr(eqv, "/000000/");
1092 if (zeros != NULL) {
1093 int mlen;
1094 mlen = len - (zeros - eqv) - 7;
1095 memmove(zeros, &zeros[7], mlen);
1096 len = len - 7;
1097 eqv[len] = '\0';
1098 }
1099 }
61bb5906 1100 return eqv;
748a9306 1101 }
a0d0e21e 1102 else {
2512681b 1103 /* Impose security constraints only if tainting */
bc10a425
CB		 1104 if (sys) {
1105 /* Impose security constraints only if tainting */
284167a5 1106 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425 1107 }
843027b0
CB		 1108 else {
1109 secure = 0;
1110 }
1111
1112 flags =
f675dbe5 1113#ifdef SECURE_INTERNAL_GETENV
843027b0 1114 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1115#else
843027b0 1116 0
f675dbe5 1117#endif
843027b0
CB		 1118 ;
1119
1120 /* For the getenv interface we combine all the equivalence names
1121 * of a search list logical into one value to acquire a maximum
1122 * value length of 255*128 (assuming %ENV is using logicals).
1123 */
1124 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1125
1126 /* If the name contains a semicolon-delimited index, parse it
1127 * off and make sure we only retrieve the equivalence name for
1128 * that index. */
1129 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1130 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
843027b0
CB		 1131 idx = strtoul(cp2+1,NULL,0);
1132 lnm = uplnm;
1133 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1134 }
1135
1136 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1137
4e205ed6 1138 return success ? eqv : NULL;
a0d0e21e 1139 }
a0d0e21e
LW		 1140
1141} /* end of my_getenv() */
1142/*}}}*/
1143
f675dbe5 1144
a6c40364
GS		 1145/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1146char *
fd8cd3a3 1147Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1148{
f7ddb74a
JM		 1149 const char *cp1;
1150 char *buf, *cp2;
a6c40364 1151 unsigned long idx = 0;
843027b0 1152 int midx, flags;
fa537f88 1153 static char *__my_getenv_len_eqv = NULL;
998ae67e 1154 int secure;
cc077a9f
HM		 1155 SV *tmpsv;
1156
f7ddb74a 1157 midx = my_maxidx(lnm) + 1;
fa537f88 1158
cc077a9f
HM		 1159 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1160 /* Set up a temporary buffer for the return value; Perl will
1161 * clean it up at the next statement transition */
fa537f88 1162 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1163 if (!tmpsv) return NULL;
1164 buf = SvPVX(tmpsv);
1165 }
fa537f88
CB		 1166 else {
1167 /* Assume no interpreter ==> single thread */
1168 if (__my_getenv_len_eqv != NULL) {
1169 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1170 }
1171 else {
a02a5408 1172 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1173 }
1174 buf = __my_getenv_len_eqv;
1175 }
1176
f7ddb74a 1177 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1178 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1179 char * zeros;
1180
f675dbe5 1181 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1182 *len = strlen(buf);
f7ddb74a
JM		 1183
1184 /* Get rid of "000000/ in rooted filespecs */
1185 if (*len > 7) {
1186 zeros = strstr(buf, "/000000/");
1187 if (zeros != NULL) {
1188 int mlen;
1189 mlen = *len - (zeros - buf) - 7;
1190 memmove(zeros, &zeros[7], mlen);
1191 *len = *len - 7;
1192 buf[*len] = '\0';
1193 }
1194 }
a6c40364 1195 return buf;
f675dbe5
CB		 1196 }
1197 else {
bc10a425
CB		 1198 if (sys) {
1199 /* Impose security constraints only if tainting */
284167a5 1200 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425 1201 }
843027b0
CB		 1202 else {
1203 secure = 0;
1204 }
1205
1206 flags =
f675dbe5 1207#ifdef SECURE_INTERNAL_GETENV
843027b0 1208 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1209#else
843027b0 1210 0
f675dbe5 1211#endif
843027b0
CB		 1212 ;
1213
1214 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1215
1216 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1217 my_strlcpy(buf, lnm, cp2 - lnm + 1);
843027b0
CB		 1218 idx = strtoul(cp2+1,NULL,0);
1219 lnm = buf;
1220 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1221 }
1222
1223 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1224
f7ddb74a
JM		 1225 /* Get rid of "000000/ in rooted filespecs */
1226 if (*len > 7) {
ce12d4b7 1227 char * zeros;
f7ddb74a
JM		 1228 zeros = strstr(buf, "/000000/");
1229 if (zeros != NULL) {
1230 int mlen;
1231 mlen = *len - (zeros - buf) - 7;
1232 memmove(zeros, &zeros[7], mlen);
1233 *len = *len - 7;
1234 buf[*len] = '\0';
1235 }
1236 }
1237
4e205ed6 1238 return *len ? buf : NULL;
f675dbe5
CB		 1239 }
1240
a6c40364 1241} /* end of my_getenv_len() */
f675dbe5
CB		 1242/*}}}*/
1243
8a646e0b 1244static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1245
1246static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1247
740ce14c 1248/*{{{ void prime_env_iter() */
1249void
1250prime_env_iter(void)
1251/* Fill the %ENV associative array with all logical names we can
1252 * find, in preparation for iterating over it.
1253 */
1254{
17f28c40 1255 static int primed = 0;
3eeba6fb 1256 HV *seenhv = NULL, *envhv;
22be8b3c 1257 SV *sv = NULL;
4e205ed6 1258 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1259 unsigned short int chan;
1260#ifndef CLI$M_TRUSTED
1261# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1262#endif
f675dbe5 1263 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
4e0c9737 1264 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
f675dbe5
CB		 1265 long int i;
1266 bool have_sym = FALSE, have_lnm = FALSE;
1267 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1268 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1269 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1270 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1271 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1272#if defined(PERL_IMPLICIT_CONTEXT)
1273 pTHX;
1274#endif
3db8f154 1275#if defined(USE_ITHREADS)
b2b3adea
HM		 1276 static perl_mutex primenv_mutex;
1277 MUTEX_INIT(&primenv_mutex);
61bb5906 1278#endif
740ce14c 1279
fd8cd3a3
DS		 1280#if defined(PERL_IMPLICIT_CONTEXT)
1281 /* We jump through these hoops because we can be called at */
1282 /* platform-specific initialization time, which is before anything is */
1283 /* set up--we can't even do a plain dTHX since that relies on the */
1284 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1285 if (PL_curinterp) {
1286 aTHX = PERL_GET_INTERP;
1287 } else {
ebd4d70b
JM		 1288 /* we never get here because the NULL pointer will cause the */
1289 /* several of the routines called by this routine to access violate */
1290
1291 /* This routine is only called by hv.c/hv_iterinit which has a */
1292 /* context, so the real fix may be to pass it through instead of */
1293 /* the hoops above */
fd8cd3a3
DS		 1294 aTHX = NULL;
1295 }
1296#endif
fd8cd3a3 1297
3eeba6fb 1298 if (primed || !PL_envgv) return;
61bb5906
CB		 1299 MUTEX_LOCK(&primenv_mutex);
1300 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1301 envhv = GvHVn(PL_envgv);
740ce14c 1302 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1303 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1304 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1305
f675dbe5
CB		 1306 for (i = 0; env_tables[i]; i++) {
1307 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1308 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1309 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1310 }
f675dbe5
CB		 1311 if (have_sym || have_lnm) {
1312 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1313 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1314 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1315 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1316 }
f675dbe5
CB		 1317
1318 for (i--; i >= 0; i--) {
1319 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1320 char *start;
1321 int j;
9dee5840
CB		 1322 /* Start at the end, so if there is a duplicate we keep the first one. */
1323 for (j = 0; environ[j]; j++);
1324 for (j--; j >= 0; j--) {
f675dbe5 1325 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1326 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1327 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1328 }
1329 else {
1330 start++;
22be8b3c
CB		 1331 sv = newSVpv(start,0);
1332 SvTAINTED_on(sv);
1333 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1334 }
1335 }
1336 continue;
740ce14c 1337 }
f675dbe5
CB		 1338 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1339 !str$case_blind_compare(&tmpdsc,&clisym)) {
a35dcc95 1340 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
f675dbe5
CB		 1341 cmddsc.dsc$w_length = 20;
1342 if (env_tables[i]->dsc$w_length == 12 &&
1343 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
a35dcc95 1344 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
f675dbe5
CB		 1345 flags = defflags | CLI$M_NOLOGNAM;
1346 }
1347 else {
a35dcc95 1348 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
f675dbe5 1349 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
a35dcc95 1350 my_strlcat(cmd," /Table=", sizeof(cmd));
88e3936f 1351 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
f675dbe5
CB		 1352 }
1353 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1354 flags = defflags | CLI$M_NOCLISYM;
1355 }
1356
1357 /* Create a new subprocess to execute each command, to exclude the
1358 * remote possibility that someone could subvert a mbx or file used
1359 * to write multiple commands to a single subprocess.
1360 */
1361 do {
1362 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1363 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1364 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1365 defflags &= ~CLI$M_TRUSTED;
1366 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1367 _ckvmssts(retsts);
a02a5408 1368 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1369 if (seenhv) SvREFCNT_dec(seenhv);
1370 seenhv = newHV();
1371 while (1) {
1372 char *cp1, *cp2, *key;
1373 unsigned long int sts, iosb[2], retlen, keylen;
eb578fdb 1374 U32 hash;
f675dbe5
CB		 1375
1376 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1377 if (sts & 1) sts = iosb[0] & 0xffff;
1378 if (sts == SS$_ENDOFFILE) {
1379 int wakect = 0;
1380 while (substs == 0) { sys$hiber(); wakect++;}
1381 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1382 _ckvmssts(substs);
1383 break;
1384 }
1385 _ckvmssts(sts);
1386 retlen = iosb[0] >> 16;
1387 if (!retlen) continue; /* blank line */
1388 buf[retlen] = '\0';
1389 if (iosb[1] != subpid) {
1390 if (iosb[1]) {
5c84aa53 1391 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1392 }
1393 continue;
1394 }
3eeba6fb 1395 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1396 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1397
1398 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1399 if (*cp1 == '(' || /* Logical name table name */
1400 *cp1 == '=' /* Next eqv of searchlist */) continue;
1401 if (*cp1 == '"') cp1++;
1402 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1403 key = cp1; keylen = cp2 - cp1;
1404 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1405 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1406 while (*cp2 && *cp2 == '=') cp2++;
1407 while (*cp2 && *cp2 == ' ') cp2++;
1408 if (*cp2 == '"') { /* String translation; may embed "" */
1409 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1410 cp2++; cp1--; /* Skip "" surrounding translation */
1411 }
1412 else { /* Numeric translation */
1413 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1414 cp1--; /* stop on last non-space char */
1415 }
1416 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1417 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1418 continue;
1419 }
5afd6d42 1420 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1421
1422 if (cp1 == cp2 && *cp2 == '.') {
1423 /* A single dot usually means an unprintable character, such as a null
1424 * to indicate a zero-length value. Get the actual value to make sure.
1425 */
1426 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1427 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1428 int trnlen;
ff79d39d 1429 strncpy(lnm, key, keylen);
0faef845 1430 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1431 sv = newSVpvn(eqv, strlen(eqv));
1432 }
1433 else {
1434 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1435 }
1436
22be8b3c
CB		 1437 SvTAINTED_on(sv);
1438 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1439 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1440 }
f675dbe5
CB		 1441 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1442 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1443 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1444 char eqv[LNM$C_NAMLENGTH+1];
1445 int trnlen, i;
1446 for (i = 0; ppfs[i]; i++) {
1447 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1448 sv = newSVpv(eqv,trnlen);
1449 SvTAINTED_on(sv);
1450 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1451 }
740ce14c 1452 }
1453 }
f675dbe5
CB		 1454 primed = 1;
1455 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1456 if (buf) Safefree(buf);
1457 if (seenhv) SvREFCNT_dec(seenhv);
1458 MUTEX_UNLOCK(&primenv_mutex);
1459 return;
1460
740ce14c 1461} /* end of prime_env_iter */
1462/*}}}*/
740ce14c 1463
f675dbe5 1464
2c590a56 1465/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1466/* Define or delete an element in the same "environment" as
1467 * vmstrnenv(). If an element is to be deleted, it's removed from
1468 * the first place it's found. If it's to be set, it's set in the
1469 * place designated by the first element of the table vector.
3eeba6fb 1470 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1471 */
f675dbe5 1472int
2c590a56 1473Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1474{
f7ddb74a
JM		 1475 const char *cp1;
1476 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1477 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1478 int nseg = 0, j;
a0d0e21e 1479 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1480 struct itmlst_3 *ile, *ilist;
a0d0e21e 1481 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1482 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1483 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1484 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1485 $DESCRIPTOR(local,"_LOCAL");
1486
ed253963
CB		 1487 if (!lnm) {
1488 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1489 return SS$_IVLOGNAM;
1490 }
1491
f7ddb74a 1492 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1493 *cp2 = _toupper(*cp1);
1494 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1495 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1496 return SS$_IVLOGNAM;
1497 }
1498 }
a0d0e21e 1499 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1500 if (!tabvec || !*tabvec) tabvec = env_tables;
1501
3eeba6fb 1502 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1503 for (curtab = 0; tabvec[curtab]; curtab++) {
1504 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1505 int i;
299d126a 1506 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1507 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1508 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1509 !strncmp(environ[i],lnm,cp1 - environ[i])) {
cda27dcf
CB		 1510 unsetenv(lnm);
1511 return 0;
f675dbe5
CB		 1512 }
1513 }
1514 ivenv = 1; retsts = SS$_NOLOGNAM;
f675dbe5
CB		 1515 }
1516 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1517 !str$case_blind_compare(&tmpdsc,&clisym)) {
1518 unsigned int symtype;
1519 if (tabvec[curtab]->dsc$w_length == 12 &&
1520 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1521 !str$case_blind_compare(&tmpdsc,&local))
1522 symtype = LIB$K_CLI_LOCAL_SYM;
1523 else symtype = LIB$K_CLI_GLOBAL_SYM;
1524 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1525 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1526 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1527 break;
1528 }
1529 else if (!ivlnm) {
1530 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1531 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1532 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1533 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1534 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1535 }
a0d0e21e
LW		 1536 }
1537 }
f675dbe5
CB		 1538 else { /* we're defining a value */
1539 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
3eeba6fb 1540 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5
CB		 1541 }
1542 else {
f7ddb74a 1543 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1544 eqvdsc.dsc$w_length = strlen(eqv);
1545 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1546 !str$case_blind_compare(&tmpdsc,&clisym)) {
1547 unsigned int symtype;
1548 if (tabvec[0]->dsc$w_length == 12 &&
1549 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1550 !str$case_blind_compare(&tmpdsc,&local))
1551 symtype = LIB$K_CLI_LOCAL_SYM;
1552 else symtype = LIB$K_CLI_GLOBAL_SYM;
1553 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1554 }
3eeba6fb
CB		 1555 else {
1556 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1557 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1558
1559 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1560 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1561 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1562 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1563 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1564 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1565 }
1566
a02a5408 1567 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1568 ile = ilist;
1569 if (!ile) {
1570 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1571 return SS$_INSFMEM;
a1dfe751 1572 }
fa537f88
CB		 1573 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1574
1575 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1576 ile->itmcode = LNM$_STRING;
1577 ile->bufadr = c;
1578 if ((j+1) == nseg) {
1579 ile->buflen = strlen(c);
1580 /* in case we are truncating one that's too long */
1581 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1582 }
1583 else {
1584 ile->buflen = LNM$C_NAMLENGTH;
1585 }
1586 }
1587
1588 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1589 Safefree (ilist);
1590 }
1591 else {
1592 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1593 }
3eeba6fb 1594 }
f675dbe5
CB		 1595 }
1596 }
1597 if (!(retsts & 1)) {
1598 switch (retsts) {
1599 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1600 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1601 set_errno(EVMSERR); break;
1602 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1603 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1604 set_errno(EINVAL); break;
1605 case SS$_NOPRIV:
7d2497bf 1606 set_errno(EACCES); break;
f675dbe5
CB		 1607 default:
1608 _ckvmssts(retsts);
1609 set_errno(EVMSERR);
1610 }
1611 set_vaxc_errno(retsts);
1612 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1613 }
3eeba6fb
CB		 1614 else {
1615 /* We reset error values on success because Perl does an hv_fetch()
1616 * before each hv_store(), and if the thing we're setting didn't
1617 * previously exist, we've got a leftover error message. (Of course,
1618 * this fails in the face of
1619 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1620 * in that the error reported in $! isn't spurious,
1621 * but it's right more often than not.)
1622 */
f675dbe5
CB		 1623 set_errno(0); set_vaxc_errno(retsts);
1624 return 0;
1625 }
1626
1627} /* end of vmssetenv() */
1628/*}}}*/
a0d0e21e 1629
2c590a56 1630/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1631/* This has to be a function since there's a prototype for it in proto.h */
1632void
2c590a56 1633Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1634{
bc10a425
CB		 1635 if (lnm && *lnm) {
1636 int len = strlen(lnm);
1637 if (len == 7) {
1638 char uplnm[8];
22d4bb9c
CB		 1639 int i;
1640 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1641 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1642 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1643 return;
1644 }
1645 }
22d4bb9c 1646 }
f675dbe5
CB		 1647 (void) vmssetenv(lnm,eqv,NULL);
1648}
a0d0e21e
LW		 1649/*}}}*/
1650
27c67b75 1651/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1652/* vmssetuserlnm
1653 * sets a user-mode logical in the process logical name table
1654 * used for redirection of sys$error
1655 */
1656void
0db50132 1657Perl_vmssetuserlnm(const char *name, const char *eqv)
0e06870b
CB		 1658{
1659 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1660 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1661 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1662 unsigned char acmode = PSL$C_USER;
1663 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1664 {0, 0, 0, 0}};
2fbb330f 1665 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1666 d_name.dsc$w_length = strlen(name);
1667
1668 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1669 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1670
1671 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1672 if (!(iss&1)) lib$signal(iss);
1673}
1674/*}}}*/
c07a80fd 1675
f675dbe5 1676
c07a80fd 1677/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1678/* my_crypt - VMS password hashing
1679 * my_crypt() provides an interface compatible with the Unix crypt()
1680 * C library function, and uses sys$hash_password() to perform VMS
1681 * password hashing. The quadword hashed password value is returned
1682 * as a NUL-terminated 8 character string. my_crypt() does not change
1683 * the case of its string arguments; in order to match the behavior
1684 * of LOGINOUT et al., alphabetic characters in both arguments must
1685 * be upcased by the caller.
2497a41f
JM		 1686 *
1687 * - fix me to call ACM services when available
c07a80fd 1688 */
1689char *
fd8cd3a3 1690Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1691{
1692# ifndef UAI$C_PREFERRED_ALGORITHM
1693# define UAI$C_PREFERRED_ALGORITHM 127
1694# endif
1695 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1696 unsigned short int salt = 0;
1697 unsigned long int sts;
1698 struct const_dsc {
1699 unsigned short int dsc$w_length;
1700 unsigned char dsc$b_type;
1701 unsigned char dsc$b_class;
1702 const char * dsc$a_pointer;
1703 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1704 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1705 struct itmlst_3 uailst[3] = {
1706 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1707 { sizeof salt, UAI$_SALT, &salt, 0},
1708 { 0, 0, NULL, NULL}};
1709 static char hash[9];
1710
1711 usrdsc.dsc$w_length = strlen(usrname);
1712 usrdsc.dsc$a_pointer = usrname;
1713 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1714 switch (sts) {
f282b18d 1715 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1716 set_errno(EACCES);
1717 break;
1718 case RMS$_RNF:
1719 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1720 break;
1721 default:
1722 set_errno(EVMSERR);
1723 }
1724 set_vaxc_errno(sts);
1725 if (sts != RMS$_RNF) return NULL;
1726 }
1727
1728 txtdsc.dsc$w_length = strlen(textpasswd);
1729 txtdsc.dsc$a_pointer = textpasswd;
1730 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1731 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1732 }
1733
1734 return (char *) hash;
1735
1736} /* end of my_crypt() */
1737/*}}}*/
1738
1739
360732b5
JM		 1740static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1741static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1742static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1743
e0e5e8d6
JM		 1744/* 8.3, remove() is now broken on symbolic links */
1745static int rms_erase(const char * vmsname);
1746
1747
2497a41f 1748/* mp_do_kill_file
94ae10c0 1749 * A little hack to get around a bug in some implementation of remove()
2497a41f
JM		 1750 * that do not know how to delete a directory
1751 *
1752 * Delete any file to which user has control access, regardless of whether
1753 * delete access is explicitly allowed.
1754 * Limitations: User must have write access to parent directory.
1755 * Does not block signals or ASTs; if interrupted in midstream
1756 * may leave file with an altered ACL.
1757 * HANDLE WITH CARE!
1758 */
1759/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1760static int
1761mp_do_kill_file(pTHX_ const char *name, int dirflag)
1762{
e0e5e8d6
JM		 1763 char *vmsname;
1764 char *rslt;
2497a41f 1765 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
81d2d377
CB		 1766 unsigned long int cxt = 0, aclsts, fndsts;
1767 int rmsts = -1;
2497a41f
JM		 1768 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1769 struct myacedef {
1770 unsigned char myace$b_length;
1771 unsigned char myace$b_type;
1772 unsigned short int myace$w_flags;
1773 unsigned long int myace$l_access;
1774 unsigned long int myace$l_ident;
1775 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1776 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1777 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1778 struct itmlst_3
1779 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1780 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1781 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1782 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1783 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1784 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1785
1786 /* Expand the input spec using RMS, since the CRTL remove() and
1787 * system services won't do this by themselves, so we may miss
1788 * a file "hiding" behind a logical name or search list. */
c11536f5 1789 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1790 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1791
6fb6c614 1792 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1793 if (rslt == NULL) {
c5375c28 1794 PerlMem_free(vmsname);
2497a41f
JM		 1795 return -1;
1796 }
c5375c28 1797
e0e5e8d6
JM		 1798 /* Erase the file */
1799 rmsts = rms_erase(vmsname);
2497a41f 1800
e0e5e8d6
JM		 1801 /* Did it succeed */
1802 if ($VMS_STATUS_SUCCESS(rmsts)) {
1803 PerlMem_free(vmsname);
1804 return 0;
2497a41f
JM		 1805 }
1806
1807 /* If not, can changing protections help? */
e0e5e8d6
JM		 1808 if (rmsts != RMS$_PRV) {
1809 set_vaxc_errno(rmsts);
1810 PerlMem_free(vmsname);
2497a41f
JM		 1811 return -1;
1812 }
1813
1814 /* No, so we get our own UIC to use as a rights identifier,
1815 * and the insert an ACE at the head of the ACL which allows us
1816 * to delete the file.
1817 */
ebd4d70b 1818 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1819 fildsc.dsc$w_length = strlen(vmsname);
1820 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1821 cxt = 0;
1822 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1823 rmsts = -1;
2497a41f
JM		 1824 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1825 switch (aclsts) {
1826 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1827 set_errno(ENOENT); break;
1828 case RMS$_DIR:
1829 set_errno(ENOTDIR); break;
1830 case RMS$_DEV:
1831 set_errno(ENODEV); break;
1832 case RMS$_SYN: case SS$_INVFILFOROP:
1833 set_errno(EINVAL); break;
1834 case RMS$_PRV:
1835 set_errno(EACCES); break;
1836 default:
ebd4d70b 1837 _ckvmssts_noperl(aclsts);
2497a41f
JM		 1838 }
1839 set_vaxc_errno(aclsts);
e0e5e8d6 1840 PerlMem_free(vmsname);
2497a41f
JM		 1841 return -1;
1842 }
1843 /* Grab any existing ACEs with this identifier in case we fail */
1844 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1845 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1846 || fndsts == SS$_NOMOREACE ) {
1847 /* Add the new ACE . . . */
1848 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1849 goto yourroom;
1850
e0e5e8d6
JM		 1851 rmsts = rms_erase(vmsname);
1852 if ($VMS_STATUS_SUCCESS(rmsts)) {
1853 rmsts = 0;
2497a41f
JM		 1854 }
1855 else {
e0e5e8d6 1856 rmsts = -1;
2497a41f
JM		 1857 /* We blew it - dir with files in it, no write priv for
1858 * parent directory, etc. Put things back the way they were. */
1859 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1860 goto yourroom;
1861 if (fndsts & 1) {
1862 addlst[0].bufadr = &oldace;
1863 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1864 goto yourroom;
1865 }
1866 }
1867 }
1868
1869 yourroom:
1870 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1871 /* We just deleted it, so of course it's not there. Some versions of
1872 * VMS seem to return success on the unlock operation anyhow (after all
1873 * the unlock is successful), but others don't.
1874 */
1875 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1876 if (aclsts & 1) aclsts = fndsts;
1877 if (!(aclsts & 1)) {
1878 set_errno(EVMSERR);
1879 set_vaxc_errno(aclsts);
2497a41f
JM		 1880 }
1881
e0e5e8d6 1882 PerlMem_free(vmsname);
2497a41f
JM		 1883 return rmsts;
1884
1885} /* end of kill_file() */
1886/*}}}*/
1887
1888
a0d0e21e
LW		 1889/*{{{int do_rmdir(char *name)*/
1890int
b8ffc8df 1891Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1892{
e0e5e8d6 1893 char * dirfile;
a0d0e21e 1894 int retval;
61bb5906 1895 Stat_t st;
a0d0e21e 1896
d94c5a78
JM		 1897 /* lstat returns a VMS fileified specification of the name */
1898 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 1899
46c05374 1900 retval = flex_lstat(name, &st);
d94c5a78
JM		 1901 if (retval != 0) {
1902 char * ret_spec;
1903
1904 /* Due to a historical feature, flex_stat/lstat can not see some */
1905 /* Unix format file names that the rest of the CRTL can see */
1906 /* Fixing that feature will cause some perl tests to fail */
1907 /* So try this one more time. */
1908
1909 retval = lstat(name, &st.crtl_stat);
1910 if (retval != 0)
1911 return -1;
1912
1913 /* force it to a file spec for the kill file to work. */
1914 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1915 if (ret_spec == NULL) {
1916 errno = EIO;
1917 return -1;
1918 }
e0e5e8d6 1919 }
d94c5a78
JM		 1920
1921 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1922 errno = ENOTDIR;
1923 retval = -1;
1924 }
d94c5a78
JM		 1925 else {
1926 dirfile = st.st_devnam;
1927
1928 /* It may be possible for flex_stat to find a file and vmsify() to */
1929 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1930 /* with that case, so fail it */
1931 if (dirfile[0] == 0) {
1932 errno = EIO;
1933 return -1;
1934 }
1935
e0e5e8d6 1936 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 1937 }
e0e5e8d6 1938
a0d0e21e
LW		 1939 return retval;
1940
1941} /* end of do_rmdir */
1942/*}}}*/
1943
1944/* kill_file
1945 * Delete any file to which user has control access, regardless of whether
1946 * delete access is explicitly allowed.
1947 * Limitations: User must have write access to parent directory.
1948 * Does not block signals or ASTs; if interrupted in midstream
1949 * may leave file with an altered ACL.
1950 * HANDLE WITH CARE!
1951 */
1952/*{{{int kill_file(char *name)*/
1953int
b8ffc8df 1954Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1955{
d94c5a78 1956 char * vmsfile;
e0e5e8d6
JM		 1957 Stat_t st;
1958 int rmsts;
a0d0e21e 1959
d94c5a78
JM		 1960 /* Convert the filename to VMS format and see if it is a directory */
1961 /* flex_lstat returns a vmsified file specification */
46c05374 1962 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 1963 if (rmsts != 0) {
1964
1965 /* Due to a historical feature, flex_stat/lstat can not see some */
1966 /* Unix format file names that the rest of the CRTL can see when */
1967 /* ODS-2 file specifications are in use. */
1968 /* Fixing that feature will cause some perl tests to fail */
1969 /* [.lib.ExtUtils.t]Manifest.t is one of them */
1970 st.st_mode = 0;
1971 vmsfile = (char *) name; /* cast ok */
1972
1973 } else {
1974 vmsfile = st.st_devnam;
1975 if (vmsfile[0] == 0) {
1976 /* It may be possible for flex_stat to find a file and vmsify() */
1977 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
1978 /* deal with that case, so fail it */
1979 errno = EIO;
1980 return -1;
1981 }
1982 }
1983
1984 /* Remove() is allowed to delete directories, according to the X/Open
1985 * specifications.
1986 * This may need special handling to work with the ACL hacks.
a0d0e21e 1987 */
d94c5a78
JM		 1988 if (S_ISDIR(st.st_mode)) {
1989 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
1990 return rmsts;
a0d0e21e
LW		 1991 }
1992
d94c5a78
JM		 1993 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
1994
1995 /* Need to delete all versions ? */
1996 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
1997 int i = 0;
1998
1999 /* Just use lstat() here as do not need st_dev */
2000 /* and we know that the file is in VMS format or that */
2001 /* because of a historical bug, flex_stat can not see the file */
2002 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2003 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2004 if (rmsts != 0)
2005 break;
2006 i++;
2007
2008 /* Make sure that we do not loop forever */
2009 if (i > 32767) {
2010 errno = EIO;
2011 rmsts = -1;
2012 break;
2013 }
2014 }
2015 }
a0d0e21e
LW		 2016
2017 return rmsts;
2018
2019} /* end of kill_file() */
2020/*}}}*/
2021
8cc95fdb 2022
84902520 2023/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2024int
b8ffc8df 2025Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2026{
2027 STRLEN dirlen = strlen(dir);
2028
a2a90019
CB		 2029 /* zero length string sometimes gives ACCVIO */
2030 if (dirlen == 0) return -1;
2031
8cc95fdb 2032 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2033 * null file name/type. However, it's commonplace under Unix,
2034 * so we'll allow it for a gain in portability.
2035 */
2036 if (dir[dirlen-1] == '/') {
2037 char *newdir = savepvn(dir,dirlen-1);
2038 int ret = mkdir(newdir,mode);
2039 Safefree(newdir);
2040 return ret;
2041 }
2042 else return mkdir(dir,mode);
2043} /* end of my_mkdir */
2044/*}}}*/
2045
ee8c7f54
CB		 2046/*{{{int my_chdir(char *)*/
2047int
b8ffc8df 2048Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2049{
2050 STRLEN dirlen = strlen(dir);
09f253ec 2051 const char *dir1 = dir;
ee8c7f54 2052
0fd91152 2053 /* POSIX says we should set ENOENT for zero length string. */
09f253ec 2054 if (dirlen == 0) {
0fd91152 2055 SETERRNO(ENOENT, RMS$_DNF);
09f253ec
CB		 2056 return -1;
2057 }
f7ddb74a
JM		 2058
2059 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2061 * so that existing scripts do not need to be changed.
2062 */
f7ddb74a
JM		 2063 while ((dirlen > 0) && (*dir1 == ' ')) {
2064 dir1++;
2065 dirlen--;
2066 }
ee8c7f54
CB		 2067
2068 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2069 * that implies
2070 * null file name/type. However, it's commonplace under Unix,
2071 * so we'll allow it for a gain in portability.
f7ddb74a 2072 *
4d9538c1 2073 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2074 */
f7ddb74a 2075 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2076 char *newdir;
2077 int ret;
c11536f5 2078 newdir = (char *)PerlMem_malloc(dirlen);
4d9538c1
JM		 2079 if (newdir ==NULL)
2080 _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 2081 memcpy(newdir, dir1, dirlen-1);
4d9538c1
JM		 2082 newdir[dirlen-1] = '\0';
2083 ret = chdir(newdir);
2084 PerlMem_free(newdir);
2085 return ret;
ee8c7f54 2086 }
dca5a913 2087 else return chdir(dir1);
ee8c7f54
CB		 2088} /* end of my_chdir */
2089/*}}}*/
8cc95fdb 2090
674d6c38 2091
f1db9cda
JM		 2092/*{{{int my_chmod(char *, mode_t)*/
2093int
2094Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2095{
4d9538c1
JM		 2096 Stat_t st;
2097 int ret = -1;
2098 char * changefile;
f1db9cda
JM		 2099 STRLEN speclen = strlen(file_spec);
2100
2101 /* zero length string sometimes gives ACCVIO */
2102 if (speclen == 0) return -1;
2103
2104 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2105 * that implies null file name/type. However, it's commonplace under Unix,
2106 * so we'll allow it for a gain in portability.
2107 *
2108 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2109 * in VMS file.dir notation.
2110 */
4d9538c1
JM		 2111 changefile = (char *) file_spec; /* cast ok */
2112 ret = flex_lstat(file_spec, &st);
2113 if (ret != 0) {
f1db9cda 2114
4d9538c1
JM		 2115 /* Due to a historical feature, flex_stat/lstat can not see some */
2116 /* Unix format file names that the rest of the CRTL can see when */
2117 /* ODS-2 file specifications are in use. */
2118 /* Fixing that feature will cause some perl tests to fail */
2119 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2120 st.st_mode = 0;
f1db9cda 2121
4d9538c1
JM		 2122 } else {
2123 /* It may be possible to get here with nothing in st_devname */
2124 /* chmod still may work though */
2125 if (st.st_devnam[0] != 0) {
2126 changefile = st.st_devnam;
2127 }
f1db9cda 2128 }
4d9538c1
JM		 2129 ret = chmod(changefile, mode);
2130 return ret;
f1db9cda
JM		 2131} /* end of my_chmod */
2132/*}}}*/
2133
2134
674d6c38
CB		 2135/*{{{FILE *my_tmpfile()*/
2136FILE *
2137my_tmpfile(void)
2138{
2139 FILE *fp;
2140 char *cp;
674d6c38
CB		 2141
2142 if ((fp = tmpfile())) return fp;
2143
c11536f5 2144 cp = (char *)PerlMem_malloc(L_tmpnam+24);
c5375c28
JM		 2145 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2146
2497a41f
JM		 2147 if (decc_filename_unix_only == 0)
2148 strcpy(cp,"Sys$Scratch:");
2149 else
2150 strcpy(cp,"/tmp/");
674d6c38
CB		 2151 tmpnam(cp+strlen(cp));
2152 strcat(cp,".Perltmp");
2153 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2154 PerlMem_free(cp);
674d6c38
CB		 2155 return fp;
2156}
2157/*}}}*/
2158
5c2d7af2 2159
5c2d7af2
CB		 2160/*
2161 * The C RTL's sigaction fails to check for invalid signal numbers so we
2162 * help it out a bit. The docs are correct, but the actual routine doesn't
2163 * do what the docs say it will.
2164 */
2165/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2166int
2167Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2168 struct sigaction* oact)
2169{
2170 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2171 SETERRNO(EINVAL, SS$_INVARG);
2172 return -1;
2173 }
2174 return sigaction(sig, act, oact);
2175}
2176/*}}}*/
5c2d7af2 2177
f2610a60
CL		 2178#include <errnodef.h>
2179
05c058bc
CB		 2180/* We implement our own kill() using the undocumented system service
2181 sys$sigprc for one of two reasons:
2182
2183 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2184 target process to do a sys$exit, which usually can't be handled
2185 gracefully...certainly not by Perl and the %SIG{} mechanism.
2186
05c058bc
CB		 2187 2.) If the kill() in the CRTL can't be called from a signal
2188 handler without disappearing into the ether, i.e., the signal
2189 it purportedly sends is never trapped. Still true as of VMS 7.3.
2190
2191 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2192 in the target process rather than calling sys$exit.
2193
2194 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2195 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2196 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2197 with condition codes C$_SIG0+nsig*8, catching the exception on the
2198 target process and resignaling with appropriate arguments.
2199
2200 But we don't have that VMS 7.0+ exception handler, so if you
2201 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2202
2203 Also note that SIGTERM is listed in the docs as being "unimplemented",
2204 yet always seems to be signaled with a VMS condition code of 4 (and
2205 correctly handled for that code). So we hardwire it in.
2206
2207 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2208 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2209 than signalling with an unrecognized (and unhandled by CRTL) code.
2210*/
2211
fe1de8ce 2212#define _MY_SIG_MAX 28
f2610a60 2213
9c1171d1
JM		 2214static unsigned int
2215Perl_sig_to_vmscondition_int(int sig)
f2610a60 2216{
2e34cc90 2217 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2218 {
2219 0, /* 0 ZERO */
2220 SS$_HANGUP, /* 1 SIGHUP */
2221 SS$_CONTROLC, /* 2 SIGINT */
2222 SS$_CONTROLY, /* 3 SIGQUIT */
2223 SS$_RADRMOD, /* 4 SIGILL */
2224 SS$_BREAK, /* 5 SIGTRAP */
2225 SS$_OPCCUS, /* 6 SIGABRT */
2226 SS$_COMPAT, /* 7 SIGEMT */
f2610a60 2227 SS$_HPARITH, /* 8 SIGFPE AXP */
f2610a60
CL		 2228 SS$_ABORT, /* 9 SIGKILL */
2229 SS$_ACCVIO, /* 10 SIGBUS */
2230 SS$_ACCVIO, /* 11 SIGSEGV */
2231 SS$_BADPARAM, /* 12 SIGSYS */
2232 SS$_NOMBX, /* 13 SIGPIPE */
2233 SS$_ASTFLT, /* 14 SIGALRM */
2234 4, /* 15 SIGTERM */
2235 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2236 0, /* 17 SIGUSR2 */
2237 0, /* 18 */
2238 0, /* 19 */
2239 0, /* 20 SIGCHLD */
2240 0, /* 21 SIGCONT */
2241 0, /* 22 SIGSTOP */
2242 0, /* 23 SIGTSTP */
2243 0, /* 24 SIGTTIN */
2244 0, /* 25 SIGTTOU */
2245 0, /* 26 */
2246 0, /* 27 */
2247 0 /* 28 SIGWINCH */
f2610a60
CL		 2248 };
2249
f2610a60
CL		 2250 static int initted = 0;
2251 if (!initted) {
2252 initted = 1;
2253 sig_code[16] = C$_SIGUSR1;
2254 sig_code[17] = C$_SIGUSR2;
fe1de8ce 2255 sig_code[20] = C$_SIGCHLD;
fe1de8ce 2256 sig_code[28] = C$_SIGWINCH;
f2610a60 2257 }
f2610a60 2258
2e34cc90
CL		 2259 if (sig < _SIG_MIN) return 0;
2260 if (sig > _MY_SIG_MAX) return 0;
2261 return sig_code[sig];
2262}
2263
9c1171d1
JM		 2264unsigned int
2265Perl_sig_to_vmscondition(int sig)
2266{
2267#ifdef SS$_DEBUG
2268 if (vms_debug_on_exception != 0)
2269 lib$signal(SS$_DEBUG);
2270#endif
2271 return Perl_sig_to_vmscondition_int(sig);
2272}
2273
2274
96f902ff 2275#ifdef KILL_BY_SIGPRC
c11536f5
CB		 2276#define sys$sigprc SYS$SIGPRC
2277#ifdef __cplusplus
2278extern "C" {
2279#endif
2280int sys$sigprc(unsigned int *pidadr,
2281 struct dsc$descriptor_s *prcname,
2282 unsigned int code);
2283#ifdef __cplusplus
2284}
2285#endif
2286
2e34cc90
CL		 2287int
2288Perl_my_kill(int pid, int sig)
2289{
2290 int iss;
2291 unsigned int code;
2e34cc90 2292
7a7fd8e0
JM		 2293 /* sig 0 means validate the PID */
2294 /*------------------------------*/
2295 if (sig == 0) {
2296 const unsigned long int jpicode = JPI$_PID;
2297 pid_t ret_pid;
2298 int status;
2299 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2300 if ($VMS_STATUS_SUCCESS(status))
2301 return 0;
2302 switch (status) {
2303 case SS$_NOSUCHNODE:
2304 case SS$_UNREACHABLE:
2305 case SS$_NONEXPR:
2306 errno = ESRCH;
2307 break;
2308 case SS$_NOPRIV:
2309 errno = EPERM;
2310 break;
2311 default:
2312 errno = EVMSERR;
2313 }
2314 vaxc$errno=status;
2315 return -1;
2316 }
2317
9c1171d1 2318 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2319
7a7fd8e0
JM		 2320 if (!code) {
2321 SETERRNO(EINVAL, SS$_BADPARAM);
2322 return -1;
2323 }
2324
96f902ff 2325 /* Per official UNIX specification: If pid = 0, or negative then
7a7fd8e0
JM		 2326 * signals are to be sent to multiple processes.
2327 * pid = 0 - all processes in group except ones that the system exempts
2328 * pid = -1 - all processes except ones that the system exempts
2329 * pid = -n - all processes in group (abs(n)) except ...
96f902ff
CB		 2330 *
2331 * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2332 * in doio.c already does that. killpg currently does not support the -1 case.
7a7fd8e0
JM		 2333 */
2334
2335 if (pid <= 0) {
96f902ff 2336 return killpg(-pid, sig);
f2610a60
CL		 2337 }
2338
2e34cc90 2339 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2340 if (iss&1) return 0;
2341
2342 switch (iss) {
2343 case SS$_NOPRIV:
2344 set_errno(EPERM); break;
2345 case SS$_NONEXPR:
2346 case SS$_NOSUCHNODE:
2347 case SS$_UNREACHABLE:
2348 set_errno(ESRCH); break;
2349 case SS$_INSFMEM:
2350 set_errno(ENOMEM); break;
2351 default:
ebd4d70b 2352 _ckvmssts_noperl(iss);
f2610a60
CL		 2353 set_errno(EVMSERR);
2354 }
2355 set_vaxc_errno(iss);
2356
2357 return -1;
2358}
2359#endif
2360
96f902ff
CB		 2361int
2362Perl_my_killpg(pid_t master_pid, int signum)
2363{
2364 int pid, status, i;
2365 unsigned long int jpi_context;
2366 unsigned short int iosb[4];
2367 struct itmlst_3 il3[3];
2368
2369 /* All processes on the system? Seems dangerous, but it looks
2370 * like we could implement this pretty easily with a wildcard
2371 * input to sys$process_scan.
2372 */
2373 if (master_pid == -1) {
2374 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2375 return -1;
2376 }
2377
2378 /* All processes in the current process group; find the master
2379 * pid for the current process.
2380 */
2381 if (master_pid == 0) {
2382 i = 0;
2383 il3[i].buflen = sizeof( int );
2384 il3[i].itmcode = JPI$_MASTER_PID;
2385 il3[i].bufadr = &master_pid;
2386 il3[i++].retlen = NULL;
2387
2388 il3[i].buflen = 0;
2389 il3[i].itmcode = 0;
2390 il3[i].bufadr = NULL;
2391 il3[i++].retlen = NULL;
2392
2393 status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2394 if ($VMS_STATUS_SUCCESS(status))
2395 status = iosb[0];
2396
2397 switch (status) {
2398 case SS$_NORMAL:
2399 break;
2400 case SS$_NOPRIV:
2401 case SS$_SUSPENDED:
2402 SETERRNO(EPERM, status);
2403 break;
2404 case SS$_NOMOREPROC:
2405 case SS$_NONEXPR:
2406 case SS$_NOSUCHNODE:
2407 case SS$_UNREACHABLE:
2408 SETERRNO(ESRCH, status);
2409 break;
2410 case SS$_ACCVIO:
2411 case SS$_BADPARAM:
2412 SETERRNO(EINVAL, status);
2413 break;
2414 default:
2415 SETERRNO(EVMSERR, status);
2416 }
2417 if (!$VMS_STATUS_SUCCESS(status))
2418 return -1;
2419 }
2420
2421 /* Set up a process context for those processes we will scan
2422 * with sys$getjpiw. Ask for all processes belonging to the
2423 * master pid.
2424 */
2425
2426 i = 0;
2427 il3[i].buflen = 0;
2428 il3[i].itmcode = PSCAN$_MASTER_PID;
2429 il3[i].bufadr = (void *)master_pid;
2430 il3[i++].retlen = NULL;
2431
2432 il3[i].buflen = 0;
2433 il3[i].itmcode = 0;
2434 il3[i].bufadr = NULL;
2435 il3[i++].retlen = NULL;
2436
2437 status = sys$process_scan(&jpi_context, il3);
2438 switch (status) {
2439 case SS$_NORMAL:
2440 break;
2441 case SS$_ACCVIO:
2442 case SS$_BADPARAM:
2443 case SS$_IVBUFLEN:
2444 case SS$_IVSSRQ:
2445 SETERRNO(EINVAL, status);
2446 break;
2447 default:
2448 SETERRNO(EVMSERR, status);
2449 }
2450 if (!$VMS_STATUS_SUCCESS(status))
2451 return -1;
2452
2453 i = 0;
2454 il3[i].buflen = sizeof(int);
2455 il3[i].itmcode = JPI$_PID;
2456 il3[i].bufadr = &pid;
2457 il3[i++].retlen = NULL;
2458
2459 il3[i].buflen = 0;
2460 il3[i].itmcode = 0;
2461 il3[i].bufadr = NULL;
2462 il3[i++].retlen = NULL;
2463
2464 /* Loop through the processes matching our specified criteria
2465 */
2466
2467 while (1) {
2468 /* Find the next process...
2469 */
2470 status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2471 if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2472
2473 switch (status) {
2474 case SS$_NORMAL:
2475 if (kill(pid, signum) == -1)
2476 break;
2477
2478 continue; /* next process */
2479 case SS$_NOPRIV:
2480 case SS$_SUSPENDED:
2481 SETERRNO(EPERM, status);
2482 break;
2483 case SS$_NOMOREPROC:
2484 break;
2485 case SS$_NONEXPR:
2486 case SS$_NOSUCHNODE:
2487 case SS$_UNREACHABLE:
2488 SETERRNO(ESRCH, status);
2489 break;
2490 case SS$_ACCVIO:
2491 case SS$_BADPARAM:
2492 SETERRNO(EINVAL, status);
2493 break;
2494 default:
2495 SETERRNO(EVMSERR, status);
2496 }
2497
2498 if (!$VMS_STATUS_SUCCESS(status))
2499 break;
2500 }
2501
2502 /* Release context-related resources.
2503 */
2504 (void) sys$process_scan(&jpi_context);
2505
2506 if (status != SS$_NOMOREPROC)
2507 return -1;
2508
2509 return 0;
2510}
2511
2fbb330f
JM		 2512/* Routine to convert a VMS status code to a UNIX status code.
2513** More tricky than it appears because of conflicting conventions with
2514** existing code.
2515**
2516** VMS status codes are a bit mask, with the least significant bit set for
2517** success.
2518**
2519** Special UNIX status of EVMSERR indicates that no translation is currently
2520** available, and programs should check the VMS status code.
2521**
2522** Programs compiled with _POSIX_EXIT have a special encoding that requires
2523** decoding.
2524*/
2525
2526#ifndef C_FACILITY_NO
2527#define C_FACILITY_NO 0x350000
2528#endif
2529#ifndef DCL_IVVERB
2530#define DCL_IVVERB 0x38090
2531#endif
2532
ce12d4b7
CB		 2533int
2534Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f 2535{
ce12d4b7
CB		 2536 int facility;
2537 int fac_sp;
2538 int msg_no;
2539 int msg_status;
2540 int unix_status;
2fbb330f
JM		 2541
2542 /* Assume the best or the worst */
2543 if (vms_status & STS$M_SUCCESS)
2544 unix_status = 0;
2545 else
2546 unix_status = EVMSERR;
2547
2548 msg_status = vms_status & ~STS$M_CONTROL;
2549
2550 facility = vms_status & STS$M_FAC_NO;
2551 fac_sp = vms_status & STS$M_FAC_SP;
2552 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2553
0968cdad 2554 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2555 switch(msg_no) {
2556 case SS$_NORMAL:
2557 unix_status = 0;
2558 break;
2559 case SS$_ACCVIO:
2560 unix_status = EFAULT;
2561 break;
7a7fd8e0
JM		 2562 case SS$_DEVOFFLINE:
2563 unix_status = EBUSY;
2564 break;
2565 case SS$_CLEARED:
2566 unix_status = ENOTCONN;
2567 break;
2568 case SS$_IVCHAN:
2fbb330f
JM		 2569 case SS$_IVLOGNAM:
2570 case SS$_BADPARAM:
2571 case SS$_IVLOGTAB:
2572 case SS$_NOLOGNAM:
2573 case SS$_NOLOGTAB:
2574 case SS$_INVFILFOROP:
2575 case SS$_INVARG:
2576 case SS$_NOSUCHID:
2577 case SS$_IVIDENT:
2578 unix_status = EINVAL;
2579 break;
7a7fd8e0
JM		 2580 case SS$_UNSUPPORTED:
2581 unix_status = ENOTSUP;
2582 break;
2fbb330f
JM		 2583 case SS$_FILACCERR:
2584 case SS$_NOGRPPRV:
2585 case SS$_NOSYSPRV:
2586 unix_status = EACCES;
2587 break;
2588 case SS$_DEVICEFULL:
2589 unix_status = ENOSPC;
2590 break;
2591 case SS$_NOSUCHDEV:
2592 unix_status = ENODEV;
2593 break;
2594 case SS$_NOSUCHFILE:
2595 case SS$_NOSUCHOBJECT:
2596 unix_status = ENOENT;
2597 break;
fb38d079
JM		 2598 case SS$_ABORT: /* Fatal case */
2599 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2600 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2601 unix_status = EINTR;
2602 break;
2603 case SS$_BUFFEROVF:
2604 unix_status = E2BIG;
2605 break;
2606 case SS$_INSFMEM:
2607 unix_status = ENOMEM;
2608 break;
2609 case SS$_NOPRIV:
2610 unix_status = EPERM;
2611 break;
2612 case SS$_NOSUCHNODE:
2613 case SS$_UNREACHABLE:
2614 unix_status = ESRCH;
2615 break;
2616 case SS$_NONEXPR:
2617 unix_status = ECHILD;
2618 break;
2619 default:
2620 if ((facility == 0) && (msg_no < 8)) {
2621 /* These are not real VMS status codes so assume that they are
2622 ** already UNIX status codes
2623 */
2624 unix_status = msg_no;
2625 break;
2626 }
2627 }
2628 }
2629 else {
2630 /* Translate a POSIX exit code to a UNIX exit code */
2631 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2632 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2633 }
2634 else {
7a7fd8e0
JM		 2635
2636 /* Documented traditional behavior for handling VMS child exits */
2637 /*--------------------------------------------------------------*/
2638 if (child_flag != 0) {
2639
2640 /* Success / Informational return 0 */
2641 /*----------------------------------*/
2642 if (msg_no & STS$K_SUCCESS)
2643 return 0;
2644
2645 /* Warning returns 1 */
2646 /*-------------------*/
2647 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2648 return 1;
2649
2650 /* Everything else pass through the severity bits */
2651 /*------------------------------------------------*/
2652 return (msg_no & STS$M_SEVERITY);
2653 }
2654
2655 /* Normal VMS status to ERRNO mapping attempt */
2656 /*--------------------------------------------*/
2fbb330f
JM		 2657 switch(msg_status) {
2658 /* case RMS$_EOF: */ /* End of File */
2659 case RMS$_FNF: /* File Not Found */
2660 case RMS$_DNF: /* Dir Not Found */
2661 unix_status = ENOENT;
2662 break;
2663 case RMS$_RNF: /* Record Not Found */
2664 unix_status = ESRCH;
2665 break;
2666 case RMS$_DIR:
2667 unix_status = ENOTDIR;
2668 break;
2669 case RMS$_DEV:
2670 unix_status = ENODEV;
2671 break;
7a7fd8e0
JM		 2672 case RMS$_IFI:
2673 case RMS$_FAC:
2674 case RMS$_ISI:
2675 unix_status = EBADF;
2676 break;
2677 case RMS$_FEX:
2678 unix_status = EEXIST;
2679 break;
2fbb330f
JM		 2680 case RMS$_SYN:
2681 case RMS$_FNM:
2682 case LIB$_INVSTRDES:
2683 case LIB$_INVARG:
2684 case LIB$_NOSUCHSYM:
2685 case LIB$_INVSYMNAM:
2686 case DCL_IVVERB:
2687 unix_status = EINVAL;
2688 break;
2689 case CLI$_BUFOVF:
2690 case RMS$_RTB:
2691 case CLI$_TKNOVF:
2692 case CLI$_RSLOVF:
2693 unix_status = E2BIG;
2694 break;
2695 case RMS$_PRV: /* No privilege */
2696 case RMS$_ACC: /* ACP file access failed */
2697 case RMS$_WLK: /* Device write locked */
2698 unix_status = EACCES;
2699 break;
ed1b9de0
JM		 2700 case RMS$_MKD: /* Failed to mark for delete */
2701 unix_status = EPERM;
2702 break;
2fbb330f
JM		 2703 /* case RMS$_NMF: */ /* No more files */
2704 }
2705 }
2706 }
2707
2708 return unix_status;
2709}
2710
7a7fd8e0
JM		 2711/* Try to guess at what VMS error status should go with a UNIX errno
2712 * value. This is hard to do as there could be many possible VMS
2713 * error statuses that caused the errno value to be set.
2714 */
2715
ce12d4b7
CB		 2716int
2717Perl_unix_status_to_vms(int unix_status)
7a7fd8e0 2718{
ce12d4b7 2719 int test_unix_status;
7a7fd8e0
JM		 2720
2721 /* Trivial cases first */
2722 /*---------------------*/
2723 if (unix_status == EVMSERR)
2724 return vaxc$errno;
2725
2726 /* Is vaxc$errno sane? */
2727 /*---------------------*/
2728 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2729 if (test_unix_status == unix_status)
2730 return vaxc$errno;
2731
2732 /* If way out of range, must be VMS code already */
2733 /*-----------------------------------------------*/
2734 if (unix_status > EVMSERR)
2735 return unix_status;
2736
2737 /* If out of range, punt */
2738 /*-----------------------*/
2739 if (unix_status > __ERRNO_MAX)
2740 return SS$_ABORT;
2741
2742
2743 /* Ok, now we have to do it the hard way. */
2744 /*----------------------------------------*/
2745 switch(unix_status) {
2746 case 0: return SS$_NORMAL;
2747 case EPERM: return SS$_NOPRIV;
2748 case ENOENT: return SS$_NOSUCHOBJECT;
2749 case ESRCH: return SS$_UNREACHABLE;
2750 case EINTR: return SS$_ABORT;
2751 /* case EIO: */
2752 /* case ENXIO: */
2753 case E2BIG: return SS$_BUFFEROVF;
2754 /* case ENOEXEC */
2755 case EBADF: return RMS$_IFI;
2756 case ECHILD: return SS$_NONEXPR;
2757 /* case EAGAIN */
2758 case ENOMEM: return SS$_INSFMEM;
2759 case EACCES: return SS$_FILACCERR;
2760 case EFAULT: return SS$_ACCVIO;
2761 /* case ENOTBLK */
0968cdad 2762 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2763 case EEXIST: return RMS$_FEX;
2764 /* case EXDEV */
2765 case ENODEV: return SS$_NOSUCHDEV;
2766 case ENOTDIR: return RMS$_DIR;
2767 /* case EISDIR */
2768 case EINVAL: return SS$_INVARG;
2769 /* case ENFILE */
2770 /* case EMFILE */
2771 /* case ENOTTY */
2772 /* case ETXTBSY */
2773 /* case EFBIG */
2774 case ENOSPC: return SS$_DEVICEFULL;
2775 case ESPIPE: return LIB$_INVARG;
2776 /* case EROFS: */
2777 /* case EMLINK: */
2778 /* case EPIPE: */
2779 /* case EDOM */
2780 case ERANGE: return LIB$_INVARG;
2781 /* case EWOULDBLOCK */
2782 /* case EINPROGRESS */
2783 /* case EALREADY */
2784 /* case ENOTSOCK */
2785 /* case EDESTADDRREQ */
2786 /* case EMSGSIZE */
2787 /* case EPROTOTYPE */
2788 /* case ENOPROTOOPT */
2789 /* case EPROTONOSUPPORT */
2790 /* case ESOCKTNOSUPPORT */
2791 /* case EOPNOTSUPP */
2792 /* case EPFNOSUPPORT */
2793 /* case EAFNOSUPPORT */
2794 /* case EADDRINUSE */
2795 /* case EADDRNOTAVAIL */
2796 /* case ENETDOWN */
2797 /* case ENETUNREACH */
2798 /* case ENETRESET */
2799 /* case ECONNABORTED */
2800 /* case ECONNRESET */
2801 /* case ENOBUFS */
2802 /* case EISCONN */
2803 case ENOTCONN: return SS$_CLEARED;
2804 /* case ESHUTDOWN */
2805 /* case ETOOMANYREFS */
2806 /* case ETIMEDOUT */
2807 /* case ECONNREFUSED */
2808 /* case ELOOP */
2809 /* case ENAMETOOLONG */
2810 /* case EHOSTDOWN */
2811 /* case EHOSTUNREACH */
2812 /* case ENOTEMPTY */
2813 /* case EPROCLIM */
2814 /* case EUSERS */
2815 /* case EDQUOT */
2816 /* case ENOMSG */
2817 /* case EIDRM */
2818 /* case EALIGN */
2819 /* case ESTALE */
2820 /* case EREMOTE */
2821 /* case ENOLCK */
2822 /* case ENOSYS */
2823 /* case EFTYPE */
2824 /* case ECANCELED */
2825 /* case EFAIL */
2826 /* case EINPROG */
2827 case ENOTSUP:
2828 return SS$_UNSUPPORTED;
2829 /* case EDEADLK */
2830 /* case ENWAIT */
2831 /* case EILSEQ */
2832 /* case EBADCAT */
2833 /* case EBADMSG */
2834 /* case EABANDONED */
2835 default:
2836 return SS$_ABORT; /* punt */
2837 }
7a7fd8e0 2838}
2fbb330f
JM		 2839
2840
22d4bb9c 2841/* default piping mailbox size */
054a3baf 2842#define PERL_BUFSIZ 8192
22d4bb9c 2843
674d6c38 2844
a0d0e21e 2845static void
8a646e0b 2846create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2847{
22d4bb9c
CB		 2848 unsigned long int mbxbufsiz;
2849 static unsigned long int syssize = 0;
2850 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2851 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2852 int sts;
2853
22d4bb9c
CB		 2854 if (!syssize) {
2855 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2856 /*
22d4bb9c
CB		 2857 * Get the SYSGEN parameter MAXBUF
2858 *
2859 * If the logical 'PERL_MBX_SIZE' is defined
2860 * use the value of the logical instead of PERL_BUFSIZ, but
2861 * keep the size between 128 and MAXBUF.
2862 *
a0d0e21e 2863 */
ebd4d70b 2864 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2865 }
2866
2867 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2868 mbxbufsiz = atoi(csize);
2869 } else {
2870 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2871 }
22d4bb9c
CB		 2872 if (mbxbufsiz < 128) mbxbufsiz = 128;
2873 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2874
ebd4d70b 2875 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2876
ebd4d70b
JM		 2877 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2878 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2879 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2880
2881} /* end of create_mbx() */
2882
22d4bb9c 2883
a0d0e21e 2884/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2885
2886typedef struct _iosb IOSB;
2887typedef struct _iosb* pIOSB;
2888typedef struct _pipe Pipe;
2889typedef struct _pipe* pPipe;
2890typedef struct pipe_details Info;
2891typedef struct pipe_details* pInfo;
2892typedef struct _srqp RQE;
2893typedef struct _srqp* pRQE;
2894typedef struct _tochildbuf CBuf;
2895typedef struct _tochildbuf* pCBuf;
2896
2897struct _iosb {
2898 unsigned short status;
2899 unsigned short count;
2900 unsigned long dvispec;
2901};
2902
2903#pragma member_alignment save
2904#pragma nomember_alignment quadword
2905struct _srqp { /* VMS self-relative queue entry */
2906 unsigned long qptr[2];
2907};
2908#pragma member_alignment restore
2909static RQE RQE_ZERO = {0,0};
2910
2911struct _tochildbuf {
2912 RQE q;
2913 int eof;
2914 unsigned short size;
2915 char *buf;
2916};
2917
2918struct _pipe {
2919 RQE free;
2920 RQE wait;
2921 int fd_out;
2922 unsigned short chan_in;
2923 unsigned short chan_out;
2924 char *buf;
2925 unsigned int bufsize;
2926 IOSB iosb;
2927 IOSB iosb2;
2928 int *pipe_done;
2929 int retry;
2930 int type;
2931 int shut_on_empty;
2932 int need_wake;
2933 pPipe *home;
2934 pInfo info;
2935 pCBuf curr;
2936 pCBuf curr2;
fd8cd3a3
DS		 2937#if defined(PERL_IMPLICIT_CONTEXT)
2938 void *thx; /* Either a thread or an interpreter */
2939 /* pointer, depending on how we're built */
2940#endif
22d4bb9c
CB		 2941};
2942
2943
a0d0e21e
LW		 2944struct pipe_details
2945{
22d4bb9c 2946 pInfo next;
ff7adb52
CL		 2947 PerlIO *fp; /* file pointer to pipe mailbox */
2948 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2949 int pid; /* PID of subprocess */
2950 int mode; /* == 'r' if pipe open for reading */
2951 int done; /* subprocess has completed */
ff7adb52 2952 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2953 int closing; /* my_pclose is closing this pipe */
2954 unsigned long completion; /* termination status of subprocess */
2955 pPipe in; /* pipe in to sub */
2956 pPipe out; /* pipe out of sub */
2957 pPipe err; /* pipe of sub's sys$error */
2958 int in_done; /* true when in pipe finished */
2959 int out_done;
2960 int err_done;
cd1191f1
CB		 2961 unsigned short xchan; /* channel to debug xterm */
2962 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2963};
2964
748a9306
LW		 2965struct exit_control_block
2966{
2967 struct exit_control_block *flink;
f7c699a0 2968 unsigned long int (*exit_routine)(void);
748a9306
LW		 2969 unsigned long int arg_count;
2970 unsigned long int *status_address;
2971 unsigned long int exit_status;
2972};
2973
d85f548a
JH		 2974typedef struct _closed_pipes Xpipe;
2975typedef struct _closed_pipes* pXpipe;
2976
2977struct _closed_pipes {
2978 int pid; /* PID of subprocess */
2979 unsigned long completion; /* termination status of subprocess */
2980};
2981#define NKEEPCLOSED 50
2982static Xpipe closed_list[NKEEPCLOSED];
2983static int closed_index = 0;
2984static int closed_num = 0;
2985
22d4bb9c
CB		 2986#define RETRY_DELAY "0 ::0.20"
2987#define MAX_RETRY 50
a0d0e21e 2988
22d4bb9c
CB		 2989static int pipe_ef = 0; /* first call to safe_popen inits these*/
2990static unsigned long mypid;
2991static unsigned long delaytime[2];
2992
2993static pInfo open_pipes = NULL;
2994static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2995
ff7adb52
CL		 2996#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2997
2998
3eeba6fb 2999
748a9306 3000static unsigned long int
f7c699a0 3001pipe_exit_routine(void)
748a9306 3002{
22d4bb9c 3003 pInfo info;
1e422769 3004 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
4e0c9737 3005 int sts, did_stuff, j;
ff7adb52 3006
5ce486e0
CB		 3007 /*
3008 * Flush any pending i/o, but since we are in process run-down, be
3009 * careful about referencing PerlIO structures that may already have
3010 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 3011 */
3012 info = open_pipes;
3013 while (info) {
3014 if (info->fp) {
ebd4d70b
JM		 3015#if defined(PERL_IMPLICIT_CONTEXT)
3016 /* We need to use the Perl context of the thread that created */
3017 /* the pipe. */
3018 pTHX;
3019 if (info->err)
3020 aTHX = info->err->thx;
3021 else if (info->out)
3022 aTHX = info->out->thx;
3023 else if (info->in)
3024 aTHX = info->in->thx;
3025#endif
5ce486e0
CB		 3026 if (!info->useFILE
3027#if defined(USE_ITHREADS)
3028 && my_perl
3029#endif
a24c654f
CB		 3030#ifdef USE_PERLIO
3031 && PL_perlio_fd_refcnt
3032#endif
3033 )
5ce486e0 3034 PerlIO_flush(info->fp);
ff7adb52
CL		 3035 else
3036 fflush((FILE *)info->fp);
3037 }
3038 info = info->next;
3039 }
3eeba6fb
CB		 3040
3041 /*
ff7adb52 3042 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 3043 don't hang
3044 */
3045 did_stuff = 0;
3046 info = open_pipes;
748a9306 3047
3eeba6fb 3048 while (info) {
d4c83939 3049 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 3050 if (info->in && !info->in->shut_on_empty) {
d4c83939 3051 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 3052 0, 0, 0, 0, 0, 0));
ff7adb52 3053 info->waiting = 1;
22d4bb9c 3054 did_stuff = 1;
748a9306 3055 }
d4c83939 3056 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3057 info = info->next;
3058 }
ff7adb52
CL		 3059
3060 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3061
3062 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3063 int nwait = 0;
3064
3065 info = open_pipes;
3066 while (info) {
d4c83939 3067 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3068 if (info->waiting && info->done)
3069 info->waiting = 0;
3070 nwait += info->waiting;
d4c83939 3071 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3072 info = info->next;
3073 }
3074 if (!nwait) break;
3075 sleep(1);
3076 }
3eeba6fb
CB		 3077
3078 did_stuff = 0;
3079 info = open_pipes;
3080 while (info) {
d4c83939 3081 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3082 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3083 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3084 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3085 did_stuff = 1;
3086 }
d4c83939 3087 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3088 info = info->next;
3089 }
ff7adb52
CL		 3090
3091 /* again, wait for effect */
3092
3093 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3094 int nwait = 0;
3095
3096 info = open_pipes;
3097 while (info) {
d4c83939 3098 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3099 if (info->waiting && info->done)
3100 info->waiting = 0;
3101 nwait += info->waiting;
d4c83939 3102 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3103 info = info->next;
3104 }
3105 if (!nwait) break;
3106 sleep(1);
3107 }
3eeba6fb
CB		 3108
3109 info = open_pipes;
3110 while (info) {
d4c83939 3111 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3112 if (!info->done) { /* We tried to be nice . . . */
3113 sts = sys$delprc(&info->pid,0);
d4c83939 3114 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3115 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3116 }
d4c83939 3117 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3118 info = info->next;
3119 }
3120
3121 while(open_pipes) {
ebd4d70b
JM		 3122
3123#if defined(PERL_IMPLICIT_CONTEXT)
3124 /* We need to use the Perl context of the thread that created */
3125 /* the pipe. */
3126 pTHX;
36b6faa8
CB		 3127 if (open_pipes->err)
3128 aTHX = open_pipes->err->thx;
3129 else if (open_pipes->out)
3130 aTHX = open_pipes->out->thx;
3131 else if (open_pipes->in)
3132 aTHX = open_pipes->in->thx;
ebd4d70b 3133#endif
1e422769 3134 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3135 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3136 }
3137 return retsts;
3138}
3139
3140static struct exit_control_block pipe_exitblock =
3141 {(struct exit_control_block *) 0,
3142 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3143
22d4bb9c
CB		 3144static void pipe_mbxtofd_ast(pPipe p);
3145static void pipe_tochild1_ast(pPipe p);
3146static void pipe_tochild2_ast(pPipe p);
748a9306 3147
a0d0e21e 3148static void
22d4bb9c 3149popen_completion_ast(pInfo info)
a0d0e21e 3150{
22d4bb9c
CB		 3151 pInfo i = open_pipes;
3152 int iss;
d85f548a
JH		 3153
3154 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3155 closed_list[closed_index].pid = info->pid;
3156 closed_list[closed_index].completion = info->completion;
3157 closed_index++;
3158 if (closed_index == NKEEPCLOSED)
3159 closed_index = 0;
3160 closed_num++;
22d4bb9c
CB		 3161
3162 while (i) {
3163 if (i == info) break;
3164 i = i->next;
3165 }
3166 if (!i) return; /* unlinked, probably freed too */
3167
22d4bb9c
CB		 3168 info->done = TRUE;
3169
3170/*
3171 Writing to subprocess ...
3172 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3173
3174 chan_out may be waiting for "done" flag, or hung waiting
3175 for i/o completion to child...cancel the i/o. This will
3176 put it into "snarf mode" (done but no EOF yet) that discards
3177 input.
3178
3179 Output from subprocess (stdout, stderr) needs to be flushed and
3180 shut down. We try sending an EOF, but if the mbx is full the pipe
3181 routine should still catch the "shut_on_empty" flag, telling it to
3182 use immediate-style reads so that "mbx empty" -> EOF.
3183
3184
3185*/
3186 if (info->in && !info->in_done) { /* only for mode=w */
3187 if (info->in->shut_on_empty && info->in->need_wake) {
3188 info->in->need_wake = FALSE;
fd8cd3a3 3189 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3190 } else {
fd8cd3a3 3191 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3192 }
3193 }
3194
3195 if (info->out && !info->out_done) { /* were we also piping output? */
3196 info->out->shut_on_empty = TRUE;
3197 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3198 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3199 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3200 }
3201
3202 if (info->err && !info->err_done) { /* we were piping stderr */
3203 info->err->shut_on_empty = TRUE;
3204 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3205 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3206 _ckvmssts_noperl(iss);
a0d0e21e 3207 }
fd8cd3a3 3208 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3209
a0d0e21e
LW		 3210}
3211
2fbb330f 3212static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3213static void vms_execfree(struct dsc$descriptor_s *vmscmd);
22d4bb9c
CB		 3214static void pipe_infromchild_ast(pPipe p);
3215
3216/*
3217 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3218 inside an AST routine without worrying about reentrancy and which Perl
3219 memory allocator is being used.
3220
3221 We read data and queue up the buffers, then spit them out one at a
3222 time to the output mailbox when the output mailbox is ready for one.
3223
3224*/
3225#define INITIAL_TOCHILDQUEUE 2
3226
3227static pPipe
fd8cd3a3 3228pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3229{
22d4bb9c
CB		 3230 pPipe p;
3231 pCBuf b;
3232 char mbx1[64], mbx2[64];
3233 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3234 DSC$K_CLASS_S, mbx1},
3235 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3236 DSC$K_CLASS_S, mbx2};
3237 unsigned int dviitm = DVI$_DEVBUFSIZ;
3238 int j, n;
3239
d4c83939 3240 n = sizeof(Pipe);
ebd4d70b 3241 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3242
8a646e0b
JM		 3243 create_mbx(&p->chan_in , &d_mbx1);
3244 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3245 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3246
3247 p->buf = 0;
3248 p->shut_on_empty = FALSE;
3249 p->need_wake = FALSE;
3250 p->type = 0;
3251 p->retry = 0;
3252 p->iosb.status = SS$_NORMAL;
3253 p->iosb2.status = SS$_NORMAL;
3254 p->free = RQE_ZERO;
3255 p->wait = RQE_ZERO;
3256 p->curr = 0;
3257 p->curr2 = 0;
3258 p->info = 0;
fd8cd3a3
DS		 3259#ifdef PERL_IMPLICIT_CONTEXT
3260 p->thx = aTHX;
3261#endif
22d4bb9c
CB		 3262
3263 n = sizeof(CBuf) + p->bufsize;
3264
3265 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3266 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3267 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3268 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3269 }
3270
3271 pipe_tochild2_ast(p);
3272 pipe_tochild1_ast(p);
3273 strcpy(wmbx, mbx1);
3274 strcpy(rmbx, mbx2);
3275 return p;
3276}
3277
3278/* reads the MBX Perl is writing, and queues */
3279
3280static void
3281pipe_tochild1_ast(pPipe p)
3282{
22d4bb9c
CB		 3283 pCBuf b = p->curr;
3284 int iss = p->iosb.status;
3285 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3286 int sts;
fd8cd3a3
DS		 3287#ifdef PERL_IMPLICIT_CONTEXT
3288 pTHX = p->thx;
3289#endif
22d4bb9c
CB		 3290
3291 if (p->retry) {
3292 if (eof) {
3293 p->shut_on_empty = TRUE;
3294 b->eof = TRUE;
ebd4d70b 3295 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3296 } else {
ebd4d70b 3297 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3298 }
3299
3300 b->eof = eof;
3301 b->size = p->iosb.count;
ebd4d70b 3302 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3303 if (p->need_wake) {
3304 p->need_wake = FALSE;
ebd4d70b 3305 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3306 }
3307 } else {
3308 p->retry = 1; /* initial call */
3309 }
3310
3311 if (eof) { /* flush the free queue, return when done */
3312 int n = sizeof(CBuf) + p->bufsize;
3313 while (1) {
3314 iss = lib$remqti(&p->free, &b);
3315 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3316 _ckvmssts_noperl(iss);
3317 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3318 }
3319 }
3320
3321 iss = lib$remqti(&p->free, &b);
3322 if (iss == LIB$_QUEWASEMP) {
3323 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3324 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3325 b->buf = (char *) b + sizeof(CBuf);
3326 } else {
ebd4d70b 3327 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3328 }
3329
3330 p->curr = b;
3331 iss = sys$qio(0,p->chan_in,
3332 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3333 &p->iosb,
3334 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3335 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3336 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3337}
3338
3339
3340/* writes queued buffers to output, waits for each to complete before
3341 doing the next */
3342
3343static void
3344pipe_tochild2_ast(pPipe p)
3345{
22d4bb9c
CB		 3346 pCBuf b = p->curr2;
3347 int iss = p->iosb2.status;
3348 int n = sizeof(CBuf) + p->bufsize;
3349 int done = (p->info && p->info->done) ||
3350 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3351#if defined(PERL_IMPLICIT_CONTEXT)
3352 pTHX = p->thx;
3353#endif
22d4bb9c
CB		 3354
3355 do {
3356 if (p->type) { /* type=1 has old buffer, dispose */
3357 if (p->shut_on_empty) {
ebd4d70b 3358 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3359 } else {
ebd4d70b 3360 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3361 }
3362 p->type = 0;
3363 }
3364
3365 iss = lib$remqti(&p->wait, &b);
3366 if (iss == LIB$_QUEWASEMP) {
3367 if (p->shut_on_empty) {
3368 if (done) {
ebd4d70b 3369 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3370 *p->pipe_done = TRUE;
ebd4d70b 3371 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3372 } else {
ebd4d70b 3373 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3374 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3375 }
3376 return;
3377 }
3378 p->need_wake = TRUE;
3379 return;
3380 }
ebd4d70b 3381 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3382 p->type = 1;
3383 } while (done);
3384
3385
3386 p->curr2 = b;
3387 if (b->eof) {
ebd4d70b 3388 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3389 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3390 } else {
ebd4d70b 3391 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3392 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3393 }
3394
3395 return;
3396
3397}
3398
3399
3400static pPipe
fd8cd3a3 3401pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3402{
22d4bb9c
CB		 3403 pPipe p;
3404 char mbx1[64], mbx2[64];
3405 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3406 DSC$K_CLASS_S, mbx1},
3407 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3408 DSC$K_CLASS_S, mbx2};
3409 unsigned int dviitm = DVI$_DEVBUFSIZ;
3410
d4c83939 3411 int n = sizeof(Pipe);
ebd4d70b 3412 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3413 create_mbx(&p->chan_in , &d_mbx1);
3414 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3415
ebd4d70b 3416 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3417 n = p->bufsize * sizeof(char);
ebd4d70b 3418 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3419 p->shut_on_empty = FALSE;
3420 p->info = 0;
3421 p->type = 0;
3422 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3423#if defined(PERL_IMPLICIT_CONTEXT)
3424 p->thx = aTHX;
3425#endif
22d4bb9c
CB		 3426 pipe_infromchild_ast(p);
3427
3428 strcpy(wmbx, mbx1);
3429 strcpy(rmbx, mbx2);
3430 return p;
3431}
3432
3433static void
3434pipe_infromchild_ast(pPipe p)
3435{
22d4bb9c
CB		 3436 int iss = p->iosb.status;
3437 int eof = (iss == SS$_ENDOFFILE);
3438 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3439 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3440#if defined(PERL_IMPLICIT_CONTEXT)
3441 pTHX = p->thx;
3442#endif
22d4bb9c
CB		 3443
3444 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3445 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3446 p->chan_out = 0;
3447 }
3448
3449 /* read completed:
3450 input shutdown if EOF from self (done or shut_on_empty)
3451 output shutdown if closing flag set (my_pclose)
3452 send data/eof from child or eof from self
3453 otherwise, re-read (snarf of data from child)
3454 */
3455
3456 if (p->type == 1) {
3457 p->type = 0;
3458 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3459 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3460 p->chan_in = 0;
3461 }
3462
3463 if (p->chan_out) {
3464 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3465 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3466 pipe_infromchild_ast, p,
3467 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3468 return;
3469 } else if (eof) { /* eat EOF --- fall through to read*/
3470
3471 } else { /* transmit data */
ebd4d70b
JM		 3472 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3473 pipe_infromchild_ast,p,
3474 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3475 return;
3476 }
3477 }
3478 }
3479
3480 /* everything shut? flag as done */
3481
3482 if (!p->chan_in && !p->chan_out) {
3483 *p->pipe_done = TRUE;
ebd4d70b 3484 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3485 return;
3486 }
3487
3488 /* write completed (or read, if snarfing from child)
3489 if still have input active,
3490 queue read...immediate mode if shut_on_empty so we get EOF if empty
3491 otherwise,
3492 check if Perl reading, generate EOFs as needed
3493 */
3494
3495 if (p->type == 0) {
3496 p->type = 1;
3497 if (p->chan_in) {
3498 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3499 pipe_infromchild_ast,p,
3500 p->buf, p->bufsize, 0, 0, 0, 0);
3501 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3502 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3503 } else { /* send EOFs for extra reads */
3504 p->iosb.status = SS$_ENDOFFILE;
3505 p->iosb.dvispec = 0;
ebd4d70b
JM		 3506 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3507 0, 0, 0,
3508 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3509 }
3510 }
3511}
3512
3513static pPipe
fd8cd3a3 3514pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3515{
22d4bb9c
CB		 3516 pPipe p;
3517 char mbx[64];
3518 unsigned long dviitm = DVI$_DEVBUFSIZ;
3519 struct stat s;
3520 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3521 DSC$K_CLASS_S, mbx};
a480973c 3522 int n = sizeof(Pipe);
22d4bb9c
CB		 3523
3524 /* things like terminals and mbx's don't need this filter */
3525 if (fd && fstat(fd,&s) == 0) {
4e0c9737 3526 unsigned long devchar;
cfcfe586
JM		 3527 char device[65];
3528 unsigned short dev_len;
3529 struct dsc$descriptor_s d_dev;
3530 char * cptr;
3531 struct item_list_3 items[3];
3532 int status;
3533 unsigned short dvi_iosb[4];
3534
3535 cptr = getname(fd, out, 1);
ebd4d70b 3536 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3537 d_dev.dsc$a_pointer = out;
3538 d_dev.dsc$w_length = strlen(out);
3539 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3540 d_dev.dsc$b_class = DSC$K_CLASS_S;
3541
3542 items[0].len = 4;
3543 items[0].code = DVI$_DEVCHAR;
3544 items[0].bufadr = &devchar;
3545 items[0].retadr = NULL;
3546 items[1].len = 64;
3547 items[1].code = DVI$_FULLDEVNAM;
3548 items[1].bufadr = device;
3549 items[1].retadr = &dev_len;
3550 items[2].len = 0;
3551 items[2].code = 0;
3552
3553 status = sys$getdviw
3554 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3555 _ckvmssts_noperl(status);
cfcfe586
JM		 3556 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3557 device[dev_len] = 0;
3558
3559 if (!(devchar & DEV$M_DIR)) {
3560 strcpy(out, device);
3561 return 0;
3562 }
3563 }
22d4bb9c
CB		 3564 }
3565
ebd4d70b 3566 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3567 p->fd_out = dup(fd);
8a646e0b 3568 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3569 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3570 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3571 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3572 p->shut_on_empty = FALSE;
3573 p->retry = 0;
3574 p->info = 0;
3575 strcpy(out, mbx);
3576
ebd4d70b
JM		 3577 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3578 pipe_mbxtofd_ast, p,
3579 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3580
3581 return p;
3582}
3583
3584static void
3585pipe_mbxtofd_ast(pPipe p)
3586{
22d4bb9c
CB		 3587 int iss = p->iosb.status;
3588 int done = p->info->done;
3589 int iss2;
3590 int eof = (iss == SS$_ENDOFFILE);
3591 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3592 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3593#if defined(PERL_IMPLICIT_CONTEXT)
3594 pTHX = p->thx;
3595#endif
22d4bb9c
CB		 3596
3597 if (done && myeof) { /* end piping */
3598 close(p->fd_out);
3599 sys$dassgn(p->chan_in);
3600 *p->pipe_done = TRUE;
ebd4d70b 3601 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3602 return;
3603 }
3604
3605 if (!err && !eof) { /* good data to send to file */
3606 p->buf[p->iosb.count] = '\n';
3607 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3608 if (iss2 < 0) {
3609 p->retry++;
3610 if (p->retry < MAX_RETRY) {
ebd4d70b 3611 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3612 return;
3613 }
3614 }
3615 p->retry = 0;
3616 } else if (err) {
ebd4d70b 3617 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3618 }
3619
3620
3621 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3622 pipe_mbxtofd_ast, p,
3623 p->buf, p->bufsize, 0, 0, 0, 0);
3624 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3625 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3626}
3627
3628
3629typedef struct _pipeloc PLOC;
3630typedef struct _pipeloc* pPLOC;
3631
3632struct _pipeloc {
3633 pPLOC next;
3634 char dir[NAM$C_MAXRSS+1];
3635};
3636static pPLOC head_PLOC = 0;
3637
5c0ae288 3638void
fd8cd3a3 3639free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3640{
3641 pPLOC p, pnext;
ff7adb52 3642 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3643
ff7adb52 3644 p = *pHead;
5c0ae288
CL		 3645 while (p) {
3646 pnext = p->next;
e0ef6b43 3647 PerlMem_free(p);
5c0ae288
CL		 3648 p = pnext;
3649 }
ff7adb52 3650 *pHead = 0;
5c0ae288 3651}
22d4bb9c
CB		 3652
3653static void
fd8cd3a3 3654store_pipelocs(pTHX)
22d4bb9c
CB		 3655{
3656 int i;
3657 pPLOC p;
ff7adb52 3658 AV *av = 0;
22d4bb9c 3659 SV *dirsv;
22d4bb9c
CB		 3660 char *dir, *x;
3661 char *unixdir;
3662 char temp[NAM$C_MAXRSS+1];
3663 STRLEN n_a;
3664
ff7adb52 3665 if (head_PLOC)
218fdd94 3666 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3667
22d4bb9c
CB		 3668/* the . directory from @INC comes last */
3669
e0ef6b43 3670 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3671 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3672 p->next = head_PLOC;
3673 head_PLOC = p;
3674 strcpy(p->dir,"./");
3675
3676/* get the directory from $^X */
3677
c11536f5 3678 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3679 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3680
218fdd94
CL		 3681#ifdef PERL_IMPLICIT_CONTEXT
3682 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3683#else
22d4bb9c 3684 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3685#endif
a35dcc95 3686 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
22d4bb9c 3687 x = strrchr(temp,']');
2497a41f
JM		 3688 if (x == NULL) {
3689 x = strrchr(temp,'>');
3690 if (x == NULL) {
3691 /* It could be a UNIX path */
3692 x = strrchr(temp,'/');
3693 }
3694 }
3695 if (x)
3696 x[1] = '\0';
3697 else {
3698 /* Got a bare name, so use default directory */
3699 temp[0] = '.';
3700 temp[1] = '\0';
3701 }
22d4bb9c 3702
4e205ed6 3703 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3704 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3705 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3706 p->next = head_PLOC;
3707 head_PLOC = p;
a35dcc95 3708 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
c5375c28 3709 }
22d4bb9c
CB		 3710 }
3711
3712/* reverse order of @INC entries, skip "." since entered above */
3713
218fdd94
CL		 3714#ifdef PERL_IMPLICIT_CONTEXT
3715 if (aTHX)
3716#endif
ff7adb52
CL		 3717 if (PL_incgv) av = GvAVn(PL_incgv);
3718
3719 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3720 dirsv = *av_fetch(av,i,TRUE);
3721
3722 if (SvROK(dirsv)) continue;
3723 dir = SvPVx(dirsv,n_a);
3724 if (strcmp(dir,".") == 0) continue;
4e205ed6 3725 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3726 continue;
3727
e0ef6b43 3728 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3729 p->next = head_PLOC;
3730 head_PLOC = p;
a35dcc95 3731 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3732 }
3733
3734/* most likely spot (ARCHLIB) put first in the list */
3735
3736#ifdef ARCHLIB_EXP
4e205ed6 3737 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3738 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3739 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3740 p->next = head_PLOC;
3741 head_PLOC = p;
a35dcc95 3742 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3743 }
3744#endif
c5375c28 3745 PerlMem_free(unixdir);
22d4bb9c
CB		 3746}
3747
ce12d4b7
CB		 3748static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3749 const char *fname, int opts);
a1887106
JM		 3750#if !defined(PERL_IMPLICIT_CONTEXT)
3751#define cando_by_name_int Perl_cando_by_name_int
3752#else
3753#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3754#endif
22d4bb9c
CB		 3755
3756static char *
fd8cd3a3 3757find_vmspipe(pTHX)
22d4bb9c
CB		 3758{
3759 static int vmspipe_file_status = 0;
3760 static char vmspipe_file[NAM$C_MAXRSS+1];
3761
3762 /* already found? Check and use ... need read+execute permission */
3763
3764 if (vmspipe_file_status == 1) {
a1887106
JM		 3765 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3766 && cando_by_name_int
3767 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3768 return vmspipe_file;
3769 }
3770 vmspipe_file_status = 0;
3771 }
3772
3773 /* scan through stored @INC, $^X */
3774
3775 if (vmspipe_file_status == 0) {
3776 char file[NAM$C_MAXRSS+1];
3777 pPLOC p = head_PLOC;
3778
3779 while (p) {
2f4077ca 3780 char * exp_res;
4d743a9b 3781 int dirlen;
a35dcc95
CB		 3782 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3783 my_strlcat(file, "vmspipe.com", sizeof(file));
22d4bb9c
CB		 3784 p = p->next;
3785
6fb6c614 3786 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3787 if (!exp_res) continue;
22d4bb9c 3788
a1887106
JM		 3789 if (cando_by_name_int
3790 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3791 && cando_by_name_int
3792 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3793 vmspipe_file_status = 1;
3794 return vmspipe_file;
3795 }
3796 }
3797 vmspipe_file_status = -1; /* failed, use tempfiles */
3798 }
3799
3800 return 0;
3801}
3802
3803static FILE *
fd8cd3a3 3804vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3805{
3806 char file[NAM$C_MAXRSS+1];
3807 FILE *fp;
3808 static int index = 0;
2497a41f
JM		 3809 Stat_t s0, s1;
3810 int cmp_result;
22d4bb9c
CB		 3811
3812 /* create a tempfile */
3813
3814 /* we can't go from W, shr=get to R, shr=get without
3815 an intermediate vulnerable state, so don't bother trying...
3816
3817 and lib$spawn doesn't shr=put, so have to close the write
3818
3819 So... match up the creation date/time and the FID to
3820 make sure we're dealing with the same file
3821
3822 */
3823
3824 index++;
2497a41f
JM		 3825 if (!decc_filename_unix_only) {
3826 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3827 fp = fopen(file,"w");
3828 if (!fp) {
22d4bb9c
CB		 3829 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3830 fp = fopen(file,"w");
3831 if (!fp) {
3832 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3833 fp = fopen(file,"w");
2497a41f
JM		 3834 }
3835 }
3836 }
3837 else {
3838 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3839 fp = fopen(file,"w");
3840 if (!fp) {
3841 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3842 fp = fopen(file,"w");
3843 if (!fp) {
3844 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3845 fp = fopen(file,"w");
3846 }
3847 }
22d4bb9c
CB		 3848 }
3849 if (!fp) return 0; /* we're hosed */
3850
f9ecfa39 3851 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3852 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3853 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3854 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3855 fprintf(fp,"$ perl_on = \"set noon\"\n");
3856 fprintf(fp,"$ perl_exit = \"exit\"\n");
3857 fprintf(fp,"$ perl_del = \"delete\"\n");
3858 fprintf(fp,"$ pif = \"if\"\n");
3859 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3860 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3861 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3862 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3863 fprintf(fp,"$! --- build command line to get max possible length\n");
3864 fprintf(fp,"$c=perl_popen_cmd0\n");
3865 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3866 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3867 fprintf(fp,"$x=perl_popen_cmd3\n");
3868 fprintf(fp,"$c=c+x\n");
22d4bb9c 3869 fprintf(fp,"$ perl_on\n");
f9ecfa39 3870 fprintf(fp,"$ 'c'\n");
22d4bb9c 3871 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3872 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3873 fprintf(fp,"$ perl_exit 'perl_status'\n");
3874 fsync(fileno(fp));
3875
3876 fgetname(fp, file, 1);
312ac60b 3877 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3878 fclose(fp);
3879
2497a41f 3880 if (decc_filename_unix_only)
0e5ce2c7 3881 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3882 fp = fopen(file,"r","shr=get");
3883 if (!fp) return 0;
312ac60b 3884 fstat(fileno(fp), &s1.crtl_stat);
2497a41f 3885
682e4b71 3886 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3887 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3888 fclose(fp);
3889 return 0;
3890 }
3891
3892 return fp;
3893}
3894
3895
ce12d4b7
CB		 3896static int
3897vms_is_syscommand_xterm(void)
cd1191f1
CB		 3898{
3899 const static struct dsc$descriptor_s syscommand_dsc =
3900 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3901
3902 const static struct dsc$descriptor_s decwdisplay_dsc =
3903 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3904
3905 struct item_list_3 items[2];
3906 unsigned short dvi_iosb[4];
3907 unsigned long devchar;
3908 unsigned long devclass;
3909 int status;
3910
3911 /* Very simple check to guess if sys$command is a decterm? */
3912 /* First see if the DECW$DISPLAY: device exists */
3913 items[0].len = 4;
3914 items[0].code = DVI$_DEVCHAR;
3915 items[0].bufadr = &devchar;
3916 items[0].retadr = NULL;
3917 items[1].len = 0;
3918 items[1].code = 0;
3919
3920 status = sys$getdviw
3921 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3922
3923 if ($VMS_STATUS_SUCCESS(status)) {
3924 status = dvi_iosb[0];
3925 }
3926
3927 if (!$VMS_STATUS_SUCCESS(status)) {
3928 SETERRNO(EVMSERR, status);
3929 return -1;
3930 }
3931
3932 /* If it does, then for now assume that we are on a workstation */
3933 /* Now verify that SYS$COMMAND is a terminal */
3934 /* for creating the debugger DECTerm */
3935
3936 items[0].len = 4;
3937 items[0].code = DVI$_DEVCLASS;
3938 items[0].bufadr = &devclass;
3939 items[0].retadr = NULL;
3940 items[1].len = 0;
3941 items[1].code = 0;
3942
3943 status = sys$getdviw
3944 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3945
3946 if ($VMS_STATUS_SUCCESS(status)) {
3947 status = dvi_iosb[0];
3948 }
3949
3950 if (!$VMS_STATUS_SUCCESS(status)) {
3951 SETERRNO(EVMSERR, status);
3952 return -1;
3953 }
3954 else {
3955 if (devclass == DC$_TERM) {
3956 return 0;
3957 }
3958 }
3959 return -1;
3960}
3961
3962/* If we are on a DECTerm, we can pretend to fork xterms when requested */
ce12d4b7
CB		 3963static PerlIO*
3964create_forked_xterm(pTHX_ const char *cmd, const char *mode)
cd1191f1
CB		 3965{
3966 int status;
3967 int ret_stat;
3968 char * ret_char;
3969 char device_name[65];
3970 unsigned short device_name_len;
3971 struct dsc$descriptor_s customization_dsc;
3972 struct dsc$descriptor_s device_name_dsc;
3973 const char * cptr;
cd1191f1
CB		 3974 char customization[200];
3975 char title[40];
3976 pInfo info = NULL;
3977 char mbx1[64];
3978 unsigned short p_chan;
3979 int n;
3980 unsigned short iosb[4];
cd1191f1
CB		 3981 const char * cust_str =
3982 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3983 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3984 DSC$K_CLASS_S, mbx1};
3985
8cb5d3d5
JM		 3986 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3987 /*---------------------------------------*/
d30c1055 3988 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3989
3990
3991 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3992 ret_char = strstr(cmd," xterm ");
3993 if (ret_char == NULL)
3994 return NULL;
3995 cptr = ret_char + 7;
3996 ret_char = strstr(cmd,"tty");
3997 if (ret_char == NULL)
3998 return NULL;
3999 ret_char = strstr(cmd,"sleep");
4000 if (ret_char == NULL)
4001 return NULL;
4002
8cb5d3d5
JM		 4003 if (decw_term_port == 0) {
4004 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4005 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4006 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4007
d30c1055 4008 status = lib$find_image_symbol
8cb5d3d5
JM		 4009 (&filename1_dsc,
4010 &decw_term_port_dsc,
4011 (void *)&decw_term_port,
4012 NULL,
4013 0);
4014
4015 /* Try again with the other image name */
4016 if (!$VMS_STATUS_SUCCESS(status)) {
4017
d30c1055 4018 status = lib$find_image_symbol
8cb5d3d5
JM		 4019 (&filename2_dsc,
4020 &decw_term_port_dsc,
4021 (void *)&decw_term_port,
4022 NULL,
4023 0);
4024
4025 }
4026
4027 }
4028
4029
4030 /* No decw$term_port, give it up */
4031 if (!$VMS_STATUS_SUCCESS(status))
4032 return NULL;
4033
cd1191f1
CB		 4034 /* Are we on a workstation? */
4035 /* to do: capture the rows / columns and pass their properties */
4036 ret_stat = vms_is_syscommand_xterm();
4037 if (ret_stat < 0)
4038 return NULL;
4039
4040 /* Make the title: */
4041 ret_char = strstr(cptr,"-title");
4042 if (ret_char != NULL) {
4043 while ((*cptr != 0) && (*cptr != '\"')) {
4044 cptr++;
4045 }
4046 if (*cptr == '\"')
4047 cptr++;
4048 n = 0;
4049 while ((*cptr != 0) && (*cptr != '\"')) {
4050 title[n] = *cptr;
4051 n++;
4052 if (n == 39) {
07bee079 4053 title[39] = 0;
cd1191f1
CB		 4054 break;
4055 }
4056 cptr++;
4057 }
4058 title[n] = 0;
4059 }
4060 else {
4061 /* Default title */
4062 strcpy(title,"Perl Debug DECTerm");
4063 }
4064 sprintf(customization, cust_str, title);
4065
4066 customization_dsc.dsc$a_pointer = customization;
4067 customization_dsc.dsc$w_length = strlen(customization);
4068 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4069 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4070
4071 device_name_dsc.dsc$a_pointer = device_name;
4072 device_name_dsc.dsc$w_length = sizeof device_name -1;
4073 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4074 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4075
4076 device_name_len = 0;
4077
4078 /* Try to create the window */
8cb5d3d5 4079 status = (*decw_term_port)
cd1191f1
CB		 4080 (NULL,
4081 NULL,
4082 &customization_dsc,
4083 &device_name_dsc,
4084 &device_name_len,
4085 NULL,
4086 NULL,
4087 NULL);
4088 if (!$VMS_STATUS_SUCCESS(status)) {
4089 SETERRNO(EVMSERR, status);
4090 return NULL;
4091 }
4092
4093 device_name[device_name_len] = '\0';
4094
4095 /* Need to set this up to look like a pipe for cleanup */
4096 n = sizeof(Info);
4097 status = lib$get_vm(&n, &info);
4098 if (!$VMS_STATUS_SUCCESS(status)) {
4099 SETERRNO(ENOMEM, status);
4100 return NULL;
4101 }
4102
4103 info->mode = *mode;
4104 info->done = FALSE;
4105 info->completion = 0;
4106 info->closing = FALSE;
4107 info->in = 0;
4108 info->out = 0;
4109 info->err = 0;
4e205ed6 4110 info->fp = NULL;
cd1191f1
CB		 4111 info->useFILE = 0;
4112 info->waiting = 0;
4113 info->in_done = TRUE;
4114 info->out_done = TRUE;
4115 info->err_done = TRUE;
4116
4117 /* Assign a channel on this so that it will persist, and not login */
4118 /* We stash this channel in the info structure for reference. */
4119 /* The created xterm self destructs when the last channel is removed */
4120 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4121 /* So leave this assigned. */
4122 device_name_dsc.dsc$w_length = device_name_len;
4123 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4124 if (!$VMS_STATUS_SUCCESS(status)) {
4125 SETERRNO(EVMSERR, status);
4126 return NULL;
4127 }
4128 info->xchan_valid = 1;
4129
4130 /* Now create a mailbox to be read by the application */
4131
8a646e0b 4132 create_mbx(&p_chan, &d_mbx1);
cd1191f1
CB		 4133
4134 /* write the name of the created terminal to the mailbox */
4135 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4136 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4137
4138 if (!$VMS_STATUS_SUCCESS(status)) {
4139 SETERRNO(EVMSERR, status);
4140 return NULL;
4141 }
4142
4143 info->fp = PerlIO_open(mbx1, mode);
4144
4145 /* Done with this channel */
4146 sys$dassgn(p_chan);
4147
4148 /* If any errors, then clean up */
4149 if (!info->fp) {
4150 n = sizeof(Info);
ebd4d70b 4151 _ckvmssts_noperl(lib$free_vm(&n, &info));
cd1191f1
CB		 4152 return NULL;
4153 }
4154
4155 /* All done */
4156 return info->fp;
4157}
22d4bb9c 4158
ebd4d70b
JM		 4159static I32 my_pclose_pinfo(pTHX_ pInfo info);
4160
8fde5078 4161static PerlIO *
2fbb330f 4162safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4163{
748a9306 4164 static int handler_set_up = FALSE;
ebd4d70b 4165 PerlIO * ret_fp;
55f2b99c 4166 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4167 /* The use of a GLOBAL table (as was done previously) rendered
4168 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4169 * environment. Hence we've switched to LOCAL symbol table.
4170 */
4171 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4172 int j, wait = 0, n;
ff7adb52 4173 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4174 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4175 FILE *tpipe = 0;
4176 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4177 pInfo info = NULL;
48b5a746 4178 char cmd_sym_name[20];
22d4bb9c
CB		 4179 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4180 DSC$K_CLASS_S, symbol};
22d4bb9c 4181 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4182 DSC$K_CLASS_S, 0};
48b5a746
CL		 4183 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4184 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4185 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4186 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4187 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4188 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4189
cd1191f1
CB		 4190 /* Check here for Xterm create request. This means looking for
4191 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4192 * is possible to create an xterm.
4193 */
4194 if (*in_mode == 'r') {
4195 PerlIO * xterm_fd;
4196
4d9538c1
JM		 4197#if defined(PERL_IMPLICIT_CONTEXT)
4198 /* Can not fork an xterm with a NULL context */
4199 /* This probably could never happen */
4200 xterm_fd = NULL;
4201 if (aTHX != NULL)
4202#endif
cd1191f1 4203 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4e205ed6 4204 if (xterm_fd != NULL)
cd1191f1
CB		 4205 return xterm_fd;
4206 }
cd1191f1 4207
afd8f436
JH		 4208 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4209
22d4bb9c
CB		 4210 /* once-per-program initialization...
4211 note that the SETAST calls and the dual test of pipe_ef
4212 makes sure that only the FIRST thread through here does
4213 the initialization...all other threads wait until it's
4214 done.
4215
4216 Yeah, uglier than a pthread call, it's got all the stuff inline
4217 rather than in a separate routine.
4218 */
4219
4220 if (!pipe_ef) {
ebd4d70b 4221 _ckvmssts_noperl(sys$setast(0));
22d4bb9c
CB		 4222 if (!pipe_ef) {
4223 unsigned long int pidcode = JPI$_PID;
4224 $DESCRIPTOR(d_delay, RETRY_DELAY);
ebd4d70b
JM		 4225 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4226 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4227 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
22d4bb9c
CB		 4228 }
4229 if (!handler_set_up) {
ebd4d70b 4230 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
22d4bb9c
CB		 4231 handler_set_up = TRUE;
4232 }
ebd4d70b 4233 _ckvmssts_noperl(sys$setast(1));
22d4bb9c
CB		 4234 }
4235
4236 /* see if we can find a VMSPIPE.COM */
4237
4238 tfilebuf[0] = '@';
fd8cd3a3 4239 vmspipe = find_vmspipe(aTHX);
22d4bb9c 4240 if (vmspipe) {
a35dcc95 4241 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
22d4bb9c 4242 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4243 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4244 if (!tpipe) { /* a fish popular in Boston */
4245 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4246 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c 4247 }
4e205ed6 4248 return NULL;
22d4bb9c
CB		 4249 }
4250 fgetname(tpipe,tfilebuf+1,1);
a35dcc95 4251 vmspipedsc.dsc$w_length = strlen(tfilebuf);
22d4bb9c
CB		 4252 }
4253 vmspipedsc.dsc$a_pointer = tfilebuf;
a0d0e21e 4254
218fdd94 4255 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4256 if (!(sts & 1)) {
4257 switch (sts) {
4258 case RMS$_FNF: case RMS$_DNF:
4259 set_errno(ENOENT); break;
4260 case RMS$_DIR:
4261 set_errno(ENOTDIR); break;
4262 case RMS$_DEV:
4263 set_errno(ENODEV); break;
4264 case RMS$_PRV:
4265 set_errno(EACCES); break;
4266 case RMS$_SYN:
4267 set_errno(EINVAL); break;
4268 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4269 set_errno(E2BIG); break;
4270 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 4271 _ckvmssts_noperl(sts); /* fall through */
a2669cfc
JH		 4272 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4273 set_errno(EVMSERR);
4274 }
4275 set_vaxc_errno(sts);
cd1191f1 4276 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4277 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4278 }
ff7adb52 4279 *psts = sts;
4e205ed6 4280 return NULL;
a2669cfc 4281 }
d4c83939 4282 n = sizeof(Info);
ebd4d70b 4283 _ckvmssts_noperl(lib$get_vm(&n, &info));
22d4bb9c 4284
a35dcc95 4285 my_strlcpy(mode, in_mode, sizeof(mode));
22d4bb9c
CB		 4286 info->mode = *mode;
4287 info->done = FALSE;
4288 info->completion = 0;
4289 info->closing = FALSE;
4290 info->in = 0;
4291 info->out = 0;
4292 info->err = 0;
4e205ed6 4293 info->fp = NULL;
ff7adb52
CL		 4294 info->useFILE = 0;
4295 info->waiting = 0;
22d4bb9c
CB		 4296 info->in_done = TRUE;
4297 info->out_done = TRUE;
4298 info->err_done = TRUE;
cd1191f1
CB		 4299 info->xchan = 0;
4300 info->xchan_valid = 0;
cfcfe586 4301
c11536f5 4302 in = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4303 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4304 out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4305 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4306 err = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4307 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4308
0e06870b 4309 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4310
ff7adb52
CL		 4311 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4312 info->useFILE = 1;
4313 strcpy(p,p+1);
4314 }
4315 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4316 wait = 1;
4317 strcpy(p,p+1);
4318 }
4319
22d4bb9c 4320 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4321
fd8cd3a3 4322 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4323 if (info->out) {
4324 info->out->pipe_done = &info->out_done;
4325 info->out_done = FALSE;
4326 info->out->info = info;
4327 }
ff7adb52 4328 if (!info->useFILE) {
cd1191f1 4329 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4330 } else {
4331 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
0db50132 4332 vmssetuserlnm("SYS$INPUT", mbx);
ff7adb52
CL		 4333 }
4334
22d4bb9c
CB		 4335 if (!info->fp && info->out) {
4336 sys$cancel(info->out->chan_out);
4337
4338 while (!info->out_done) {
4339 int done;
ebd4d70b 4340 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4341 done = info->out_done;
ebd4d70b
JM		 4342 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4343 _ckvmssts_noperl(sys$setast(1));
4344 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
0e06870b 4345 }
22d4bb9c 4346
d4c83939
CB		 4347 if (info->out->buf) {
4348 n = info->out->bufsize * sizeof(char);
ebd4d70b 4349 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
d4c83939
CB		 4350 }
4351 n = sizeof(Pipe);
ebd4d70b 4352 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
d4c83939 4353 n = sizeof(Info);
ebd4d70b 4354 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4355 *psts = RMS$_FNF;
4e205ed6 4356 return NULL;
0e06870b 4357 }
22d4bb9c 4358
fd8cd3a3 4359 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4360 if (info->err) {
4361 info->err->pipe_done = &info->err_done;
4362 info->err_done = FALSE;
4363 info->err->info = info;
4364 }
a0d0e21e 4365
ff7adb52
CL		 4366 } else if (*mode == 'w') { /* piping to subroutine */
4367
4368 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4369 if (info->out) {
4370 info->out->pipe_done = &info->out_done;
4371 info->out_done = FALSE;
4372 info->out->info = info;
4373 }
4374
4375 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4376 if (info->err) {
4377 info->err->pipe_done = &info->err_done;
4378 info->err_done = FALSE;
4379 info->err->info = info;
4380 }
a0d0e21e 4381
fd8cd3a3 4382 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4383 if (!info->useFILE) {
a480973c 4384 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4385 } else {
4386 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
0db50132 4387 vmssetuserlnm("SYS$OUTPUT", mbx);
ff7adb52
CL		 4388 }
4389
22d4bb9c
CB		 4390 if (info->in) {
4391 info->in->pipe_done = &info->in_done;
4392 info->in_done = FALSE;
4393 info->in->info = info;
4394 }
a0d0e21e 4395
22d4bb9c
CB		 4396 /* error cleanup */
4397 if (!info->fp && info->in) {
4398 info->done = TRUE;
ebd4d70b
JM		 4399 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4400 0, 0, 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 4401
4402 while (!info->in_done) {
4403 int done;
ebd4d70b 4404 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4405 done = info->in_done;
ebd4d70b
JM		 4406 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4407 _ckvmssts_noperl(sys$setast(1));
4408 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
22d4bb9c 4409 }
a0d0e21e 4410
d4c83939
CB		 4411 if (info->in->buf) {
4412 n = info->in->bufsize * sizeof(char);
ebd4d70b 4413 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
d4c83939
CB		 4414 }
4415 n = sizeof(Pipe);
ebd4d70b 4416 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
d4c83939 4417 n = sizeof(Info);
ebd4d70b 4418 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4419 *psts = RMS$_FNF;
4e205ed6 4420 return NULL;
22d4bb9c 4421 }
a0d0e21e 4422
22d4bb9c 4423
ff7adb52 4424 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
e2d6c6fb
CB		 4425 /* Let the child inherit standard input, unless it's a directory. */
4426 Stat_t st;
3f80905d
CB		 4427 if (my_trnlnm("SYS$INPUT", in, 0)) {
4428 if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4429 *in = '\0';
4430 }
e2d6c6fb 4431
fd8cd3a3 4432 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4433 if (info->out) {
4434 info->out->pipe_done = &info->out_done;
4435 info->out_done = FALSE;
4436 info->out->info = info;
4437 }
0e06870b 4438
fd8cd3a3 4439 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4440 if (info->err) {
4441 info->err->pipe_done = &info->err_done;
4442 info->err_done = FALSE;
4443 info->err->info = info;
4444 }
748a9306 4445 }
22d4bb9c 4446
a35dcc95 4447 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
ebd4d70b 4448 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
22d4bb9c 4449
a35dcc95 4450 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
ebd4d70b 4451 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
22d4bb9c 4452
a35dcc95 4453 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
ebd4d70b 4454 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4455
cfcfe586
JM		 4456 /* Done with the names for the pipes */
4457 PerlMem_free(err);
4458 PerlMem_free(out);
4459 PerlMem_free(in);
4460
218fdd94 4461 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4462 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4463 if (*p == '$') p++; /* remove leading $ */
4464 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4465
4466 for (j = 0; j < 4; j++) {
4467 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4468 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4469
a35dcc95 4470 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
ebd4d70b 4471 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
22d4bb9c 4472
48b5a746
CL		 4473 if (strlen(p) > MAX_DCL_SYMBOL) {
4474 p += MAX_DCL_SYMBOL;
4475 } else {
4476 p += strlen(p);
4477 }
4478 }
ebd4d70b 4479 _ckvmssts_noperl(sys$setast(0));
a0d0e21e
LW		 4480 info->next=open_pipes; /* prepend to list */
4481 open_pipes=info;
ebd4d70b 4482 _ckvmssts_noperl(sys$setast(1));
55f2b99c
CB		 4483 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4484 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4485 * have SYS$COMMAND if we need it.
4486 */
ebd4d70b 4487 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4488 0, &info->pid, &info->completion,
4489 0, popen_completion_ast,info,0,0,0));
4490
4491 /* if we were using a tempfile, close it now */
4492
4493 if (tpipe) fclose(tpipe);
4494
ff7adb52 4495 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4496 we can get rid of ours */
4497
48b5a746
CL		 4498 for (j = 0; j < 4; j++) {
4499 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4500 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
ebd4d70b 4501 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4502 }
ebd4d70b
JM		 4503 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4504 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4505 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4506 vms_execfree(vmscmd);
a0d0e21e 4507
218fdd94
CL		 4508#ifdef PERL_IMPLICIT_CONTEXT
4509 if (aTHX)
4510#endif
6b88bc9c 4511 PL_forkprocess = info->pid;
218fdd94 4512
ebd4d70b 4513 ret_fp = info->fp;
ff7adb52 4514 if (wait) {
ebd4d70b 4515 dSAVEDERRNO;
ff7adb52
CL		 4516 int done = 0;
4517 while (!done) {
ebd4d70b 4518 _ckvmssts_noperl(sys$setast(0));
ff7adb52 4519 done = info->done;
ebd4d70b
JM		 4520 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4521 _ckvmssts_noperl(sys$setast(1));
4522 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
ff7adb52
CL		 4523 }
4524 *psts = info->completion;
2fbb330f
JM		 4525/* Caller thinks it is open and tries to close it. */
4526/* This causes some problems, as it changes the error status */
4527/* my_pclose(info->fp); */
ebd4d70b
JM		 4528
4529 /* If we did not have a file pointer open, then we have to */
4530 /* clean up here or eventually we will run out of something */
4531 SAVE_ERRNO;
4532 if (info->fp == NULL) {
4533 my_pclose_pinfo(aTHX_ info);
4534 }
4535 RESTORE_ERRNO;
4536
ff7adb52 4537 } else {
eed5d6a1 4538 *psts = info->pid;
ff7adb52 4539 }
ebd4d70b 4540 return ret_fp;
1e422769 4541} /* end of safe_popen */
4542
4543
a15cef0c
CB		 4544/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4545PerlIO *
2fbb330f 4546Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4547{
ff7adb52 4548 int sts;
1e422769 4549 TAINT_ENV();
4550 TAINT_PROPER("popen");
45bc9206 4551 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4552 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4553}
1e422769 4554
a0d0e21e
LW		 4555/*}}}*/
4556
ebd4d70b
JM		 4557
4558/* Routine to close and cleanup a pipe info structure */
4559
ce12d4b7
CB		 4560static I32
4561my_pclose_pinfo(pTHX_ pInfo info) {
ebd4d70b 4562
748a9306 4563 unsigned long int retsts;
4e0c9737 4564 int done, n;
ebd4d70b 4565 pInfo next, last;
748a9306 4566
bbce6d69 4567 /* If we were writing to a subprocess, insure that someone reading from
4568 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4569 * produce an EOF record in the mailbox.
4570 *
4571 * well, at least sometimes it *does*, so we have to watch out for
4572 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4573 */
ff7adb52 4574 if (info->fp) {
5ce486e0
CB		 4575 if (!info->useFILE
4576#if defined(USE_ITHREADS)
4577 && my_perl
4578#endif
a24c654f
CB		 4579#ifdef USE_PERLIO
4580 && PL_perlio_fd_refcnt
4581#endif
4582 )
5ce486e0 4583 PerlIO_flush(info->fp);
ff7adb52
CL		 4584 else
4585 fflush((FILE *)info->fp);
4586 }
22d4bb9c 4587
b08af3f0 4588 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4589 info->closing = TRUE;
4590 done = info->done && info->in_done && info->out_done && info->err_done;
4591 /* hanging on write to Perl's input? cancel it */
4592 if (info->mode == 'r' && info->out && !info->out_done) {
4593 if (info->out->chan_out) {
4594 _ckvmssts(sys$cancel(info->out->chan_out));
4595 if (!info->out->chan_in) { /* EOF generation, need AST */
4596 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4597 }
4598 }
4599 }
4600 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4601 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4602 0, 0, 0, 0, 0, 0));
b08af3f0 4603 _ckvmssts(sys$setast(1));
ff7adb52 4604 if (info->fp) {
5ce486e0
CB		 4605 if (!info->useFILE
4606#if defined(USE_ITHREADS)
4607 && my_perl
4608#endif
a24c654f
CB		 4609#ifdef USE_PERLIO
4610 && PL_perlio_fd_refcnt
4611#endif
4612 )
d4c83939 4613 PerlIO_close(info->fp);
ff7adb52
CL		 4614 else
4615 fclose((FILE *)info->fp);
4616 }
22d4bb9c
CB		 4617 /*
4618 we have to wait until subprocess completes, but ALSO wait until all
4619 the i/o completes...otherwise we'll be freeing the "info" structure
4620 that the i/o ASTs could still be using...
4621 */
4622
4623 while (!done) {
4624 _ckvmssts(sys$setast(0));
4625 done = info->done && info->in_done && info->out_done && info->err_done;
4626 if (!done) _ckvmssts(sys$clref(pipe_ef));
4627 _ckvmssts(sys$setast(1));
4628 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4629 }
4630 retsts = info->completion;
a0d0e21e 4631
a0d0e21e 4632 /* remove from list of open pipes */
b08af3f0 4633 _ckvmssts(sys$setast(0));
ebd4d70b
JM		 4634 last = NULL;
4635 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4636 if (next == info)
4637 break;
4638 }
4639
4640 if (last)
4641 last->next = info->next;
4642 else
4643 open_pipes = info->next;
b08af3f0 4644 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4645
4646 /* free buffers and structures */
4647
4648 if (info->in) {
d4c83939
CB		 4649 if (info->in->buf) {
4650 n = info->in->bufsize * sizeof(char);
4651 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4652 }
4653 n = sizeof(Pipe);
4654 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4655 }
4656 if (info->out) {
d4c83939
CB		 4657 if (info->out->buf) {
4658 n = info->out->bufsize * sizeof(char);
4659 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4660 }
4661 n = sizeof(Pipe);
4662 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4663 }
4664 if (info->err) {
d4c83939
CB		 4665 if (info->err->buf) {
4666 n = info->err->bufsize * sizeof(char);
4667 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4668 }
4669 n = sizeof(Pipe);
4670 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4671 }
d4c83939
CB		 4672 n = sizeof(Info);
4673 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4674
4675 return retsts;
ebd4d70b
JM		 4676}
4677
4678
4679/*{{{ I32 my_pclose(PerlIO *fp)*/
4680I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4681{
4682 pInfo info, last = NULL;
4683 I32 ret_status;
4684
4685 /* Fixme - need ast and mutex protection here */
4686 for (info = open_pipes; info != NULL; last = info, info = info->next)
4687 if (info->fp == fp) break;
4688
4689 if (info == NULL) { /* no such pipe open */
4690 set_errno(ECHILD); /* quoth POSIX */
4691 set_vaxc_errno(SS$_NONEXPR);
4692 return -1;
4693 }
4694
4695 ret_status = my_pclose_pinfo(aTHX_ info);
4696
4697 return ret_status;
748a9306 4698
a0d0e21e
LW		 4699} /* end of my_pclose() */
4700
aeb5cf3c
CB		 4701 /* Roll our own prototype because we want this regardless of whether
4702 * _VMS_WAIT is defined.
4703 */
c11536f5
CB		 4704
4705#ifdef __cplusplus
4706extern "C" {
4707#endif
aeb5cf3c 4708 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
c11536f5
CB		 4709#ifdef __cplusplus
4710}
4711#endif
4712
aeb5cf3c
CB		 4713/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4714 created with popen(); otherwise partially emulate waitpid() unless
4715 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4716 Also check processes not considered by the CRTL waitpid().
4717 */
4fdae800 4718/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4719Pid_t
fd8cd3a3 4720Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4721{
22d4bb9c
CB		 4722 pInfo info;
4723 int done;
aeb5cf3c 4724 int sts;
d85f548a 4725 int j;
aeb5cf3c
CB		 4726
4727 if (statusp) *statusp = 0;
a0d0e21e
LW		 4728
4729 for (info = open_pipes; info != NULL; info = info->next)
4730 if (info->pid == pid) break;
4731
4732 if (info != NULL) { /* we know about this child */
748a9306 4733 while (!info->done) {
22d4bb9c
CB		 4734 _ckvmssts(sys$setast(0));
4735 done = info->done;
4736 if (!done) _ckvmssts(sys$clref(pipe_ef));
4737 _ckvmssts(sys$setast(1));
4738 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4739 }
4740
aeb5cf3c 4741 if (statusp) *statusp = info->completion;
a0d0e21e 4742 return pid;
d85f548a
JH		 4743 }
4744
4745 /* child that already terminated? */
aeb5cf3c 4746
d85f548a
JH		 4747 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4748 if (closed_list[j].pid == pid) {
4749 if (statusp) *statusp = closed_list[j].completion;
4750 return pid;
4751 }
a0d0e21e 4752 }
d85f548a
JH		 4753
4754 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4755
aeb5cf3c
CB		 4756 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4757 * in 7.2 did we get a version that fills in the VMS completion
4758 * status as Perl has always tried to do.
4759 */
4760
4761 sts = __vms_waitpid( pid, statusp, flags );
4762
4763 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4764 return sts;
4765
4766 /* If the real waitpid tells us the child does not exist, we
4767 * fall through here to implement waiting for a child that
4768 * was created by some means other than exec() (say, spawned
4769 * from DCL) or to wait for a process that is not a subprocess
4770 * of the current process.
4771 */
4772
21bc9d50 4773 {
a0d0e21e 4774 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4775 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4776 unsigned long int pidcode = JPI$_PID, mypid;
4777 unsigned long int interval[2];
aeb5cf3c 4778 unsigned int jpi_iosb[2];
d85f548a 4779 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4780 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4781 { 0, 0, 0, 0}
4782 };
aeb5cf3c
CB		 4783
4784 if (pid <= 0) {
4785 /* Sorry folks, we don't presently implement rooting around for
4786 the first child we can find, and we definitely don't want to
4787 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4788 */
4789 set_errno(ENOTSUP);
4790 return -1;
4791 }
4792
d85f548a
JH		 4793 /* Get the owner of the child so I can warn if it's not mine. If the
4794 * process doesn't exist or I don't have the privs to look at it,
4795 * I can go home early.
aeb5cf3c
CB		 4796 */
4797 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4798 if (sts & 1) sts = jpi_iosb[0];
4799 if (!(sts & 1)) {
4800 switch (sts) {
4801 case SS$_NONEXPR:
4802 set_errno(ECHILD);
4803 break;
4804 case SS$_NOPRIV:
4805 set_errno(EACCES);
4806 break;
4807 default:
4808 _ckvmssts(sts);
4809 }
4810 set_vaxc_errno(sts);
4811 return -1;
4812 }
a0d0e21e 4813
3eeba6fb 4814 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4815 /* remind folks they are asking for non-standard waitpid behavior */
4816 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4817 if (ownerpid != mypid)
f98bc0c6 4818 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4819 "waitpid: process %x is not a child of process %x",
4820 pid,mypid);
748a9306 4821 }
a0d0e21e 4822
d85f548a
JH		 4823 /* simply check on it once a second until it's not there anymore. */
4824
4825 _ckvmssts(sys$bintim(&intdsc,interval));
4826 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4827 _ckvmssts(sys$schdwk(0,0,interval,0));
4828 _ckvmssts(sys$hiber());
d85f548a
JH		 4829 }
4830 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4831
4832 _ckvmssts(sts);
a0d0e21e 4833 return pid;
21bc9d50 4834 }
a0d0e21e 4835} /* end of waitpid() */
a0d0e21e
LW		 4836/*}}}*/
4837/*}}}*/
4838/*}}}*/
4839
4840/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4841char *
4842my_gconvert(double val, int ndig, int trail, char *buf)
4843{
4844 static char __gcvtbuf[DBL_DIG+1];
4845 char *loc;
4846
4847 loc = buf ? buf : __gcvtbuf;
71be2cbc 4848
a0d0e21e
LW		 4849 if (val) {
4850 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4851 return gcvt(val,ndig,loc);
4852 }
4853 else {
4854 loc[0] = '0'; loc[1] = '\0';
4855 return loc;
4856 }
4857
4858}
4859/*}}}*/
4860
054a3baf 4861#if !defined(NAML$C_MAXRSS)
ce12d4b7
CB		 4862static int
4863rms_free_search_context(struct FAB * fab)
a480973c 4864{
ce12d4b7 4865 struct NAM * nam;
a480973c
JM		 4866
4867 nam = fab->fab$l_nam;
4868 nam->nam$b_nop |= NAM$M_SYNCHK;
4869 nam->nam$l_rlf = NULL;
4870 fab->fab$b_dns = 0;
4871 return sys$parse(fab, NULL, NULL);
4872}
4873
4874#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4875#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4876#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4877#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4878#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4879#define rms_nam_esll(nam) nam.nam$b_esl
4880#define rms_nam_esl(nam) nam.nam$b_esl
4881#define rms_nam_name(nam) nam.nam$l_name
4882#define rms_nam_namel(nam) nam.nam$l_name
4883#define rms_nam_type(nam) nam.nam$l_type
4884#define rms_nam_typel(nam) nam.nam$l_type
4885#define rms_nam_ver(nam) nam.nam$l_ver
4886#define rms_nam_verl(nam) nam.nam$l_ver
4887#define rms_nam_rsll(nam) nam.nam$b_rsl
4888#define rms_nam_rsl(nam) nam.nam$b_rsl
4889#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4890#define rms_set_fna(fab, nam, name, size) \
a1887106 4891 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4892#define rms_get_fna(fab, nam) fab.fab$l_fna
4893#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4894 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4895#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4896#define rms_set_esa(nam, name, size) \
a1887106 4897 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4898#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4899 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4900#define rms_set_rsa(nam, name, size) \
a1887106 4901 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4902#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4903 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4904#define rms_nam_name_type_l_size(nam) \
4905 (nam.nam$b_name + nam.nam$b_type)
a480973c 4906#else
ce12d4b7
CB		 4907static int
4908rms_free_search_context(struct FAB * fab)
a480973c 4909{
ce12d4b7 4910 struct NAML * nam;
a480973c
JM		 4911
4912 nam = fab->fab$l_naml;
4913 nam->naml$b_nop |= NAM$M_SYNCHK;
4914 nam->naml$l_rlf = NULL;
4915 nam->naml$l_long_defname_size = 0;
988c775c 4916
a480973c
JM		 4917 fab->fab$b_dns = 0;
4918 return sys$parse(fab, NULL, NULL);
4919}
4920
4921#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4922#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4923#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4924#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4925#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4926#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4927#define rms_nam_esl(nam) nam.naml$b_esl
4928#define rms_nam_name(nam) nam.naml$l_name
4929#define rms_nam_namel(nam) nam.naml$l_long_name
4930#define rms_nam_type(nam) nam.naml$l_type
4931#define rms_nam_typel(nam) nam.naml$l_long_type
4932#define rms_nam_ver(nam) nam.naml$l_ver
4933#define rms_nam_verl(nam) nam.naml$l_long_ver
4934#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4935#define rms_nam_rsl(nam) nam.naml$b_rsl
4936#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4937#define rms_set_fna(fab, nam, name, size) \
a1887106 4938 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4939 nam.naml$l_long_filename_size = size; \
a1887106 4940 nam.naml$l_long_filename = name;}
a480973c
JM		 4941#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4942#define rms_set_dna(fab, nam, name, size) \
a1887106 4943 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4944 nam.naml$l_long_defname_size = size; \
a1887106 4945 nam.naml$l_long_defname = name; }
a480973c 4946#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4947#define rms_set_esa(nam, name, size) \
a1887106 4948 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4949 nam.naml$l_long_expand_alloc = size; \
a1887106 4950 nam.naml$l_long_expand = name; }
a480973c 4951#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4952 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4953 nam.naml$l_long_expand = l_name; \
a1887106 4954 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4955#define rms_set_rsa(nam, name, size) \
a1887106 4956 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4957 nam.naml$l_long_result = name; \
a1887106 4958 nam.naml$l_long_result_alloc = size; }
a480973c 4959#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4960 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4961 nam.naml$l_long_result = l_name; \
a1887106
JM		 4962 nam.naml$l_long_result_alloc = l_size; }
4963#define rms_nam_name_type_l_size(nam) \
4964 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4965#endif
4966
4fdf8f88 4967
e0e5e8d6
JM		 4968/* rms_erase
4969 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4970 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4971 * them if one of the PCP modes is active.
e0e5e8d6 4972 */
ce12d4b7
CB		 4973static int
4974rms_erase(const char * vmsname)
e0e5e8d6
JM		 4975{
4976 int status;
4977 struct FAB myfab = cc$rms_fab;
4978 rms_setup_nam(mynam);
4979
4980 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4981 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4982
e0e5e8d6
JM		 4983#ifdef NAML$M_OPEN_SPECIAL
4984 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4985#endif
4986
d30c1055 4987 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 4988
4989 return status;
4990}
4991
bbce6d69 4992
4fdf8f88
JM		 4993static int
4994vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4995 const struct dsc$descriptor_s * vms_dst_dsc,
4996 unsigned long flags)
4997{
4998 /* VMS and UNIX handle file permissions differently and the
4999 * the same ACL trick may be needed for renaming files,
5000 * especially if they are directories.
5001 */
5002
5003 /* todo: get kill_file and rename to share common code */
5004 /* I can not find online documentation for $change_acl
5005 * it appears to be replaced by $set_security some time ago */
5006
ce12d4b7
CB		 5007 const unsigned int access_mode = 0;
5008 $DESCRIPTOR(obj_file_dsc,"FILE");
5009 char *vmsname;
5010 char *rslt;
5011 unsigned long int jpicode = JPI$_UIC;
5012 int aclsts, fndsts, rnsts = -1;
5013 unsigned int ctx = 0;
5014 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5015 struct dsc$descriptor_s * clean_dsc;
5016
5017 struct myacedef {
5018 unsigned char myace$b_length;
5019 unsigned char myace$b_type;
5020 unsigned short int myace$w_flags;
5021 unsigned long int myace$l_access;
5022 unsigned long int myace$l_ident;
5023 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5024 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5025 0},
5026 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5027
5028 struct item_list_3
4fdf8f88
JM		 5029 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5030 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5031 {0,0,0,0}},
5032 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5033 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5034 {0,0,0,0}};
5035
5036
5037 /* Expand the input spec using RMS, since we do not want to put
5038 * ACLs on the target of a symbolic link */
c11536f5 5039 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4fdf8f88
JM		 5040 if (vmsname == NULL)
5041 return SS$_INSFMEM;
5042
6fb6c614 5043 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4fdf8f88 5044 vmsname,
6fb6c614 5045 PERL_RMSEXPAND_M_SYMLINK);
4fdf8f88
JM		 5046 if (rslt == NULL) {
5047 PerlMem_free(vmsname);
5048 return SS$_INSFMEM;
5049 }
5050
5051 /* So we get our own UIC to use as a rights identifier,
5052 * and the insert an ACE at the head of the ACL which allows us
5053 * to delete the file.
5054 */
ebd4d70b 5055 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4fdf8f88
JM		 5056
5057 fildsc.dsc$w_length = strlen(vmsname);
5058 fildsc.dsc$a_pointer = vmsname;
5059 ctx = 0;
5060 newace.myace$l_ident = oldace.myace$l_ident;
5061 rnsts = SS$_ABORT;
5062
5063 /* Grab any existing ACEs with this identifier in case we fail */
5064 clean_dsc = &fildsc;
5065 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5066 &fildsc,
5067 NULL,
5068 OSS$M_WLOCK,
5069 findlst,
5070 &ctx,
5071 &access_mode);
5072
5073 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5074 /* Add the new ACE . . . */
5075
5076 /* if the sys$get_security succeeded, then ctx is valid, and the
5077 * object/file descriptors will be ignored. But otherwise they
5078 * are needed
5079 */
5080 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5081 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5082 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5083 set_errno(EVMSERR);
5084 set_vaxc_errno(aclsts);
5085 PerlMem_free(vmsname);
5086 return aclsts;
5087 }
5088
5089 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5090 NULL, NULL,
5091 &flags,
5092 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5093
5094 if ($VMS_STATUS_SUCCESS(rnsts)) {
5095 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5096 }
5097
5098 /* Put things back the way they were. */
5099 ctx = 0;
5100 aclsts = sys$get_security(&obj_file_dsc,
5101 clean_dsc,
5102 NULL,
5103 OSS$M_WLOCK,
5104 findlst,
5105 &ctx,
5106 &access_mode);
5107
5108 if ($VMS_STATUS_SUCCESS(aclsts)) {
5109 int sec_flags;
5110
5111 sec_flags = 0;
5112 if (!$VMS_STATUS_SUCCESS(fndsts))
5113 sec_flags = OSS$M_RELCTX;
5114
5115 /* Get rid of the new ACE */
5116 aclsts = sys$set_security(NULL, NULL, NULL,
5117 sec_flags, dellst, &ctx, &access_mode);
5118
5119 /* If there was an old ACE, put it back */
5120 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5121 addlst[0].bufadr = &oldace;
5122 aclsts = sys$set_security(NULL, NULL, NULL,
5123 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5124 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5125 set_errno(EVMSERR);
5126 set_vaxc_errno(aclsts);
5127 rnsts = aclsts;
5128 }
5129 } else {
5130 int aclsts2;
5131
5132 /* Try to clear the lock on the ACL list */
5133 aclsts2 = sys$set_security(NULL, NULL, NULL,
5134 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5135
5136 /* Rename errors are most important */
5137 if (!$VMS_STATUS_SUCCESS(rnsts))
5138 aclsts = rnsts;
5139 set_errno(EVMSERR);
5140 set_vaxc_errno(aclsts);
5141 rnsts = aclsts;
5142 }
5143 }
5144 else {
5145 if (aclsts != SS$_ACLEMPTY)
5146 rnsts = aclsts;
5147 }
5148 }
5149 else
5150 rnsts = fndsts;
5151
5152 PerlMem_free(vmsname);
5153 return rnsts;
5154}
5155
5156
5157/*{{{int rename(const char *, const char * */
5158/* Not exactly what X/Open says to do, but doing it absolutely right
5159 * and efficiently would require a lot more work. This should be close
5160 * enough to pass all but the most strict X/Open compliance test.
5161 */
5162int
5163Perl_rename(pTHX_ const char *src, const char * dst)
5164{
ce12d4b7
CB		 5165 int retval;
5166 int pre_delete = 0;
5167 int src_sts;
5168 int dst_sts;
5169 Stat_t src_st;
5170 Stat_t dst_st;
4fdf8f88
JM		 5171
5172 /* Validate the source file */
46c05374 5173 src_sts = flex_lstat(src, &src_st);
4fdf8f88
JM		 5174 if (src_sts != 0) {
5175
5176 /* No source file or other problem */
5177 return src_sts;
5178 }
b94a8c49
JM		 5179 if (src_st.st_devnam[0] == 0) {
5180 /* This may be possible so fail if it is seen. */
5181 errno = EIO;
5182 return -1;
5183 }
4fdf8f88 5184
46c05374 5185 dst_sts = flex_lstat(dst, &dst_st);
4fdf8f88
JM		 5186 if (dst_sts == 0) {
5187
5188 if (dst_st.st_dev != src_st.st_dev) {
5189 /* Must be on the same device */
5190 errno = EXDEV;
5191 return -1;
5192 }
5193
5194 /* VMS_INO_T_COMPARE is true if the inodes are different
5195 * to match the output of memcmp
5196 */
5197
5198 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5199 /* That was easy, the files are the same! */
5200 return 0;
5201 }
5202
5203 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5204 /* If source is a directory, so must be dest */
5205 errno = EISDIR;
5206 return -1;
5207 }
5208
5209 }
5210
5211
5212 if ((dst_sts == 0) &&
5213 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5214
5215 /* We have issues here if vms_unlink_all_versions is set
5216 * If the destination exists, and is not a directory, then
5217 * we must delete in advance.
5218 *
5219 * If the src is a directory, then we must always pre-delete
5220 * the destination.
5221 *
5222 * If we successfully delete the dst in advance, and the rename fails
5223 * X/Open requires that errno be EIO.
5224 *
5225 */
5226
5227 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5228 int d_sts;
46c05374 5229 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
b94a8c49
JM		 5230 S_ISDIR(dst_st.st_mode));
5231
5232 /* Need to delete all versions ? */
5233 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5234 int i = 0;
5235
5236 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
46c05374 5237 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
b94a8c49
JM		 5238 if (d_sts != 0)
5239 break;
5240 i++;
5241
5242 /* Make sure that we do not loop forever */
5243 if (i > 32767) {
5244 errno = EIO;
5245 d_sts = -1;
5246 break;
5247 }
5248 }
5249 }
5250
4fdf8f88
JM		 5251 if (d_sts != 0)
5252 return d_sts;
5253
5254 /* We killed the destination, so only errno now is EIO */
5255 pre_delete = 1;
5256 }
5257 }
5258
5259 /* Originally the idea was to call the CRTL rename() and only
5260 * try the lib$rename_file if it failed.
5261 * It turns out that there are too many variants in what the
5262 * the CRTL rename might do, so only use lib$rename_file
5263 */
5264 retval = -1;
5265
5266 {
5267 /* Is the source and dest both in VMS format */
5268 /* if the source is a directory, then need to fileify */
94ae10c0 5269 /* and dest must be a directory or non-existent. */
4fdf8f88 5270
4fdf8f88
JM		 5271 char * vms_dst;
5272 int sts;
5273 char * ret_str;
5274 unsigned long flags;
5275 struct dsc$descriptor_s old_file_dsc;
5276 struct dsc$descriptor_s new_file_dsc;
5277
5278 /* We need to modify the src and dst depending
5279 * on if one or more of them are directories.
5280 */
5281
c11536f5 5282 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5283 if (vms_dst == NULL)
ebd4d70b 5284 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5285
5286 if (S_ISDIR(src_st.st_mode)) {
5287 char * ret_str;
5288 char * vms_dir_file;
5289
c11536f5 5290 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5291 if (vms_dir_file == NULL)
ebd4d70b 5292 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88 5293
29475144 5294 /* If the dest is a directory, we must remove it */
4fdf8f88
JM		 5295 if (dst_sts == 0) {
5296 int d_sts;
46c05374 5297 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
4fdf8f88 5298 if (d_sts != 0) {
4fdf8f88
JM		 5299 PerlMem_free(vms_dst);
5300 errno = EIO;
29475144 5301 return d_sts;
4fdf8f88
JM		 5302 }
5303
5304 pre_delete = 1;
5305 }
5306
5307 /* The dest must be a VMS file specification */
df278665 5308 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5309 if (ret_str == NULL) {
4fdf8f88
JM		 5310 PerlMem_free(vms_dst);
5311 errno = EIO;
5312 return -1;
5313 }
5314
5315 /* The source must be a file specification */
4fdf8f88
JM		 5316 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5317 if (ret_str == NULL) {
4fdf8f88
JM		 5318 PerlMem_free(vms_dst);
5319 PerlMem_free(vms_dir_file);
5320 errno = EIO;
5321 return -1;
5322 }
5323 PerlMem_free(vms_dst);
5324 vms_dst = vms_dir_file;
5325
5326 } else {
5327 /* File to file or file to new dir */
5328
5329 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5330 /* VMS pathify a dir target */
4846f1d7 5331 ret_str = int_tovmspath(dst, vms_dst, NULL);
4fdf8f88 5332 if (ret_str == NULL) {
4fdf8f88
JM		 5333 PerlMem_free(vms_dst);
5334 errno = EIO;
5335 return -1;
5336 }
5337 } else {
b94a8c49
JM		 5338 char * v_spec, * r_spec, * d_spec, * n_spec;
5339 char * e_spec, * vs_spec;
5340 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
4fdf8f88
JM		 5341
5342 /* fileify a target VMS file specification */
df278665 5343 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5344 if (ret_str == NULL) {
4fdf8f88
JM		 5345 PerlMem_free(vms_dst);
5346 errno = EIO;
5347 return -1;
5348 }
b94a8c49
JM		 5349
5350 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5351 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5352 &e_len, &vs_spec, &vs_len);
5353 if (sts == 0) {
5354 if (e_len == 0) {
5355 /* Get rid of the version */
5356 if (vs_len != 0) {
5357 *vs_spec = '\0';
5358 }
5359 /* Need to specify a '.' so that the extension */
5360 /* is not inherited */
5361 strcat(vms_dst,".");
5362 }
5363 }
4fdf8f88
JM		 5364 }
5365 }
5366
b94a8c49
JM		 5367 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5368 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
4fdf8f88
JM		 5369 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5370 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5371
5372 new_file_dsc.dsc$a_pointer = vms_dst;
5373 new_file_dsc.dsc$w_length = strlen(vms_dst);
5374 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5375 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5376
5377 flags = 0;
054a3baf 5378#if defined(NAML$C_MAXRSS)
449de3c2 5379 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
4fdf8f88
JM		 5380#endif
5381
5382 sts = lib$rename_file(&old_file_dsc,
5383 &new_file_dsc,
5384 NULL, NULL,
5385 &flags,
5386 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5387 if (!$VMS_STATUS_SUCCESS(sts)) {
5388
5389 /* We could have failed because VMS style permissions do not
5390 * permit renames that UNIX will allow. Just like the hack
5391 * in for kill_file.
5392 */
5393 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5394 }
5395
4fdf8f88
JM		 5396 PerlMem_free(vms_dst);
5397 if (!$VMS_STATUS_SUCCESS(sts)) {
5398 errno = EIO;
5399 return -1;
5400 }
5401 retval = 0;
5402 }
5403
5404 if (vms_unlink_all_versions) {
5405 /* Now get rid of any previous versions of the source file that
5406 * might still exist
5407 */
b94a8c49
JM		 5408 int i = 0;
5409 dSAVEDERRNO;
5410 SAVE_ERRNO;
46c05374 5411 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5412 S_ISDIR(src_st.st_mode));
5413 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
46c05374 5414 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5415 S_ISDIR(src_st.st_mode));
5416 if (src_sts != 0)
5417 break;
5418 i++;
5419
5420 /* Make sure that we do not loop forever */
5421 if (i > 32767) {
5422 src_sts = -1;
5423 break;
5424 }
5425 }
5426 RESTORE_ERRNO;
4fdf8f88
JM		 5427 }
5428
5429 /* We deleted the destination, so must force the error to be EIO */
5430 if ((retval != 0) && (pre_delete != 0))
5431 errno = EIO;
5432
5433 return retval;
5434}
5435/*}}}*/
5436
5437
bbce6d69 5438/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5439/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5440 * to expand file specification. Allows for a single default file
5441 * specification and a simple mask of options. If outbuf is non-NULL,
5442 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5443 * the resultant file specification is placed. If outbuf is NULL, the
5444 * resultant file specification is placed into a static buffer.
5445 * The third argument, if non-NULL, is taken to be a default file
5446 * specification string. The fourth argument is unused at present.
5447 * rmesexpand() returns the address of the resultant string if
5448 * successful, and NULL on error.
e886094b
JM		 5449 *
5450 * New functionality for previously unused opts value:
5451 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5452 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5453 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5454 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5455 */
360732b5 5456static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5457
bbce6d69 5458static char *
6fb6c614
JM		 5459int_rmsexpand
5460 (const char *filespec,
360732b5 5461 char *outbuf,
360732b5
JM		 5462 const char *defspec,
5463 unsigned opts,
5464 int * fs_utf8,
5465 int * dfs_utf8)
bbce6d69 5466{
6fb6c614
JM		 5467 char * ret_spec;
5468 const char * in_spec;
5469 char * spec_buf;
5470 const char * def_spec;
5471 char * vmsfspec, *vmsdefspec;
5472 char * esa;
7566800d 5473 char * esal = NULL;
18a3d61e
JM		 5474 char * outbufl;
5475 struct FAB myfab = cc$rms_fab;
a480973c 5476 rms_setup_nam(mynam);
18a3d61e
JM		 5477 STRLEN speclen;
5478 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5479 int sts;
5480
360732b5
JM		 5481 /* temp hack until UTF8 is actually implemented */
5482 if (fs_utf8 != NULL)
5483 *fs_utf8 = 0;
5484
18a3d61e
JM		 5485 if (!filespec || !*filespec) {
5486 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5487 return NULL;
5488 }
18a3d61e
JM		 5489
5490 vmsfspec = NULL;
6fb6c614 5491 vmsdefspec = NULL;
18a3d61e 5492 outbufl = NULL;
a1887106 5493
6fb6c614 5494 in_spec = filespec;
a1887106
JM		 5495 isunix = 0;
5496 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
6fb6c614
JM		 5497 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5498 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5499
5500 /* If this is a UNIX file spec, convert it to VMS */
5501 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5502 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5503 &e_len, &vs_spec, &vs_len);
5504 if (sts != 0) {
5505 isunix = 1;
5506 char * ret_spec;
5507
c11536f5 5508 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5509 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5510 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5511 if (ret_spec == NULL) {
5512 PerlMem_free(vmsfspec);
5513 return NULL;
5514 }
5515 in_spec = (const char *)vmsfspec;
18a3d61e 5516
6fb6c614
JM		 5517 /* Unless we are forcing to VMS format, a UNIX input means
5518 * UNIX output, and that requires long names to be used
5519 */
5520 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
054a3baf 5521#if defined(NAML$C_MAXRSS)
6fb6c614 5522 opts |= PERL_RMSEXPAND_M_LONG;
778e045f
CB		 5523#else
5524 NOOP;
b1a8dcd7 5525#endif
6fb6c614
JM		 5526 else
5527 isunix = 0;
a1887106 5528 }
18a3d61e 5529
6fb6c614
JM		 5530 }
5531
5532 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
a480973c 5533 rms_bind_fab_nam(myfab, mynam);
18a3d61e 5534
6fb6c614
JM		 5535 /* Process the default file specification if present */
5536 def_spec = defspec;
18a3d61e
JM		 5537 if (defspec && *defspec) {
5538 int t_isunix;
5539 t_isunix = is_unix_filespec(defspec);
5540 if (t_isunix) {
c11536f5 5541 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5542 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5543 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5544
5545 if (ret_spec == NULL) {
5546 /* Clean up and bail */
5547 PerlMem_free(vmsdefspec);
5548 if (vmsfspec != NULL)
5549 PerlMem_free(vmsfspec);
5550 return NULL;
5551 }
5552 def_spec = (const char *)vmsdefspec;
18a3d61e 5553 }
6fb6c614
JM		 5554 rms_set_dna(myfab, mynam,
5555 (char *)def_spec, strlen(def_spec)); /* cast ok */
18a3d61e
JM		 5556 }
5557
6fb6c614 5558 /* Now we need the expansion buffers */
c11536f5 5559 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 5560 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
054a3baf 5561#if defined(NAML$C_MAXRSS)
c11536f5 5562 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5563 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5564#endif
a1887106 5565 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5566
d584a1c6
JM		 5567 /* If a NAML block is used RMS always writes to the long and short
5568 * addresses unless you suppress the short name.
5569 */
054a3baf 5570#if defined(NAML$C_MAXRSS)
c11536f5 5571 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5572 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5573#endif
d584a1c6 5574 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5575
f7ddb74a
JM		 5576#ifdef NAM$M_NO_SHORT_UPCASE
5577 if (decc_efs_case_preserve)
a480973c 5578 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5579#endif
18a3d61e 5580
e0e5e8d6
JM		 5581 /* We may not want to follow symbolic links */
5582#ifdef NAML$M_OPEN_SPECIAL
5583 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5584 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5585#endif
5586
18a3d61e
JM		 5587 /* First attempt to parse as an existing file */
5588 retsts = sys$parse(&myfab,0,0);
5589 if (!(retsts & STS$K_SUCCESS)) {
5590
5591 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5592 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
6fb6c614
JM		 5593 if (retsts == RMS$_DNF ||
5594 retsts == RMS$_DIR ||
5595 retsts == RMS$_DEV ||
5596 retsts == RMS$_PRV) {
18a3d61e 5597 retsts = sys$parse(&myfab,0,0);
6fb6c614 5598 if (retsts & STS$K_SUCCESS) goto int_expanded;
18a3d61e
JM		 5599 }
5600
5601 /* Still could not parse the file specification */
5602 /*----------------------------------------------*/
a480973c 5603 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5604 if (vmsdefspec != NULL)
5605 PerlMem_free(vmsdefspec);
18a3d61e 5606 if (vmsfspec != NULL)
c5375c28
JM		 5607 PerlMem_free(vmsfspec);
5608 if (outbufl != NULL)
5609 PerlMem_free(outbufl);
5610 PerlMem_free(esa);
7566800d
CB		 5611 if (esal != NULL)
5612 PerlMem_free(esal);
18a3d61e
JM		 5613 set_vaxc_errno(retsts);
5614 if (retsts == RMS$_PRV) set_errno(EACCES);
5615 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5616 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5617 else set_errno(EVMSERR);
5618 return NULL;
5619 }
5620 retsts = sys$search(&myfab,0,0);
5621 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5622 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5623 if (vmsdefspec != NULL)
5624 PerlMem_free(vmsdefspec);
18a3d61e 5625 if (vmsfspec != NULL)
c5375c28
JM		 5626 PerlMem_free(vmsfspec);
5627 if (outbufl != NULL)
5628 PerlMem_free(outbufl);
5629 PerlMem_free(esa);
7566800d
CB		 5630 if (esal != NULL)
5631 PerlMem_free(esal);
18a3d61e
JM		 5632 set_vaxc_errno(retsts);
5633 if (retsts == RMS$_PRV) set_errno(EACCES);
5634 else set_errno(EVMSERR);
5635 return NULL;
5636 }
5637
5638 /* If the input filespec contained any lowercase characters,
5639 * downcase the result for compatibility with Unix-minded code. */
6fb6c614 5640int_expanded:
18a3d61e 5641 if (!decc_efs_case_preserve) {
6fb6c614 5642 char * tbuf;
c5375c28
JM		 5643 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5644 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5645 }
5646
5647 /* Is a long or a short name expected */
5648 /*------------------------------------*/
6fb6c614 5649 spec_buf = NULL;
054a3baf 5650#if defined(NAML$C_MAXRSS)
18a3d61e 5651 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5652 if (rms_nam_rsll(mynam)) {
6fb6c614 5653 spec_buf = outbufl;
a480973c 5654 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5655 }
5656 else {
6fb6c614 5657 spec_buf = esal; /* Not esa */
a480973c 5658 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5659 }
5660 }
5661 else {
778e045f 5662#endif
a480973c 5663 if (rms_nam_rsl(mynam)) {
6fb6c614 5664 spec_buf = outbuf;
a480973c 5665 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5666 }
5667 else {
6fb6c614 5668 spec_buf = esa; /* Not esal */
a480973c 5669 speclen = rms_nam_esl(mynam);
18a3d61e 5670 }
054a3baf 5671#if defined(NAML$C_MAXRSS)
18a3d61e 5672 }
778e045f 5673#endif
6fb6c614 5674 spec_buf[speclen] = '\0';
4d743a9b 5675
18a3d61e
JM		 5676 /* Trim off null fields added by $PARSE
5677 * If type > 1 char, must have been specified in original or default spec
5678 * (not true for version; $SEARCH may have added version of existing file).
5679 */
a480973c 5680 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5681 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5682 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5683 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5684 }
5685 else {
a480973c
JM		 5686 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5687 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5688 }
5689 if (trimver || trimtype) {
5690 if (defspec && *defspec) {
5691 char *defesal = NULL;
d584a1c6 5692 char *defesa = NULL;
c11536f5 5693 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
d584a1c6 5694 if (defesa != NULL) {
6fb6c614 5695 struct FAB deffab = cc$rms_fab;
054a3baf 5696#if defined(NAML$C_MAXRSS)
c11536f5 5697 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5698 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 5699#endif
a480973c 5700 rms_setup_nam(defnam);
18a3d61e 5701
a480973c
JM		 5702 rms_bind_fab_nam(deffab, defnam);
5703
5704 /* Cast ok */
5705 rms_set_fna
5706 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5707
d584a1c6
JM		 5708 /* RMS needs the esa/esal as a work area if wildcards are involved */
5709 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5710
4d743a9b 5711 rms_clear_nam_nop(defnam);
a480973c 5712 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5713#ifdef NAM$M_NO_SHORT_UPCASE
5714 if (decc_efs_case_preserve)
a480973c 5715 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5716#endif
e0e5e8d6
JM		 5717#ifdef NAML$M_OPEN_SPECIAL
5718 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5719 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5720#endif
18a3d61e
JM		 5721 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5722 if (trimver) {
a480973c 5723 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5724 }
5725 if (trimtype) {
a480973c 5726 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5727 }
5728 }
d584a1c6
JM		 5729 if (defesal != NULL)
5730 PerlMem_free(defesal);
5731 PerlMem_free(defesa);
6fb6c614
JM		 5732 } else {
5733 _ckvmssts_noperl(SS$_INSFMEM);
18a3d61e
JM		 5734 }
5735 }
5736 if (trimver) {
5737 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5738 if (*(rms_nam_verl(mynam)) != '\"')
6fb6c614 5739 speclen = rms_nam_verl(mynam) - spec_buf;
18a3d61e
JM		 5740 }
5741 else {
a480973c 5742 if (*(rms_nam_ver(mynam)) != '\"')
6fb6c614 5743 speclen = rms_nam_ver(mynam) - spec_buf;
18a3d61e
JM		 5744 }
5745 }
5746 if (trimtype) {
5747 /* If we didn't already trim version, copy down */
5748 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
6fb6c614 5749 if (speclen > rms_nam_verl(mynam) - spec_buf)
18a3d61e 5750 memmove
a480973c
JM		 5751 (rms_nam_typel(mynam),
5752 rms_nam_verl(mynam),
6fb6c614 5753 speclen - (rms_nam_verl(mynam) - spec_buf));
a480973c 5754 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5755 }
5756 else {
6fb6c614 5757 if (speclen > rms_nam_ver(mynam) - spec_buf)
18a3d61e 5758 memmove
a480973c
JM		 5759 (rms_nam_type(mynam),
5760 rms_nam_ver(mynam),
6fb6c614 5761 speclen - (rms_nam_ver(mynam) - spec_buf));
a480973c 5762 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5763 }
5764 }
5765 }
5766
5767 /* Done with these copies of the input files */
5768 /*-------------------------------------------*/
5769 if (vmsfspec != NULL)
c5375c28 5770 PerlMem_free(vmsfspec);
6fb6c614
JM		 5771 if (vmsdefspec != NULL)
5772 PerlMem_free(vmsdefspec);
18a3d61e
JM		 5773
5774 /* If we just had a directory spec on input, $PARSE "helpfully"
5775 * adds an empty name and type for us */
054a3baf 5776#if defined(NAML$C_MAXRSS)
18a3d61e 5777 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5778 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5779 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5780 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5781 speclen = rms_nam_namel(mynam) - spec_buf;
18a3d61e 5782 }
d584a1c6
JM		 5783 else
5784#endif
5785 {
a480973c
JM		 5786 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5787 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5788 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5789 speclen = rms_nam_name(mynam) - spec_buf;
18a3d61e
JM		 5790 }
5791
5792 /* Posix format specifications must have matching quotes */
4d743a9b 5793 if (speclen < (VMS_MAXRSS - 1)) {
6fb6c614
JM		 5794 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5795 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5796 spec_buf[speclen] = '\"';
4d743a9b
JM		 5797 speclen++;
5798 }
18a3d61e
JM		 5799 }
5800 }
6fb6c614
JM		 5801 spec_buf[speclen] = '\0';
5802 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
18a3d61e
JM		 5803
5804 /* Have we been working with an expanded, but not resultant, spec? */
5805 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5806 {
5807 int rsl;
18a3d61e 5808
054a3baf 5809#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 5810 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5811 rsl = rms_nam_rsll(mynam);
5812 } else
5813#endif
5814 {
5815 rsl = rms_nam_rsl(mynam);
5816 }
5817 if (!rsl) {
6fb6c614
JM		 5818 /* rsl is not present, it means that spec_buf is either */
5819 /* esa or esal, and needs to be copied to outbuf */
5820 /* convert to Unix if desired */
d584a1c6 5821 if (isunix) {
6fb6c614
JM		 5822 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5823 } else {
5824 /* VMS file specs are not in UTF-8 */
5825 if (fs_utf8 != NULL)
5826 *fs_utf8 = 0;
a35dcc95 5827 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5828 ret_spec = outbuf;
18a3d61e
JM		 5829 }
5830 }
6fb6c614
JM		 5831 else {
5832 /* Now spec_buf is either outbuf or outbufl */
5833 /* We need the result into outbuf */
5834 if (isunix) {
5835 /* If we need this in UNIX, then we need another buffer */
5836 /* to keep things in order */
5837 char * src;
5838 char * new_src = NULL;
5839 if (spec_buf == outbuf) {
c11536f5 5840 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 5841 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
6fb6c614
JM		 5842 } else {
5843 src = spec_buf;
5844 }
5845 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5846 if (new_src) {
5847 PerlMem_free(new_src);
5848 }
5849 } else {
5850 /* VMS file specs are not in UTF-8 */
5851 if (fs_utf8 != NULL)
5852 *fs_utf8 = 0;
5853
5854 /* Copy the buffer if needed */
5855 if (outbuf != spec_buf)
a35dcc95 5856 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5857 ret_spec = outbuf;
d584a1c6 5858 }
18a3d61e 5859 }
18a3d61e 5860 }
6fb6c614
JM		 5861
5862 /* Need to clean up the search context */
a480973c
JM		 5863 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5864 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5865
5866 /* Clean up the extra buffers */
7566800d 5867 if (esal != NULL)
6fb6c614
JM		 5868 PerlMem_free(esal);
5869 PerlMem_free(esa);
c5375c28
JM		 5870 if (outbufl != NULL)
5871 PerlMem_free(outbufl);
6fb6c614
JM		 5872
5873 /* Return the result */
5874 return ret_spec;
5875}
5876
5877/* Common simple case - Expand an already VMS spec */
5878static char *
5879int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5880 opts |= PERL_RMSEXPAND_M_VMS_IN;
5881 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5882}
5883
5884/* Common simple case - Expand to a VMS spec */
5885static char *
5886int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5887 opts |= PERL_RMSEXPAND_M_VMS;
5888 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5889}
5890
5891
5892/* Entry point used by perl routines */
5893static char *
5894mp_do_rmsexpand
5895 (pTHX_ const char *filespec,
5896 char *outbuf,
5897 int ts,
5898 const char *defspec,
5899 unsigned opts,
5900 int * fs_utf8,
5901 int * dfs_utf8)
5902{
5903 static char __rmsexpand_retbuf[VMS_MAXRSS];
5904 char * expanded, *ret_spec, *ret_buf;
5905
5906 expanded = NULL;
5907 ret_buf = outbuf;
5908 if (ret_buf == NULL) {
5909 if (ts) {
5910 Newx(expanded, VMS_MAXRSS, char);
5911 if (expanded == NULL)
5912 _ckvmssts(SS$_INSFMEM);
5913 ret_buf = expanded;
5914 } else {
5915 ret_buf = __rmsexpand_retbuf;
5916 }
5917 }
5918
5919
5920 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5921 opts, fs_utf8, dfs_utf8);
5922
5923 if (ret_spec == NULL) {
5924 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5925 if (expanded)
5926 Safefree(expanded);
5927 }
5928
5929 return ret_spec;
bbce6d69 5930}
5931/*}}}*/
5932/* External entry points */
ce12d4b7
CB		 5933char *
5934Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5935{
5936 return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5937}
5938
5939char *
5940Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5941{
5942 return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5943}
5944
5945char *
5946Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5947 unsigned opt, int * fs_utf8, int * dfs_utf8)
5948{
5949 return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5950}
5951
5952char *
5953Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5954 unsigned opt, int * fs_utf8, int * dfs_utf8)
5955{
5956 return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5957}
bbce6d69 5958
5959
a0d0e21e
LW		 5960/*
5961** The following routines are provided to make life easier when
5962** converting among VMS-style and Unix-style directory specifications.
5963** All will take input specifications in either VMS or Unix syntax. On
5964** failure, all return NULL. If successful, the routines listed below
748a9306 5965** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5966** reformatted spec (and, therefore, subsequent calls to that routine
5967** will clobber the result), while the routines of the same names with
5968** a _ts suffix appended will return a pointer to a mallocd string
5969** containing the appropriately reformatted spec.
5970** In all cases, only explicit syntax is altered; no check is made that
5971** the resulting string is valid or that the directory in question
5972** actually exists.
5973**
5974** fileify_dirspec() - convert a directory spec into the name of the
5975** directory file (i.e. what you can stat() to see if it's a dir).
5976** The style (VMS or Unix) of the result is the same as the style
5977** of the parameter passed in.
5978** pathify_dirspec() - convert a directory spec into a path (i.e.
5979** what you prepend to a filename to indicate what directory it's in).
5980** The style (VMS or Unix) of the result is the same as the style
5981** of the parameter passed in.
5982** tounixpath() - convert a directory spec into a Unix-style path.
5983** tovmspath() - convert a directory spec into a VMS-style path.
5984** tounixspec() - convert any file spec into a Unix-style file spec.
5985** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5986** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5987**
bd3fa61c 5988** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5989** Permission is given to distribute this code as part of the Perl
5990** standard distribution under the terms of the GNU General Public
5991** License or the Perl Artistic License. Copies of each may be
5992** found in the Perl standard distribution.
a0d0e21e
LW		 5993 */
5994
a979ce91
JM		 5995/*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5996static char *
5997int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
a0d0e21e 5998{
4e0c9737 5999 unsigned long int dirlen, retlen, hasfilename = 0;
a979ce91 6000 char *cp1, *cp2, *lastdir;
a480973c 6001 char *trndir, *vmsdir;
2d9f3838 6002 unsigned short int trnlnm_iter_count;
f7ddb74a 6003 int sts;
360732b5
JM		 6004 if (utf8_fl != NULL)
6005 *utf8_fl = 0;
a0d0e21e 6006
c07a80fd 6007 if (!dir || !*dir) {
6008 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6009 }
a0d0e21e 6010 dirlen = strlen(dir);
a2a90019 6011 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 6012 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 6013 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6014 dir = "/sys$disk";
6015 dirlen = 9;
6016 }
6017 else
6018 dirlen = 1;
61bb5906 6019 }
a480973c
JM		 6020 if (dirlen > (VMS_MAXRSS - 1)) {
6021 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6022 return NULL;
c07a80fd 6023 }
c11536f5 6024 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6025 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 6026 if (!strpbrk(dir+1,"/]>:") &&
6027 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 6028 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 6029 trnlnm_iter_count = 0;
b8486b9d 6030 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 6031 trnlnm_iter_count++;
6032 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6033 }
b8ffc8df 6034 dirlen = strlen(trndir);
e518068a 6035 }
01b8edb6 6036 else {
a35dcc95 6037 memcpy(trndir, dir, dirlen);
01b8edb6 6038 trndir[dirlen] = '\0';
01b8edb6 6039 }
b8ffc8df
RGS		 6040
6041 /* At this point we are done with *dir and use *trndir which is a
6042 * copy that can be modified. *dir must not be modified.
6043 */
6044
c07a80fd 6045 /* If we were handed a rooted logical name or spec, treat it like a
6046 * simple directory, so that
6047 * $ Define myroot dev:[dir.]
6048 * ... do_fileify_dirspec("myroot",buf,1) ...
6049 * does something useful.
6050 */
b8ffc8df
RGS		 6051 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6052 trndir[--dirlen] = '\0';
6053 trndir[dirlen-1] = ']';
c07a80fd 6054 }
b8ffc8df
RGS		 6055 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6056 trndir[--dirlen] = '\0';
6057 trndir[dirlen-1] = '>';
46112e17 6058 }
e518068a 6059
b8ffc8df 6060 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 6061 /* If we've got an explicit filename, we can just shuffle the string. */
6062 if (*(cp1+1)) hasfilename = 1;
6063 /* Similarly, we can just back up a level if we've got multiple levels
6064 of explicit directories in a VMS spec which ends with directories. */
6065 else {
b8ffc8df 6066 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 6067 if (*cp2 == '.') {
6068 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 6069/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 6070 *cp2 = *cp1; *cp1 = '\0';
6071 hasfilename = 1;
6072 break;
6073 }
b7ae7a0d 6074 }
6075 if (*cp2 == '[' || *cp2 == '<') break;
6076 }
6077 }
6078 }
6079
c11536f5 6080 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6081 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 6082 cp1 = strpbrk(trndir,"]:>");
60e5a54b
CB		 6083 if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
6084 cp1 = strpbrk(cp1+2,"]:>");
6085
a979ce91
JM		 6086 if (hasfilename || !cp1) { /* filename present or not VMS */
6087
b8ffc8df 6088 if (trndir[0] == '.') {
a480973c 6089 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 6090 PerlMem_free(trndir);
6091 PerlMem_free(vmsdir);
a979ce91 6092 return int_fileify_dirspec("[]", buf, NULL);
a480973c 6093 }
b8ffc8df 6094 else if (trndir[1] == '.' &&
a480973c 6095 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 6096 PerlMem_free(trndir);
6097 PerlMem_free(vmsdir);
a979ce91 6098 return int_fileify_dirspec("[-]", buf, NULL);
a480973c 6099 }
748a9306 6100 }
b8ffc8df 6101 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 6102 dirlen -= 1; /* to last element */
b8ffc8df 6103 lastdir = strrchr(trndir,'/');
a0d0e21e 6104 }
b8ffc8df 6105 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 6106 /* If we have "/." or "/..", VMSify it and let the VMS code
6107 * below expand it, rather than repeating the code to handle
6108 * relative components of a filespec here */
4633a7c4
LW		 6109 do {
6110 if (*(cp1+2) == '.') cp1++;
6111 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 6112 char * ret_chr;
df278665 6113 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
c5375c28
JM		 6114 PerlMem_free(trndir);
6115 PerlMem_free(vmsdir);
a480973c
JM		 6116 return NULL;
6117 }
fc1ce8cc 6118 if (strchr(vmsdir,'/') != NULL) {
df278665 6119 /* If int_tovmsspec() returned it, it must have VMS syntax
fc1ce8cc
CB		 6120 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6121 * the time to check this here only so we avoid a recursion
6122 * loop; otherwise, gigo.
6123 */
c5375c28
JM		 6124 PerlMem_free(trndir);
6125 PerlMem_free(vmsdir);
a480973c
JM		 6126 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6127 return NULL;
fc1ce8cc 6128 }
a979ce91 6129 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6130 PerlMem_free(trndir);
6131 PerlMem_free(vmsdir);
a480973c
JM		 6132 return NULL;
6133 }
0e5ce2c7 6134 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6135 PerlMem_free(trndir);
6136 PerlMem_free(vmsdir);
a480973c 6137 return ret_chr;
4633a7c4
LW		 6138 }
6139 cp1++;
6140 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 6141 lastdir = strrchr(trndir,'/');
748a9306 6142 }
b8ffc8df 6143 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 6144 char * ret_chr;
61bb5906
CB		 6145 /* Ditto for specs that end in an MFD -- let the VMS code
6146 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 6147
6148 /* This should not happen any more. Allowing the fake /000000
6149 * in a UNIX pathname causes all sorts of problems when trying
6150 * to run in UNIX emulation. So the VMS to UNIX conversions
6151 * now remove the fake /000000 directories.
6152 */
6153
b8ffc8df 6154 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
df278665 6155 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
c5375c28
JM		 6156 PerlMem_free(trndir);
6157 PerlMem_free(vmsdir);
a480973c
JM		 6158 return NULL;
6159 }
a979ce91 6160 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6161 PerlMem_free(trndir);
6162 PerlMem_free(vmsdir);
a480973c
JM		 6163 return NULL;
6164 }
0e5ce2c7 6165 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6166 PerlMem_free(trndir);
6167 PerlMem_free(vmsdir);
a480973c 6168 return ret_chr;
61bb5906 6169 }
a0d0e21e 6170 else {
f7ddb74a 6171
b8ffc8df
RGS		 6172 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6173 !(lastdir = cp1 = strrchr(trndir,']')) &&
6174 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
f7ddb74a 6175
a979ce91
JM		 6176 cp2 = strrchr(cp1,'.');
6177 if (cp2) {
6178 int e_len, vs_len = 0;
6179 int is_dir = 0;
6180 char * cp3;
6181 cp3 = strchr(cp2,';');
6182 e_len = strlen(cp2);
6183 if (cp3) {
6184 vs_len = strlen(cp3);
6185 e_len = e_len - vs_len;
6186 }
6187 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6188 if (!is_dir) {
6189 if (!decc_efs_charset) {
6190 /* If this is not EFS, then not a directory */
6191 PerlMem_free(trndir);
6192 PerlMem_free(vmsdir);
6193 set_errno(ENOTDIR);
6194 set_vaxc_errno(RMS$_DIR);
6195 return NULL;
6196 }
6197 } else {
6198 /* Ok, here we have an issue, technically if a .dir shows */
6199 /* from inside a directory, then we should treat it as */
6200 /* xxx^.dir.dir. But we do not have that context at this */
6201 /* point unless this is totally restructured, so we remove */
6202 /* The .dir for now, and fix this better later */
6203 dirlen = cp2 - trndir;
6204 }
37769287
CB		 6205 if (decc_efs_charset && !strchr(trndir,'/')) {
6206 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
a9fac63d
CB		 6207 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6208
6209 for (; cp4 > cp1; cp4--) {
6210 if (*cp4 == '.') {
6211 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6212 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6213 *cp4 = '^';
6214 dirlen++;
6215 }
6216 }
6217 }
6218 }
a0d0e21e 6219 }
a979ce91 6220
748a9306 6221 }
f7ddb74a
JM		 6222
6223 retlen = dirlen + 6;
a979ce91
JM		 6224 memcpy(buf, trndir, dirlen);
6225 buf[dirlen] = '\0';
f7ddb74a 6226
a0d0e21e
LW		 6227 /* We've picked up everything up to the directory file name.
6228 Now just add the type and version, and we're set. */
839e16da 6229 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6e2e048b 6230 strcat(buf,".dir");
839e16da 6231 else
6e2e048b
CB		 6232 strcat(buf,".DIR");
6233 if (!decc_filename_unix_no_version)
6234 strcat(buf,";1");
c5375c28
JM		 6235 PerlMem_free(trndir);
6236 PerlMem_free(vmsdir);
a979ce91 6237 return buf;
a0d0e21e
LW		 6238 }
6239 else { /* VMS-style directory spec */
a480973c 6240
d584a1c6
JM		 6241 char *esa, *esal, term, *cp;
6242 char *my_esa;
6243 int my_esa_len;
4e0c9737 6244 unsigned long int cmplen, haslower = 0;
a0d0e21e 6245 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6246 rms_setup_nam(savnam);
6247 rms_setup_nam(dirnam);
6248
c11536f5 6249 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 6250 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6251 esal = NULL;
054a3baf 6252#if defined(NAML$C_MAXRSS)
c11536f5 6253 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6254 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6255#endif
a480973c
JM		 6256 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6257 rms_bind_fab_nam(dirfab, dirnam);
6258 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 6259 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 6260#ifdef NAM$M_NO_SHORT_UPCASE
6261 if (decc_efs_case_preserve)
a480973c 6262 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6263#endif
01b8edb6 6264
b8ffc8df 6265 for (cp = trndir; *cp; cp++)
01b8edb6 6266 if (islower(*cp)) { haslower = 1; break; }
a480973c 6267 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
a979ce91
JM		 6268 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6269 (dirfab.fab$l_sts == RMS$_DNF) ||
6270 (dirfab.fab$l_sts == RMS$_PRV)) {
6271 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6272 sts = sys$parse(&dirfab);
e518068a 6273 }
6274 if (!sts) {
c5375c28 6275 PerlMem_free(esa);
d584a1c6
JM		 6276 if (esal != NULL)
6277 PerlMem_free(esal);
c5375c28
JM		 6278 PerlMem_free(trndir);
6279 PerlMem_free(vmsdir);
748a9306
LW		 6280 set_errno(EVMSERR);
6281 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6282 return NULL;
6283 }
e518068a 6284 }
6285 else {
6286 savnam = dirnam;
a480973c
JM		 6287 /* Does the file really exist? */
6288 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6289 /* Yes; fake the fnb bits so we'll check type below */
a979ce91 6290 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6291 }
752635ea 6292 else { /* No; just work with potential name */
60e5a54b
CB		 6293 if (dirfab.fab$l_sts == RMS$_FNF
6294 || dirfab.fab$l_sts == RMS$_DNF
6295 || dirfab.fab$l_sts == RMS$_FND)
6296 dirnam = savnam;
752635ea 6297 else {
2623a4a6
JM		 6298 int fab_sts;
6299 fab_sts = dirfab.fab$l_sts;
6300 sts = rms_free_search_context(&dirfab);
c5375c28 6301 PerlMem_free(esa);
d584a1c6
JM		 6302 if (esal != NULL)
6303 PerlMem_free(esal);
c5375c28
JM		 6304 PerlMem_free(trndir);
6305 PerlMem_free(vmsdir);
2623a4a6 6306 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6307 return NULL;
6308 }
e518068a 6309 }
a0d0e21e 6310 }
d584a1c6
JM		 6311
6312 /* Make sure we are using the right buffer */
054a3baf 6313#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 6314 if (esal != NULL) {
6315 my_esa = esal;
6316 my_esa_len = rms_nam_esll(dirnam);
6317 } else {
778e045f 6318#endif
d584a1c6
JM		 6319 my_esa = esa;
6320 my_esa_len = rms_nam_esl(dirnam);
054a3baf 6321#if defined(NAML$C_MAXRSS)
d584a1c6 6322 }
778e045f 6323#endif
d584a1c6 6324 my_esa[my_esa_len] = '\0';
a480973c 6325 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6326 cp1 = strchr(my_esa,']');
6327 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6328 if (cp1) { /* Should always be true */
d584a1c6
JM		 6329 my_esa_len -= cp1 - my_esa - 1;
6330 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6331 }
6332 }
a480973c 6333 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6334 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6335 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6336 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6337 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6338 sts = rms_free_search_context(&dirfab);
c5375c28 6339 PerlMem_free(esa);
d584a1c6
JM		 6340 if (esal != NULL)
6341 PerlMem_free(esal);
c5375c28
JM		 6342 PerlMem_free(trndir);
6343 PerlMem_free(vmsdir);
748a9306
LW		 6344 set_errno(ENOTDIR);
6345 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6346 return NULL;
6347 }
748a9306 6348 }
ae6d78fe 6349
a480973c 6350 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306 6351 /* They provided at least the name; we added the type, if necessary, */
a35dcc95 6352 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a480973c 6353 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6354 PerlMem_free(trndir);
6355 PerlMem_free(esa);
d584a1c6
JM		 6356 if (esal != NULL)
6357 PerlMem_free(esal);
c5375c28 6358 PerlMem_free(vmsdir);
a979ce91 6359 return buf;
748a9306 6360 }
c07a80fd 6361 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6362 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6363 *cp1 = '\0';
d584a1c6 6364 my_esa_len -= 9;
c07a80fd 6365 }
d584a1c6 6366 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6367 if (cp1 == NULL) { /* should never happen */
a480973c 6368 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6369 PerlMem_free(trndir);
6370 PerlMem_free(esa);
d584a1c6
JM		 6371 if (esal != NULL)
6372 PerlMem_free(esal);
c5375c28 6373 PerlMem_free(vmsdir);
752635ea
CB		 6374 return NULL;
6375 }
748a9306
LW		 6376 term = *cp1;
6377 *cp1 = '\0';
d584a1c6
JM		 6378 retlen = strlen(my_esa);
6379 cp1 = strrchr(my_esa,'.');
f7ddb74a 6380 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6381 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6382 while (cp1 != NULL) {
d584a1c6 6383 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6384 break;
6385 else {
6386 cp1--;
d584a1c6 6387 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6388 cp1--;
6389 }
d584a1c6 6390 if (cp1 == my_esa)
f7ddb74a
JM		 6391 cp1 = NULL;
6392 }
6393
6394 if ((cp1) != NULL) {
748a9306
LW		 6395 /* There's more than one directory in the path. Just roll back. */
6396 *cp1 = term;
a35dcc95 6397 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a0d0e21e
LW		 6398 }
6399 else {
a480973c 6400 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6401 /* Go back and expand rooted logical name */
a480973c 6402 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6403#ifdef NAM$M_NO_SHORT_UPCASE
6404 if (decc_efs_case_preserve)
a480973c 6405 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6406#endif
a480973c
JM		 6407 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6408 sts = rms_free_search_context(&dirfab);
c5375c28 6409 PerlMem_free(esa);
d584a1c6
JM		 6410 if (esal != NULL)
6411 PerlMem_free(esal);
c5375c28
JM		 6412 PerlMem_free(trndir);
6413 PerlMem_free(vmsdir);
748a9306
LW		 6414 set_errno(EVMSERR);
6415 set_vaxc_errno(dirfab.fab$l_sts);
6416 return NULL;
6417 }
d584a1c6
JM		 6418
6419 /* This changes the length of the string of course */
6420 if (esal != NULL) {
6421 my_esa_len = rms_nam_esll(dirnam);
6422 } else {
6423 my_esa_len = rms_nam_esl(dirnam);
6424 }
6425
6426 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
d584a1c6
JM		 6427 cp1 = strstr(my_esa,"][");
6428 if (!cp1) cp1 = strstr(my_esa,"]<");
6429 dirlen = cp1 - my_esa;
a979ce91 6430 memcpy(buf, my_esa, dirlen);
748a9306 6431 if (!strncmp(cp1+2,"000000]",7)) {
a979ce91 6432 buf[dirlen-1] = '\0';
657054d4 6433 /* fix-me Not full ODS-5, just extra dots in directories for now */
a979ce91
JM		 6434 cp1 = buf + dirlen - 1;
6435 while (cp1 > buf)
f7ddb74a
JM		 6436 {
6437 if (*cp1 == '[')
6438 break;
6439 if (*cp1 == '.') {
6440 if (*(cp1-1) != '^')
6441 break;
6442 }
6443 cp1--;
6444 }
4633a7c4
LW		 6445 if (*cp1 == '.') *cp1 = ']';
6446 else {
a979ce91 6447 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6448 memmove(cp1+1,"000000]",7);
4633a7c4 6449 }
748a9306
LW		 6450 }
6451 else {
a979ce91
JM		 6452 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6453 buf[retlen] = '\0';
748a9306 6454 /* Convert last '.' to ']' */
a979ce91 6455 cp1 = buf+retlen-1;
f7ddb74a
JM		 6456 while (*cp != '[') {
6457 cp1--;
6458 if (*cp1 == '.') {
6459 /* Do not trip on extra dots in ODS-5 directories */
a979ce91 6460 if ((cp1 == buf) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6461 break;
6462 }
6463 }
4633a7c4
LW		 6464 if (*cp1 == '.') *cp1 = ']';
6465 else {
a979ce91 6466 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6467 memmove(cp1+1,"000000]",7);
4633a7c4 6468 }
748a9306 6469 }
a0d0e21e 6470 }
748a9306 6471 else { /* This is a top-level dir. Add the MFD to the path. */
60e5a54b
CB		 6472 cp1 = strrchr(my_esa, ':');
6473 assert(cp1);
6474 memmove(buf, my_esa, cp1 - my_esa + 1);
6475 memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6476 memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6477 buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
a0d0e21e 6478 }
748a9306 6479 }
a480973c 6480 sts = rms_free_search_context(&dirfab);
748a9306 6481 /* We've set up the string up through the filename. Add the
a0d0e21e 6482 type and version, and we're done. */
a979ce91 6483 strcat(buf,".DIR;1");
01b8edb6 6484
6485 /* $PARSE may have upcased filespec, so convert output to lower
6486 * case if input contained any lowercase characters. */
a979ce91 6487 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
c5375c28
JM		 6488 PerlMem_free(trndir);
6489 PerlMem_free(esa);
d584a1c6
JM		 6490 if (esal != NULL)
6491 PerlMem_free(esal);
c5375c28 6492 PerlMem_free(vmsdir);
a979ce91 6493 return buf;
a0d0e21e 6494 }
a979ce91
JM		 6495} /* end of int_fileify_dirspec() */
6496
6497
6498/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 6499static char *
6500mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a979ce91
JM		 6501{
6502 static char __fileify_retbuf[VMS_MAXRSS];
6503 char * fileified, *ret_spec, *ret_buf;
6504
6505 fileified = NULL;
6506 ret_buf = buf;
6507 if (ret_buf == NULL) {
6508 if (ts) {
6509 Newx(fileified, VMS_MAXRSS, char);
6510 if (fileified == NULL)
6511 _ckvmssts(SS$_INSFMEM);
6512 ret_buf = fileified;
6513 } else {
6514 ret_buf = __fileify_retbuf;
6515 }
6516 }
6517
6518 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6519
6520 if (ret_spec == NULL) {
6521 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6522 if (fileified)
6523 Safefree(fileified);
6524 }
6525
6526 return ret_spec;
a0d0e21e
LW		 6527} /* end of do_fileify_dirspec() */
6528/*}}}*/
a979ce91 6529
a0d0e21e 6530/* External entry points */
ce12d4b7
CB		 6531char *
6532Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6533{
6534 return do_fileify_dirspec(dir, buf, 0, NULL);
6535}
6536
6537char *
6538Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6539{
6540 return do_fileify_dirspec(dir, buf, 1, NULL);
6541}
6542
6543char *
6544Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6545{
6546 return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6547}
6548
6549char *
6550Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6551{
6552 return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6553}
6554
6555static char *
6556int_pathify_dirspec_simple(const char * dir, char * buf,
1fe570cc
JM		 6557 char * v_spec, int v_len, char * r_spec, int r_len,
6558 char * d_spec, int d_len, char * n_spec, int n_len,
ce12d4b7
CB		 6559 char * e_spec, int e_len, char * vs_spec, int vs_len)
6560{
1fe570cc
JM		 6561
6562 /* VMS specification - Try to do this the simple way */
6563 if ((v_len + r_len > 0) || (d_len > 0)) {
6564 int is_dir;
6565
6566 /* No name or extension component, already a directory */
6567 if ((n_len + e_len + vs_len) == 0) {
6568 strcpy(buf, dir);
6569 return buf;
6570 }
6571
6572 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6573 /* This results from catfile() being used instead of catdir() */
6574 /* So even though it should not work, we need to allow it */
6575
6576 /* If this is .DIR;1 then do a simple conversion */
6577 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6578 if (is_dir || (e_len == 0) && (d_len > 0)) {
6579 int len;
6580 len = v_len + r_len + d_len - 1;
6581 char dclose = d_spec[d_len - 1];
a35dcc95 6582 memcpy(buf, dir, len);
1fe570cc
JM		 6583 buf[len] = '.';
6584 len++;
a35dcc95 6585 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6586 len += n_len;
6587 buf[len] = dclose;
6588 buf[len + 1] = '\0';
6589 return buf;
6590 }
6591
6592#ifdef HAS_SYMLINK
6593 else if (d_len > 0) {
6594 /* In the olden days, a directory needed to have a .DIR */
6595 /* extension to be a valid directory, but now it could */
6596 /* be a symbolic link */
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 if (e_len > 0) {
6606 if (decc_efs_charset) {
07531283
CB		 6607 if (e_len == 4
6608 && (toupper(e_spec[1]) == 'D')
6609 && (toupper(e_spec[2]) == 'I')
6610 && (toupper(e_spec[3]) == 'R')) {
6611
6612 /* Corner case: directory spec with invalid version.
6613 * Valid would have followed is_dir path above.
6614 */
6615 SETERRNO(ENOTDIR, RMS$_DIR);
6616 return NULL;
6617 }
6618 else {
6619 buf[len] = '^';
6620 len++;
6621 memcpy(&buf[len], e_spec, e_len);
6622 len += e_len;
6623 }
6624 }
6625 else {
6626 SETERRNO(ENOTDIR, RMS$_DIR);
1fe570cc
JM		 6627 return NULL;
6628 }
6629 }
6630 buf[len] = dclose;
6631 buf[len + 1] = '\0';
6632 return buf;
6633 }
6634#else
6635 else {
6636 set_vaxc_errno(RMS$_DIR);
6637 set_errno(ENOTDIR);
6638 return NULL;
6639 }
6640#endif
6641 }
6642 set_vaxc_errno(RMS$_DIR);
6643 set_errno(ENOTDIR);
6644 return NULL;
6645}
6646
6647
6648/* Internal routine to make sure or convert a directory to be in a */
6649/* path specification. No utf8 flag because it is not changed or used */
ce12d4b7
CB		 6650static char *
6651int_pathify_dirspec(const char *dir, char *buf)
a0d0e21e 6652{
1fe570cc
JM		 6653 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6654 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6655 char * exp_spec, *ret_spec;
6656 char * trndir;
2d9f3838 6657 unsigned short int trnlnm_iter_count;
baf3cf9c 6658 STRLEN trnlen;
1fe570cc
JM		 6659 int need_to_lower;
6660
6661 if (vms_debug_fileify) {
6662 if (dir == NULL)
6663 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6664 else
6665 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6666 }
6667
6668 /* We may need to lower case the result if we translated */
6669 /* a logical name or got the current working directory */
6670 need_to_lower = 0;
a0d0e21e 6671
c07a80fd 6672 if (!dir || !*dir) {
1fe570cc
JM		 6673 set_errno(EINVAL);
6674 set_vaxc_errno(SS$_BADPARAM);
6675 return NULL;
c07a80fd 6676 }
6677
c11536f5 6678 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6679 if (trndir == NULL)
6680 _ckvmssts_noperl(SS$_INSFMEM);
c07a80fd 6681
1fe570cc
JM		 6682 /* If no directory specified use the current default */
6683 if (*dir)
a35dcc95 6684 my_strlcpy(trndir, dir, VMS_MAXRSS);
1fe570cc
JM		 6685 else {
6686 getcwd(trndir, VMS_MAXRSS - 1);
6687 need_to_lower = 1;
6688 }
6689
6690 /* now deal with bare names that could be logical names */
2d9f3838 6691 trnlnm_iter_count = 0;
93948341 6692 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1fe570cc
JM		 6693 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6694 trnlnm_iter_count++;
6695 need_to_lower = 1;
6696 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6697 break;
6698 trnlen = strlen(trndir);
6699
6700 /* Trap simple rooted lnms, and return lnm:[000000] */
6701 if (!strcmp(trndir+trnlen-2,".]")) {
a35dcc95 6702 my_strlcpy(buf, dir, VMS_MAXRSS);
1fe570cc
JM		 6703 strcat(buf, ":[000000]");
6704 PerlMem_free(trndir);
6705
6706 if (vms_debug_fileify) {
6707 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6708 }
6709 return buf;
6710 }
c07a80fd 6711 }
748a9306 6712
1fe570cc 6713 /* At this point we do not work with *dir, but the copy in *trndir */
b8ffc8df 6714
1fe570cc
JM		 6715 if (need_to_lower && !decc_efs_case_preserve) {
6716 /* Legacy mode, lower case the returned value */
6717 __mystrtolower(trndir);
6718 }
f7ddb74a 6719
1fe570cc
JM		 6720
6721 /* Some special cases, '..', '.' */
6722 sts = 0;
6723 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6724 /* Force UNIX filespec */
6725 sts = 1;
6726
6727 } else {
6728 /* Is this Unix or VMS format? */
6729 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6730 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6731 &e_len, &vs_spec, &vs_len);
6732 if (sts == 0) {
6733
6734 /* Just a filename? */
6735 if ((v_len + r_len + d_len) == 0) {
6736
6737 /* Now we have a problem, this could be Unix or VMS */
6738 /* We have to guess. .DIR usually means VMS */
6739
6740 /* In UNIX report mode, the .DIR extension is removed */
6741 /* if one shows up, it is for a non-directory or a directory */
6742 /* in EFS charset mode */
6743
6744 /* So if we are in Unix report mode, assume that this */
6745 /* is a relative Unix directory specification */
6746
6747 sts = 1;
6748 if (!decc_filename_unix_report && decc_efs_charset) {
6749 int is_dir;
6750 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6751
6752 if (is_dir) {
6753 /* Traditional mode, assume .DIR is directory */
6754 buf[0] = '[';
6755 buf[1] = '.';
a35dcc95 6756 memcpy(&buf[2], n_spec, n_len);
1fe570cc
JM		 6757 buf[n_len + 2] = ']';
6758 buf[n_len + 3] = '\0';
6759 PerlMem_free(trndir);
6760 if (vms_debug_fileify) {
6761 fprintf(stderr,
6762 "int_pathify_dirspec: buf = %s\n",
6763 buf);
6764 }
6765 return buf;
6766 }
6767 }
6768 }
a0d0e21e 6769 }
a0d0e21e 6770 }
1fe570cc
JM		 6771 if (sts == 0) {
6772 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6773 v_spec, v_len, r_spec, r_len,
6774 d_spec, d_len, n_spec, n_len,
6775 e_spec, e_len, vs_spec, vs_len);
a0d0e21e 6776
1fe570cc
JM		 6777 if (ret_spec != NULL) {
6778 PerlMem_free(trndir);
6779 if (vms_debug_fileify) {
6780 fprintf(stderr,
6781 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6782 }
6783 return ret_spec;
b7ae7a0d 6784 }
1fe570cc
JM		 6785
6786 /* Simple way did not work, which means that a logical name */
6787 /* was present for the directory specification. */
6788 /* Need to use an rmsexpand variant to decode it completely */
c11536f5 6789 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6790 if (exp_spec == NULL)
6791 _ckvmssts_noperl(SS$_INSFMEM);
6792
6793 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6794 if (ret_spec != NULL) {
6795 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6796 &r_spec, &r_len, &d_spec, &d_len,
6797 &n_spec, &n_len, &e_spec,
6798 &e_len, &vs_spec, &vs_len);
6799 if (sts == 0) {
6800 ret_spec = int_pathify_dirspec_simple(
6801 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6802 d_spec, d_len, n_spec, n_len,
6803 e_spec, e_len, vs_spec, vs_len);
6804
6805 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6806 /* Legacy mode, lower case the returned value */
6807 __mystrtolower(ret_spec);
6808 }
6809 } else {
6810 set_vaxc_errno(RMS$_DIR);
6811 set_errno(ENOTDIR);
6812 ret_spec = NULL;
6813 }
b7ae7a0d 6814 }
1fe570cc
JM		 6815 PerlMem_free(exp_spec);
6816 PerlMem_free(trndir);
6817 if (vms_debug_fileify) {
6818 if (ret_spec == NULL)
6819 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6820 else
6821 fprintf(stderr,
6822 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6823 }
6824 return ret_spec;
a480973c 6825
1fe570cc 6826 } else {
bd1901c6
CB		 6827 /* Unix specification, Could be trivial conversion, */
6828 /* but have to deal with trailing '.dir' or extra '.' */
1fe570cc 6829
bd1901c6
CB		 6830 char * lastdot;
6831 char * lastslash;
6832 int is_dir;
6833 STRLEN dir_len = strlen(trndir);
1fe570cc 6834
bd1901c6
CB		 6835 lastslash = strrchr(trndir, '/');
6836 if (lastslash == NULL)
6837 lastslash = trndir;
6838 else
6839 lastslash++;
6840
6841 lastdot = NULL;
6842
6843 /* '..' or '.' are valid directory components */
6844 is_dir = 0;
6845 if (lastslash[0] == '.') {
6846 if (lastslash[1] == '\0') {
6847 is_dir = 1;
6848 } else if (lastslash[1] == '.') {
6849 if (lastslash[2] == '\0') {
6850 is_dir = 1;
6851 } else {
6852 /* And finally allow '...' */
6853 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
1fe570cc 6854 is_dir = 1;
1fe570cc
JM		 6855 }
6856 }
6857 }
bd1901c6 6858 }
01b8edb6 6859
bd1901c6
CB		 6860 if (!is_dir) {
6861 lastdot = strrchr(lastslash, '.');
6862 }
6863 if (lastdot != NULL) {
6864 STRLEN e_len;
6865 /* '.dir' is discarded, and any other '.' is invalid */
6866 e_len = strlen(lastdot);
1fe570cc 6867
bd1901c6 6868 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
1fe570cc 6869
bd1901c6
CB		 6870 if (is_dir) {
6871 dir_len = dir_len - 4;
1fe570cc 6872 }
e518068a 6873 }
1fe570cc 6874
a35dcc95 6875 my_strlcpy(buf, trndir, VMS_MAXRSS);
1fe570cc
JM		 6876 if (buf[dir_len - 1] != '/') {
6877 buf[dir_len] = '/';
6878 buf[dir_len + 1] = '\0';
a0d0e21e 6879 }
1fe570cc
JM		 6880
6881 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6882 if (!decc_efs_charset) {
6883 int dir_start = 0;
6884 char * str = buf;
6885 if (str[0] == '.') {
6886 char * dots = str;
6887 int cnt = 1;
6888 while ((dots[cnt] == '.') && (cnt < 3))
6889 cnt++;
6890 if (cnt <= 3) {
6891 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6892 dir_start = 1;
6893 str += cnt;
6894 }
6895 }
6896 }
6897 for (; *str; ++str) {
6898 while (*str == '/') {
6899 dir_start = 1;
6900 *str++;
6901 }
6902 if (dir_start) {
6903
6904 /* Have to skip up to three dots which could be */
6905 /* directories, 3 dots being a VMS extension for Perl */
6906 char * dots = str;
6907 int cnt = 0;
6908 while ((dots[cnt] == '.') && (cnt < 3)) {
6909 cnt++;
6910 }
6911 if (dots[cnt] == '\0')
6912 break;
6913 if ((cnt > 1) && (dots[cnt] != '/')) {
6914 dir_start = 0;
6915 } else {
6916 str += cnt;
6917 }
6918
6919 /* too many dots? */
6920 if ((cnt == 0) || (cnt > 3)) {
6921 dir_start = 0;
6922 }
6923 }
6924 if (!dir_start && (*str == '.')) {
6925 *str = '_';
6926 }
6927 }
e518068a 6928 }
1fe570cc
JM		 6929 PerlMem_free(trndir);
6930 ret_spec = buf;
6931 if (vms_debug_fileify) {
6932 if (ret_spec == NULL)
6933 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6934 else
6935 fprintf(stderr,
6936 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
a0d0e21e 6937 }
1fe570cc
JM		 6938 return ret_spec;
6939 }
6940}
d584a1c6 6941
1fe570cc 6942/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
ce12d4b7
CB		 6943static char *
6944mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
1fe570cc
JM		 6945{
6946 static char __pathify_retbuf[VMS_MAXRSS];
6947 char * pathified, *ret_spec, *ret_buf;
6948
6949 pathified = NULL;
6950 ret_buf = buf;
6951 if (ret_buf == NULL) {
6952 if (ts) {
6953 Newx(pathified, VMS_MAXRSS, char);
6954 if (pathified == NULL)
6955 _ckvmssts(SS$_INSFMEM);
6956 ret_buf = pathified;
6957 } else {
6958 ret_buf = __pathify_retbuf;
6959 }
6960 }
d584a1c6 6961
1fe570cc
JM		 6962 ret_spec = int_pathify_dirspec(dir, ret_buf);
6963
6964 if (ret_spec == NULL) {
6965 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6966 if (pathified)
6967 Safefree(pathified);
a0d0e21e
LW		 6968 }
6969
1fe570cc
JM		 6970 return ret_spec;
6971
a0d0e21e 6972} /* end of do_pathify_dirspec() */
1fe570cc
JM		 6973
6974
a0d0e21e 6975/* External entry points */
ce12d4b7
CB		 6976char *
6977Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6978{
6979 return do_pathify_dirspec(dir, buf, 0, NULL);
6980}
6981
6982char *
6983Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6984{
6985 return do_pathify_dirspec(dir, buf, 1, NULL);
6986}
6987
6988char *
6989Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6990{
6991 return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6992}
6993
6994char *
6995Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6996{
6997 return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6998}
a0d0e21e 6999
0e5ce2c7
JM		 7000/* Internal tounixspec routine that does not use a thread context */
7001/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7002static char *
7003int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
a0d0e21e 7004{
0e5ce2c7 7005 char *dirend, *cp1, *cp3, *tmp;
b8ffc8df 7006 const char *cp2;
4e0c9737 7007 int dirlen;
2d9f3838 7008 unsigned short int trnlnm_iter_count;
b7ac4551 7009 int cmp_rslt, outchars_added;
360732b5
JM		 7010 if (utf8_fl != NULL)
7011 *utf8_fl = 0;
a0d0e21e 7012
0e5ce2c7
JM		 7013 if (vms_debug_fileify) {
7014 if (spec == NULL)
7015 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7016 else
7017 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7018 }
7019
7020
7021 if (spec == NULL) {
7022 set_errno(EINVAL);
7023 set_vaxc_errno(SS$_BADPARAM);
7024 return NULL;
7025 }
7026 if (strlen(spec) > (VMS_MAXRSS-1)) {
7027 set_errno(E2BIG);
7028 set_vaxc_errno(SS$_BUFFEROVF);
7029 return NULL;
e518068a 7030 }
f7ddb74a 7031
2497a41f
JM		 7032 /* New VMS specific format needs translation
7033 * glob passes filenames with trailing '\n' and expects this preserved.
7034 */
7035 if (decc_posix_compliant_pathnames) {
7036 if (strncmp(spec, "\"^UP^", 5) == 0) {
7037 char * uspec;
7038 char *tunix;
7039 int tunix_len;
7040 int nl_flag;
7041
c11536f5 7042 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7043 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 7044 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
2497a41f
JM		 7045 nl_flag = 0;
7046 if (tunix[tunix_len - 1] == '\n') {
7047 tunix[tunix_len - 1] = '\"';
7048 tunix[tunix_len] = '\0';
7049 tunix_len--;
7050 nl_flag = 1;
7051 }
7052 uspec = decc$translate_vms(tunix);
367e4b85 7053 PerlMem_free(tunix);
2497a41f 7054 if ((int)uspec > 0) {
a35dcc95 7055 my_strlcpy(rslt, uspec, VMS_MAXRSS);
2497a41f
JM		 7056 if (nl_flag) {
7057 strcat(rslt,"\n");
7058 }
7059 else {
7060 /* If we can not translate it, makemaker wants as-is */
a35dcc95 7061 my_strlcpy(rslt, spec, VMS_MAXRSS);
2497a41f
JM		 7062 }
7063 return rslt;
7064 }
7065 }
7066 }
7067
f7ddb74a
JM		 7068 cmp_rslt = 0; /* Presume VMS */
7069 cp1 = strchr(spec, '/');
7070 if (cp1 == NULL)
7071 cmp_rslt = 0;
7072
7073 /* Look for EFS ^/ */
7074 if (decc_efs_charset) {
7075 while (cp1 != NULL) {
7076 cp2 = cp1 - 1;
7077 if (*cp2 != '^') {
7078 /* Found illegal VMS, assume UNIX */
7079 cmp_rslt = 1;
7080 break;
7081 }
7082 cp1++;
7083 cp1 = strchr(cp1, '/');
7084 }
7085 }
7086
7087 /* Look for "." and ".." */
7088 if (decc_filename_unix_report) {
7089 if (spec[0] == '.') {
7090 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7091 cmp_rslt = 1;
7092 }
7093 else {
7094 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7095 cmp_rslt = 1;
7096 }
7097 }
7098 }
7099 }
b7ac4551
CB		 7100
7101 cp1 = rslt;
7102 cp2 = spec;
7103
7104 /* This is already UNIX or at least nothing VMS understands,
7105 * so all we can reasonably do is unescape extended chars.
7106 */
f7ddb74a 7107 if (cmp_rslt) {
b7ac4551
CB		 7108 while (*cp2) {
7109 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7110 cp1 += outchars_added;
7111 }
7112 *cp1 = '\0';
0e5ce2c7
JM		 7113 if (vms_debug_fileify) {
7114 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7115 }
a0d0e21e
LW		 7116 return rslt;
7117 }
7118
a0d0e21e
LW		 7119 dirend = strrchr(spec,']');
7120 if (dirend == NULL) dirend = strrchr(spec,'>');
7121 if (dirend == NULL) dirend = strchr(spec,':');
7122 if (dirend == NULL) {
09c9c44c 7123 while (*cp2) {
812e68ff
CB		 7124 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7125 cp1 += outchars_added;
09c9c44c
CB		 7126 }
7127 *cp1 = '\0';
0e5ce2c7
JM		 7128 if (vms_debug_fileify) {
7129 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7130 }
a0d0e21e
LW		 7131 return rslt;
7132 }
f7ddb74a
JM		 7133
7134 /* Special case 1 - sys$posix_root = / */
f7ddb74a
JM		 7135 if (!decc_disable_posix_root) {
7136 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7137 *cp1 = '/';
7138 cp1++;
7139 cp2 = cp2 + 15;
7140 }
7141 }
f7ddb74a
JM		 7142
7143 /* Special case 2 - Convert NLA0: to /dev/null */
f7ddb74a 7144 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
f7ddb74a
JM		 7145 if (cmp_rslt == 0) {
7146 strcpy(rslt, "/dev/null");
7147 cp1 = cp1 + 9;
7148 cp2 = cp2 + 5;
7149 if (spec[6] != '\0') {
07bee079 7150 cp1[9] = '/';
f7ddb74a
JM		 7151 cp1++;
7152 cp2++;
7153 }
7154 }
7155
7156 /* Also handle special case "SYS$SCRATCH:" */
f7ddb74a 7157 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
c11536f5 7158 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7159 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 7160 if (cmp_rslt == 0) {
7161 int islnm;
7162
b8486b9d 7163 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
f7ddb74a
JM		 7164 if (!islnm) {
7165 strcpy(rslt, "/tmp");
7166 cp1 = cp1 + 4;
7167 cp2 = cp2 + 12;
7168 if (spec[12] != '\0') {
07bee079 7169 cp1[4] = '/';
f7ddb74a
JM		 7170 cp1++;
7171 cp2++;
7172 }
7173 }
7174 }
7175
a5f75d66 7176 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 7177 *(cp1++) = '/';
7178 }
7179 else { /* the VMS spec begins with directories */
7180 cp2++;
a5f75d66 7181 if (*cp2 == ']' || *cp2 == '>') {
f401ac15
CB		 7182 *(cp1++) = '.';
7183 *(cp1++) = '/';
a5f75d66 7184 }
f7ddb74a 7185 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 7186 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
367e4b85 7187 PerlMem_free(tmp);
0e5ce2c7
JM		 7188 if (vms_debug_fileify) {
7189 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7190 }
a0d0e21e
LW		 7191 return NULL;
7192 }
2d9f3838 7193 trnlnm_iter_count = 0;
a0d0e21e
LW		 7194 do {
7195 cp3 = tmp;
7196 while (*cp3 != ':' && *cp3) cp3++;
7197 *(cp3++) = '\0';
7198 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 7199 trnlnm_iter_count++;
7200 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 7201 } while (vmstrnenv(tmp,tmp,0,fildev,0));
0e5ce2c7 7202 cp1 = rslt;
f86702cc 7203 cp3 = tmp;
7204 *(cp1++) = '/';
7205 while (*cp3) {
7206 *(cp1++) = *(cp3++);
0e5ce2c7 7207 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
367e4b85 7208 PerlMem_free(tmp);
0e5ce2c7
JM		 7209 set_errno(ENAMETOOLONG);
7210 set_vaxc_errno(SS$_BUFFEROVF);
7211 if (vms_debug_fileify) {
7212 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7213 }
2f4077ca
JM		 7214 return NULL; /* No room */
7215 }
a0d0e21e 7216 }
f86702cc 7217 *(cp1++) = '/';
7218 }
f7ddb74a 7219 if ((*cp2 == '^')) {
812e68ff
CB		 7220 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7221 cp1 += outchars_added;
f7ddb74a 7222 }
f86702cc 7223 else if ( *cp2 == '.') {
7224 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7225 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7226 cp2 += 3;
7227 }
7228 else cp2++;
a0d0e21e 7229 }
a0d0e21e 7230 }
367e4b85 7231 PerlMem_free(tmp);
a0d0e21e 7232 for (; cp2 <= dirend; cp2++) {
f7ddb74a 7233 if ((*cp2 == '^')) {
9b2457c1
CB		 7234 /* EFS file escape -- unescape it. */
7235 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7236 cp1 += outchars_added;
f7ddb74a 7237 }
9b2457c1 7238 else if (*cp2 == ':') {
a0d0e21e 7239 *(cp1++) = '/';
5ad5b34c 7240 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
a0d0e21e 7241 }
f86702cc 7242 else if (*cp2 == ']' || *cp2 == '>') {
7243 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7244 }
f7ddb74a 7245 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 7246 *(cp1++) = '/';
e518068a 7247 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7248 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7249 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7250 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7251 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7252 }
f86702cc 7253 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7254 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7255 cp2 += 2;
7256 }
a0d0e21e
LW		 7257 }
7258 else if (*cp2 == '-') {
7259 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7260 while (*cp2 == '-') {
7261 cp2++;
7262 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7263 }
7264 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
0e5ce2c7 7265 /* filespecs like */
01b8edb6 7266 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
0e5ce2c7
JM		 7267 if (vms_debug_fileify) {
7268 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7269 }
a0d0e21e
LW		 7270 return NULL;
7271 }
a0d0e21e
LW		 7272 }
7273 else *(cp1++) = *cp2;
7274 }
7275 else *(cp1++) = *cp2;
7276 }
0e5ce2c7 7277 /* Translate the rest of the filename. */
42cd432e 7278 while (*cp2) {
b7ac4551 7279 int dot_seen = 0;
0e5ce2c7
JM		 7280 switch(*cp2) {
7281 /* Fixme - for compatibility with the CRTL we should be removing */
7282 /* spaces from the file specifications, but this may show that */
7283 /* some tests that were appearing to pass are not really passing */
7284 case '%':
7285 cp2++;
7286 *(cp1++) = '?';
7287 break;
7288 case '^':
812e68ff
CB		 7289 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7290 cp1 += outchars_added;
0e5ce2c7
JM		 7291 break;
7292 case ';':
7293 if (decc_filename_unix_no_version) {
7294 /* Easy, drop the version */
7295 while (*cp2)
7296 cp2++;
7297 break;
7298 } else {
7299 /* Punt - passing the version as a dot will probably */
7300 /* break perl in weird ways, but so did passing */
7301 /* through the ; as a version. Follow the CRTL and */
7302 /* hope for the best. */
7303 cp2++;
7304 *(cp1++) = '.';
7305 }
7306 break;
7307 case '.':
7308 if (dot_seen) {
7309 /* We will need to fix this properly later */
7310 /* As Perl may be installed on an ODS-5 volume, but not */
7311 /* have the EFS_CHARSET enabled, it still may encounter */
7312 /* filenames with extra dots in them, and a precedent got */
7313 /* set which allowed them to work, that we will uphold here */
7314 /* If extra dots are present in a name and no ^ is on them */
7315 /* VMS assumes that the first one is the extension delimiter */
7316 /* the rest have an implied ^. */
7317
7318 /* this is also a conflict as the . is also a version */
7319 /* delimiter in VMS, */
7320
7321 *(cp1++) = *(cp2++);
7322 break;
7323 }
7324 dot_seen = 1;
7325 /* This is an extension */
7326 if (decc_readdir_dropdotnotype) {
7327 cp2++;
7328 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7329 /* Drop the dot for the extension */
7330 break;
7331 } else {
7332 *(cp1++) = '.';
7333 }
7334 break;
7335 }
7336 default:
7337 *(cp1++) = *(cp2++);
7338 }
42cd432e 7339 }
a0d0e21e
LW		 7340 *cp1 = '\0';
7341
f7ddb74a
JM		 7342 /* This still leaves /000000/ when working with a
7343 * VMS device root or concealed root.
7344 */
7345 {
ce12d4b7
CB		 7346 int ulen;
7347 char * zeros;
f7ddb74a
JM		 7348
7349 ulen = strlen(rslt);
7350
7351 /* Get rid of "000000/ in rooted filespecs */
7352 if (ulen > 7) {
7353 zeros = strstr(rslt, "/000000/");
7354 if (zeros != NULL) {
7355 int mlen;
7356 mlen = ulen - (zeros - rslt) - 7;
7357 memmove(zeros, &zeros[7], mlen);
7358 ulen = ulen - 7;
7359 rslt[ulen] = '\0';
7360 }
7361 }
7362 }
7363
0e5ce2c7
JM		 7364 if (vms_debug_fileify) {
7365 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7366 }
a0d0e21e
LW		 7367 return rslt;
7368
0e5ce2c7
JM		 7369} /* end of int_tounixspec() */
7370
7371
7372/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7373static char *
7374mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
0e5ce2c7
JM		 7375{
7376 static char __tounixspec_retbuf[VMS_MAXRSS];
7377 char * unixspec, *ret_spec, *ret_buf;
7378
7379 unixspec = NULL;
7380 ret_buf = buf;
7381 if (ret_buf == NULL) {
7382 if (ts) {
7383 Newx(unixspec, VMS_MAXRSS, char);
7384 if (unixspec == NULL)
7385 _ckvmssts(SS$_INSFMEM);
7386 ret_buf = unixspec;
7387 } else {
7388 ret_buf = __tounixspec_retbuf;
7389 }
7390 }
7391
7392 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7393
7394 if (ret_spec == NULL) {
7395 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7396 if (unixspec)
7397 Safefree(unixspec);
7398 }
7399
7400 return ret_spec;
7401
a0d0e21e
LW		 7402} /* end of do_tounixspec() */
7403/*}}}*/
7404/* External entry points */
ce12d4b7
CB		 7405char *
7406Perl_tounixspec(pTHX_ const char *spec, char *buf)
7407{
7408 return do_tounixspec(spec, buf, 0, NULL);
7409}
7410
7411char *
7412Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7413{
7414 return do_tounixspec(spec,buf,1, NULL);
7415}
7416
7417char *
7418Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7419{
7420 return do_tounixspec(spec,buf,0, utf8_fl);
7421}
7422
7423char *
7424Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7425{
7426 return do_tounixspec(spec,buf,1, utf8_fl);
7427}
a0d0e21e 7428
360732b5
JM		 7429/*
7430 This procedure is used to identify if a path is based in either
7431 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7432 it returns the OpenVMS format directory for it.
7433
7434 It is expecting specifications of only '/' or '/xxxx/'
7435
7436 If a posix root does not exist, or 'xxxx' is not a directory
7437 in the posix root, it returns a failure.
7438
7439 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7440
7441 It is used only internally by posix_to_vmsspec_hardway().
7442 */
7443
ce12d4b7
CB		 7444static int
7445posix_root_to_vms(char *vmspath, int vmspath_len,
7446 const char *unixpath, const int * utf8_fl)
7447{
7448 int sts;
7449 struct FAB myfab = cc$rms_fab;
7450 rms_setup_nam(mynam);
7451 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7452 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7453 char * esa, * esal, * rsa, * rsal;
7454 int dir_flag;
7455 int unixlen;
7456
7457 dir_flag = 0;
7458 vmspath[0] = '\0';
7459 unixlen = strlen(unixpath);
7460 if (unixlen == 0) {
7461 return RMS$_FNF;
7462 }
360732b5
JM		 7463
7464#if __CRTL_VER >= 80200000
2497a41f 7465 /* If not a posix spec already, convert it */
360732b5
JM		 7466 if (decc_posix_compliant_pathnames) {
7467 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7468 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7469 }
7470 else {
7471 /* This is already a VMS specification, no conversion */
7472 unixlen--;
a35dcc95 7473 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
360732b5 7474 }
2497a41f 7475 }
360732b5
JM		 7476 else
7477#endif
7478 {
ce12d4b7
CB		 7479 int path_len;
7480 int i,j;
360732b5
JM		 7481
7482 /* Check to see if this is under the POSIX root */
7483 if (decc_disable_posix_root) {
7484 return RMS$_FNF;
7485 }
7486
7487 /* Skip leading / */
7488 if (unixpath[0] == '/') {
7489 unixpath++;
7490 unixlen--;
7491 }
7492
7493
7494 strcpy(vmspath,"SYS$POSIX_ROOT:");
7495
7496 /* If this is only the / , or blank, then... */
7497 if (unixpath[0] == '\0') {
7498 /* by definition, this is the answer */
7499 return SS$_NORMAL;
7500 }
7501
7502 /* Need to look up a directory */
7503 vmspath[15] = '[';
7504 vmspath[16] = '\0';
7505
7506 /* Copy and add '^' escape characters as needed */
7507 j = 16;
7508 i = 0;
7509 while (unixpath[i] != 0) {
7510 int k;
7511
7512 j += copy_expand_unix_filename_escape
7513 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7514 i += k;
7515 }
7516
7517 path_len = strlen(vmspath);
7518 if (vmspath[path_len - 1] == '/')
7519 path_len--;
7520 vmspath[path_len] = ']';
7521 path_len++;
7522 vmspath[path_len] = '\0';
7523
2497a41f
JM		 7524 }
7525 vmspath[vmspath_len] = 0;
7526 if (unixpath[unixlen - 1] == '/')
7527 dir_flag = 1;
c11536f5 7528 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7529 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7530 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 7531 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7532 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7533 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7534 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
d584a1c6
JM		 7535 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7536 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7537 rms_bind_fab_nam(myfab, mynam);
7538 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7539 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 7540 if (decc_efs_case_preserve)
7541 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 7542#ifdef NAML$M_OPEN_SPECIAL
2497a41f 7543 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 7544#endif
2497a41f
JM		 7545
7546 /* Set up the remaining naml fields */
7547 sts = sys$parse(&myfab);
7548
7549 /* It failed! Try again as a UNIX filespec */
7550 if (!(sts & 1)) {
d584a1c6 7551 PerlMem_free(esal);
367e4b85 7552 PerlMem_free(esa);
d584a1c6
JM		 7553 PerlMem_free(rsal);
7554 PerlMem_free(rsa);
2497a41f
JM		 7555 return sts;
7556 }
7557
7558 /* get the Device ID and the FID */
7559 sts = sys$search(&myfab);
d584a1c6
JM		 7560
7561 /* These are no longer needed */
7562 PerlMem_free(esa);
7563 PerlMem_free(rsal);
7564 PerlMem_free(rsa);
7565
2497a41f
JM		 7566 /* on any failure, returned the POSIX ^UP^ filespec */
7567 if (!(sts & 1)) {
d584a1c6 7568 PerlMem_free(esal);
2497a41f
JM		 7569 return sts;
7570 }
7571 specdsc.dsc$a_pointer = vmspath;
7572 specdsc.dsc$w_length = vmspath_len;
7573
7574 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7575 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7576 sts = lib$fid_to_name
7577 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7578
7579 /* on any failure, returned the POSIX ^UP^ filespec */
7580 if (!(sts & 1)) {
7581 /* This can happen if user does not have permission to read directories */
7582 if (strncmp(unixpath,"\"^UP^",5) != 0)
7583 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7584 else
a35dcc95 7585 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
2497a41f
JM		 7586 }
7587 else {
7588 vmspath[specdsc.dsc$w_length] = 0;
7589
7590 /* Are we expecting a directory? */
7591 if (dir_flag != 0) {
7592 int i;
7593 char *eptr;
7594
7595 eptr = NULL;
7596
7597 i = specdsc.dsc$w_length - 1;
7598 while (i > 0) {
7599 int zercnt;
7600 zercnt = 0;
7601 /* Version must be '1' */
7602 if (vmspath[i--] != '1')
7603 break;
7604 /* Version delimiter is one of ".;" */
7605 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7606 break;
7607 i--;
7608 if (vmspath[i--] != 'R')
7609 break;
7610 if (vmspath[i--] != 'I')
7611 break;
7612 if (vmspath[i--] != 'D')
7613 break;
7614 if (vmspath[i--] != '.')
7615 break;
7616 eptr = &vmspath[i+1];
7617 while (i > 0) {
7618 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7619 if (vmspath[i-1] != '^') {
7620 if (zercnt != 6) {
7621 *eptr = vmspath[i];
7622 eptr[1] = '\0';
7623 vmspath[i] = '.';
7624 break;
7625 }
7626 else {
7627 /* Get rid of 6 imaginary zero directory filename */
7628 vmspath[i+1] = '\0';
7629 }
7630 }
7631 }
7632 if (vmspath[i] == '0')
7633 zercnt++;
7634 else
7635 zercnt = 10;
7636 i--;
7637 }
7638 break;
7639 }
7640 }
7641 }
d584a1c6 7642 PerlMem_free(esal);
2497a41f
JM		 7643 return sts;
7644}
7645
360732b5
JM		 7646/* /dev/mumble needs to be handled special.
7647 /dev/null becomes NLA0:, And there is the potential for other stuff
7648 like /dev/tty which may need to be mapped to something.
7649*/
7650
7651static int
ce12d4b7 7652slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
360732b5 7653{
ce12d4b7
CB		 7654 char * nextslash;
7655 int len;
7656 int cmp;
360732b5
JM		 7657
7658 unixptr += 4;
7659 nextslash = strchr(unixptr, '/');
7660 len = strlen(unixptr);
7661 if (nextslash != NULL)
7662 len = nextslash - unixptr;
7663 cmp = strncmp("null", unixptr, 5);
7664 if (cmp == 0) {
7665 if (vmspath_len >= 6) {
7666 strcpy(vmspath, "_NLA0:");
7667 return SS$_NORMAL;
7668 }
7669 }
c5193628 7670 return 0;
360732b5
JM		 7671}
7672
7673
7674/* The built in routines do not understand perl's special needs, so
7675 doing a manual conversion from UNIX to VMS
7676
7677 If the utf8_fl is not null and points to a non-zero value, then
7678 treat 8 bit characters as UTF-8.
7679
7680 The sequence starting with '$(' and ending with ')' will be passed
7681 through with out interpretation instead of being escaped.
7682
7683 */
ce12d4b7
CB		 7684static int
7685posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7686 int dir_flag, int * utf8_fl)
7687{
7688
7689 char *esa;
7690 const char *unixptr;
7691 const char *unixend;
7692 char *vmsptr;
7693 const char *lastslash;
7694 const char *lastdot;
7695 int unixlen;
7696 int vmslen;
7697 int dir_start;
7698 int dir_dot;
7699 int quoted;
7700 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7701 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7702
360732b5
JM		 7703 if (utf8_fl != NULL)
7704 *utf8_fl = 0;
2497a41f
JM		 7705
7706 unixptr = unixpath;
7707 dir_dot = 0;
7708
7709 /* Ignore leading "/" characters */
7710 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7711 unixptr++;
7712 }
7713 unixlen = strlen(unixptr);
7714
7715 /* Do nothing with blank paths */
7716 if (unixlen == 0) {
7717 vmspath[0] = '\0';
7718 return SS$_NORMAL;
7719 }
7720
360732b5
JM		 7721 quoted = 0;
7722 /* This could have a "^UP^ on the front */
7723 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7724 quoted = 1;
7725 unixptr+= 5;
7726 unixlen-= 5;
7727 }
7728
2497a41f
JM		 7729 lastslash = strrchr(unixptr,'/');
7730 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7731 unixend = strrchr(unixptr,'\"');
7732 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7733 unixend = unixptr + unixlen;
7734 }
2497a41f
JM		 7735
7736 /* last dot is last dot or past end of string */
7737 if (lastdot == NULL)
7738 lastdot = unixptr + unixlen;
7739
7740 /* if no directories, set last slash to beginning of string */
7741 if (lastslash == NULL) {
7742 lastslash = unixptr;
7743 }
7744 else {
7745 /* Watch out for trailing "." after last slash, still a directory */
7746 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7747 lastslash = unixptr + unixlen;
7748 }
7749
94ae10c0 7750 /* Watch out for trailing ".." after last slash, still a directory */
2497a41f
JM		 7751 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7752 lastslash = unixptr + unixlen;
7753 }
7754
7755 /* dots in directories are aways escaped */
7756 if (lastdot < lastslash)
7757 lastdot = unixptr + unixlen;
7758 }
7759
7760 /* if (unixptr < lastslash) then we are in a directory */
7761
7762 dir_start = 0;
2497a41f
JM		 7763
7764 vmsptr = vmspath;
7765 vmslen = 0;
7766
2497a41f
JM		 7767 /* Start with the UNIX path */
7768 if (*unixptr != '/') {
7769 /* relative paths */
360732b5
JM		 7770
7771 /* If allowing logical names on relative pathnames, then handle here */
7772 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7773 !decc_posix_compliant_pathnames) {
7774 char * nextslash;
7775 int seg_len;
7776 char * trn;
7777 int islnm;
7778
7779 /* Find the next slash */
7780 nextslash = strchr(unixptr,'/');
7781
c11536f5 7782 esa = (char *)PerlMem_malloc(vmspath_len);
360732b5
JM		 7783 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7784
c11536f5 7785 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
360732b5
JM		 7786 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7787
7788 if (nextslash != NULL) {
7789
7790 seg_len = nextslash - unixptr;
a35dcc95 7791 memcpy(esa, unixptr, seg_len);
360732b5
JM		 7792 esa[seg_len] = 0;
7793 }
7794 else {
a35dcc95 7795 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
360732b5
JM		 7796 }
7797 /* trnlnm(section) */
7798 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7799
7800 if (islnm) {
7801 /* Now fix up the directory */
7802
7803 /* Split up the path to find the components */
7804 sts = vms_split_path
7805 (trn,
7806 &v_spec,
7807 &v_len,
7808 &r_spec,
7809 &r_len,
7810 &d_spec,
7811 &d_len,
7812 &n_spec,
7813 &n_len,
7814 &e_spec,
7815 &e_len,
7816 &vs_spec,
7817 &vs_len);
7818
7819 while (sts == 0) {
360732b5
JM		 7820 int cmp;
7821
7822 /* A logical name must be a directory or the full
7823 specification. It is only a full specification if
7824 it is the only component */
7825 if ((unixptr[seg_len] == '\0') ||
7826 (unixptr[seg_len+1] == '\0')) {
7827
7828 /* Is a directory being required? */
7829 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7830 /* Not a logical name */
7831 break;
7832 }
7833
7834
7835 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7836 /* This must be a directory */
7837 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
a35dcc95 7838 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
360732b5
JM		 7839 vmsptr[vmslen] = ':';
7840 vmslen++;
7841 vmsptr[vmslen] = '\0';
7842 return SS$_NORMAL;
7843 }
7844 }
7845
7846 }
7847
7848
7849 /* must be dev/directory - ignore version */
7850 if ((n_len + e_len) != 0)
7851 break;
7852
7853 /* transfer the volume */
7854 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
a35dcc95 7855 memcpy(vmsptr, v_spec, v_len);
360732b5
JM		 7856 vmsptr += v_len;
7857 vmsptr[0] = '\0';
7858 vmslen += v_len;
7859 }
7860
7861 /* unroot the rooted directory */
7862 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7863 r_spec[0] = '[';
7864 r_spec[r_len - 1] = ']';
7865
7866 /* This should not be there, but nothing is perfect */
7867 if (r_len > 9) {
7868 cmp = strcmp(&r_spec[1], "000000.");
7869 if (cmp == 0) {
7870 r_spec += 7;
7871 r_spec[7] = '[';
7872 r_len -= 7;
7873 if (r_len == 2)
7874 r_len = 0;
7875 }
7876 }
7877 if (r_len > 0) {
a35dcc95 7878 memcpy(vmsptr, r_spec, r_len);
360732b5
JM		 7879 vmsptr += r_len;
7880 vmslen += r_len;
7881 vmsptr[0] = '\0';
7882 }
7883 }
7884 /* Bring over the directory. */
7885 if ((d_len > 0) &&
7886 ((d_len + vmslen) < vmspath_len)) {
7887 d_spec[0] = '[';
7888 d_spec[d_len - 1] = ']';
7889 if (d_len > 9) {
7890 cmp = strcmp(&d_spec[1], "000000.");
7891 if (cmp == 0) {
7892 d_spec += 7;
7893 d_spec[7] = '[';
7894 d_len -= 7;
7895 if (d_len == 2)
7896 d_len = 0;
7897 }
7898 }
7899
7900 if (r_len > 0) {
7901 /* Remove the redundant root */
7902 if (r_len > 0) {
7903 /* remove the ][ */
7904 vmsptr--;
7905 vmslen--;
7906 d_spec++;
7907 d_len--;
7908 }
a35dcc95 7909 memcpy(vmsptr, d_spec, d_len);
360732b5
JM		 7910 vmsptr += d_len;
7911 vmslen += d_len;
7912 vmsptr[0] = '\0';
7913 }
7914 }
7915 break;
7916 }
7917 }
7918
7919 PerlMem_free(esa);
7920 PerlMem_free(trn);
7921 }
7922
2497a41f
JM		 7923 if (lastslash > unixptr) {
7924 int dotdir_seen;
7925
7926 /* skip leading ./ */
7927 dotdir_seen = 0;
7928 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7929 dotdir_seen = 1;
7930 unixptr++;
7931 unixptr++;
7932 }
7933
7934 /* Are we still in a directory? */
7935 if (unixptr <= lastslash) {
7936 *vmsptr++ = '[';
7937 vmslen = 1;
7938 dir_start = 1;
7939
7940 /* if not backing up, then it is relative forward. */
7941 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7942 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7943 *vmsptr++ = '.';
7944 vmslen++;
7945 dir_dot = 1;
360732b5 7946 }
2497a41f
JM		 7947 }
7948 else {
7949 if (dotdir_seen) {
7950 /* Perl wants an empty directory here to tell the difference
94ae10c0 7951 * between a DCL command and a filename
2497a41f
JM		 7952 */
7953 *vmsptr++ = '[';
7954 *vmsptr++ = ']';
7955 vmslen = 2;
7956 }
7957 }
7958 }
7959 else {
7960 /* Handle two special files . and .. */
7961 if (unixptr[0] == '.') {
360732b5 7962 if (&unixptr[1] == unixend) {
2497a41f
JM		 7963 *vmsptr++ = '[';
7964 *vmsptr++ = ']';
7965 vmslen += 2;
7966 *vmsptr++ = '\0';
7967 return SS$_NORMAL;
7968 }
360732b5 7969 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7970 *vmsptr++ = '[';
7971 *vmsptr++ = '-';
7972 *vmsptr++ = ']';
7973 vmslen += 3;
7974 *vmsptr++ = '\0';
7975 return SS$_NORMAL;
7976 }
7977 }
7978 }
7979 }
7980 else { /* Absolute PATH handling */
7981 int sts;
7982 char * nextslash;
7983 int seg_len;
7984 /* Need to find out where root is */
7985
7986 /* In theory, this procedure should never get an absolute POSIX pathname
7987 * that can not be found on the POSIX root.
7988 * In practice, that can not be relied on, and things will show up
7989 * here that are a VMS device name or concealed logical name instead.
7990 * So to make things work, this procedure must be tolerant.
7991 */
c11536f5 7992 esa = (char *)PerlMem_malloc(vmspath_len);
c5375c28 7993 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7994
7995 sts = SS$_NORMAL;
7996 nextslash = strchr(&unixptr[1],'/');
7997 seg_len = 0;
7998 if (nextslash != NULL) {
db4c2905 7999 int cmp;
2497a41f 8000 seg_len = nextslash - &unixptr[1];
db4c2905 8001 my_strlcpy(vmspath, unixptr, seg_len + 2);
360732b5
JM		 8002 cmp = 1;
8003 if (seg_len == 3) {
8004 cmp = strncmp(vmspath, "dev", 4);
8005 if (cmp == 0) {
8006 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
07bee079 8007 if (sts == SS$_NORMAL)
360732b5
JM		 8008 return SS$_NORMAL;
8009 }
8010 }
8011 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 8012 }
8013
360732b5 8014 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 8015 /* This is verified to be a real path */
8016
360732b5
JM		 8017 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8018 if ($VMS_STATUS_SUCCESS(sts)) {
a35dcc95 8019 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
360732b5
JM		 8020 vmsptr = vmspath + vmslen;
8021 unixptr++;
8022 if (unixptr < lastslash) {
8023 char * rptr;
8024 vmsptr--;
8025 *vmsptr++ = '.';
8026 dir_start = 1;
8027 dir_dot = 1;
8028 if (vmslen > 7) {
8029 int cmp;
8030 rptr = vmsptr - 7;
8031 cmp = strcmp(rptr,"000000.");
8032 if (cmp == 0) {
8033 vmslen -= 7;
8034 vmsptr -= 7;
8035 vmsptr[1] = '\0';
8036 } /* removing 6 zeros */
8037 } /* vmslen < 7, no 6 zeros possible */
8038 } /* Not in a directory */
8039 } /* Posix root found */
8040 else {
8041 /* No posix root, fall back to default directory */
8042 strcpy(vmspath, "SYS$DISK:[");
8043 vmsptr = &vmspath[10];
8044 vmslen = 10;
8045 if (unixptr > lastslash) {
8046 *vmsptr = ']';
8047 vmsptr++;
8048 vmslen++;
8049 }
8050 else {
8051 dir_start = 1;
8052 }
8053 }
2497a41f
JM		 8054 } /* end of verified real path handling */
8055 else {
8056 int add_6zero;
8057 int islnm;
8058
8059 /* Ok, we have a device or a concealed root that is not in POSIX
8060 * or we have garbage. Make the best of it.
8061 */
8062
8063 /* Posix to VMS destroyed this, so copy it again */
db4c2905
CB		 8064 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8065 vmslen = strlen(vmspath); /* We know we're truncating. */
2497a41f
JM		 8066 vmsptr = &vmsptr[vmslen];
8067 islnm = 0;
8068
8069 /* Now do we need to add the fake 6 zero directory to it? */
8070 add_6zero = 1;
8071 if ((*lastslash == '/') && (nextslash < lastslash)) {
8072 /* No there is another directory */
8073 add_6zero = 0;
8074 }
8075 else {
8076 int trnend;
360732b5 8077 int cmp;
2497a41f
JM		 8078
8079 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 8080 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 8081
8082 if (!islnm && !decc_posix_compliant_pathnames) {
8083
8084 cmp = strncmp("bin", vmspath, 4);
8085 if (cmp == 0) {
8086 /* bin => SYS$SYSTEM: */
8087 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8088 }
8089 else {
8090 /* tmp => SYS$SCRATCH: */
8091 cmp = strncmp("tmp", vmspath, 4);
8092 if (cmp == 0) {
8093 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8094 }
8095 }
8096 }
8097
7ded3206 8098 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 8099
8100 /* if this was a logical name, ']' or '>' must be present */
8101 /* if not a logical name, then assume a device and hope. */
8102 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8103
8104 /* if log name and trailing '.' then rooted - treat as device */
8105 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8106
8107 /* Fix me, if not a logical name, a device lookup should be
8108 * done to see if the device is file structured. If the device
8109 * is not file structured, the 6 zeros should not be put on.
8110 *
8111 * As it is, perl is occasionally looking for dev:[000000]tty.
8112 * which looks a little strange.
360732b5
JM		 8113 *
8114 * Not that easy to detect as "/dev" may be file structured with
8115 * special device files.
2497a41f
JM		 8116 */
8117
30e68285 8118 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
360732b5 8119 (&nextslash[1] == unixend)) {
2497a41f
JM		 8120 /* No real directory present */
8121 add_6zero = 1;
8122 }
8123 }
8124
8125 /* Put the device delimiter on */
8126 *vmsptr++ = ':';
8127 vmslen++;
8128 unixptr = nextslash;
8129 unixptr++;
8130
8131 /* Start directory if needed */
8132 if (!islnm || add_6zero) {
8133 *vmsptr++ = '[';
8134 vmslen++;
8135 dir_start = 1;
8136 }
8137
8138 /* add fake 000000] if needed */
8139 if (add_6zero) {
8140 *vmsptr++ = '0';
8141 *vmsptr++ = '0';
8142 *vmsptr++ = '0';
8143 *vmsptr++ = '0';
8144 *vmsptr++ = '0';
8145 *vmsptr++ = '0';
8146 *vmsptr++ = ']';
8147 vmslen += 7;
8148 dir_start = 0;
8149 }
8150
8151 } /* non-POSIX translation */
367e4b85 8152 PerlMem_free(esa);
2497a41f
JM		 8153 } /* End of relative/absolute path handling */
8154
360732b5 8155 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
ce12d4b7
CB		 8156 int dash_flag;
8157 int in_cnt;
8158 int out_cnt;
2497a41f
JM		 8159
8160 dash_flag = 0;
8161
8162 if (dir_start != 0) {
8163
8164 /* First characters in a directory are handled special */
8165 while ((*unixptr == '/') ||
8166 ((*unixptr == '.') &&
360732b5
JM		 8167 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8168 (&unixptr[1]==unixend)))) {
2497a41f
JM		 8169 int loop_flag;
8170
8171 loop_flag = 0;
8172
8173 /* Skip redundant / in specification */
8174 while ((*unixptr == '/') && (dir_start != 0)) {
8175 loop_flag = 1;
8176 unixptr++;
8177 if (unixptr == lastslash)
8178 break;
8179 }
8180 if (unixptr == lastslash)
8181 break;
8182
8183 /* Skip redundant ./ characters */
8184 while ((*unixptr == '.') &&
360732b5 8185 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 8186 loop_flag = 1;
8187 unixptr++;
8188 if (unixptr == lastslash)
8189 break;
8190 if (*unixptr == '/')
8191 unixptr++;
8192 }
8193 if (unixptr == lastslash)
8194 break;
8195
8196 /* Skip redundant ../ characters */
8197 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 8198 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 8199 /* Set the backing up flag */
8200 loop_flag = 1;
8201 dir_dot = 0;
8202 dash_flag = 1;
8203 *vmsptr++ = '-';
8204 vmslen++;
8205 unixptr++; /* first . */
8206 unixptr++; /* second . */
8207 if (unixptr == lastslash)
8208 break;
8209 if (*unixptr == '/') /* The slash */
8210 unixptr++;
8211 }
8212 if (unixptr == lastslash)
8213 break;
8214
8215 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8216 /* Not needed when VMS is pretending to be UNIX. */
8217
8218 /* Is this loop stuck because of too many dots? */
8219 if (loop_flag == 0) {
8220 /* Exit the loop and pass the rest through */
8221 break;
8222 }
8223 }
8224
8225 /* Are we done with directories yet? */
8226 if (unixptr >= lastslash) {
8227
8228 /* Watch out for trailing dots */
8229 if (dir_dot != 0) {
8230 vmslen --;
8231 vmsptr--;
8232 }
8233 *vmsptr++ = ']';
8234 vmslen++;
8235 dash_flag = 0;
8236 dir_start = 0;
8237 if (*unixptr == '/')
8238 unixptr++;
8239 }
8240 else {
8241 /* Have we stopped backing up? */
8242 if (dash_flag) {
8243 *vmsptr++ = '.';
8244 vmslen++;
8245 dash_flag = 0;
8246 /* dir_start continues to be = 1 */
8247 }
8248 if (*unixptr == '-') {
8249 *vmsptr++ = '^';
8250 *vmsptr++ = *unixptr++;
8251 vmslen += 2;
8252 dir_start = 0;
8253
8254 /* Now are we done with directories yet? */
8255 if (unixptr >= lastslash) {
8256
8257 /* Watch out for trailing dots */
8258 if (dir_dot != 0) {
8259 vmslen --;
8260 vmsptr--;
8261 }
8262
8263 *vmsptr++ = ']';
8264 vmslen++;
8265 dash_flag = 0;
8266 dir_start = 0;
8267 }
8268 }
8269 }
8270 }
8271
8272 /* All done? */
360732b5 8273 if (unixptr >= unixend)
2497a41f
JM		 8274 break;
8275
8276 /* Normal characters - More EFS work probably needed */
8277 dir_start = 0;
8278 dir_dot = 0;
8279
8280 switch(*unixptr) {
8281 case '/':
8282 /* remove multiple / */
8283 while (unixptr[1] == '/') {
8284 unixptr++;
8285 }
8286 if (unixptr == lastslash) {
8287 /* Watch out for trailing dots */
8288 if (dir_dot != 0) {
8289 vmslen --;
8290 vmsptr--;
8291 }
8292 *vmsptr++ = ']';
8293 }
8294 else {
8295 dir_start = 1;
8296 *vmsptr++ = '.';
8297 dir_dot = 1;
8298
8299 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8300 /* Not needed when VMS is pretending to be UNIX. */
8301
8302 }
8303 dash_flag = 0;
360732b5 8304 if (unixptr != unixend)
2497a41f
JM		 8305 unixptr++;
8306 vmslen++;
8307 break;
2497a41f 8308 case '.':
360732b5
JM		 8309 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8310 (&unixptr[1] == unixend)) {
2497a41f
JM		 8311 *vmsptr++ = '^';
8312 *vmsptr++ = '.';
8313 vmslen += 2;
8314 unixptr++;
8315
8316 /* trailing dot ==> '^..' on VMS */
360732b5 8317 if (unixptr == unixend) {
2497a41f
JM		 8318 *vmsptr++ = '.';
8319 vmslen++;
360732b5 8320 unixptr++;
2497a41f 8321 }
2497a41f
JM		 8322 break;
8323 }
360732b5 8324
2497a41f 8325 *vmsptr++ = *unixptr++;
360732b5
JM		 8326 vmslen ++;
8327 break;
8328 case '"':
8329 if (quoted && (&unixptr[1] == unixend)) {
8330 unixptr++;
8331 break;
8332 }
8333 in_cnt = copy_expand_unix_filename_escape
8334 (vmsptr, unixptr, &out_cnt, utf8_fl);
8335 vmsptr += out_cnt;
8336 unixptr += in_cnt;
2497a41f
JM		 8337 break;
8338 case '~':
8339 case ';':
8340 case '\\':
360732b5
JM		 8341 case '?':
8342 case ' ':
2497a41f 8343 default:
360732b5
JM		 8344 in_cnt = copy_expand_unix_filename_escape
8345 (vmsptr, unixptr, &out_cnt, utf8_fl);
8346 vmsptr += out_cnt;
8347 unixptr += in_cnt;
2497a41f
JM		 8348 break;
8349 }
8350 }
8351
8352 /* Make sure directory is closed */
8353 if (unixptr == lastslash) {
8354 char *vmsptr2;
8355 vmsptr2 = vmsptr - 1;
8356
8357 if (*vmsptr2 != ']') {
8358 *vmsptr2--;
8359
8360 /* directories do not end in a dot bracket */
8361 if (*vmsptr2 == '.') {
8362 vmsptr2--;
8363
8364 /* ^. is allowed */
8365 if (*vmsptr2 != '^') {
8366 vmsptr--; /* back up over the dot */
8367 }
8368 }
8369 *vmsptr++ = ']';
8370 }
8371 }
8372 else {
8373 char *vmsptr2;
8374 /* Add a trailing dot if a file with no extension */
8375 vmsptr2 = vmsptr - 1;
360732b5
JM		 8376 if ((vmslen > 1) &&
8377 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
30e68285 8378 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
2497a41f
JM		 8379 *vmsptr++ = '.';
8380 vmslen++;
8381 }
8382 }
8383
8384 *vmsptr = '\0';
8385 return SS$_NORMAL;
8386}
2497a41f 8387
b7bc7afb
CB		 8388/* A convenience macro for copying dots in filenames and escaping
8389 * them when they haven't already been escaped, with guards to
8390 * avoid checking before the start of the buffer or advancing
8391 * beyond the end of it (allowing room for the NUL terminator).
c1abd561 8392 */
b7bc7afb 8393#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
c1abd561
CB		 8394 if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8395 || ((vmsefsdot) == (vmsefsbuf))) \
b7bc7afb 8396 && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
c1abd561
CB		 8397 ) { \
8398 *((vmsefsdot)++) = '^'; \
c1abd561 8399 } \
b7bc7afb
CB		 8400 if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8401 *((vmsefsdot)++) = '.'; \
c1abd561 8402} STMT_END
df278665 8403
360732b5 8404/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8405static char *
8406int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8407{
df278665 8408 char *dirend;
f7ddb74a 8409 char *lastdot;
eb578fdb 8410 char *cp1;
b8ffc8df 8411 const char *cp2;
e518068a 8412 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 8413 int rslt_len;
8414 int no_type_seen;
360732b5
JM		 8415 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8416 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 8417
df278665
JM		 8418 if (vms_debug_fileify) {
8419 if (path == NULL)
8420 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8421 else
8422 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8423 }
8424
8425 if (path == NULL) {
8426 /* If we fail, we should be setting errno */
8427 set_errno(EINVAL);
8428 set_vaxc_errno(SS$_BADPARAM);
8429 return NULL;
8430 }
4d743a9b 8431 rslt_len = VMS_MAXRSS-1;
360732b5
JM		 8432
8433 /* '.' and '..' are "[]" and "[-]" for a quick check */
8434 if (path[0] == '.') {
8435 if (path[1] == '\0') {
8436 strcpy(rslt,"[]");
8437 if (utf8_flag != NULL)
8438 *utf8_flag = 0;
8439 return rslt;
8440 }
8441 else {
8442 if (path[1] == '.' && path[2] == '\0') {
8443 strcpy(rslt,"[-]");
8444 if (utf8_flag != NULL)
8445 *utf8_flag = 0;
8446 return rslt;
8447 }
8448 }
a0d0e21e 8449 }
f7ddb74a 8450
2497a41f
JM		 8451 /* Posix specifications are now a native VMS format */
8452 /*--------------------------------------------------*/
054a3baf 8453#if __CRTL_VER >= 80200000
2497a41f
JM		 8454 if (decc_posix_compliant_pathnames) {
8455 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 8456 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 8457 return rslt;
8458 }
8459 }
8460#endif
8461
360732b5
JM		 8462 /* This is really the only way to see if this is already in VMS format */
8463 sts = vms_split_path
8464 (path,
8465 &v_spec,
8466 &v_len,
8467 &r_spec,
8468 &r_len,
8469 &d_spec,
8470 &d_len,
8471 &n_spec,
8472 &n_len,
8473 &e_spec,
8474 &e_len,
8475 &vs_spec,
8476 &vs_len);
8477 if (sts == 0) {
8478 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8479 replacement, because the above parse just took care of most of
8480 what is needed to do vmspath when the specification is already
8481 in VMS format.
8482
8483 And if it is not already, it is easier to do the conversion as
8484 part of this routine than to call this routine and then work on
8485 the result.
8486 */
2497a41f 8487
360732b5
JM		 8488 /* If VMS punctuation was found, it is already VMS format */
8489 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8490 if (utf8_flag != NULL)
8491 *utf8_flag = 0;
a35dcc95 8492 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8493 if (vms_debug_fileify) {
8494 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8495 }
360732b5
JM		 8496 return rslt;
8497 }
8498 /* Now, what to do with trailing "." cases where there is no
8499 extension? If this is a UNIX specification, and EFS characters
8500 are enabled, then the trailing "." should be converted to a "^.".
8501 But if this was already a VMS specification, then it should be
8502 left alone.
2497a41f 8503
360732b5
JM		 8504 So in the case of ambiguity, leave the specification alone.
8505 */
2497a41f 8506
2497a41f 8507
360732b5
JM		 8508 /* If there is a possibility of UTF8, then if any UTF8 characters
8509 are present, then they must be converted to VTF-7
8510 */
8511 if (utf8_flag != NULL)
8512 *utf8_flag = 0;
a35dcc95 8513 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8514 if (vms_debug_fileify) {
8515 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8516 }
2497a41f
JM		 8517 return rslt;
8518 }
8519
360732b5
JM		 8520 dirend = strrchr(path,'/');
8521
8522 if (dirend == NULL) {
db2284bc
CB		 8523 /* If we get here with no Unix directory delimiters, then this is an
8524 * ambiguous file specification, such as a Unix glob specification, a
8525 * shell or make macro, or a filespec that would be valid except for
8526 * unescaped extended characters. The safest thing if it's a macro
8527 * is to pass it through as-is.
360732b5 8528 */
db2284bc
CB		 8529 if (strstr(path, "$(")) {
8530 my_strlcpy(rslt, path, VMS_MAXRSS);
8531 if (vms_debug_fileify) {
8532 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8533 }
8534 return rslt;
df278665 8535 }
db2284bc 8536 hasdir = 0;
360732b5 8537 }
e645f6f8 8538 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 8539 if (!*(dirend+2)) dirend +=2;
8540 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
06099f79 8541 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 8542 }
f7ddb74a 8543
a0d0e21e
LW		 8544 cp1 = rslt;
8545 cp2 = path;
f7ddb74a 8546 lastdot = strrchr(cp2,'.');
a0d0e21e 8547 if (*cp2 == '/') {
a480973c 8548 char *trndev;
e518068a 8549 int islnm, rooted;
8550 STRLEN trnend;
8551
b7ae7a0d 8552 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 8553 if (!*(cp2+1)) {
f7ddb74a
JM		 8554 if (decc_disable_posix_root) {
8555 strcpy(rslt,"sys$disk:[000000]");
8556 }
8557 else {
8558 strcpy(rslt,"sys$posix_root:[000000]");
8559 }
360732b5
JM		 8560 if (utf8_flag != NULL)
8561 *utf8_flag = 0;
df278665
JM		 8562 if (vms_debug_fileify) {
8563 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8564 }
61bb5906
CB		 8565 return rslt;
8566 }
a0d0e21e 8567 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 8568 *cp1 = '\0';
c11536f5 8569 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 8570 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
b8486b9d 8571 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8572
8573 /* DECC special handling */
8574 if (!islnm) {
8575 if (strcmp(rslt,"bin") == 0) {
8576 strcpy(rslt,"sys$system");
8577 cp1 = rslt + 10;
8578 *cp1 = 0;
b8486b9d 8579 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8580 }
8581 else if (strcmp(rslt,"tmp") == 0) {
8582 strcpy(rslt,"sys$scratch");
8583 cp1 = rslt + 11;
8584 *cp1 = 0;
b8486b9d 8585 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8586 }
8587 else if (!decc_disable_posix_root) {
8588 strcpy(rslt, "sys$posix_root");
b8486b9d 8589 cp1 = rslt + 14;
f7ddb74a
JM		 8590 *cp1 = 0;
8591 cp2 = path;
8592 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
b8486b9d 8593 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8594 }
8595 else if (strcmp(rslt,"dev") == 0) {
8596 if (strncmp(cp2,"/null", 5) == 0) {
8597 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8598 strcpy(rslt,"NLA0");
8599 cp1 = rslt + 4;
8600 *cp1 = 0;
8601 cp2 = cp2 + 5;
b8486b9d 8602 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8603 }
8604 }
8605 }
8606 }
8607
e518068a 8608 trnend = islnm ? strlen(trndev) - 1 : 0;
8609 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8610 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8611 /* If the first element of the path is a logical name, determine
8612 * whether it has to be translated so we can add more directories. */
8613 if (!islnm || rooted) {
8614 *(cp1++) = ':';
8615 *(cp1++) = '[';
8616 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8617 else cp2++;
8618 }
8619 else {
8620 if (cp2 != dirend) {
a35dcc95 8621 my_strlcpy(rslt, trndev, VMS_MAXRSS);
e518068a 8622 cp1 = rslt + trnend;
755b3d5d
JM		 8623 if (*cp2 != 0) {
8624 *(cp1++) = '.';
8625 cp2++;
8626 }
e518068a 8627 }
8628 else {
f7ddb74a
JM		 8629 if (decc_disable_posix_root) {
8630 *(cp1++) = ':';
8631 hasdir = 0;
8632 }
e518068a 8633 }
8634 }
367e4b85 8635 PerlMem_free(trndev);
748a9306 8636 }
59247333 8637 else if (hasdir) {
a0d0e21e 8638 *(cp1++) = '[';
748a9306
LW		 8639 if (*cp2 == '.') {
8640 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8641 cp2 += 2; /* skip over "./" - it's redundant */
8642 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8643 }
8644 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8645 *(cp1++) = '-'; /* "../" --> "-" */
8646 cp2 += 3;
8647 }
f86702cc 8648 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8649 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8650 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8651 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8652 cp2 += 4;
8653 }
f7ddb74a
JM		 8654 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8655 /* Escape the extra dots in EFS file specifications */
8656 *(cp1++) = '^';
8657 }
748a9306
LW		 8658 if (cp2 > dirend) cp2 = dirend;
8659 }
8660 else *(cp1++) = '.';
8661 }
8662 for (; cp2 < dirend; cp2++) {
8663 if (*cp2 == '/') {
01b8edb6 8664 if (*(cp2-1) == '/') continue;
59247333 8665 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
748a9306
LW		 8666 infront = 0;
8667 }
8668 else if (!infront && *cp2 == '.') {
01b8edb6 8669 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8670 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9 8671 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
59247333
CB		 8672 if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8673 else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
4ab1eb56
CB		 8674 else {
8675 *(cp1++) = '-';
748a9306
LW		 8676 }
8677 cp2 += 2;
01b8edb6 8678 if (cp2 == dirend) break;
748a9306 8679 }
f86702cc 8680 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8681 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
59247333 8682 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
f86702cc 8683 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8684 if (!*(cp2+3)) {
8685 *(cp1++) = '.'; /* Simulate trailing '/' */
8686 cp2 += 2; /* for loop will incr this to == dirend */
8687 }
8688 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8689 }
f7ddb74a 8690 else {
b7bc7afb 8691 if (decc_efs_charset == 0) {
59247333 8692 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8693 cp1--; /* remove the escape, if any */
f7ddb74a 8694 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
b7bc7afb 8695 }
f7ddb74a 8696 else {
b7bc7afb 8697 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8698 }
8699 }
748a9306
LW		 8700 }
8701 else {
59247333 8702 if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a 8703 if (*cp2 == '.') {
b7bc7afb 8704 if (decc_efs_charset == 0) {
59247333 8705 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8706 cp1--; /* remove the escape, if any */
f7ddb74a 8707 *(cp1++) = '_';
b7bc7afb 8708 }
f7ddb74a 8709 else {
b7bc7afb 8710 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8711 }
8712 }
e283d9f3
CB		 8713 else {
8714 int out_cnt;
8715 cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8716 cp2--; /* we're in a loop that will increment this */
8717 cp1 += out_cnt;
8718 }
748a9306
LW		 8719 infront = 1;
8720 }
a0d0e21e 8721 }
59247333 8722 if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8723 if (hasdir) *(cp1++) = ']';
2e82b6ce 8724 if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
f7ddb74a
JM		 8725 no_type_seen = 0;
8726 if (cp2 > lastdot)
8727 no_type_seen = 1;
8728 while (*cp2) {
8729 switch(*cp2) {
8730 case '?':
360732b5
JM		 8731 if (decc_efs_charset == 0)
8732 *(cp1++) = '%';
8733 else
8734 *(cp1++) = '?';
f7ddb74a
JM		 8735 cp2++;
8736 case ' ':
2e82b6ce 8737 if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
c434e88d 8738 *(cp1)++ = '^';
f7ddb74a
JM		 8739 *(cp1)++ = '_';
8740 cp2++;
8741 break;
8742 case '.':
8743 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8744 decc_readdir_dropdotnotype) {
b7bc7afb 8745 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8746 cp2++;
8747
8748 /* trailing dot ==> '^..' on VMS */
8749 if (*cp2 == '\0') {
8750 *(cp1++) = '.';
8751 no_type_seen = 0;
8752 }
8753 }
8754 else {
8755 *(cp1++) = *(cp2++);
8756 no_type_seen = 0;
8757 }
8758 break;
360732b5
JM		 8759 case '$':
8760 /* This could be a macro to be passed through */
8761 *(cp1++) = *(cp2++);
8762 if (*cp2 == '(') {
8763 const char * save_cp2;
8764 char * save_cp1;
8765 int is_macro;
8766
8767 /* paranoid check */
8768 save_cp2 = cp2;
8769 save_cp1 = cp1;
8770 is_macro = 0;
8771
8772 /* Test through */
8773 *(cp1++) = *(cp2++);
8774 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8775 *(cp1++) = *(cp2++);
8776 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8777 *(cp1++) = *(cp2++);
8778 }
8779 if (*cp2 == ')') {
8780 *(cp1++) = *(cp2++);
8781 is_macro = 1;
8782 }
8783 }
8784 if (is_macro == 0) {
8785 /* Not really a macro - never mind */
8786 cp2 = save_cp2;
8787 cp1 = save_cp1;
8788 }
8789 }
8790 break;
f7ddb74a
JM		 8791 case '\"':
8792 case '~':
8793 case '`':
8794 case '!':
8795 case '#':
8796 case '%':
8797 case '^':
adc11f0b
CB		 8798 /* Don't escape again if following character is
8799 * already something we escape.
8800 */
8801 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8802 *(cp1++) = *(cp2++);
8803 break;
8804 }
8805 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8806 case '&':
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 '>':
676447f9 8822 if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
c434e88d 8823 *(cp1++) = '^';
f7ddb74a
JM		 8824 *(cp1++) = *(cp2++);
8825 break;
8826 case ';':
d5e61aaf 8827 /* If it doesn't look like the beginning of a version number,
6e2e048b 8828 * or we've been promised there are no version numbers, then
d5e61aaf
CB		 8829 * escape it.
8830 */
6e2e048b 8831 if (decc_filename_unix_no_version) {
f7ddb74a
JM		 8832 *(cp1++) = '^';
8833 }
6e2e048b
CB		 8834 else {
8835 size_t all_nums = strspn(cp2+1, "0123456789");
8836 if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8837 *(cp1++) = '^';
8838 }
f7ddb74a
JM		 8839 *(cp1++) = *(cp2++);
8840 break;
8841 default:
8842 *(cp1++) = *(cp2++);
8843 }
8844 }
8845 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8846 char *lcp1;
8847 lcp1 = cp1;
8848 lcp1--;
8849 /* Fix me for "^]", but that requires making sure that you do
8850 * not back up past the start of the filename
8851 */
8852 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8853 *cp1++ = '.';
8854 }
a0d0e21e
LW		 8855 *cp1 = '\0';
8856
360732b5
JM		 8857 if (utf8_flag != NULL)
8858 *utf8_flag = 0;
df278665
JM		 8859 if (vms_debug_fileify) {
8860 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8861 }
a0d0e21e
LW		 8862 return rslt;
8863
df278665
JM		 8864} /* end of int_tovmsspec() */
8865
8866
8867/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8868static char *
8869mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8870{
8871 static char __tovmsspec_retbuf[VMS_MAXRSS];
df278665
JM		 8872 char * vmsspec, *ret_spec, *ret_buf;
8873
8874 vmsspec = NULL;
8875 ret_buf = buf;
8876 if (ret_buf == NULL) {
8877 if (ts) {
8878 Newx(vmsspec, VMS_MAXRSS, char);
8879 if (vmsspec == NULL)
8880 _ckvmssts(SS$_INSFMEM);
8881 ret_buf = vmsspec;
8882 } else {
8883 ret_buf = __tovmsspec_retbuf;
8884 }
8885 }
8886
8887 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8888
8889 if (ret_spec == NULL) {
8890 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8891 if (vmsspec)
8892 Safefree(vmsspec);
8893 }
8894
8895 return ret_spec;
8896
8897} /* end of mp_do_tovmsspec() */
a0d0e21e
LW		 8898/*}}}*/
8899/* External entry points */
ce12d4b7
CB		 8900char *
8901Perl_tovmsspec(pTHX_ const char *path, char *buf)
8902{
8903 return do_tovmsspec(path, buf, 0, NULL);
8904}
8905
8906char *
8907Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8908{
8909 return do_tovmsspec(path, buf, 1, NULL);
8910}
8911
8912char *
8913Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8914{
8915 return do_tovmsspec(path, buf, 0, utf8_fl);
8916}
8917
8918char *
8919Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8920{
8921 return do_tovmsspec(path, buf, 1, utf8_fl);
8922}
360732b5 8923
4846f1d7 8924/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
94ae10c0 8925/* Internal routine for use with out an explicit context present */
ce12d4b7
CB		 8926static char *
8927int_tovmspath(const char *path, char *buf, int * utf8_fl)
8928{
4846f1d7
JM		 8929 char * ret_spec, *pathified;
8930
8931 if (path == NULL)
8932 return NULL;
8933
c11536f5 8934 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
4846f1d7
JM		 8935 if (pathified == NULL)
8936 _ckvmssts_noperl(SS$_INSFMEM);
8937
8938 ret_spec = int_pathify_dirspec(path, pathified);
8939
8940 if (ret_spec == NULL) {
8941 PerlMem_free(pathified);
8942 return NULL;
8943 }
8944
8945 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8946
8947 PerlMem_free(pathified);
8948 return ret_spec;
8949
8950}
8951
360732b5 8952/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
ce12d4b7
CB		 8953static char *
8954mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8955{
a480973c 8956 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8957 int vmslen;
a480973c 8958 char *pathified, *vmsified, *cp;
a0d0e21e 8959
748a9306 8960 if (path == NULL) return NULL;
c11536f5 8961 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 8962 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 8963 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 8964 PerlMem_free(pathified);
a480973c
JM		 8965 return NULL;
8966 }
c5375c28
JM		 8967
8968 vmsified = NULL;
8969 if (buf == NULL)
8970 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8971 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8972 PerlMem_free(pathified);
8973 if (vmsified) Safefree(vmsified);
a480973c
JM		 8974 return NULL;
8975 }
c5375c28 8976 PerlMem_free(pathified);
a480973c 8977 if (buf) {
a480973c
JM		 8978 return buf;
8979 }
a0d0e21e
LW		 8980 else if (ts) {
8981 vmslen = strlen(vmsified);
a02a5408 8982 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8983 memcpy(cp,vmsified,vmslen);
8984 cp[vmslen] = '\0';
a480973c 8985 Safefree(vmsified);
a0d0e21e
LW		 8986 return cp;
8987 }
8988 else {
a35dcc95 8989 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
a480973c 8990 Safefree(vmsified);
a0d0e21e
LW		 8991 return __tovmspath_retbuf;
8992 }
8993
8994} /* end of do_tovmspath() */
8995/*}}}*/
8996/* External entry points */
ce12d4b7
CB		 8997char *
8998Perl_tovmspath(pTHX_ const char *path, char *buf)
8999{
9000 return do_tovmspath(path, buf, 0, NULL);
9001}
9002
9003char *
9004Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9005{
9006 return do_tovmspath(path, buf, 1, NULL);
9007}
9008
9009char *
9010Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9011{
9012 return do_tovmspath(path, buf, 0, utf8_fl);
9013}
9014
9015char *
9016Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9017{
9018 return do_tovmspath(path, buf, 1, utf8_fl);
9019}
360732b5
JM		 9020
9021
9022/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 9023static char *
9024mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9025{
a480973c 9026 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 9027 int unixlen;
a480973c 9028 char *pathified, *unixified, *cp;
a0d0e21e 9029
748a9306 9030 if (path == NULL) return NULL;
c11536f5 9031 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9032 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 9033 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 9034 PerlMem_free(pathified);
a480973c
JM		 9035 return NULL;
9036 }
c5375c28
JM		 9037
9038 unixified = NULL;
9039 if (buf == NULL) {
9040 Newx(unixified, VMS_MAXRSS, char);
9041 }
360732b5 9042 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 9043 PerlMem_free(pathified);
9044 if (unixified) Safefree(unixified);
a480973c
JM		 9045 return NULL;
9046 }
c5375c28 9047 PerlMem_free(pathified);
a480973c 9048 if (buf) {
a480973c
JM		 9049 return buf;
9050 }
a0d0e21e
LW		 9051 else if (ts) {
9052 unixlen = strlen(unixified);
a02a5408 9053 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 9054 memcpy(cp,unixified,unixlen);
9055 cp[unixlen] = '\0';
a480973c 9056 Safefree(unixified);
a0d0e21e
LW		 9057 return cp;
9058 }
9059 else {
a35dcc95 9060 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
a480973c 9061 Safefree(unixified);
a0d0e21e
LW		 9062 return __tounixpath_retbuf;
9063 }
9064
9065} /* end of do_tounixpath() */
9066/*}}}*/
9067/* External entry points */
ce12d4b7
CB		 9068char *
9069Perl_tounixpath(pTHX_ const char *path, char *buf)
9070{
9071 return do_tounixpath(path, buf, 0, NULL);
9072}
9073
9074char *
9075Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9076{
9077 return do_tounixpath(path, buf, 1, NULL);
9078}
9079
9080char *
9081Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9082{
9083 return do_tounixpath(path, buf, 0, utf8_fl);
9084}
9085
9086char *
9087Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9088{
9089 return do_tounixpath(path, buf, 1, utf8_fl);
9090}
a0d0e21e
LW		 9091
9092/*
cbb8049c 9093 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9094 *
9095 *****************************************************************************
9096 * *
cbb8049c 9097 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 9098 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9099 * *
cbb8049c
MP		 9100 * Permission is hereby granted for the reproduction of this software *
9101 * on condition that this copyright notice is included in source *
9102 * distributions of the software. The code may be modified and *
9103 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 9104 * *
9105 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 9106 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 9107 *****************************************************************************
9108 */
9109
9110/*
9111 * getredirection() is intended to aid in porting C programs
9112 * to VMS (Vax-11 C). The native VMS environment does not support
9113 * '>' and '<' I/O redirection, or command line wild card expansion,
9114 * or a command line pipe mechanism using the '|' AND background
9115 * command execution '&'. All of these capabilities are provided to any
9116 * C program which calls this procedure as the first thing in the
9117 * main program.
9118 * The piping mechanism will probably work with almost any 'filter' type
9119 * of program. With suitable modification, it may useful for other
9120 * portability problems as well.
9121 *
cbb8049c 9122 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9123 */
9124struct list_item
9125 {
9126 struct list_item *next;
9127 char *value;
9128 };
9129
9130static void add_item(struct list_item **head,
9131 struct list_item **tail,
9132 char *value,
9133 int *count);
9134
4b19af01
CB		 9135static void mp_expand_wild_cards(pTHX_ char *item,
9136 struct list_item **head,
9137 struct list_item **tail,
9138 int *count);
a0d0e21e 9139
8df869cb 9140static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 9141
fd8cd3a3 9142static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 9143
9144/*{{{ void getredirection(int *ac, char ***av)*/
84902520 9145static void
4b19af01 9146mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 9147/*
9148 * Process vms redirection arg's. Exit if any error is seen.
9149 * If getredirection() processes an argument, it is erased
9150 * from the vector. getredirection() returns a new argc and argv value.
9151 * In the event that a background command is requested (by a trailing "&"),
9152 * this routine creates a background subprocess, and simply exits the program.
9153 *
9154 * Warning: do not try to simplify the code for vms. The code
9155 * presupposes that getredirection() is called before any data is
9156 * read from stdin or written to stdout.
9157 *
9158 * Normal usage is as follows:
9159 *
9160 * main(argc, argv)
9161 * int argc;
9162 * char *argv[];
9163 * {
9164 * getredirection(&argc, &argv);
9165 * }
9166 */
9167{
9168 int argc = *ac; /* Argument Count */
9169 char **argv = *av; /* Argument Vector */
9170 char *ap; /* Argument pointer */
9171 int j; /* argv[] index */
9172 int item_count = 0; /* Count of Items in List */
9173 struct list_item *list_head = 0; /* First Item in List */
9174 struct list_item *list_tail; /* Last Item in List */
9175 char *in = NULL; /* Input File Name */
9176 char *out = NULL; /* Output File Name */
9177 char *outmode = "w"; /* Mode to Open Output File */
9178 char *err = NULL; /* Error File Name */
9179 char *errmode = "w"; /* Mode to Open Error File */
9180 int cmargc = 0; /* Piped Command Arg Count */
9181 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 9182
9183 /*
9184 * First handle the case where the last thing on the line ends with
9185 * a '&'. This indicates the desire for the command to be run in a
9186 * subprocess, so we satisfy that desire.
9187 */
9188 ap = argv[argc-1];
9189 if (0 == strcmp("&", ap))
8c3eed29 9190 exit(background_process(aTHX_ --argc, argv));
e518068a 9191 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 9192 {
9193 ap[strlen(ap)-1] = '\0';
8c3eed29 9194 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 9195 }
9196 /*
9197 * Now we handle the general redirection cases that involve '>', '>>',
9198 * '<', and pipes '|'.
9199 */
9200 for (j = 0; j < argc; ++j)
9201 {
9202 if (0 == strcmp("<", argv[j]))
9203 {
9204 if (j+1 >= argc)
9205 {
fd71b04b 9206 fprintf(stderr,"No input file after < on command line");
748a9306 9207 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9208 }
9209 in = argv[++j];
9210 continue;
9211 }
9212 if ('<' == *(ap = argv[j]))
9213 {
9214 in = 1 + ap;
9215 continue;
9216 }
9217 if (0 == strcmp(">", ap))
9218 {
9219 if (j+1 >= argc)
9220 {
fd71b04b 9221 fprintf(stderr,"No output file after > on command line");
748a9306 9222 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9223 }
9224 out = argv[++j];
9225 continue;
9226 }
9227 if ('>' == *ap)
9228 {
9229 if ('>' == ap[1])
9230 {
9231 outmode = "a";
9232 if ('\0' == ap[2])
9233 out = argv[++j];
9234 else
9235 out = 2 + ap;
9236 }
9237 else
9238 out = 1 + ap;
9239 if (j >= argc)
9240 {
fd71b04b 9241 fprintf(stderr,"No output file after > or >> on command line");
748a9306 9242 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9243 }
9244 continue;
9245 }
9246 if (('2' == *ap) && ('>' == ap[1]))
9247 {
9248 if ('>' == ap[2])
9249 {
9250 errmode = "a";
9251 if ('\0' == ap[3])
9252 err = argv[++j];
9253 else
9254 err = 3 + ap;
9255 }
9256 else
9257 if ('\0' == ap[2])
9258 err = argv[++j];
9259 else
748a9306 9260 err = 2 + ap;
a0d0e21e
LW		 9261 if (j >= argc)
9262 {
fd71b04b 9263 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 9264 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9265 }
9266 continue;
9267 }
9268 if (0 == strcmp("|", argv[j]))
9269 {
9270 if (j+1 >= argc)
9271 {
fd71b04b 9272 fprintf(stderr,"No command into which to pipe on command line");
748a9306 9273 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9274 }
9275 cmargc = argc-(j+1);
9276 cmargv = &argv[j+1];
9277 argc = j;
9278 continue;
9279 }
9280 if ('|' == *(ap = argv[j]))
9281 {
9282 ++argv[j];
9283 cmargc = argc-j;
9284 cmargv = &argv[j];
9285 argc = j;
9286 continue;
9287 }
9288 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9289 }
9290 /*
9291 * Allocate and fill in the new argument vector, Some Unix's terminate
9292 * the list with an extra null pointer.
9293 */
e0ef6b43 9294 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 9295 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9296 *av = argv;
9297 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9298 argv[j] = list_head->value;
9299 *ac = item_count;
9300 if (cmargv != NULL)
9301 {
9302 if (out != NULL)
9303 {
fd71b04b 9304 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 9305 exit(LIB$_INVARGORD);
a0d0e21e 9306 }
fd8cd3a3 9307 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 9308 }
9309
9310 /* Check for input from a pipe (mailbox) */
9311
a5f75d66 9312 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 9313 {
9314 char mbxname[L_tmpnam];
9315 long int bufsize;
9316 long int dvi_item = DVI$_DEVBUFSIZ;
9317 $DESCRIPTOR(mbxnam, "");
9318 $DESCRIPTOR(mbxdevnam, "");
9319
9320 /* Input from a pipe, reopen it in binary mode to disable */
9321 /* carriage control processing. */
9322
bf8d1304 9323 fgetname(stdin, mbxname, 1);
a0d0e21e
LW		 9324 mbxnam.dsc$a_pointer = mbxname;
9325 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9326 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9327 mbxdevnam.dsc$a_pointer = mbxname;
9328 mbxdevnam.dsc$w_length = sizeof(mbxname);
9329 dvi_item = DVI$_DEVNAM;
9330 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9331 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 9332 set_errno(0);
9333 set_vaxc_errno(1);
a0d0e21e
LW		 9334 freopen(mbxname, "rb", stdin);
9335 if (errno != 0)
9336 {
fd71b04b 9337 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 9338 exit(vaxc$errno);
a0d0e21e
LW		 9339 }
9340 }
9341 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9342 {
fd71b04b 9343 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 9344 exit(vaxc$errno);
a0d0e21e
LW		 9345 }
9346 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9347 {
fd71b04b 9348 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 9349 exit(vaxc$errno);
a0d0e21e 9350 }
0db50132 9351 if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
0e06870b 9352
748a9306 9353 if (err != NULL) {
71d7ec5d 9354 if (strcmp(err,"&1") == 0) {
a15cef0c 9355 dup2(fileno(stdout), fileno(stderr));
0db50132 9356 vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
71d7ec5d 9357 } else {
748a9306
LW		 9358 FILE *tmperr;
9359 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9360 {
fd71b04b 9361 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 9362 exit(vaxc$errno);
9363 }
9364 fclose(tmperr);
a15cef0c 9365 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 9366 {
9367 exit(vaxc$errno);
9368 }
0db50132 9369 vmssetuserlnm("SYS$ERROR", err);
a0d0e21e 9370 }
71d7ec5d 9371 }
a0d0e21e 9372#ifdef ARGPROC_DEBUG
740ce14c 9373 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 9374 for (j = 0; j < *ac; ++j)
740ce14c 9375 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 9376#endif
b7ae7a0d 9377 /* Clear errors we may have hit expanding wildcards, so they don't
9378 show up in Perl's $! later */
9379 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 9380} /* end of getredirection() */
9381/*}}}*/
9382
ce12d4b7
CB		 9383static void
9384add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
a0d0e21e
LW		 9385{
9386 if (*head == 0)
9387 {
e0ef6b43 9388 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9389 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9390 *tail = *head;
9391 }
9392 else {
e0ef6b43 9393 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9394 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9395 *tail = (*tail)->next;
9396 }
9397 (*tail)->value = value;
9398 ++(*count);
9399}
9400
ce12d4b7
CB		 9401static void
9402mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9403 struct list_item **tail, int *count)
9404{
9405 int expcount = 0;
9406 unsigned long int context = 0;
9407 int isunix = 0;
9408 int item_len = 0;
9409 char *had_version;
9410 char *had_device;
9411 int had_directory;
9412 char *devdir,*cp;
9413 char *vmsspec;
9414 $DESCRIPTOR(filespec, "");
9415 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9416 $DESCRIPTOR(resultspec, "");
9417 unsigned long int lff_flags = 0;
9418 int sts;
9419 int rms_sts;
a480973c
JM		 9420
9421#ifdef VMS_LONGNAME_SUPPORT
9422 lff_flags = LIB$M_FIL_LONG_NAMES;
9423#endif
a0d0e21e 9424
f675dbe5
CB		 9425 for (cp = item; *cp; cp++) {
9426 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9427 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9428 }
9429 if (!*cp || isspace(*cp))
a0d0e21e
LW		 9430 {
9431 add_item(head, tail, item, count);
9432 return;
9433 }
773da73d
JH		 9434 else
9435 {
9436 /* "double quoted" wild card expressions pass as is */
9437 /* From DCL that means using e.g.: */
9438 /* perl program """perl.*""" */
9439 item_len = strlen(item);
9440 if ( '"' == *item && '"' == item[item_len-1] )
9441 {
9442 item++;
9443 item[item_len-2] = '\0';
9444 add_item(head, tail, item, count);
9445 return;
9446 }
9447 }
a0d0e21e
LW		 9448 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9449 resultspec.dsc$b_class = DSC$K_CLASS_D;
9450 resultspec.dsc$a_pointer = NULL;
c11536f5 9451 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9452 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 9453 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
df278665 9454 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
a0d0e21e
LW		 9455 if (!isunix || !filespec.dsc$a_pointer)
9456 filespec.dsc$a_pointer = item;
9457 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9458 /*
9459 * Only return version specs, if the caller specified a version
9460 */
9461 had_version = strchr(item, ';');
9462 /*
94ae10c0 9463 * Only return device and directory specs, if the caller specified either.
a0d0e21e
LW		 9464 */
9465 had_device = strchr(item, ':');
9466 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9467
a480973c
JM		 9468 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9469 (&filespec, &resultspec, &context,
dca5a913 9470 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 9471 {
9472 char *string;
9473 char *c;
9474
c11536f5 9475 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
c5375c28 9476 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
db4c2905 9477 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
a0d0e21e 9478 if (NULL == had_version)
f7ddb74a 9479 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 9480 if ((!had_directory) && (had_device == NULL))
9481 {
9482 if (NULL == (devdir = strrchr(string, ']')))
9483 devdir = strrchr(string, '>');
db4c2905 9484 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
a0d0e21e
LW		 9485 }
9486 /*
9487 * Be consistent with what the C RTL has already done to the rest of
9488 * the argv items and lowercase all of these names.
9489 */
f7ddb74a
JM		 9490 if (!decc_efs_case_preserve) {
9491 for (c = string; *c; ++c)
a0d0e21e
LW		 9492 if (isupper(*c))
9493 *c = tolower(*c);
f7ddb74a 9494 }
f86702cc 9495 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 9496 add_item(head, tail, string, count);
9497 ++expcount;
a480973c 9498 }
367e4b85 9499 PerlMem_free(vmsspec);
c07a80fd 9500 if (sts != RMS$_NMF)
9501 {
9502 set_vaxc_errno(sts);
9503 switch (sts)
9504 {
f282b18d 9505 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9506 set_errno(ENOENT); break;
f282b18d
CB		 9507 case RMS$_DIR:
9508 set_errno(ENOTDIR); break;
c07a80fd 9509 case RMS$_DEV:
9510 set_errno(ENODEV); break;
f282b18d 9511 case RMS$_FNM: case RMS$_SYN:
c07a80fd 9512 set_errno(EINVAL); break;
9513 case RMS$_PRV:
9514 set_errno(EACCES); break;
9515 default:
b7ae7a0d 9516 _ckvmssts_noperl(sts);
c07a80fd 9517 }
9518 }
a0d0e21e
LW		 9519 if (expcount == 0)
9520 add_item(head, tail, item, count);
b7ae7a0d 9521 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9522 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 9523}
9524
a0d0e21e 9525
ff7adb52
CL		 9526static void
9527pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 9528{
ff7adb52 9529 PerlIO *fp;
218fdd94 9530 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 9531 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9532 int sts, j, l, ismcr, quote, tquote = 0;
9533
218fdd94
CL		 9534 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9535 vms_execfree(vmscmd);
ff7adb52
CL		 9536
9537 j = l = 0;
9538 p = subcmd;
9539 q = cmargv[0];
9540 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9541 && toupper(*(q+2)) == 'R' && !*(q+3);
9542
9543 while (q && l < MAX_DCL_LINE_LENGTH) {
9544 if (!*q) {
9545 if (j > 0 && quote) {
9546 *p++ = '"';
9547 l++;
9548 }
9549 q = cmargv[++j];
9550 if (q) {
9551 if (ismcr && j > 1) quote = 1;
9552 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9553 *p++ = ' ';
9554 l++;
9555 if (quote || tquote) {
9556 *p++ = '"';
9557 l++;
9558 }
988c775c 9559 }
ff7adb52
CL		 9560 } else {
9561 if ((quote||tquote) && *q == '"') {
9562 *p++ = '"';
9563 l++;
988c775c 9564 }
ff7adb52
CL		 9565 *p++ = *q++;
9566 l++;
9567 }
9568 }
9569 *p = '\0';
a0d0e21e 9570
218fdd94 9571 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4e205ed6 9572 if (fp == NULL) {
ff7adb52 9573 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 9574 }
a0d0e21e
LW		 9575}
9576
ce12d4b7
CB		 9577static int
9578background_process(pTHX_ int argc, char **argv)
9579{
9580 char command[MAX_DCL_SYMBOL + 1] = "$";
9581 $DESCRIPTOR(value, "");
9582 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9583 static $DESCRIPTOR(null, "NLA0:");
9584 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9585 char pidstring[80];
9586 $DESCRIPTOR(pidstr, "");
9587 int pid;
9588 unsigned long int flags = 17, one = 1, retsts;
9589 int len;
a0d0e21e 9590
a35dcc95 9591 len = my_strlcat(command, argv[0], sizeof(command));
a480973c 9592 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e 9593 {
a35dcc95
CB		 9594 my_strlcat(command, " \"", sizeof(command));
9595 my_strlcat(command, *(++argv), sizeof(command));
9596 len = my_strlcat(command, "\"", sizeof(command));
a0d0e21e
LW		 9597 }
9598 value.dsc$a_pointer = command;
9599 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 9600 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 9601 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9602 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 9603 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 9604 }
9605 else {
b7ae7a0d 9606 _ckvmssts_noperl(retsts);
748a9306 9607 }
a0d0e21e 9608#ifdef ARGPROC_DEBUG
740ce14c 9609 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 9610#endif
9611 sprintf(pidstring, "%08X", pid);
740ce14c 9612 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 9613 pidstr.dsc$a_pointer = pidstring;
9614 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9615 lib$set_symbol(&pidsymbol, &pidstr);
9616 return(SS$_NORMAL);
9617}
9618/*}}}*/
9619/***** End of code taken from Mark Pizzolato's argproc.c package *****/
9620
84902520
TB		 9621
9622/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 9623/* Older VAXC header files lack these constants */
9624#ifndef JPI$_RIGHTS_SIZE
9625# define JPI$_RIGHTS_SIZE 817
9626#endif
9627#ifndef KGB$M_SUBSYSTEM
9628# define KGB$M_SUBSYSTEM 0x8
9629#endif
a480973c 9630
e0ef6b43
CB		 9631/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9632
84902520
TB		 9633/*{{{void vms_image_init(int *, char ***)*/
9634void
9635vms_image_init(int *argcp, char ***argvp)
9636{
b53f3677 9637 int status;
f675dbe5
CB		 9638 char eqv[LNM$C_NAMLENGTH+1] = "";
9639 unsigned int len, tabct = 8, tabidx = 0;
9640 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 9641 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9642 unsigned short int dummy, rlen;
f675dbe5 9643 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 9644#if defined(PERL_IMPLICIT_CONTEXT)
9645 pTHX = NULL;
9646#endif
61bb5906
CB		 9647 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9648 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9649 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9650 { 0, 0, 0, 0} };
84902520 9651
2e34cc90 9652#ifdef KILL_BY_SIGPRC
f7ddb74a 9653 Perl_csighandler_init();
2e34cc90
CL		 9654#endif
9655
b53f3677
JM		 9656 /* This was moved from the pre-image init handler because on threaded */
9657 /* Perl it was always returning 0 for the default value. */
98c7875d 9658 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
b53f3677
JM		 9659 if (status > 0) {
9660 int s;
9661 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9662 if (s > 0) {
9663 int initial;
9664 initial = decc$feature_get_value(s, 4);
98c7875d
CB		 9665 if (initial > 0) {
9666 /* initial is: 0 if nothing has set the feature */
9667 /* -1 if initialized to default */
9668 /* 1 if set by logical name */
9669 /* 2 if set by decc$feature_set_value */
b53f3677
JM		 9670 decc_disable_posix_root = decc$feature_get_value(s, 1);
9671
9672 /* If the value is not valid, force the feature off */
9673 if (decc_disable_posix_root < 0) {
9674 decc$feature_set_value(s, 1, 1);
9675 decc_disable_posix_root = 1;
9676 }
9677 }
9678 else {
98c7875d 9679 /* Nothing has asked for it explicitly, so use our own default. */
b53f3677
JM		 9680 decc_disable_posix_root = 1;
9681 decc$feature_set_value(s, 1, 1);
9682 }
9683 }
9684 }
b53f3677 9685
fd8cd3a3
DS		 9686 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9687 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9688 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9689 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 9690 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 9691 will_taint = TRUE;
84902520
TB		 9692 break;
9693 }
9694 }
61bb5906 9695 /* Rights identifiers might trigger tainting as well. */
f675dbe5 9696 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 9697 while (rlen < rsz) {
9698 /* We didn't get all the identifiers on the first pass. Allocate a
9699 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9700 * were needed to hold all identifiers at time of last call; we'll
9701 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 9702 * If it gave us less than it wanted to despite ample buffer space,
9703 * something's broken. Is your system missing a system identifier?
61bb5906 9704 */
22d4bb9c
CB		 9705 if (rsz <= jpilist[1].buflen) {
9706 /* Perl_croak accvios when used this early in startup. */
9707 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9708 rsz, (unsigned long) jpilist[1].buflen,
9709 "Check your rights database for corruption.\n");
9710 exit(SS$_ABORT);
9711 }
e0ef6b43
CB		 9712 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9713 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9714 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9715 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9716 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9717 _ckvmssts_noperl(iosb[0]);
61bb5906 9718 }
c11536f5 9719 mask = (unsigned long int *)jpilist[1].bufadr;
61bb5906
CB		 9720 /* Check attribute flags for each identifier (2nd longword); protected
9721 * subsystem identifiers trigger tainting.
9722 */
9723 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9724 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9725 will_taint = TRUE;
61bb5906
CB		 9726 break;
9727 }
9728 }
367e4b85 9729 if (mask != rlst) PerlMem_free(mask);
61bb5906 9730 }
f7ddb74a
JM		 9731
9732 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9733 * logical, some versions of the CRTL will add a phanthom /000000/
9734 * directory. This needs to be removed.
9735 */
9736 if (decc_filename_unix_report) {
ce12d4b7
CB		 9737 char * zeros;
9738 int ulen;
f7ddb74a
JM		 9739 ulen = strlen(argvp[0][0]);
9740 if (ulen > 7) {
9741 zeros = strstr(argvp[0][0], "/000000/");
9742 if (zeros != NULL) {
9743 int mlen;
9744 mlen = ulen - (zeros - argvp[0][0]) - 7;
9745 memmove(zeros, &zeros[7], mlen);
9746 ulen = ulen - 7;
9747 argvp[0][0][ulen] = '\0';
9748 }
9749 }
9750 /* It also may have a trailing dot that needs to be removed otherwise
9751 * it will be converted to VMS mode incorrectly.
9752 */
9753 ulen--;
9754 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9755 argvp[0][0][ulen] = '\0';
9756 }
9757
61bb5906 9758 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9759 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9760 * hasn't been allocated when vms_image_init() is called.
9761 */
f675dbe5 9762 if (will_taint) {
ec618cdf
CB		 9763 char **newargv, **oldargv;
9764 oldargv = *argvp;
e0ef6b43 9765 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9766 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9767 newargv[0] = oldargv[0];
c11536f5 9768 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
c5375c28 9769 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9770 strcpy(newargv[1], "-T");
9771 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9772 (*argcp)++;
9773 newargv[*argcp] = NULL;
61bb5906
CB		 9774 /* We orphan the old argv, since we don't know where it's come from,
9775 * so we don't know how to free it.
9776 */
ec618cdf 9777 *argvp = newargv;
61bb5906 9778 }
f675dbe5
CB		 9779 else { /* Did user explicitly request tainting? */
9780 int i;
9781 char *cp, **av = *argvp;
9782 for (i = 1; i < *argcp; i++) {
9783 if (*av[i] != '-') break;
9784 for (cp = av[i]+1; *cp; cp++) {
9785 if (*cp == 'T') { will_taint = 1; break; }
9786 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9787 strchr("DFIiMmx",*cp)) break;
9788 }
9789 if (will_taint) break;
9790 }
9791 }
9792
9793 for (tabidx = 0;
9794 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9795 tabidx++) {
c5375c28
JM		 9796 if (!tabidx) {
9797 tabvec = (struct dsc$descriptor_s **)
9798 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9799 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9800 }
f675dbe5
CB		 9801 else if (tabidx >= tabct) {
9802 tabct += 8;
e0ef6b43 9803 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9804 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9805 }
e0ef6b43 9806 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9807 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
88e3936f 9808 tabvec[tabidx]->dsc$w_length = len;
f675dbe5 9809 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
88e3936f 9810 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
4f119521 9811 tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
88e3936f
CB		 9812 if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9813 my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
f675dbe5
CB		 9814 }
9815 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9816
84902520 9817 getredirection(argcp,argvp);
3bc25146
CB		 9818#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9819 {
9820# include <reentrancy.h>
f7ddb74a 9821 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9822 }
9823#endif
84902520
TB		 9824 return;
9825}
9826/*}}}*/
9827
9828
a0d0e21e
LW		 9829/* trim_unixpath()
9830 * Trim Unix-style prefix off filespec, so it looks like what a shell
9831 * glob expansion would return (i.e. from specified prefix on, not
9832 * full path). Note that returned filespec is Unix-style, regardless
9833 * of whether input filespec was VMS-style or Unix-style.
9834 *
a3e9d8c9 9835 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9836 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9837 * vector of options; at present, only bit 0 is used, and if set tells
9838 * trim unixpath to try the current default directory as a prefix when
9839 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9840 *
9841 * Returns !=0 on success, with trimmed filespec replacing contents of
9842 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9843 */
f86702cc 9844/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9845int
2fbb330f 9846Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9847{
c11536f5 9848 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
eb578fdb 9849 int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9850
a3e9d8c9 9851 if (!wildspec || !fspec) return 0;
ebd4d70b 9852
c11536f5 9853 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9854 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9855 tplate = unixwild;
a3e9d8c9 9856 if (strpbrk(wildspec,"]>:") != NULL) {
0e5ce2c7 9857 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
367e4b85 9858 PerlMem_free(unixwild);
a480973c
JM		 9859 return 0;
9860 }
a3e9d8c9 9861 }
2fbb330f 9862 else {
a35dcc95 9863 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
2fbb330f 9864 }
c11536f5 9865 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9866 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e 9867 if (strpbrk(fspec,"]>:") != NULL) {
0e5ce2c7 9868 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
367e4b85
JM		 9869 PerlMem_free(unixwild);
9870 PerlMem_free(unixified);
a480973c
JM		 9871 return 0;
9872 }
a0d0e21e 9873 else base = unixified;
a3e9d8c9 9874 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9875 * check to see that final result fits into (isn't longer than) fspec */
9876 reslen = strlen(fspec);
a0d0e21e
LW		 9877 }
9878 else base = fspec;
a3e9d8c9 9879
9880 /* No prefix or absolute path on wildcard, so nothing to remove */
c11536f5 9881 if (!*tplate || *tplate == '/') {
367e4b85 9882 PerlMem_free(unixwild);
a480973c 9883 if (base == fspec) {
367e4b85 9884 PerlMem_free(unixified);
a480973c
JM		 9885 return 1;
9886 }
a3e9d8c9 9887 tmplen = strlen(unixified);
a480973c 9888 if (tmplen > reslen) {
367e4b85 9889 PerlMem_free(unixified);
a480973c
JM		 9890 return 0; /* not enough space */
9891 }
a3e9d8c9 9892 /* Copy unixified resultant, including trailing NUL */
9893 memmove(fspec,unixified,tmplen+1);
367e4b85 9894 PerlMem_free(unixified);
a3e9d8c9 9895 return 1;
9896 }
a0d0e21e 9897
f86702cc 9898 for (end = base; *end; end++) ; /* Find end of resultant filespec */
c11536f5
CB		 9899 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9900 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
f86702cc 9901 for (cp1 = end ;cp1 >= base; cp1--)
9902 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9903 { cp1++; break; }
9904 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9905 PerlMem_free(unixified);
9906 PerlMem_free(unixwild);
a3e9d8c9 9907 return 1;
9908 }
f86702cc 9909 else {
a480973c 9910 char *tpl, *lcres;
f86702cc 9911 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9912 int ells = 1, totells, segdirs, match;
a480973c 9913 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9914 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9915
9916 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9917 totells = ells;
9918 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
c11536f5 9919 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9920 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9921 if (ellipsis == tplate && opts & 1) {
f86702cc 9922 /* Template begins with an ellipsis. Since we can't tell how many
9923 * directory names at the front of the resultant to keep for an
9924 * arbitrary starting point, we arbitrarily choose the current
9925 * default directory as a starting point. If it's there as a prefix,
9926 * clip it off. If not, fall through and act as if the leading
9927 * ellipsis weren't there (i.e. return shortest possible path that
9928 * could match template).
9929 */
a480973c 9930 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9931 PerlMem_free(tpl);
9932 PerlMem_free(unixified);
9933 PerlMem_free(unixwild);
a480973c
JM		 9934 return 0;
9935 }
f7ddb74a
JM		 9936 if (!decc_efs_case_preserve) {
9937 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9938 if (_tolower(*cp1) != _tolower(*cp2)) break;
9939 }
f86702cc 9940 segdirs = dirs - totells; /* Min # of dirs we must have left */
9941 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9942 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9943 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9944 PerlMem_free(tpl);
9945 PerlMem_free(unixified);
9946 PerlMem_free(unixwild);
f86702cc 9947 return 1;
a3e9d8c9 9948 }
a3e9d8c9 9949 }
f86702cc 9950 /* First off, back up over constant elements at end of path */
9951 if (dirs) {
9952 for (front = end ; front >= base; front--)
9953 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9954 }
c11536f5 9955 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9956 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9957 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
a480973c
JM		 9958 cp1++,cp2++) {
9959 if (!decc_efs_case_preserve) {
9960 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9961 }
9962 else {
9963 *cp2 = *cp1;
9964 }
9965 }
9966 if (cp1 != '\0') {
367e4b85
JM		 9967 PerlMem_free(tpl);
9968 PerlMem_free(unixified);
9969 PerlMem_free(unixwild);
c5375c28 9970 PerlMem_free(lcres);
a480973c 9971 return 0; /* Path too long. */
f7ddb74a 9972 }
f86702cc 9973 lcend = cp2;
9974 *cp2 = '\0'; /* Pick up with memcpy later */
9975 lcfront = lcres + (front - base);
9976 /* Now skip over each ellipsis and try to match the path in front of it. */
9977 while (ells--) {
c11536f5 9978 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
f86702cc 9979 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9980 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
c11536f5 9981 if (cp1 < tplate) break; /* template started with an ellipsis */
f86702cc 9982 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9983 ellipsis = cp1; continue;
9984 }
a480973c 9985 wilddsc.dsc$a_pointer = tpl;
f86702cc 9986 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9987 nextell = cp1;
9988 for (segdirs = 0, cp2 = tpl;
a480973c 9989 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9990 cp1++, cp2++) {
9991 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9992 else {
9993 if (!decc_efs_case_preserve) {
9994 *cp2 = _tolower(*cp1); /* else lowercase for match */
9995 }
9996 else {
9997 *cp2 = *cp1; /* else preserve case for match */
9998 }
9999 }
f86702cc 10000 if (*cp2 == '/') segdirs++;
10001 }
a480973c 10002 if (cp1 != ellipsis - 1) {
367e4b85
JM		 10003 PerlMem_free(tpl);
10004 PerlMem_free(unixified);
10005 PerlMem_free(unixwild);
10006 PerlMem_free(lcres);
a480973c
JM		 10007 return 0; /* Path too long */
10008 }
f86702cc 10009 /* Back up at least as many dirs as in template before matching */
10010 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10011 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10012 for (match = 0; cp1 > lcres;) {
10013 resdsc.dsc$a_pointer = cp1;
10014 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10015 match++;
10016 if (match == 1) lcfront = cp1;
10017 }
10018 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10019 }
a480973c 10020 if (!match) {
367e4b85
JM		 10021 PerlMem_free(tpl);
10022 PerlMem_free(unixified);
10023 PerlMem_free(unixwild);
10024 PerlMem_free(lcres);
a480973c
JM		 10025 return 0; /* Can't find prefix ??? */
10026 }
f86702cc 10027 if (match > 1 && opts & 1) {
10028 /* This ... wildcard could cover more than one set of dirs (i.e.
10029 * a set of similar dir names is repeated). If the template
10030 * contains more than 1 ..., upstream elements could resolve the
10031 * ambiguity, but it's not worth a full backtracking setup here.
10032 * As a quick heuristic, clip off the current default directory
10033 * if it's present to find the trimmed spec, else use the
10034 * shortest string that this ... could cover.
10035 */
10036 char def[NAM$C_MAXRSS+1], *st;
10037
a480973c 10038 if (getcwd(def, sizeof def,0) == NULL) {
827f156d
JM		 10039 PerlMem_free(unixified);
10040 PerlMem_free(unixwild);
10041 PerlMem_free(lcres);
10042 PerlMem_free(tpl);
a480973c
JM		 10043 return 0;
10044 }
f7ddb74a
JM		 10045 if (!decc_efs_case_preserve) {
10046 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10047 if (_tolower(*cp1) != _tolower(*cp2)) break;
10048 }
f86702cc 10049 segdirs = dirs - totells; /* Min # of dirs we must have left */
10050 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10051 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 10052 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 10053 PerlMem_free(tpl);
10054 PerlMem_free(unixified);
10055 PerlMem_free(unixwild);
10056 PerlMem_free(lcres);
f86702cc 10057 return 1;
10058 }
10059 /* Nope -- stick with lcfront from above and keep going. */
10060 }
10061 }
18a3d61e 10062 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 10063 PerlMem_free(tpl);
10064 PerlMem_free(unixified);
10065 PerlMem_free(unixwild);
10066 PerlMem_free(lcres);
a3e9d8c9 10067 return 1;
a0d0e21e 10068 }
a0d0e21e
LW		 10069
10070} /* end of trim_unixpath() */
10071/*}}}*/
10072
a0d0e21e
LW		 10073
10074/*
10075 * VMS readdir() routines.
10076 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 10077 *
bd3fa61c 10078 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 10079 * Minor modifications to original routines.
10080 */
10081
a9852f7c
CB		 10082/* readdir may have been redefined by reentr.h, so make sure we get
10083 * the local version for what we do here.
10084 */
10085#ifdef readdir
10086# undef readdir
10087#endif
10088#if !defined(PERL_IMPLICIT_CONTEXT)
10089# define readdir Perl_readdir
10090#else
10091# define readdir(a) Perl_readdir(aTHX_ a)
10092#endif
10093
a0d0e21e
LW		 10094 /* Number of elements in vms_versions array */
10095#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10096
10097/*
10098 * Open a directory, return a handle for later use.
10099 */
10100/*{{{ DIR *opendir(char*name) */
ddcbaa1c 10101DIR *
b8ffc8df 10102Perl_opendir(pTHX_ const char *name)
a0d0e21e 10103{
ddcbaa1c 10104 DIR *dd;
657054d4 10105 char *dir;
61bb5906 10106 Stat_t sb;
657054d4
JM		 10107
10108 Newx(dir, VMS_MAXRSS, char);
4846f1d7 10109 if (int_tovmspath(name, dir, NULL) == NULL) {
657054d4 10110 Safefree(dir);
61bb5906 10111 return NULL;
a0d0e21e 10112 }
ada67d10
CB		 10113 /* Check access before stat; otherwise stat does not
10114 * accurately report whether it's a directory.
10115 */
0f669c9d
CB		 10116 if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10117 && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 10118 /* cando_by_name has already set errno */
657054d4 10119 Safefree(dir);
ada67d10
CB		 10120 return NULL;
10121 }
61bb5906
CB		 10122 if (flex_stat(dir,&sb) == -1) return NULL;
10123 if (!S_ISDIR(sb.st_mode)) {
657054d4 10124 Safefree(dir);
61bb5906
CB		 10125 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10126 return NULL;
10127 }
61bb5906 10128 /* Get memory for the handle, and the pattern. */
ddcbaa1c 10129 Newx(dd,1,DIR);
a02a5408 10130 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 10131
10132 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 10133 sprintf(dd->pattern, "%s*.*",dir);
657054d4 10134 Safefree(dir);
a0d0e21e
LW		 10135 dd->context = 0;
10136 dd->count = 0;
657054d4 10137 dd->flags = 0;
6d53ee29
CB		 10138 /* By saying we want the result of readdir() in unix format, we are really
10139 * saying we want all the escapes removed, translating characters that
10140 * must be escaped in a VMS-format name to their unescaped form, which is
10141 * presumably allowed in a Unix-format name.
a096370a 10142 */
6d53ee29 10143 dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
a0d0e21e
LW		 10144 dd->pat.dsc$a_pointer = dd->pattern;
10145 dd->pat.dsc$w_length = strlen(dd->pattern);
10146 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10147 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 10148#if defined(USE_ITHREADS)
a02a5408 10149 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 10150 MUTEX_INIT( (perl_mutex *) dd->mutex );
10151#else
10152 dd->mutex = NULL;
10153#endif
a0d0e21e
LW		 10154
10155 return dd;
10156} /* end of opendir() */
10157/*}}}*/
10158
10159/*
10160 * Set the flag to indicate we want versions or not.
10161 */
10162/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10163void
ddcbaa1c 10164vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 10165{
657054d4
JM		 10166 if (flag)
10167 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10168 else
10169 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 10170}
10171/*}}}*/
10172
10173/*
10174 * Free up an opened directory.
10175 */
10176/*{{{ void closedir(DIR *dd)*/
10177void
ddcbaa1c 10178Perl_closedir(DIR *dd)
a0d0e21e 10179{
f7ddb74a
JM		 10180 int sts;
10181
10182 sts = lib$find_file_end(&dd->context);
a0d0e21e 10183 Safefree(dd->pattern);
3bc25146 10184#if defined(USE_ITHREADS)
a9852f7c
CB		 10185 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10186 Safefree(dd->mutex);
10187#endif
f7ddb74a 10188 Safefree(dd);
a0d0e21e
LW		 10189}
10190/*}}}*/
10191
10192/*
10193 * Collect all the version numbers for the current file.
10194 */
10195static void
ddcbaa1c 10196collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 10197{
10198 struct dsc$descriptor_s pat;
10199 struct dsc$descriptor_s res;
ddcbaa1c 10200 struct dirent *e;
657054d4 10201 char *p, *text, *buff;
a0d0e21e
LW		 10202 int i;
10203 unsigned long context, tmpsts;
10204
10205 /* Convenient shorthand. */
10206 e = &dd->entry;
10207
10208 /* Add the version wildcard, ignoring the "*.*" put on before */
10209 i = strlen(dd->pattern);
a02a5408 10210 Newx(text,i + e->d_namlen + 3,char);
a35dcc95 10211 my_strlcpy(text, dd->pattern, i + 1);
f7ddb74a 10212 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 10213
10214 /* Set up the pattern descriptor. */
10215 pat.dsc$a_pointer = text;
10216 pat.dsc$w_length = i + e->d_namlen - 1;
10217 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10218 pat.dsc$b_class = DSC$K_CLASS_S;
10219
10220 /* Set up result descriptor. */
657054d4 10221 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10222 res.dsc$a_pointer = buff;
657054d4 10223 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10224 res.dsc$b_dtype = DSC$K_DTYPE_T;
10225 res.dsc$b_class = DSC$K_CLASS_S;
10226
10227 /* Read files, collecting versions. */
10228 for (context = 0, e->vms_verscount = 0;
10229 e->vms_verscount < VERSIZE(e);
10230 e->vms_verscount++) {
657054d4
JM		 10231 unsigned long rsts;
10232 unsigned long flags = 0;
10233
10234#ifdef VMS_LONGNAME_SUPPORT
988c775c 10235 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10236#endif
10237 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 10238 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 10239 _ckvmssts(tmpsts);
657054d4 10240 buff[VMS_MAXRSS - 1] = '\0';
748a9306 10241 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 10242 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10243 else
10244 e->vms_versions[e->vms_verscount] = -1;
10245 }
10246
748a9306 10247 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 10248 Safefree(text);
657054d4 10249 Safefree(buff);
a0d0e21e
LW		 10250
10251} /* end of collectversions() */
10252
10253/*
10254 * Read the next entry from the directory.
10255 */
10256/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 10257struct dirent *
10258Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 10259{
10260 struct dsc$descriptor_s res;
657054d4 10261 char *p, *buff;
a0d0e21e 10262 unsigned long int tmpsts;
657054d4
JM		 10263 unsigned long rsts;
10264 unsigned long flags = 0;
dca5a913 10265 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 10266 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 10267
10268 /* Set up result descriptor, and get next file. */
657054d4 10269 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10270 res.dsc$a_pointer = buff;
657054d4 10271 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10272 res.dsc$b_dtype = DSC$K_DTYPE_T;
10273 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 10274
10275#ifdef VMS_LONGNAME_SUPPORT
988c775c 10276 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10277#endif
10278
10279 tmpsts = lib$find_file
10280 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
66facaa3
CB		 10281 if (dd->context == 0)
10282 tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
10283
4633a7c4 10284 if (!(tmpsts & 1)) {
4633a7c4 10285 switch (tmpsts) {
66facaa3
CB		 10286 case RMS$_NMF:
10287 break; /* no more files considered success */
4633a7c4 10288 case RMS$_PRV:
66facaa3 10289 SETERRNO(EACCES, tmpsts); break;
4633a7c4 10290 case RMS$_DEV:
66facaa3 10291 SETERRNO(ENODEV, tmpsts); break;
4633a7c4 10292 case RMS$_DIR:
66facaa3 10293 SETERRNO(ENOTDIR, tmpsts); break;
f282b18d 10294 case RMS$_FNF: case RMS$_DNF:
66facaa3 10295 SETERRNO(ENOENT, tmpsts); break;
4633a7c4 10296 default:
66facaa3 10297 SETERRNO(EVMSERR, tmpsts);
4633a7c4 10298 }
657054d4 10299 Safefree(buff);
4633a7c4
LW		 10300 return NULL;
10301 }
10302 dd->count++;
a0d0e21e 10303 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
c43a0d1c
CB		 10304 buff[res.dsc$w_length] = '\0';
10305 p = buff + res.dsc$w_length;
10306 while (--p >= buff) if (!isspace(*p)) break;
10307 *p = '\0';
f7ddb74a 10308 if (!decc_efs_case_preserve) {
f7ddb74a 10309 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a 10310 }
a0d0e21e
LW		 10311
10312 /* Skip any directory component and just copy the name. */
657054d4 10313 sts = vms_split_path
360732b5 10314 (buff,
657054d4
JM		 10315 &v_spec,
10316 &v_len,
10317 &r_spec,
10318 &r_len,
10319 &d_spec,
10320 &d_len,
10321 &n_spec,
10322 &n_len,
10323 &e_spec,
10324 &e_len,
10325 &vs_spec,
10326 &vs_len);
10327
0dddfaca
JM		 10328 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10329
10330 /* In Unix report mode, remove the ".dir;1" from the name */
10331 /* if it is a real directory. */
d5eaec22 10332 if (decc_filename_unix_report && decc_efs_charset) {
f785e3a1
JM		 10333 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10334 Stat_t statbuf;
10335 int ret_sts;
10336
10337 ret_sts = flex_lstat(buff, &statbuf);
10338 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10339 e_len = 0;
10340 e_spec[0] = 0;
0dddfaca
JM		 10341 }
10342 }
10343 }
10344
10345 /* Drop NULL extensions on UNIX file specification */
10346 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10347 e_len = 0;
10348 e_spec[0] = '\0';
10349 }
dca5a913
JM		 10350 }
10351
a35dcc95 10352 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
657054d4 10353 dd->entry.d_name[n_len + e_len] = '\0';
a84b1d1f 10354 dd->entry.d_namlen = n_len + e_len;
a0d0e21e 10355
657054d4
JM		 10356 /* Convert the filename to UNIX format if needed */
10357 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10358
10359 /* Translate the encoded characters. */
38a44b82 10360 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 10361 if (strchr(dd->entry.d_name, '^') != NULL) {
10362 char new_name[256];
10363 char * q;
657054d4
JM		 10364 p = dd->entry.d_name;
10365 q = new_name;
10366 while (*p != 0) {
f617045b
CB		 10367 int inchars_read, outchars_added;
10368 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10369 p += inchars_read;
10370 q += outchars_added;
dca5a913 10371 /* fix-me */
f617045b 10372 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 10373 /* Wide file specifications need to be passed in Perl */
38a44b82 10374 /* counted strings apparently with a Unicode flag */
657054d4
JM		 10375 }
10376 *q = 0;
a35dcc95 10377 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
657054d4 10378 }
657054d4 10379 }
a0d0e21e 10380
a0d0e21e 10381 dd->entry.vms_verscount = 0;
657054d4
JM		 10382 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10383 Safefree(buff);
a0d0e21e
LW		 10384 return &dd->entry;
10385
10386} /* end of readdir() */
10387/*}}}*/
10388
10389/*
a9852f7c
CB		 10390 * Read the next entry from the directory -- thread-safe version.
10391 */
10392/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10393int
ddcbaa1c 10394Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 10395{
10396 int retval;
10397
10398 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10399
7ded3206 10400 entry = readdir(dd);
a9852f7c
CB		 10401 *result = entry;
10402 retval = ( *result == NULL ? errno : 0 );
10403
10404 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10405
10406 return retval;
10407
10408} /* end of readdir_r() */
10409/*}}}*/
10410
10411/*
a0d0e21e
LW		 10412 * Return something that can be used in a seekdir later.
10413 */
10414/*{{{ long telldir(DIR *dd)*/
10415long
ddcbaa1c 10416Perl_telldir(DIR *dd)
a0d0e21e
LW		 10417{
10418 return dd->count;
10419}
10420/*}}}*/
10421
10422/*
10423 * Return to a spot where we used to be. Brute force.
10424 */
10425/*{{{ void seekdir(DIR *dd,long count)*/
10426void
ddcbaa1c 10427Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 10428{
657054d4 10429 int old_flags;
a0d0e21e
LW		 10430
10431 /* If we haven't done anything yet... */
10432 if (dd->count == 0)
10433 return;
10434
10435 /* Remember some state, and clear it. */
657054d4
JM		 10436 old_flags = dd->flags;
10437 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 10438 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 10439 dd->context = 0;
10440
10441 /* The increment is in readdir(). */
10442 for (dd->count = 0; dd->count < count; )
f7ddb74a 10443 readdir(dd);
a0d0e21e 10444
657054d4 10445 dd->flags = old_flags;
a0d0e21e
LW		 10446
10447} /* end of seekdir() */
10448/*}}}*/
10449
10450/* VMS subprocess management
10451 *
10452 * my_vfork() - just a vfork(), after setting a flag to record that
10453 * the current script is trying a Unix-style fork/exec.
10454 *
10455 * vms_do_aexec() and vms_do_exec() are called in response to the
10456 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 10457 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 10458 * execvp (for those who really want to try this under VMS).
10459 * Otherwise, they do exactly what the perl docs say exec should
10460 * do - terminate the current script and invoke a new command
10461 * (See below for notes on command syntax.)
10462 *
10463 * do_aspawn() and do_spawn() implement the VMS side of the perl
10464 * 'system' function.
10465 *
10466 * Note on command arguments to perl 'exec' and 'system': When handled
10467 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 10468 * are concatenated to form a DCL command string. If the first non-numeric
10469 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 10470 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 10471 * the first token of the command is taken as the filespec of an image
10472 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 10473 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 10474 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 10475 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 10476 * but I hope it will form a happy medium between what VMS folks expect
10477 * from lib$spawn and what Unix folks expect from exec.
10478 */
10479
10480static int vfork_called;
10481
f7c699a0 10482/*{{{int my_vfork(void)*/
a0d0e21e 10483int
f7c699a0 10484my_vfork(void)
a0d0e21e 10485{
748a9306 10486 vfork_called++;
a0d0e21e
LW		 10487 return vfork();
10488}
10489/*}}}*/
10490
4633a7c4 10491
a0d0e21e 10492static void
218fdd94
CL		 10493vms_execfree(struct dsc$descriptor_s *vmscmd)
10494{
10495 if (vmscmd) {
10496 if (vmscmd->dsc$a_pointer) {
c5375c28 10497 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 10498 }
c5375c28 10499 PerlMem_free(vmscmd);
4633a7c4
LW		 10500 }
10501}
10502
10503static char *
fd8cd3a3 10504setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 10505{
4e205ed6 10506 char *junk, *tmps = NULL;
eb578fdb 10507 size_t cmdlen = 0;
a0d0e21e 10508 size_t rlen;
eb578fdb 10509 SV **idx;
2d8e6c8d 10510 STRLEN n_a;
a0d0e21e
LW		 10511
10512 idx = mark;
4633a7c4
LW		 10513 if (really) {
10514 tmps = SvPV(really,rlen);
10515 if (*tmps) {
10516 cmdlen += rlen + 1;
10517 idx++;
10518 }
a0d0e21e
LW		 10519 }
10520
10521 for (idx++; idx <= sp; idx++) {
10522 if (*idx) {
10523 junk = SvPVx(*idx,rlen);
10524 cmdlen += rlen ? rlen + 1 : 0;
10525 }
10526 }
c5375c28 10527 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 10528
4633a7c4 10529 if (tmps && *tmps) {
a35dcc95 10530 my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
a0d0e21e
LW		 10531 mark++;
10532 }
6b88bc9c 10533 else *PL_Cmd = '\0';
a0d0e21e
LW		 10534 while (++mark <= sp) {
10535 if (*mark) {
3eeba6fb
CB		 10536 char *s = SvPVx(*mark,n_a);
10537 if (!*s) continue;
a35dcc95
CB		 10538 if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10539 my_strlcat(PL_Cmd, s, cmdlen+1);
a0d0e21e
LW		 10540 }
10541 }
6b88bc9c 10542 return PL_Cmd;
a0d0e21e
LW		 10543
10544} /* end of setup_argstr() */
10545
4633a7c4 10546
a0d0e21e 10547static unsigned long int
2fbb330f 10548setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 10549 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 10550{
e919cd19
JM		 10551 char * vmsspec;
10552 char * resspec;
e886094b
JM		 10553 char image_name[NAM$C_MAXRSS+1];
10554 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 10555 $DESCRIPTOR(defdsc,".EXE");
8012a33e 10556 $DESCRIPTOR(defdsc2,".");
e919cd19 10557 struct dsc$descriptor_s resdsc;
218fdd94 10558 struct dsc$descriptor_s *vmscmd;
a0d0e21e 10559 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 10560 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
eb578fdb 10561 char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 10562 char * cmd;
10563 int cmdlen;
eb578fdb 10564 int isdcl;
a0d0e21e 10565
426fe37a 10566 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
ebd4d70b 10567 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 10568
e919cd19 10569 /* vmsspec is a DCL command buffer, not just a filename */
c11536f5 10570 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
e919cd19
JM		 10571 if (vmsspec == NULL)
10572 _ckvmssts_noperl(SS$_INSFMEM);
10573
c11536f5 10574 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
e919cd19
JM		 10575 if (resspec == NULL)
10576 _ckvmssts_noperl(SS$_INSFMEM);
10577
2fbb330f
JM		 10578 /* Make a copy for modification */
10579 cmdlen = strlen(incmd);
c11536f5 10580 cmd = (char *)PerlMem_malloc(cmdlen+1);
ebd4d70b 10581 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 10582 my_strlcpy(cmd, incmd, cmdlen + 1);
e886094b
JM		 10583 image_name[0] = 0;
10584 image_argv[0] = 0;
2fbb330f 10585
e919cd19
JM		 10586 resdsc.dsc$a_pointer = resspec;
10587 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10588 resdsc.dsc$b_class = DSC$K_CLASS_S;
10589 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10590
218fdd94
CL		 10591 vmscmd->dsc$a_pointer = NULL;
10592 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10593 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10594 vmscmd->dsc$w_length = 0;
10595 if (pvmscmd) *pvmscmd = vmscmd;
10596
ff7adb52
CL		 10597 if (suggest_quote) *suggest_quote = 0;
10598
2fbb330f 10599 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 10600 PerlMem_free(cmd);
e919cd19
JM		 10601 PerlMem_free(vmsspec);
10602 PerlMem_free(resspec);
a2669cfc 10603 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 10604 }
10605
a0d0e21e 10606 s = cmd;
2fbb330f 10607
a0d0e21e 10608 while (*s && isspace(*s)) s++;
aa779de1
CB		 10609
10610 if (*s == '@' || *s == '$') {
10611 vmsspec[0] = *s; rest = s + 1;
10612 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10613 }
10614 else { cp = vmsspec; rest = s; }
22831cc5
CB		 10615
10616 /* If the first word is quoted, then we need to unquote it and
10617 * escape spaces within it. We'll expand into the resspec buffer,
10618 * then copy back into the cmd buffer, expanding the latter if
10619 * necessary.
10620 */
10621 if (*rest == '"') {
10622 char *cp2;
10623 char *r = rest;
10624 bool in_quote = 0;
10625 int clen = cmdlen;
10626 int soff = s - cmd;
10627
10628 for (cp2 = resspec;
10629 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10630 rest++) {
10631
10632 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10633 *cp2 = '^';
10634 *(++cp2) = '_';
10635 cp2++;
10636 clen++;
10637 }
10638 else if (*rest == '"') {
10639 clen--;
10640 if (in_quote) { /* Must be closing quote. */
10641 rest++;
10642 break;
10643 }
10644 in_quote = 1;
10645 }
10646 else {
10647 *cp2 = *rest;
10648 cp2++;
10649 }
10650 }
10651 *cp2 = '\0';
10652
10653 /* Expand the command buffer if necessary. */
10654 if (clen > cmdlen) {
223c162b 10655 cmd = (char *)PerlMem_realloc(cmd, clen);
22831cc5
CB		 10656 if (cmd == NULL)
10657 _ckvmssts_noperl(SS$_INSFMEM);
10658 /* Where we are may have changed, so recompute offsets */
10659 r = cmd + (r - s - soff);
10660 rest = cmd + (rest - s - soff);
10661 s = cmd + soff;
10662 }
10663
10664 /* Shift the non-verb portion of the command (if any) up or
10665 * down as necessary.
10666 */
10667 if (*rest)
10668 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10669
10670 /* Copy the unquoted and escaped command verb into place. */
10671 memcpy(r, resspec, cp2 - resspec);
10672 cmd[clen] = '\0';
10673 cmdlen = clen;
10674 rest = r; /* Rewind for subsequent operations. */
10675 }
10676
aa779de1
CB		 10677 if (*rest == '.' || *rest == '/') {
10678 char *cp2;
10679 for (cp2 = resspec;
e919cd19 10680 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
aa779de1
CB		 10681 rest++, cp2++) *cp2 = *rest;
10682 *cp2 = '\0';
df278665 10683 if (int_tovmsspec(resspec, cp, 0, NULL)) {
aa779de1 10684 s = vmsspec;
cfbf46cd
JM		 10685
10686 /* When a UNIX spec with no file type is translated to VMS, */
10687 /* A trailing '.' is appended under ODS-5 rules. */
10688 /* Here we do not want that trailing "." as it prevents */
10689 /* Looking for a implied ".exe" type. */
10690 if (decc_efs_charset) {
10691 int i;
10692 i = strlen(vmsspec);
10693 if (vmsspec[i-1] == '.') {
10694 vmsspec[i-1] = '\0';
10695 }
10696 }
10697
aa779de1
CB		 10698 if (*rest) {
10699 for (cp2 = vmsspec + strlen(vmsspec);
e919cd19 10700 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
aa779de1
CB		 10701 rest++, cp2++) *cp2 = *rest;
10702 *cp2 = '\0';
a0d0e21e
LW		 10703 }
10704 }
10705 }
aa779de1
CB		 10706 /* Intuit whether verb (first word of cmd) is a DCL command:
10707 * - if first nonspace char is '@', it's a DCL indirection
10708 * otherwise
10709 * - if verb contains a filespec separator, it's not a DCL command
10710 * - if it doesn't, caller tells us whether to default to a DCL
10711 * command, or to a local image unless told it's DCL (by leading '$')
10712 */
ff7adb52
CL		 10713 if (*s == '@') {
10714 isdcl = 1;
10715 if (suggest_quote) *suggest_quote = 1;
10716 } else {
eb578fdb 10717 char *filespec = strpbrk(s,":<[.;");
aa779de1
CB		 10718 rest = wordbreak = strpbrk(s," \"\t/");
10719 if (!wordbreak) wordbreak = s + strlen(s);
10720 if (*s == '$') check_img = 0;
10721 if (filespec && (filespec < wordbreak)) isdcl = 0;
10722 else isdcl = !check_img;
10723 }
10724
3eeba6fb 10725 if (!isdcl) {
dca5a913 10726 int rsts;
aa779de1
CB		 10727 imgdsc.dsc$a_pointer = s;
10728 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 10729 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e 10730 if (!(retsts&1)) {
ebd4d70b 10731 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10732 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f 10733 if (!(retsts & 1) && *s == '$') {
ebd4d70b 10734 _ckvmssts_noperl(lib$find_file_end(&cxt));
2497a41f 10735 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 10736 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f 10737 if (!(retsts&1)) {
ebd4d70b 10738 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10739 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 10740 }
10741 }
aa779de1 10742 }
ebd4d70b 10743 _ckvmssts_noperl(lib$find_file_end(&cxt));
8012a33e 10744
aa779de1 10745 if (retsts & 1) {
8012a33e 10746 FILE *fp;
a0d0e21e
LW		 10747 s = resspec;
10748 while (*s && !isspace(*s)) s++;
10749 *s = '\0';
8012a33e
CB		 10750
10751 /* check that it's really not DCL with no file extension */
e886094b 10752 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 10753 if (fp) {
2497a41f
JM		 10754 char b[256] = {0,0,0,0};
10755 read(fileno(fp), b, 256);
8012a33e 10756 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 10757 if (isdcl) {
e886094b
JM		 10758 int shebang_len;
10759
2497a41f 10760 /* Check for script */
e886094b
JM		 10761 shebang_len = 0;
10762 if ((b[0] == '#') && (b[1] == '!'))
10763 shebang_len = 2;
10764#ifdef ALTERNATE_SHEBANG
10765 else {
10766 shebang_len = strlen(ALTERNATE_SHEBANG);
10767 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10768 char * perlstr;
10769 perlstr = strstr("perl",b);
10770 if (perlstr == NULL)
10771 shebang_len = 0;
10772 }
10773 else
10774 shebang_len = 0;
10775 }
10776#endif
10777
10778 if (shebang_len > 0) {
10779 int i;
10780 int j;
10781 char tmpspec[NAM$C_MAXRSS + 1];
10782
10783 i = shebang_len;
10784 /* Image is following after white space */
10785 /*--------------------------------------*/
10786 while (isprint(b[i]) && isspace(b[i]))
10787 i++;
10788
10789 j = 0;
10790 while (isprint(b[i]) && !isspace(b[i])) {
10791 tmpspec[j++] = b[i++];
10792 if (j >= NAM$C_MAXRSS)
10793 break;
10794 }
10795 tmpspec[j] = '\0';
10796
10797 /* There may be some default parameters to the image */
10798 /*---------------------------------------------------*/
10799 j = 0;
10800 while (isprint(b[i])) {
10801 image_argv[j++] = b[i++];
10802 if (j >= NAM$C_MAXRSS)
10803 break;
10804 }
10805 while ((j > 0) && !isprint(image_argv[j-1]))
10806 j--;
10807 image_argv[j] = 0;
10808
2497a41f 10809 /* It will need to be converted to VMS format and validated */
e886094b
JM		 10810 if (tmpspec[0] != '\0') {
10811 char * iname;
10812
10813 /* Try to find the exact program requested to be run */
10814 /*---------------------------------------------------*/
6fb6c614
JM		 10815 iname = int_rmsexpand
10816 (tmpspec, image_name, ".exe",
360732b5 10817 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10818 if (iname != NULL) {
a1887106
JM		 10819 if (cando_by_name_int
10820 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10821 /* MCR prefix needed */
10822 isdcl = 0;
10823 }
10824 else {
10825 /* Try again with a null type */
10826 /*----------------------------*/
6fb6c614
JM		 10827 iname = int_rmsexpand
10828 (tmpspec, image_name, ".",
360732b5 10829 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10830 if (iname != NULL) {
a1887106
JM		 10831 if (cando_by_name_int
10832 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10833 /* MCR prefix needed */
10834 isdcl = 0;
10835 }
10836 }
10837 }
10838
10839 /* Did we find the image to run the script? */
10840 /*------------------------------------------*/
10841 if (isdcl) {
10842 char *tchr;
10843
10844 /* Assume DCL or foreign command exists */
10845 /*--------------------------------------*/
10846 tchr = strrchr(tmpspec, '/');
10847 if (tchr != NULL) {
10848 tchr++;
10849 }
10850 else {
10851 tchr = tmpspec;
10852 }
a35dcc95 10853 my_strlcpy(image_name, tchr, sizeof(image_name));
e886094b
JM		 10854 }
10855 }
10856 }
2497a41f
JM		 10857 }
10858 }
8012a33e
CB		 10859 fclose(fp);
10860 }
e919cd19
JM		 10861 if (check_img && isdcl) {
10862 PerlMem_free(cmd);
10863 PerlMem_free(resspec);
10864 PerlMem_free(vmsspec);
10865 return RMS$_FNF;
10866 }
8012a33e 10867
3eeba6fb 10868 if (cando_by_name(S_IXUSR,0,resspec)) {
c11536f5 10869 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
ebd4d70b 10870 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012a33e 10871 if (!isdcl) {
a35dcc95 10872 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
e886094b 10873 if (image_name[0] != 0) {
a35dcc95
CB		 10874 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10875 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10876 }
10877 } else if (image_name[0] != 0) {
a35dcc95
CB		 10878 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10879 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
8012a33e 10880 } else {
a35dcc95 10881 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
8012a33e 10882 }
e886094b
JM		 10883 if (suggest_quote) *suggest_quote = 1;
10884
10885 /* If there is an image name, use original command */
10886 if (image_name[0] == 0)
a35dcc95 10887 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10888 else {
10889 rest = cmd;
10890 while (*rest && isspace(*rest)) rest++;
10891 }
10892
10893 if (image_argv[0] != 0) {
a35dcc95
CB		 10894 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10895 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10896 }
10897 if (rest) {
10898 int rest_len;
10899 int vmscmd_len;
10900
10901 rest_len = strlen(rest);
10902 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10903 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
a35dcc95 10904 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10905 else
10906 retsts = CLI$_BUFOVF;
10907 }
218fdd94 10908 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10909 PerlMem_free(cmd);
e919cd19
JM		 10910 PerlMem_free(vmsspec);
10911 PerlMem_free(resspec);
218fdd94 10912 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10913 }
c5375c28
JM		 10914 else
10915 retsts = RMS$_PRV;
a0d0e21e
LW		 10916 }
10917 }
3eeba6fb 10918 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10919 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10920
c11536f5 10921 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
a35dcc95 10922 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
c5375c28
JM		 10923
10924 PerlMem_free(cmd);
e919cd19
JM		 10925 PerlMem_free(resspec);
10926 PerlMem_free(vmsspec);
2fbb330f 10927
ff7adb52
CL		 10928 /* check if it's a symbol (for quoting purposes) */
10929 if (suggest_quote && !*suggest_quote) {
10930 int iss;
10931 char equiv[LNM$C_NAMLENGTH];
10932 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10933 eqvdsc.dsc$a_pointer = equiv;
10934
218fdd94 10935 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10936 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10937 }
3eeba6fb
CB		 10938 if (!(retsts & 1)) {
10939 /* just hand off status values likely to be due to user error */
10940 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10941 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10942 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
ebd4d70b 10943 else { _ckvmssts_noperl(retsts); }
3eeba6fb 10944 }
a0d0e21e 10945
218fdd94 10946 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10947
a0d0e21e
LW		 10948} /* end of setup_cmddsc() */
10949
a3e9d8c9 10950
a0d0e21e
LW		 10951/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10952bool
fd8cd3a3 10953Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10954{
ce12d4b7
CB		 10955 bool exec_sts;
10956 char * cmd;
c5375c28 10957
a0d0e21e
LW		 10958 if (sp > mark) {
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_aexec(really,mark,sp);
a0d0e21e 10966 }
4633a7c4 10967 /* no vfork - act VMSish */
c5375c28
JM		 10968 cmd = setup_argstr(aTHX_ really,mark,sp);
10969 exec_sts = vms_do_exec(cmd);
10970 Safefree(cmd); /* Clean up from setup_argstr() */
10971 return exec_sts;
a0d0e21e
LW		 10972 }
10973
10974 return FALSE;
10975} /* end of vms_do_aexec() */
10976/*}}}*/
10977
10978/* {{{bool vms_do_exec(char *cmd) */
10979bool
2fbb330f 10980Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10981{
218fdd94 10982 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10983
10984 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10985 vfork_called--;
10986 if (vfork_called < 0) {
5c84aa53 10987 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10988 vfork_called = 0;
10989 }
10990 else return do_exec(cmd);
a0d0e21e 10991 }
748a9306
LW		 10992
10993 { /* no vfork - act VMSish */
748a9306 10994 unsigned long int retsts;
a0d0e21e 10995
1e422769 10996 TAINT_ENV();
10997 TAINT_PROPER("exec");
218fdd94
CL		 10998 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10999 retsts = lib$do_command(vmscmd);
a0d0e21e 11000
09b7f37c 11001 switch (retsts) {
f282b18d 11002 case RMS$_FNF: case RMS$_DNF:
09b7f37c 11003 set_errno(ENOENT); break;
f282b18d 11004 case RMS$_DIR:
09b7f37c 11005 set_errno(ENOTDIR); break;
f282b18d
CB		 11006 case RMS$_DEV:
11007 set_errno(ENODEV); break;
09b7f37c
CB		 11008 case RMS$_PRV:
11009 set_errno(EACCES); break;
11010 case RMS$_SYN:
11011 set_errno(EINVAL); break;
a2669cfc 11012 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 11013 set_errno(E2BIG); break;
11014 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 11015 _ckvmssts_noperl(retsts); /* fall through */
09b7f37c
CB		 11016 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11017 set_errno(EVMSERR);
11018 }
748a9306 11019 set_vaxc_errno(retsts);
3eeba6fb 11020 if (ckWARN(WARN_EXEC)) {
f98bc0c6 11021 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 11022 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 11023 }
218fdd94 11024 vms_execfree(vmscmd);
a0d0e21e
LW		 11025 }
11026
11027 return FALSE;
11028
11029} /* end of vms_do_exec() */
11030/*}}}*/
11031
9ec7171b 11032int do_spawn2(pTHX_ const char *, int);
a0d0e21e 11033
9ec7171b
CB		 11034int
11035Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
a0d0e21e 11036{
ce12d4b7
CB		 11037 unsigned long int sts;
11038 char * cmd;
11039 int flags = 0;
a0d0e21e 11040
c5375c28 11041 if (sp > mark) {
eed5d6a1
CB		 11042
11043 /* We'll copy the (undocumented?) Win32 behavior and allow a
11044 * numeric first argument. But the only value we'll support
11045 * through do_aspawn is a value of 1, which means spawn without
11046 * waiting for completion -- other values are ignored.
11047 */
9ec7171b 11048 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
eed5d6a1 11049 ++mark;
9ec7171b 11050 flags = SvIVx(*mark);
eed5d6a1
CB		 11051 }
11052
11053 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11054 flags = CLI$M_NOWAIT;
11055 else
11056 flags = 0;
11057
9ec7171b 11058 cmd = setup_argstr(aTHX_ really, mark, sp);
eed5d6a1 11059 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 11060 /* pp_sys will clean up cmd */
11061 return sts;
11062 }
a0d0e21e
LW		 11063 return SS$_ABORT;
11064} /* end of do_aspawn() */
11065/*}}}*/
11066
eed5d6a1 11067
9ec7171b
CB		 11068/* {{{int do_spawn(char* cmd) */
11069int
11070Perl_do_spawn(pTHX_ char* cmd)
a0d0e21e 11071{
7918f24d
NC		 11072 PERL_ARGS_ASSERT_DO_SPAWN;
11073
eed5d6a1
CB		 11074 return do_spawn2(aTHX_ cmd, 0);
11075}
11076/*}}}*/
11077
9ec7171b
CB		 11078/* {{{int do_spawn_nowait(char* cmd) */
11079int
11080Perl_do_spawn_nowait(pTHX_ char* cmd)
11081{
11082 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11083
11084 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11085}
11086/*}}}*/
11087
11088/* {{{int do_spawn2(char *cmd) */
11089int
eed5d6a1
CB		 11090do_spawn2(pTHX_ const char *cmd, int flags)
11091{
209030df 11092 unsigned long int sts, substs;
a0d0e21e 11093
c5375c28
JM		 11094 /* The caller of this routine expects to Safefree(PL_Cmd) */
11095 Newx(PL_Cmd,10,char);
11096
1e422769 11097 TAINT_ENV();
11098 TAINT_PROPER("spawn");
748a9306 11099 if (!cmd || !*cmd) {
eed5d6a1 11100 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 11101 if (!(sts & 1)) {
11102 switch (sts) {
209030df
JH		 11103 case RMS$_FNF: case RMS$_DNF:
11104 set_errno(ENOENT); break;
11105 case RMS$_DIR:
11106 set_errno(ENOTDIR); break;
11107 case RMS$_DEV:
11108 set_errno(ENODEV); break;
11109 case RMS$_PRV:
11110 set_errno(EACCES); break;
11111 case RMS$_SYN:
11112 set_errno(EINVAL); break;
11113 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11114 set_errno(E2BIG); break;
11115 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 11116 _ckvmssts_noperl(sts); /* fall through */
209030df
JH		 11117 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11118 set_errno(EVMSERR);
c8795d8b
JH		 11119 }
11120 set_vaxc_errno(sts);
11121 if (ckWARN(WARN_EXEC)) {
f98bc0c6 11122 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 11123 Strerror(errno));
11124 }
09b7f37c 11125 }
c8795d8b 11126 sts = substs;
48023aa8
CL		 11127 }
11128 else {
eed5d6a1 11129 char mode[3];
2fbb330f 11130 PerlIO * fp;
eed5d6a1
CB		 11131 if (flags & CLI$M_NOWAIT)
11132 strcpy(mode, "n");
11133 else
11134 strcpy(mode, "nW");
11135
11136 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 11137 if (fp != NULL)
11138 my_pclose(fp);
7d78c51a
CB		 11139 /* sts will be the pid in the nowait case, so leave a
11140 * hint saying not to do any bit shifting to it.
11141 */
11142 if (flags & CLI$M_NOWAIT)
11143 PL_statusvalue = -1;
48023aa8 11144 }
48023aa8 11145 return sts;
eed5d6a1 11146} /* end of do_spawn2() */
a0d0e21e
LW		 11147/*}}}*/
11148
bc10a425
CB		 11149
11150static unsigned int *sockflags, sockflagsize;
11151
11152/*
11153 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11154 * routines found in some versions of the CRTL can't deal with sockets.
11155 * We don't shim the other file open routines since a socket isn't
11156 * likely to be opened by a name.
11157 */
275feba9 11158/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
ce12d4b7
CB		 11159FILE *
11160my_fdopen(int fd, const char *mode)
bc10a425 11161{
f7ddb74a 11162 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 11163
11164 if (fp) {
11165 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 11166 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 11167 if (!sockflagsize || fdoff > sockflagsize) {
11168 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 11169 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 11170 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11171 sockflagsize = fdoff + 2;
11172 }
312ac60b 11173 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 11174 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11175 }
11176 return fp;
11177
11178}
11179/*}}}*/
11180
11181
11182/*
11183 * Clear the corresponding bit when the (possibly) socket stream is closed.
11184 * There still a small hole: we miss an implicit close which might occur
11185 * via freopen(). >> Todo
11186 */
11187/*{{{ int my_fclose(FILE *fp)*/
ce12d4b7
CB		 11188int
11189my_fclose(FILE *fp) {
bc10a425
CB		 11190 if (fp) {
11191 unsigned int fd = fileno(fp);
11192 unsigned int fdoff = fd / sizeof(unsigned int);
11193
e0951028 11194 if (sockflagsize && fdoff < sockflagsize)
bc10a425
CB		 11195 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11196 }
11197 return fclose(fp);
11198}
11199/*}}}*/
11200
11201
a0d0e21e
LW		 11202/*
11203 * A simple fwrite replacement which outputs itmsz*nitm chars without
11204 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 11205 * We are using fputs, which depends on a terminating null. We may
11206 * well be writing binary data, so we need to accommodate not only
11207 * data with nulls sprinkled in the middle but also data with no null
11208 * byte at the end.
a0d0e21e 11209 */
a15cef0c 11210/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 11211int
a15cef0c 11212my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 11213{
eb578fdb 11214 char *cp, *end, *cpd;
2e05a54c 11215 char *data;
eb578fdb
KW		 11216 unsigned int fd = fileno(dest);
11217 unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 11218 int retval;
bc10a425
CB		 11219 int bufsize = itmsz * nitm + 1;
11220
11221 if (fdoff < sockflagsize &&
11222 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11223 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11224 return nitm;
11225 }
22d4bb9c 11226
bc10a425 11227 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 11228 memcpy( data, src, itmsz*nitm );
11229 data[itmsz*nitm] = '\0';
a0d0e21e 11230
22d4bb9c
CB		 11231 end = data + itmsz * nitm;
11232 retval = (int) nitm; /* on success return # items written */
a0d0e21e 11233
22d4bb9c
CB		 11234 cpd = data;
11235 while (cpd <= end) {
11236 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11237 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 11238 if (cp < end)
22d4bb9c
CB		 11239 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11240 cpd = cp + 1;
a0d0e21e
LW		 11241 }
11242
bc10a425 11243 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 11244 return retval;
a0d0e21e
LW		 11245
11246} /* end of my_fwrite() */
11247/*}}}*/
11248
d27fe803
JH		 11249/*{{{ int my_flush(FILE *fp)*/
11250int
fd8cd3a3 11251Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 11252{
11253 int res;
93948341 11254 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 11255#ifdef VMS_DO_SOCKETS
61bb5906 11256 Stat_t s;
ed1b9de0 11257 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
d27fe803
JH		 11258#endif
11259 res = fsync(fileno(fp));
11260 }
22d4bb9c
CB		 11261/*
11262 * If the flush succeeded but set end-of-file, we need to clear
11263 * the error because our caller may check ferror(). BTW, this
11264 * probably means we just flushed an empty file.
11265 */
11266 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11267
d27fe803
JH		 11268 return res;
11269}
11270/*}}}*/
11271
bf8d1304
JM		 11272/* fgetname() is not returning the correct file specifications when
11273 * decc_filename_unix_report mode is active. So we have to have it
11274 * aways return filenames in VMS mode and convert it ourselves.
11275 */
11276
11277/*{{{ char * my_fgetname(FILE *fp, buf)*/
11278char *
11279Perl_my_fgetname(FILE *fp, char * buf) {
11280 char * retname;
11281 char * vms_name;
11282
11283 retname = fgetname(fp, buf, 1);
11284
11285 /* If we are in VMS mode, then we are done */
11286 if (!decc_filename_unix_report || (retname == NULL)) {
11287 return retname;
11288 }
11289
11290 /* Convert this to Unix format */
c11536f5 11291 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 11292 my_strlcpy(vms_name, retname, VMS_MAXRSS);
bf8d1304
JM		 11293 retname = int_tounixspec(vms_name, buf, NULL);
11294 PerlMem_free(vms_name);
11295
11296 return retname;
11297}
11298/*}}}*/
11299
748a9306
LW		 11300/*
11301 * Here are replacements for the following Unix routines in the VMS environment:
11302 * getpwuid Get information for a particular UIC or UID
11303 * getpwnam Get information for a named user
11304 * getpwent Get information for each user in the rights database
11305 * setpwent Reset search to the start of the rights database
11306 * endpwent Finish searching for users in the rights database
11307 *
11308 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11309 * (defined in pwd.h), which contains the following fields:-
11310 * struct passwd {
11311 * char *pw_name; Username (in lower case)
11312 * char *pw_passwd; Hashed password
11313 * unsigned int pw_uid; UIC
11314 * unsigned int pw_gid; UIC group number
11315 * char *pw_unixdir; Default device/directory (VMS-style)
11316 * char *pw_gecos; Owner name
11317 * char *pw_dir; Default device/directory (Unix-style)
11318 * char *pw_shell; Default CLI name (eg. DCL)
11319 * };
11320 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11321 *
11322 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11323 * not the UIC member number (eg. what's returned by getuid()),
11324 * getpwuid() can accept either as input (if uid is specified, the caller's
11325 * UIC group is used), though it won't recognise gid=0.
11326 *
11327 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11328 * information about other users in your group or in other groups, respectively.
11329 * If the required privilege is not available, then these routines fill only
11330 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11331 * string).
11332 *
11333 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11334 */
11335
11336/* sizes of various UAF record fields */
11337#define UAI$S_USERNAME 12
11338#define UAI$S_IDENT 31
11339#define UAI$S_OWNER 31
11340#define UAI$S_DEFDEV 31
11341#define UAI$S_DEFDIR 63
11342#define UAI$S_DEFCLI 31
11343#define UAI$S_PWD 8
11344
11345#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11346 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11347 (uic).uic$v_group != UIC$K_WILD_GROUP)
11348
4633a7c4
LW		 11349static char __empty[]= "";
11350static struct passwd __passwd_empty=
748a9306
LW		 11351 {(char *) __empty, (char *) __empty, 0, 0,
11352 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11353static int contxt= 0;
11354static struct passwd __pwdcache;
11355static char __pw_namecache[UAI$S_IDENT+1];
11356
748a9306
LW		 11357/*
11358 * This routine does most of the work extracting the user information.
11359 */
ce12d4b7
CB		 11360static int
11361fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 11362{
748a9306
LW		 11363 static struct {
11364 unsigned char length;
11365 char pw_gecos[UAI$S_OWNER+1];
11366 } owner;
11367 static union uicdef uic;
11368 static struct {
11369 unsigned char length;
11370 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11371 } defdev;
11372 static struct {
11373 unsigned char length;
11374 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11375 } defdir;
11376 static struct {
11377 unsigned char length;
11378 char pw_shell[UAI$S_DEFCLI+1];
11379 } defcli;
11380 static char pw_passwd[UAI$S_PWD+1];
11381
11382 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11383 struct dsc$descriptor_s name_desc;
c07a80fd 11384 unsigned long int sts;
748a9306 11385
4633a7c4 11386 static struct itmlst_3 itmlst[]= {
748a9306
LW		 11387 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11388 {sizeof(uic), UAI$_UIC, &uic, &luic},
11389 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11390 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11391 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11392 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11393 {0, 0, NULL, NULL}};
11394
11395 name_desc.dsc$w_length= strlen(name);
11396 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11397 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 11398 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 11399
11400/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 11401 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11402 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11403 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11404 }
11405 else { _ckvmssts(sts); }
11406 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 11407
11408 if ((int) owner.length < lowner) lowner= (int) owner.length;
11409 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11410 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11411 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11412 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11413 owner.pw_gecos[lowner]= '\0';
11414 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11415 defcli.pw_shell[ldefcli]= '\0';
11416 if (valid_uic(uic)) {
11417 pwd->pw_uid= uic.uic$l_uic;
11418 pwd->pw_gid= uic.uic$v_group;
11419 }
11420 else
5c84aa53 11421 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 11422 pwd->pw_passwd= pw_passwd;
11423 pwd->pw_gecos= owner.pw_gecos;
11424 pwd->pw_dir= defdev.pw_dir;
360732b5 11425 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 11426 pwd->pw_shell= defcli.pw_shell;
11427 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11428 int ldir;
11429 ldir= strlen(pwd->pw_unixdir) - 1;
11430 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11431 }
11432 else
a35dcc95 11433 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
f7ddb74a
JM		 11434 if (!decc_efs_case_preserve)
11435 __mystrtolower(pwd->pw_unixdir);
c07a80fd 11436 return 1;
a0d0e21e 11437}
748a9306
LW		 11438
11439/*
11440 * Get information for a named user.
11441*/
11442/*{{{struct passwd *getpwnam(char *name)*/
ce12d4b7
CB		 11443struct passwd *
11444Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 11445{
11446 struct dsc$descriptor_s name_desc;
11447 union uicdef uic;
4e0c9737 11448 unsigned long int sts;
748a9306
LW		 11449
11450 __pwdcache = __passwd_empty;
fd8cd3a3 11451 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 11452 /* We still may be able to determine pw_uid and pw_gid */
11453 name_desc.dsc$w_length= strlen(name);
11454 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11455 name_desc.dsc$b_class= DSC$K_CLASS_S;
11456 name_desc.dsc$a_pointer= (char *) name;
aa689395 11457 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 11458 __pwdcache.pw_uid= uic.uic$l_uic;
11459 __pwdcache.pw_gid= uic.uic$v_group;
11460 }
c07a80fd 11461 else {
aa689395 11462 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11463 set_vaxc_errno(sts);
11464 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 11465 return NULL;
11466 }
aa689395 11467 else { _ckvmssts(sts); }
c07a80fd 11468 }
748a9306 11469 }
a35dcc95 11470 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
748a9306
LW		 11471 __pwdcache.pw_name= __pw_namecache;
11472 return &__pwdcache;
11473} /* end of my_getpwnam() */
a0d0e21e
LW		 11474/*}}}*/
11475
748a9306
LW		 11476/*
11477 * Get information for a particular UIC or UID.
11478 * Called by my_getpwent with uid=-1 to list all users.
11479*/
11480/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
ce12d4b7
CB		 11481struct passwd *
11482Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 11483{
748a9306
LW		 11484 const $DESCRIPTOR(name_desc,__pw_namecache);
11485 unsigned short lname;
11486 union uicdef uic;
11487 unsigned long int status;
11488
11489 if (uid == (unsigned int) -1) {
11490 do {
11491 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11492 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 11493 set_vaxc_errno(status);
11494 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 11495 my_endpwent();
11496 return NULL;
11497 }
11498 else { _ckvmssts(status); }
11499 } while (!valid_uic (uic));
11500 }
11501 else {
11502 uic.uic$l_uic= uid;
c07a80fd 11503 if (!uic.uic$v_group)
76e3520e 11504 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 11505 if (valid_uic(uic))
11506 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11507 else status = SS$_IVIDENT;
c07a80fd 11508 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11509 status == RMS$_PRV) {
11510 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11511 return NULL;
11512 }
11513 else { _ckvmssts(status); }
748a9306
LW		 11514 }
11515 __pw_namecache[lname]= '\0';
01b8edb6 11516 __mystrtolower(__pw_namecache);
748a9306
LW		 11517
11518 __pwdcache = __passwd_empty;
11519 __pwdcache.pw_name = __pw_namecache;
11520
11521/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11522 The identifier's value is usually the UIC, but it doesn't have to be,
11523 so if we can, we let fillpasswd update this. */
11524 __pwdcache.pw_uid = uic.uic$l_uic;
11525 __pwdcache.pw_gid = uic.uic$v_group;
11526
fd8cd3a3 11527 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 11528 return &__pwdcache;
a0d0e21e 11529
748a9306
LW		 11530} /* end of my_getpwuid() */
11531/*}}}*/
11532
11533/*
11534 * Get information for next user.
11535*/
11536/*{{{struct passwd *my_getpwent()*/
ce12d4b7
CB		 11537struct passwd *
11538Perl_my_getpwent(pTHX)
748a9306
LW		 11539{
11540 return (my_getpwuid((unsigned int) -1));
11541}
11542/*}}}*/
a0d0e21e 11543
748a9306
LW		 11544/*
11545 * Finish searching rights database for users.
11546*/
11547/*{{{void my_endpwent()*/
ce12d4b7
CB		 11548void
11549Perl_my_endpwent(pTHX)
748a9306
LW		 11550{
11551 if (contxt) {
11552 _ckvmssts(sys$finish_rdb(&contxt));
11553 contxt= 0;
11554 }
a0d0e21e
LW		 11555}
11556/*}}}*/
748a9306 11557
ff0cee69 11558/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11559 * my_utime(), and flex_stat(), all of which operate on UTC unless
11560 * VMSISH_TIMES is true.
11561 */
11562/* method used to handle UTC conversions:
11563 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 11564 */
ff0cee69 11565static int gmtime_emulation_type;
11566/* number of secs to add to UTC POSIX-style time to get local time */
11567static long int utc_offset_secs;
e518068a 11568
ff0cee69 11569/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11570 * in vmsish.h. #undef them here so we can call the CRTL routines
11571 * directly.
e518068a 11572 */
11573#undef gmtime
ff0cee69 11574#undef localtime
11575#undef time
11576
61bb5906
CB		 11577
11578static time_t toutc_dst(time_t loc) {
11579 struct tm *rsltmp;
11580
f7c699a0 11581 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
61bb5906
CB		 11582 loc -= utc_offset_secs;
11583 if (rsltmp->tm_isdst) loc -= 3600;
11584 return loc;
11585}
32da55ab 11586#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11587 ((gmtime_emulation_type || my_time(NULL)), \
11588 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11589 ((secs) - utc_offset_secs))))
11590
11591static time_t toloc_dst(time_t utc) {
11592 struct tm *rsltmp;
11593
11594 utc += utc_offset_secs;
f7c699a0 11595 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
61bb5906
CB		 11596 if (rsltmp->tm_isdst) utc += 3600;
11597 return utc;
11598}
32da55ab 11599#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11600 ((gmtime_emulation_type || my_time(NULL)), \
11601 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11602 ((secs) + utc_offset_secs))))
11603
ff0cee69 11604/* my_time(), my_localtime(), my_gmtime()
61bb5906 11605 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11606 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11607 * Note: We need to use these functions even when the CRTL has working
11608 * UTC support, since they also handle C<use vmsish qw(times);>
11609 *
ff0cee69 11610 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11611 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11612 */
11613
11614/*{{{time_t my_time(time_t *timep)*/
ce12d4b7
CB		 11615time_t
11616Perl_my_time(pTHX_ time_t *timep)
e518068a 11617{
e518068a 11618 time_t when;
61bb5906 11619 struct tm *tm_p;
e518068a 11620
11621 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11622 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11623 /* results of calls to gmtime() and localtime() */
11624 /* for same &base */
ff0cee69 11625
e518068a 11626 gmtime_emulation_type++;
ff0cee69 11627 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11628 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11629
e518068a 11630 gmtime_emulation_type++;
f675dbe5 11631 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11632 gmtime_emulation_type++;
22d4bb9c 11633 utc_offset_secs = 0;
5c84aa53 11634 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11635 }
11636 else { utc_offset_secs = atol(off); }
e518068a 11637 }
ff0cee69 11638 else { /* We've got a working gmtime() */
11639 struct tm gmt, local;
e518068a 11640
ff0cee69 11641 gmt = *tm_p;
11642 tm_p = localtime(&base);
11643 local = *tm_p;
11644 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11645 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11646 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11647 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11648 }
e518068a 11649 }
ff0cee69 11650
11651 when = time(NULL);
61bb5906 11652# ifdef VMSISH_TIME
61bb5906 11653 if (VMSISH_TIME) when = _toloc(when);
61bb5906 11654# endif
ff0cee69 11655 if (timep != NULL) *timep = when;
11656 return when;
11657
11658} /* end of my_time() */
11659/*}}}*/
11660
11661
11662/*{{{struct tm *my_gmtime(const time_t *timep)*/
11663struct tm *
fd8cd3a3 11664Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11665{
ff0cee69 11666 time_t when;
61bb5906 11667 struct tm *rsltmp;
ff0cee69 11668
68dc0745 11669 if (timep == NULL) {
11670 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11671 return NULL;
11672 }
11673 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11674
11675 when = *timep;
11676# ifdef VMSISH_TIME
61bb5906
CB		 11677 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11678# endif
61bb5906 11679 return gmtime(&when);
e518068a 11680} /* end of my_gmtime() */
e518068a 11681/*}}}*/
11682
11683
ff0cee69 11684/*{{{struct tm *my_localtime(const time_t *timep)*/
11685struct tm *
fd8cd3a3 11686Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11687{
c11536f5 11688 time_t when;
ff0cee69 11689
68dc0745 11690 if (timep == NULL) {
11691 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11692 return NULL;
11693 }
11694 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11695 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11696
11697 when = *timep;
11698# ifdef VMSISH_TIME
61bb5906 11699 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11700# endif
61bb5906 11701 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11702 return localtime(&when);
ff0cee69 11703} /* end of my_localtime() */
11704/*}}}*/
11705
11706/* Reset definitions for later calls */
11707#define gmtime(t) my_gmtime(t)
11708#define localtime(t) my_localtime(t)
11709#define time(t) my_time(t)
11710
11711
941b3de1
CB		 11712/* my_utime - update modification/access time of a file
11713 *
941b3de1
CB		 11714 * Only the UTC translation is home-grown. The rest is handled by the
11715 * CRTL utime(), which will take into account the relevant feature
11716 * logicals and ODS-5 volume characteristics for true access times.
11717 *
ff0cee69 11718 */
11719
11720/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11721 * to VMS epoch (01-JAN-1858 00:00:00.00)
11722 * in 100 ns intervals.
11723 */
11724static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11725
94a11853 11726/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
ce12d4b7
CB		 11727int
11728Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11729{
941b3de1
CB		 11730 struct utimbuf utc_utimes, *utc_utimesp;
11731
11732 if (utimes != NULL) {
11733 utc_utimes.actime = utimes->actime;
11734 utc_utimes.modtime = utimes->modtime;
11735# ifdef VMSISH_TIME
11736 /* If input was local; convert to UTC for sys svc */
11737 if (VMSISH_TIME) {
11738 utc_utimes.actime = _toutc(utimes->actime);
11739 utc_utimes.modtime = _toutc(utimes->modtime);
11740 }
11741# endif
11742 utc_utimesp = &utc_utimes;
11743 }
11744 else {
11745 utc_utimesp = NULL;
11746 }
11747
11748 return utime(file, utc_utimesp);
11749
ff0cee69 11750} /* end of my_utime() */
11751/*}}}*/
11752
748a9306 11753/*
2497a41f 11754 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11755 * basic stat, but gets it right when asked to stat
11756 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11757 */
11758
2497a41f 11759#ifndef _USE_STD_STAT
748a9306
LW		 11760/* encode_dev packs a VMS device name string into an integer to allow
11761 * simple comparisons. This can be used, for example, to check whether two
11762 * files are located on the same device, by comparing their encoded device
11763 * names. Even a string comparison would not do, because stat() reuses the
11764 * device name buffer for each call; so without encode_dev, it would be
11765 * necessary to save the buffer and use strcmp (this would mean a number of
11766 * changes to the standard Perl code, to say nothing of what a Perl script
11767 * would have to do.
11768 *
11769 * The device lock id, if it exists, should be unique (unless perhaps compared
11770 * with lock ids transferred from other nodes). We have a lock id if the disk is
11771 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11772 * device names. Thus we use the lock id in preference, and only if that isn't
11773 * available, do we try to pack the device name into an integer (flagged by
11774 * the sign bit (LOCKID_MASK) being set).
11775 *
e518068a 11776 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11777 * name and its encoded form, but it seems very unlikely that we will find
11778 * two files on different disks that share the same encoded device names,
11779 * and even more remote that they will share the same file id (if the test
11780 * is to check for the same file).
11781 *
11782 * A better method might be to use sys$device_scan on the first call, and to
11783 * search for the device, returning an index into the cached array.
cb9e088c 11784 * The number returned would be more intelligible.
748a9306
LW		 11785 * This is probably not worth it, and anyway would take quite a bit longer
11786 * on the first call.
11787 */
11788#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
ce12d4b7
CB		 11789static mydev_t
11790encode_dev (pTHX_ const char *dev)
748a9306
LW		 11791{
11792 int i;
11793 unsigned long int f;
aa689395 11794 mydev_t enc;
748a9306
LW		 11795 char c;
11796 const char *q;
11797
11798 if (!dev || !dev[0]) return 0;
11799
11800#if LOCKID_MASK
11801 {
11802 struct dsc$descriptor_s dev_desc;
cb9e088c 11803 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11804
11805 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11806 can try that first. */
11807 dev_desc.dsc$w_length = strlen (dev);
11808 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11809 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11810 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11811 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11812 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11813 switch (status) {
11814 case SS$_NOSUCHDEV:
11815 SETERRNO(ENODEV, status);
11816 return 0;
11817 default:
11818 _ckvmssts(status);
11819 }
11820 }
748a9306
LW		 11821 if (lockid) return (lockid & ~LOCKID_MASK);
11822 }
a0d0e21e 11823#endif
748a9306
LW		 11824
11825 /* Otherwise we try to encode the device name */
11826 enc = 0;
11827 f = 1;
11828 i = 0;
11829 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11830 if (*q == ':')
11831 break;
748a9306
LW		 11832 if (isdigit (*q))
11833 c= (*q) - '0';
11834 else if (isalpha (toupper (*q)))
11835 c= toupper (*q) - 'A' + (char)10;
11836 else
11837 continue; /* Skip '$'s */
11838 i++;
11839 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11840 if (i>1) f *= 36;
11841 enc += f * (unsigned long int) c;
11842 }
11843 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11844
11845} /* end of encode_dev() */
cfcfe586
JM		 11846#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11847 device_no = encode_dev(aTHX_ devname)
11848#else
11849#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11850 device_no = new_dev_no
2497a41f 11851#endif
748a9306 11852
748a9306 11853static int
135577da 11854is_null_device(const char *name)
748a9306 11855{
2497a41f 11856 if (decc_bug_devnull != 0) {
682e4b71 11857 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 11858 return 1;
11859 }
748a9306
LW		 11860 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11861 The underscore prefix, controller letter, and unit number are
11862 independently optional; for our purposes, the colon punctuation
11863 is not. The colon can be trailed by optional directory and/or
11864 filename, but two consecutive colons indicates a nodename rather
11865 than a device. [pr] */
11866 if (*name == '_') ++name;
11867 if (tolower(*name++) != 'n') return 0;
11868 if (tolower(*name++) != 'l') return 0;
11869 if (tolower(*name) == 'a') ++name;
11870 if (*name == '0') ++name;
11871 return (*name++ == ':') && (*name != ':');
11872}
11873
312ac60b
JM		 11874static int
11875Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
c07a80fd 11876
46c05374
CB		 11877#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11878
a1887106 11879static I32
ce12d4b7 11880Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11881{
e538e23f
CB		 11882 char usrname[L_cuserid];
11883 struct dsc$descriptor_s usrdsc =
748a9306 11884 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11885 char *vmsname = NULL, *fileified = NULL;
597c27e2 11886 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11887 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11888 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11889 union prvdef curprv;
597c27e2
CB		 11890 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11891 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11892 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11893 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11894 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11895 {0,0,0,0}};
11896 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11897 {0,0,0,0}};
ada67d10 11898 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11899 Stat_t st;
6151c65c 11900 static int profile_context = -1;
748a9306
LW		 11901
11902 if (!fname || !*fname) return FALSE;
a1887106 11903
e538e23f 11904 /* Make sure we expand logical names, since sys$check_access doesn't */
c11536f5 11905 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11906 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f 11907 if (!strpbrk(fname,"/]>:")) {
a35dcc95 11908 my_strlcpy(fileified, fname, VMS_MAXRSS);
a1887106 11909 trnlnm_iter_count = 0;
e538e23f 11910 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11911 trnlnm_iter_count++;
11912 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11913 }
11914 fname = fileified;
e538e23f
CB		 11915 }
11916
c11536f5 11917 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11918 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f
CB		 11919 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11920 /* Don't know if already in VMS format, so make sure */
360732b5 11921 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11922 PerlMem_free(fileified);
e538e23f 11923 PerlMem_free(vmsname);
a1887106
JM		 11924 return FALSE;
11925 }
a1887106
JM		 11926 }
11927 else {
a35dcc95 11928 my_strlcpy(vmsname, fname, VMS_MAXRSS);
a5f75d66
AD		 11929 }
11930
858aded6 11931 /* sys$check_access needs a file spec, not a directory spec.
312ac60b 11932 * flex_stat now will handle a null thread context during startup.
858aded6 11933 */
e538e23f
CB		 11934
11935 retlen = namdsc.dsc$w_length = strlen(vmsname);
11936 if (vmsname[retlen-1] == ']'
11937 || vmsname[retlen-1] == '>'
858aded6 11938 || vmsname[retlen-1] == ':'
46c05374 11939 || (!flex_stat_int(vmsname, &st, 1) &&
312ac60b 11940 S_ISDIR(st.st_mode))) {
e538e23f 11941
a979ce91 11942 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
e538e23f
CB		 11943 PerlMem_free(fileified);
11944 PerlMem_free(vmsname);
11945 return FALSE;
11946 }
11947 fname = fileified;
11948 }
858aded6
CB		 11949 else {
11950 fname = vmsname;
11951 }
e538e23f
CB		 11952
11953 retlen = namdsc.dsc$w_length = strlen(fname);
11954 namdsc.dsc$a_pointer = (char *)fname;
11955
748a9306 11956 switch (bit) {
f282b18d 11957 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11958 access = ARM$M_EXECUTE;
597c27e2
CB		 11959 flags = CHP$M_READ;
11960 break;
f282b18d 11961 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11962 access = ARM$M_READ;
597c27e2
CB		 11963 flags = CHP$M_READ | CHP$M_USEREADALL;
11964 break;
f282b18d 11965 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11966 access = ARM$M_WRITE;
597c27e2
CB		 11967 flags = CHP$M_READ | CHP$M_WRITE;
11968 break;
f282b18d 11969 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11970 access = ARM$M_DELETE;
597c27e2
CB		 11971 flags = CHP$M_READ | CHP$M_WRITE;
11972 break;
748a9306 11973 default:
a1887106
JM		 11974 if (fileified != NULL)
11975 PerlMem_free(fileified);
e538e23f
CB		 11976 if (vmsname != NULL)
11977 PerlMem_free(vmsname);
748a9306
LW		 11978 return FALSE;
11979 }
11980
ada67d10
CB		 11981 /* Before we call $check_access, create a user profile with the current
11982 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11983 * UAF and might give false positives or negatives. This only works on
11984 * VMS versions v6.0 and later since that's when sys$create_user_profile
11985 * became available.
ada67d10
CB		 11986 */
11987
11988 /* get current process privs and username */
ebd4d70b
JM		 11989 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11990 _ckvmssts_noperl(iosb[0]);
ada67d10
CB		 11991
11992 /* find out the space required for the profile */
ebd4d70b 11993 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11994 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11995
11996 /* allocate space for the profile and get it filled in */
c11536f5 11997 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
ebd4d70b
JM		 11998 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11999 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 12000 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 12001
12002 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 12003 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 12004 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 12005 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c 12006
bbce6d69 12007 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 12008 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 12009 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 12010 set_vaxc_errno(retsts);
12011 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12012 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12013 else set_errno(ENOENT);
a1887106
JM		 12014 if (fileified != NULL)
12015 PerlMem_free(fileified);
e538e23f
CB		 12016 if (vmsname != NULL)
12017 PerlMem_free(vmsname);
a3e9d8c9 12018 return FALSE;
12019 }
ada67d10 12020 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 12021 if (fileified != NULL)
12022 PerlMem_free(fileified);
e538e23f
CB		 12023 if (vmsname != NULL)
12024 PerlMem_free(vmsname);
3a385817
GS		 12025 return TRUE;
12026 }
ebd4d70b 12027 _ckvmssts_noperl(retsts);
748a9306 12028
a1887106
JM		 12029 if (fileified != NULL)
12030 PerlMem_free(fileified);
e538e23f
CB		 12031 if (vmsname != NULL)
12032 PerlMem_free(vmsname);
748a9306
LW		 12033 return FALSE; /* Should never get here */
12034
a1887106
JM		 12035}
12036
12037/* Do the permissions allow some operation? Assumes PL_statcache already set. */
12038/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12039 * subset of the applicable information.
12040 */
12041bool
12042Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12043{
12044 return cando_by_name_int
12045 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12046} /* end of cando() */
12047/*}}}*/
12048
12049
12050/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12051I32
12052Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12053{
12054 return cando_by_name_int(bit, effective, fname, 0);
12055
748a9306
LW		 12056} /* end of cando_by_name() */
12057/*}}}*/
12058
12059
61bb5906 12060/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 12061int
fd8cd3a3 12062Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 12063{
a1027d22 12064 dSAVE_ERRNO; /* fstat may set this even on success */
312ac60b 12065 if (!fstat(fd, &statbufp->crtl_stat)) {
75796008 12066 char *cptr;
988c775c 12067 char *vms_filename;
c11536f5 12068 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
988c775c 12069 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 12070
988c775c
JM		 12071 /* Save name for cando by name in VMS format */
12072 cptr = getname(fd, vms_filename, 1);
75796008 12073
988c775c
JM		 12074 /* This should not happen, but just in case */
12075 if (cptr == NULL) {
12076 statbufp->st_devnam[0] = 0;
12077 }
12078 else {
12079 /* Make sure that the saved name fits in 255 characters */
6fb6c614 12080 cptr = int_rmsexpand_vms
988c775c
JM		 12081 (vms_filename,
12082 statbufp->st_devnam,
6fb6c614 12083 0);
75796008 12084 if (cptr == NULL)
988c775c 12085 statbufp->st_devnam[0] = 0;
75796008 12086 }
988c775c 12087 PerlMem_free(vms_filename);
682e4b71
JM		 12088
12089 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12090 VMS_DEVICE_ENCODE
12091 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 12092
61bb5906
CB		 12093# ifdef VMSISH_TIME
12094 if (VMSISH_TIME) {
12095 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12096 statbufp->st_atime = _toloc(statbufp->st_atime);
12097 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12098 }
12099# endif
a1027d22 12100 RESTORE_ERRNO;
b7ae7a0d 12101 return 0;
12102 }
12103 return -1;
748a9306
LW		 12104
12105} /* end of flex_fstat() */
12106/*}}}*/
12107
2497a41f
JM		 12108static int
12109Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 12110{
9b9f19da
CB		 12111 char *temp_fspec = NULL;
12112 char *fileified = NULL;
312ac60b
JM		 12113 const char *save_spec;
12114 char *ret_spec;
bbce6d69 12115 int retval = -1;
cc5de3bd
CB		 12116 char efs_hack = 0;
12117 char already_fileified = 0;
4ee39169 12118 dSAVEDERRNO;
748a9306 12119
312ac60b
JM		 12120 if (!fspec) {
12121 errno = EINVAL;
12122 return retval;
12123 }
988c775c 12124
2497a41f 12125 if (decc_bug_devnull != 0) {
312ac60b 12126 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2497a41f 12127 memset(statbufp,0,sizeof *statbufp);
cfcfe586 12128 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 12129 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12130 statbufp->st_uid = 0x00010001;
12131 statbufp->st_gid = 0x0001;
12132 time((time_t *)&statbufp->st_mtime);
12133 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12134 return 0;
12135 }
748a9306
LW		 12136 }
12137
9b9f19da
CB		 12138 SAVE_ERRNO;
12139
054a3baf 12140#if __CRTL_VER >= 80200000
9b9f19da
CB		 12141 /*
12142 * If we are in POSIX filespec mode, accept the filename as is.
12143 */
12144 if (decc_posix_compliant_pathnames == 0) {
12145#endif
12146
12147 /* Try for a simple stat first. If fspec contains a filename without
61bb5906 12148 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9b9f19da 12149 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
bbce6d69 12150 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12151 * not sea:[wine.dark]., if the latter exists. If the intended target is
12152 * the file with null type, specify this by calling flex_stat() with
12153 * a '.' at the end of fspec.
12154 */
f36b279d 12155
9b9f19da
CB		 12156 if (lstat_flag == 0)
12157 retval = stat(fspec, &statbufp->crtl_stat);
12158 else
12159 retval = lstat(fspec, &statbufp->crtl_stat);
f36b279d 12160
cc5de3bd
CB		 12161 if (!retval) {
12162 save_spec = fspec;
12163 }
12164 else {
12165 /* In the odd case where we have write but not read access
12166 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12167 */
c11536f5 12168 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
cc5de3bd
CB		 12169 if (fileified == NULL)
12170 _ckvmssts_noperl(SS$_INSFMEM);
12171
12172 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12173 if (ret_spec != NULL) {
12174 if (lstat_flag == 0)
12175 retval = stat(fileified, &statbufp->crtl_stat);
12176 else
12177 retval = lstat(fileified, &statbufp->crtl_stat);
12178 save_spec = fileified;
12179 already_fileified = 1;
12180 }
12181 }
12182
312ac60b
JM		 12183 if (retval && vms_bug_stat_filename) {
12184
c11536f5 12185 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12186 if (temp_fspec == NULL)
12187 _ckvmssts_noperl(SS$_INSFMEM);
12188
12189 /* We should try again as a vmsified file specification. */
312ac60b
JM		 12190
12191 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12192 if (ret_spec != NULL) {
12193 if (lstat_flag == 0)
12194 retval = stat(temp_fspec, &statbufp->crtl_stat);
12195 else
12196 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12197 save_spec = temp_fspec;
12198 }
2497a41f 12199 }
312ac60b 12200
f1db9cda 12201 if (retval) {
9b9f19da 12202 /* Last chance - allow multiple dots without EFS CHARSET */
312ac60b
JM		 12203 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12204 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12205 * enable it if it isn't already.
12206 */
312ac60b
JM		 12207 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12208 decc$feature_set_value(decc_efs_charset_index, 1, 1);
312ac60b
JM		 12209 if (lstat_flag == 0)
12210 retval = stat(fspec, &statbufp->crtl_stat);
12211 else
12212 retval = lstat(fspec, &statbufp->crtl_stat);
12213 save_spec = fspec;
312ac60b
JM		 12214 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12215 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12216 efs_hack = 1;
12217 }
f1db9cda 12218 }
312ac60b 12219
054a3baf 12220#if __CRTL_VER >= 80200000
2497a41f
JM		 12221 } else {
12222 if (lstat_flag == 0)
312ac60b 12223 retval = stat(temp_fspec, &statbufp->crtl_stat);
2497a41f 12224 else
312ac60b 12225 retval = lstat(temp_fspec, &statbufp->crtl_stat);
988c775c 12226 save_spec = temp_fspec;
2497a41f
JM		 12227 }
12228#endif
f36b279d 12229
f36b279d
CB		 12230 /* As you were... */
12231 if (!decc_efs_charset)
12232 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
f36b279d 12233
ff0cee69 12234 if (!retval) {
9b9f19da
CB		 12235 char *cptr;
12236 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
d584a1c6
JM		 12237
12238 /* If this is an lstat, do not follow the link */
12239 if (lstat_flag)
12240 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12241
312ac60b
JM		 12242 /* If we used the efs_hack above, we must also use it here for */
12243 /* perl_cando to work */
12244 if (efs_hack && (decc_efs_charset_index > 0)) {
12245 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12246 }
9b9f19da
CB		 12247
12248 /* If we've got a directory, save a fileified, expanded version of it
12249 * in st_devnam. If not a directory, just an expanded version.
12250 */
cc5de3bd 12251 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
c11536f5 12252 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12253 if (fileified == NULL)
12254 _ckvmssts_noperl(SS$_INSFMEM);
12255
12256 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12257 if (cptr != NULL)
12258 save_spec = fileified;
12259 }
12260
12261 cptr = int_rmsexpand(save_spec,
12262 statbufp->st_devnam,
12263 NULL,
12264 rmsex_flags,
12265 0,
12266 0);
12267
312ac60b
JM		 12268 if (efs_hack && (decc_efs_charset_index > 0)) {
12269 decc$feature_set_value(decc_efs_charset, 1, 0);
12270 }
312ac60b
JM		 12271
12272 /* Fix me: If this is NULL then stat found a file, and we could */
12273 /* not convert the specification to VMS - Should never happen */
988c775c
JM		 12274 if (cptr == NULL)
12275 statbufp->st_devnam[0] = 0;
12276
682e4b71 12277 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12278 VMS_DEVICE_ENCODE
12279 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 12280# ifdef VMSISH_TIME
12281 if (VMSISH_TIME) {
12282 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12283 statbufp->st_atime = _toloc(statbufp->st_atime);
12284 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12285 }
12286# endif
ff0cee69 12287 }
9543c6b6 12288 /* If we were successful, leave errno where we found it */
4ee39169 12289 if (retval == 0) RESTORE_ERRNO;
9b9f19da
CB		 12290 if (temp_fspec)
12291 PerlMem_free(temp_fspec);
12292 if (fileified)
12293 PerlMem_free(fileified);
748a9306
LW		 12294 return retval;
12295
2497a41f
JM		 12296} /* end of flex_stat_int() */
12297
12298
12299/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12300int
12301Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12302{
7ded3206 12303 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12304}
12305/*}}}*/
12306
12307/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12308int
12309Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12310{
7ded3206 12311 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12312}
748a9306
LW		 12313/*}}}*/
12314
b7ae7a0d 12315
a5f75d66
AD		 12316/* rmscopy - copy a file using VMS RMS routines
12317 *
12318 * Copies contents and attributes of spec_in to spec_out, except owner
12319 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12320 * defaults for spec_out. The third parameter specifies whether rmscopy()
12321 * should try to propagate timestamps from the input file to the output file.
12322 * If it is less than 0, no timestamps are preserved. If it is 0, then
12323 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12324 * propagated to the output file at creation iff the output file specification
12325 * did not contain an explicit name or type, and the revision date is always
12326 * updated at the end of the copy operation. If it is greater than 0, then
12327 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12328 * other than the revision date should be propagated, and bit 1 indicates
12329 * that the revision date should be propagated.
12330 *
12331 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12332 *
bd3fa61c 12333 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12334 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12335 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12336 * as part of the Perl standard distribution under the terms of the
12337 * GNU General Public License or the Perl Artistic License. Copies
12338 * of each may be found in the Perl standard distribution.
a480973c 12339 */ /* FIXME */
a3e9d8c9 12340/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12341int
12342Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12343{
d584a1c6
JM		 12344 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12345 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
4e0c9737 12346 unsigned long int sts;
a1887106 12347 int dna_len;
a480973c
JM		 12348 struct FAB fab_in, fab_out;
12349 struct RAB rab_in, rab_out;
a1887106
JM		 12350 rms_setup_nam(nam);
12351 rms_setup_nam(nam_out);
a480973c
JM		 12352 struct XABDAT xabdat;
12353 struct XABFHC xabfhc;
12354 struct XABRDT xabrdt;
12355 struct XABSUM xabsum;
12356
c11536f5 12357 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12358 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12359 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12360 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665
JM		 12361 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12362 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
c5375c28
JM		 12363 PerlMem_free(vmsin);
12364 PerlMem_free(vmsout);
a480973c
JM		 12365 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12366 return 0;
12367 }
12368
c11536f5 12369 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12370 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12371 esal = NULL;
054a3baf 12372#if defined(NAML$C_MAXRSS)
c11536f5 12373 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12374 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12375#endif
a480973c 12376 fab_in = cc$rms_fab;
a1887106 12377 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12378 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12379 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12380 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12381 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12382 fab_in.fab$l_xab = (void *) &xabdat;
12383
c11536f5 12384 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12385 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12386 rsal = NULL;
054a3baf 12387#if defined(NAML$C_MAXRSS)
c11536f5 12388 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12389 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12390#endif
12391 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12392 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12393 rms_nam_esl(nam) = 0;
12394 rms_nam_rsl(nam) = 0;
12395 rms_nam_esll(nam) = 0;
12396 rms_nam_rsll(nam) = 0;
a480973c
JM		 12397#ifdef NAM$M_NO_SHORT_UPCASE
12398 if (decc_efs_case_preserve)
a1887106 12399 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12400#endif
12401
12402 xabdat = cc$rms_xabdat; /* To get creation date */
12403 xabdat.xab$l_nxt = (void *) &xabfhc;
12404
12405 xabfhc = cc$rms_xabfhc; /* To get record length */
12406 xabfhc.xab$l_nxt = (void *) &xabsum;
12407
12408 xabsum = cc$rms_xabsum; /* To get key and area information */
12409
12410 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12411 PerlMem_free(vmsin);
12412 PerlMem_free(vmsout);
12413 PerlMem_free(esa);
d584a1c6
JM		 12414 if (esal != NULL)
12415 PerlMem_free(esal);
c5375c28 12416 PerlMem_free(rsa);
d584a1c6
JM		 12417 if (rsal != NULL)
12418 PerlMem_free(rsal);
a480973c
JM		 12419 set_vaxc_errno(sts);
12420 switch (sts) {
12421 case RMS$_FNF: case RMS$_DNF:
12422 set_errno(ENOENT); break;
12423 case RMS$_DIR:
12424 set_errno(ENOTDIR); break;
12425 case RMS$_DEV:
12426 set_errno(ENODEV); break;
12427 case RMS$_SYN:
12428 set_errno(EINVAL); break;
12429 case RMS$_PRV:
12430 set_errno(EACCES); break;
12431 default:
12432 set_errno(EVMSERR);
12433 }
12434 return 0;
12435 }
12436
12437 nam_out = nam;
12438 fab_out = fab_in;
12439 fab_out.fab$w_ifi = 0;
12440 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12441 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12442 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12443 rms_bind_fab_nam(fab_out, nam_out);
12444 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12445 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12446 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
c11536f5 12447 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12448 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12449 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12450 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12451 esal_out = NULL;
12452 rsal_out = NULL;
054a3baf 12453#if defined(NAML$C_MAXRSS)
c11536f5 12454 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12455 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12456 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12457 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12458#endif
12459 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12460 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12461
12462 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12463 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12464 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12465 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12466 PerlMem_free(vmsin);
12467 PerlMem_free(vmsout);
12468 PerlMem_free(esa);
d584a1c6
JM		 12469 if (esal != NULL)
12470 PerlMem_free(esal);
c5375c28 12471 PerlMem_free(rsa);
d584a1c6
JM		 12472 if (rsal != NULL)
12473 PerlMem_free(rsal);
c5375c28 12474 PerlMem_free(esa_out);
d584a1c6
JM		 12475 if (esal_out != NULL)
12476 PerlMem_free(esal_out);
12477 PerlMem_free(rsa_out);
12478 if (rsal_out != NULL)
12479 PerlMem_free(rsal_out);
a480973c
JM		 12480 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12481 set_vaxc_errno(sts);
12482 return 0;
12483 }
12484 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12485 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12486 preserve_dates = 1;
a480973c
JM		 12487 }
12488 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12489 preserve_dates =0; /* bitmask from this point forward */
12490
12491 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12492 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12493 PerlMem_free(vmsin);
12494 PerlMem_free(vmsout);
12495 PerlMem_free(esa);
d584a1c6
JM		 12496 if (esal != NULL)
12497 PerlMem_free(esal);
c5375c28 12498 PerlMem_free(rsa);
d584a1c6
JM		 12499 if (rsal != NULL)
12500 PerlMem_free(rsal);
c5375c28 12501 PerlMem_free(esa_out);
d584a1c6
JM		 12502 if (esal_out != NULL)
12503 PerlMem_free(esal_out);
12504 PerlMem_free(rsa_out);
12505 if (rsal_out != NULL)
12506 PerlMem_free(rsal_out);
a480973c
JM		 12507 set_vaxc_errno(sts);
12508 switch (sts) {
12509 case RMS$_DNF:
12510 set_errno(ENOENT); break;
12511 case RMS$_DIR:
12512 set_errno(ENOTDIR); break;
12513 case RMS$_DEV:
12514 set_errno(ENODEV); break;
12515 case RMS$_SYN:
12516 set_errno(EINVAL); break;
12517 case RMS$_PRV:
12518 set_errno(EACCES); break;
12519 default:
12520 set_errno(EVMSERR);
12521 }
12522 return 0;
12523 }
12524 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12525 if (preserve_dates & 2) {
12526 /* sys$close() will process xabrdt, not xabdat */
12527 xabrdt = cc$rms_xabrdt;
a480973c 12528 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
a480973c
JM		 12529 fab_out.fab$l_xab = (void *) &xabrdt;
12530 }
12531
c11536f5 12532 ubf = (char *)PerlMem_malloc(32256);
ebd4d70b 12533 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 12534 rab_in = cc$rms_rab;
12535 rab_in.rab$l_fab = &fab_in;
12536 rab_in.rab$l_rop = RAB$M_BIO;
12537 rab_in.rab$l_ubf = ubf;
12538 rab_in.rab$w_usz = 32256;
12539 if (!((sts = sys$connect(&rab_in)) & 1)) {
12540 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12541 PerlMem_free(vmsin);
12542 PerlMem_free(vmsout);
c5375c28 12543 PerlMem_free(ubf);
d584a1c6
JM		 12544 PerlMem_free(esa);
12545 if (esal != NULL)
12546 PerlMem_free(esal);
c5375c28 12547 PerlMem_free(rsa);
d584a1c6
JM		 12548 if (rsal != NULL)
12549 PerlMem_free(rsal);
c5375c28 12550 PerlMem_free(esa_out);
d584a1c6
JM		 12551 if (esal_out != NULL)
12552 PerlMem_free(esal_out);
12553 PerlMem_free(rsa_out);
12554 if (rsal_out != NULL)
12555 PerlMem_free(rsal_out);
a480973c
JM		 12556 set_errno(EVMSERR); set_vaxc_errno(sts);
12557 return 0;
12558 }
12559
12560 rab_out = cc$rms_rab;
12561 rab_out.rab$l_fab = &fab_out;
12562 rab_out.rab$l_rbf = ubf;
12563 if (!((sts = sys$connect(&rab_out)) & 1)) {
12564 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12565 PerlMem_free(vmsin);
12566 PerlMem_free(vmsout);
c5375c28 12567 PerlMem_free(ubf);
d584a1c6
JM		 12568 PerlMem_free(esa);
12569 if (esal != NULL)
12570 PerlMem_free(esal);
c5375c28 12571 PerlMem_free(rsa);
d584a1c6
JM		 12572 if (rsal != NULL)
12573 PerlMem_free(rsal);
c5375c28 12574 PerlMem_free(esa_out);
d584a1c6
JM		 12575 if (esal_out != NULL)
12576 PerlMem_free(esal_out);
12577 PerlMem_free(rsa_out);
12578 if (rsal_out != NULL)
12579 PerlMem_free(rsal_out);
a480973c
JM		 12580 set_errno(EVMSERR); set_vaxc_errno(sts);
12581 return 0;
12582 }
12583
12584 while ((sts = sys$read(&rab_in))) { /* always true */
12585 if (sts == RMS$_EOF) break;
12586 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12587 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12588 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12589 PerlMem_free(vmsin);
12590 PerlMem_free(vmsout);
c5375c28 12591 PerlMem_free(ubf);
d584a1c6
JM		 12592 PerlMem_free(esa);
12593 if (esal != NULL)
12594 PerlMem_free(esal);
c5375c28 12595 PerlMem_free(rsa);
d584a1c6
JM		 12596 if (rsal != NULL)
12597 PerlMem_free(rsal);
c5375c28 12598 PerlMem_free(esa_out);
d584a1c6
JM		 12599 if (esal_out != NULL)
12600 PerlMem_free(esal_out);
12601 PerlMem_free(rsa_out);
12602 if (rsal_out != NULL)
12603 PerlMem_free(rsal_out);
a480973c
JM		 12604 set_errno(EVMSERR); set_vaxc_errno(sts);
12605 return 0;
12606 }
12607 }
12608
12609
12610 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12611 sys$close(&fab_in); sys$close(&fab_out);
12612 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12613
c5375c28
JM		 12614 PerlMem_free(vmsin);
12615 PerlMem_free(vmsout);
c5375c28 12616 PerlMem_free(ubf);
d584a1c6
JM		 12617 PerlMem_free(esa);
12618 if (esal != NULL)
12619 PerlMem_free(esal);
c5375c28 12620 PerlMem_free(rsa);
d584a1c6
JM		 12621 if (rsal != NULL)
12622 PerlMem_free(rsal);
c5375c28 12623 PerlMem_free(esa_out);
d584a1c6
JM		 12624 if (esal_out != NULL)
12625 PerlMem_free(esal_out);
12626 PerlMem_free(rsa_out);
12627 if (rsal_out != NULL)
12628 PerlMem_free(rsal_out);
12629
12630 if (!(sts & 1)) {
12631 set_errno(EVMSERR); set_vaxc_errno(sts);
12632 return 0;
12633 }
12634
a480973c
JM		 12635 return 1;
12636
12637} /* end of rmscopy() */
a5f75d66
AD		 12638/*}}}*/
12639
12640
748a9306
LW		 12641/*** The following glue provides 'hooks' to make some of the routines
12642 * from this file available from Perl. These routines are sufficiently
12643 * basic, and are required sufficiently early in the build process,
12644 * that's it's nice to have them available to miniperl as well as the
12645 * full Perl, so they're set up here instead of in an extension. The
12646 * Perl code which handles importation of these names into a given
12647 * package lives in [.VMS]Filespec.pm in @INC.
12648 */
12649
12650void
5c84aa53 12651rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12652{
12653 dXSARGS;
bbce6d69 12654 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12655 STRLEN n_a;
360732b5 12656 int fs_utf8, dfs_utf8;
01b8edb6 12657
360732b5
JM		 12658 fs_utf8 = 0;
12659 dfs_utf8 = 0;
bbce6d69 12660 if (!items || items > 2)
5c84aa53 12661 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12662 fspec = SvPV(ST(0),n_a);
360732b5 12663 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12664 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12665 if (items == 2) {
12666 defspec = SvPV(ST(1),n_a);
12667 dfs_utf8 = SvUTF8(ST(1));
12668 }
12669 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12670 ST(0) = sv_newmortal();
360732b5
JM		 12671 if (rslt != NULL) {
12672 sv_usepvn(ST(0),rslt,strlen(rslt));
12673 if (fs_utf8) {
12674 SvUTF8_on(ST(0));
12675 }
12676 }
740ce14c 12677 XSRETURN(1);
01b8edb6 12678}
12679
12680void
5c84aa53 12681vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12682{
12683 dXSARGS;
12684 char *vmsified;
2d8e6c8d 12685 STRLEN n_a;
360732b5 12686 int utf8_fl;
748a9306 12687
5c84aa53 12688 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12689 utf8_fl = SvUTF8(ST(0));
12690 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12691 ST(0) = sv_newmortal();
360732b5
JM		 12692 if (vmsified != NULL) {
12693 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12694 if (utf8_fl) {
12695 SvUTF8_on(ST(0));
12696 }
12697 }
748a9306
LW		 12698 XSRETURN(1);
12699}
12700
12701void
5c84aa53 12702unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12703{
12704 dXSARGS;
12705 char *unixified;
2d8e6c8d 12706 STRLEN n_a;
360732b5 12707 int utf8_fl;
748a9306 12708
5c84aa53 12709 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12710 utf8_fl = SvUTF8(ST(0));
12711 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12712 ST(0) = sv_newmortal();
360732b5
JM		 12713 if (unixified != NULL) {
12714 sv_usepvn(ST(0),unixified,strlen(unixified));
12715 if (utf8_fl) {
12716 SvUTF8_on(ST(0));
12717 }
12718 }
748a9306
LW		 12719 XSRETURN(1);
12720}
12721
12722void
5c84aa53 12723fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12724{
12725 dXSARGS;
12726 char *fileified;
2d8e6c8d 12727 STRLEN n_a;
360732b5 12728 int utf8_fl;
748a9306 12729
5c84aa53 12730 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12731 utf8_fl = SvUTF8(ST(0));
12732 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12733 ST(0) = sv_newmortal();
360732b5
JM		 12734 if (fileified != NULL) {
12735 sv_usepvn(ST(0),fileified,strlen(fileified));
12736 if (utf8_fl) {
12737 SvUTF8_on(ST(0));
12738 }
12739 }
748a9306
LW		 12740 XSRETURN(1);
12741}
12742
12743void
5c84aa53 12744pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12745{
12746 dXSARGS;
12747 char *pathified;
2d8e6c8d 12748 STRLEN n_a;
360732b5 12749 int utf8_fl;
748a9306 12750
5c84aa53 12751 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12752 utf8_fl = SvUTF8(ST(0));
12753 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12754 ST(0) = sv_newmortal();
360732b5
JM		 12755 if (pathified != NULL) {
12756 sv_usepvn(ST(0),pathified,strlen(pathified));
12757 if (utf8_fl) {
12758 SvUTF8_on(ST(0));
12759 }
12760 }
748a9306
LW		 12761 XSRETURN(1);
12762}
12763
12764void
5c84aa53 12765vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12766{
12767 dXSARGS;
12768 char *vmspath;
2d8e6c8d 12769 STRLEN n_a;
360732b5 12770 int utf8_fl;
748a9306 12771
5c84aa53 12772 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12773 utf8_fl = SvUTF8(ST(0));
12774 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12775 ST(0) = sv_newmortal();
360732b5
JM		 12776 if (vmspath != NULL) {
12777 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12778 if (utf8_fl) {
12779 SvUTF8_on(ST(0));
12780 }
12781 }
748a9306
LW		 12782 XSRETURN(1);
12783}
12784
12785void
5c84aa53 12786unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12787{
12788 dXSARGS;
12789 char *unixpath;
2d8e6c8d 12790 STRLEN n_a;
360732b5 12791 int utf8_fl;
748a9306 12792
5c84aa53 12793 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12794 utf8_fl = SvUTF8(ST(0));
12795 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12796 ST(0) = sv_newmortal();
360732b5
JM		 12797 if (unixpath != NULL) {
12798 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12799 if (utf8_fl) {
12800 SvUTF8_on(ST(0));
12801 }
12802 }
748a9306
LW		 12803 XSRETURN(1);
12804}
12805
12806void
5c84aa53 12807candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12808{
12809 dXSARGS;
988c775c 12810 char *fspec, *fsp;
a5f75d66
AD		 12811 SV *mysv;
12812 IO *io;
2d8e6c8d 12813 STRLEN n_a;
748a9306 12814
5c84aa53 12815 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12816
12817 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12818 Newx(fspec, VMS_MAXRSS, char);
12819 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
6d24fbd1 12820 if (isGV_with_GP(mysv)) {
a15cef0c 12821 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12822 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12823 ST(0) = &PL_sv_no;
988c775c 12824 Safefree(fspec);
a5f75d66
AD		 12825 XSRETURN(1);
12826 }
12827 fsp = fspec;
12828 }
12829 else {
2d8e6c8d 12830 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 12831 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12832 ST(0) = &PL_sv_no;
988c775c 12833 Safefree(fspec);
a5f75d66
AD		 12834 XSRETURN(1);
12835 }
12836 }
12837
54310121 12838 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12839 Safefree(fspec);
a5f75d66
AD		 12840 XSRETURN(1);
12841}
12842
12843void
5c84aa53 12844rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12845{
12846 dXSARGS;
a480973c 12847 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12848 int date_flag;
a5f75d66
AD		 12849 SV *mysv;
12850 IO *io;
2d8e6c8d 12851 STRLEN n_a;
a5f75d66 12852
a3e9d8c9 12853 if (items < 2 || items > 3)
5c84aa53 12854 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12855
12856 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12857 Newx(inspec, VMS_MAXRSS, char);
6d24fbd1 12858 if (isGV_with_GP(mysv)) {
a15cef0c 12859 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12860 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12861 ST(0) = sv_2mortal(newSViv(0));
a480973c 12862 Safefree(inspec);
a5f75d66
AD		 12863 XSRETURN(1);
12864 }
12865 inp = inspec;
12866 }
12867 else {
2d8e6c8d 12868 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 12869 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12870 ST(0) = sv_2mortal(newSViv(0));
a480973c 12871 Safefree(inspec);
a5f75d66
AD		 12872 XSRETURN(1);
12873 }
12874 }
12875 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12876 Newx(outspec, VMS_MAXRSS, char);
6d24fbd1 12877 if (isGV_with_GP(mysv)) {
a15cef0c 12878 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12879 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12880 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12881 Safefree(inspec);
12882 Safefree(outspec);
a5f75d66
AD		 12883 XSRETURN(1);
12884 }
12885 outp = outspec;
12886 }
12887 else {
2d8e6c8d 12888 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12889 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12890 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12891 Safefree(inspec);
12892 Safefree(outspec);
a5f75d66
AD		 12893 XSRETURN(1);
12894 }
12895 }
a3e9d8c9 12896 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12897
fd188159 12898 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
a480973c
JM		 12899 Safefree(inspec);
12900 Safefree(outspec);
748a9306
LW		 12901 XSRETURN(1);
12902}
12903
a480973c
JM		 12904/* The mod2fname is limited to shorter filenames by design, so it should
12905 * not be modified to support longer EFS pathnames
12906 */
4b19af01 12907void
fd8cd3a3 12908mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12909{
12910 dXSARGS;
12911 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12912 workbuff[NAM$C_MAXRSS*1 + 1];
c70927a6 12913 SSize_t counter, num_entries;
4b19af01
CB		 12914 /* ODS-5 ups this, but we want to be consistent, so... */
12915 int max_name_len = 39;
12916 AV *in_array = (AV *)SvRV(ST(0));
12917
b9f2b683 12918 num_entries = av_tindex(in_array);
4b19af01
CB		 12919
12920 /* All the names start with PL_. */
12921 strcpy(ultimate_name, "PL_");
12922
12923 /* Clean up our working buffer */
12924 Zero(work_name, sizeof(work_name), char);
12925
12926 /* Run through the entries and build up a working name */
12927 for(counter = 0; counter <= num_entries; counter++) {
12928 /* If it's not the first name then tack on a __ */
12929 if (counter) {
a35dcc95 12930 my_strlcat(work_name, "__", sizeof(work_name));
4b19af01 12931 }
a35dcc95 12932 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
4b19af01
CB		 12933 }
12934
12935 /* Check to see if we actually have to bother...*/
12936 if (strlen(work_name) + 3 <= max_name_len) {
a35dcc95 12937 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12938 } else {
12939 /* It's too darned big, so we need to go strip. We use the same */
12940 /* algorithm as xsubpp does. First, strip out doubled __ */
12941 char *source, *dest, last;
12942 dest = workbuff;
12943 last = 0;
12944 for (source = work_name; *source; source++) {
12945 if (last == *source && last == '_') {
12946 continue;
12947 }
12948 *dest++ = *source;
12949 last = *source;
12950 }
12951 /* Go put it back */
a35dcc95 12952 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12953 /* Is it still too big? */
12954 if (strlen(work_name) + 3 > max_name_len) {
12955 /* Strip duplicate letters */
12956 last = 0;
12957 dest = workbuff;
12958 for (source = work_name; *source; source++) {
12959 if (last == toupper(*source)) {
12960 continue;
12961 }
12962 *dest++ = *source;
12963 last = toupper(*source);
12964 }
a35dcc95 12965 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12966 }
12967
12968 /* Is it *still* too big? */
12969 if (strlen(work_name) + 3 > max_name_len) {
12970 /* Too bad, we truncate */
12971 work_name[max_name_len - 2] = 0;
12972 }
a35dcc95 12973 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12974 }
12975
12976 /* Okay, return it */
12977 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12978 XSRETURN(1);
12979}
12980
748a9306 12981void
96e176bf
CL		 12982hushexit_fromperl(pTHX_ CV *cv)
12983{
12984 dXSARGS;
12985
12986 if (items > 0) {
12987 VMSISH_HUSHED = SvTRUE(ST(0));
12988 }
12989 ST(0) = boolSV(VMSISH_HUSHED);
12990 XSRETURN(1);
12991}
12992
dca5a913
JM		 12993
12994PerlIO *
ce12d4b7 12995Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
dca5a913
JM		 12996{
12997 PerlIO *fp;
12998 struct vs_str_st *rslt;
12999 char *vmsspec;
13000 char *rstr;
13001 char *begin, *cp;
13002 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13003 PerlIO *tmpfp;
13004 STRLEN i;
13005 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13006 struct dsc$descriptor_vs rsdsc;
13007 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13008 unsigned long hasver = 0, isunix = 0;
13009 unsigned long int lff_flags = 0;
13010 int rms_sts;
85e7c9de 13011 int vms_old_glob = 1;
dca5a913 13012
83b907a4
CB		 13013 if (!SvOK(tmpglob)) {
13014 SETERRNO(ENOENT,RMS$_FNF);
13015 return NULL;
13016 }
13017
85e7c9de
JM		 13018 vms_old_glob = !decc_filename_unix_report;
13019
dca5a913
JM		 13020#ifdef VMS_LONGNAME_SUPPORT
13021 lff_flags = LIB$M_FIL_LONG_NAMES;
13022#endif
13023 /* The Newx macro will not allow me to assign a smaller array
13024 * to the rslt pointer, so we will assign it to the begin char pointer
13025 * and then copy the value into the rslt pointer.
13026 */
13027 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13028 rslt = (struct vs_str_st *)begin;
13029 rslt->length = 0;
13030 rstr = &rslt->str[0];
13031 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13032 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13033 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13034 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13035
13036 Newx(vmsspec, VMS_MAXRSS, char);
13037
13038 /* We could find out if there's an explicit dev/dir or version
13039 by peeking into lib$find_file's internal context at
13040 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13041 but that's unsupported, so I don't want to do it now and
13042 have it bite someone in the future. */
13043 /* Fix-me: vms_split_path() is the only way to do this, the
13044 existing method will fail with many legal EFS or UNIX specifications
13045 */
13046
13047 cp = SvPV(tmpglob,i);
13048
13049 for (; i; i--) {
13050 if (cp[i] == ';') hasver = 1;
13051 if (cp[i] == '.') {
13052 if (sts) hasver = 1;
13053 else sts = 1;
13054 }
13055 if (cp[i] == '/') {
13056 hasdir = isunix = 1;
13057 break;
13058 }
13059 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13060 hasdir = 1;
13061 break;
13062 }
13063 }
85e7c9de
JM		 13064
13065 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13066 if ((hasdir == 0) && decc_filename_unix_report) {
13067 isunix = 1;
13068 }
13069
dca5a913 13070 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
85e7c9de
JM		 13071 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13072 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13073 int wildstar = 0;
13074 int wildquery = 0;
990cad08 13075 int found = 0;
dca5a913
JM		 13076 Stat_t st;
13077 int stat_sts;
13078 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13079 if (!stat_sts && S_ISDIR(st.st_mode)) {
85e7c9de
JM		 13080 char * vms_dir;
13081 const char * fname;
13082 STRLEN fname_len;
13083
13084 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13085 /* path delimiter of ':>]', if so, then the old behavior has */
94ae10c0 13086 /* obviously been specifically requested */
85e7c9de
JM		 13087
13088 fname = SvPVX_const(tmpglob);
13089 fname_len = strlen(fname);
13090 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13091 if (vms_old_glob || (vms_dir != NULL)) {
13092 wilddsc.dsc$a_pointer = tovmspath_utf8(
13093 SvPVX(tmpglob),vmsspec,NULL);
13094 ok = (wilddsc.dsc$a_pointer != NULL);
13095 /* maybe passed 'foo' rather than '[.foo]', thus not
13096 detected above */
13097 hasdir = 1;
13098 } else {
13099 /* Operate just on the directory, the special stat/fstat for */
13100 /* leaves the fileified specification in the st_devnam */
13101 /* member. */
13102 wilddsc.dsc$a_pointer = st.st_devnam;
13103 ok = 1;
13104 }
dca5a913
JM		 13105 }
13106 else {
360732b5 13107 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 13108 ok = (wilddsc.dsc$a_pointer != NULL);
13109 }
13110 if (ok)
13111 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13112
13113 /* If not extended character set, replace ? with % */
13114 /* With extended character set, ? is a wildcard single character */
85e7c9de
JM		 13115 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13116 if (*cp == '?') {
13117 wildquery = 1;
998e0439 13118 if (!decc_efs_charset)
85e7c9de
JM		 13119 *cp = '%';
13120 } else if (*cp == '%') {
13121 wildquery = 1;
13122 } else if (*cp == '*') {
13123 wildstar = 1;
13124 }
dca5a913 13125 }
85e7c9de
JM		 13126
13127 if (ok) {
13128 wv_sts = vms_split_path(
13129 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13130 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13131 &wvs_spec, &wvs_len);
13132 } else {
13133 wn_spec = NULL;
13134 wn_len = 0;
13135 we_spec = NULL;
13136 we_len = 0;
13137 }
13138
dca5a913
JM		 13139 sts = SS$_NORMAL;
13140 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13141 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13142 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
85e7c9de 13143 int valid_find;
dca5a913 13144
85e7c9de 13145 valid_find = 0;
dca5a913
JM		 13146 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13147 &dfltdsc,NULL,&rms_sts,&lff_flags);
13148 if (!$VMS_STATUS_SUCCESS(sts))
13149 break;
13150
13151 /* with varying string, 1st word of buffer contains result length */
13152 rstr[rslt->length] = '\0';
13153
13154 /* Find where all the components are */
13155 v_sts = vms_split_path
360732b5 13156 (rstr,
dca5a913
JM		 13157 &v_spec,
13158 &v_len,
13159 &r_spec,
13160 &r_len,
13161 &d_spec,
13162 &d_len,
13163 &n_spec,
13164 &n_len,
13165 &e_spec,
13166 &e_len,
13167 &vs_spec,
13168 &vs_len);
13169
13170 /* If no version on input, truncate the version on output */
13171 if (!hasver && (vs_len > 0)) {
13172 *vs_spec = '\0';
13173 vs_len = 0;
85e7c9de
JM		 13174 }
13175
13176 if (isunix) {
13177
13178 /* In Unix report mode, remove the ".dir;1" from the name */
13179 /* if it is a real directory */
d5eaec22 13180 if (decc_filename_unix_report && decc_efs_charset) {
85e7c9de
JM		 13181 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13182 Stat_t statbuf;
13183 int ret_sts;
13184
13185 ret_sts = flex_lstat(rstr, &statbuf);
13186 if ((ret_sts == 0) &&
13187 S_ISDIR(statbuf.st_mode)) {
13188 e_len = 0;
13189 e_spec[0] = 0;
13190 }
13191 }
13192 }
dca5a913
JM		 13193
13194 /* No version & a null extension on UNIX handling */
85e7c9de 13195 if ((e_len == 1) && decc_readdir_dropdotnotype) {
dca5a913
JM		 13196 e_len = 0;
13197 *e_spec = '\0';
13198 }
13199 }
13200
13201 if (!decc_efs_case_preserve) {
13202 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13203 }
13204
85e7c9de
JM		 13205 /* Find File treats a Null extension as return all extensions */
13206 /* This is contrary to Perl expectations */
13207
13208 if (wildstar || wildquery || vms_old_glob) {
13209 /* really need to see if the returned file name matched */
13210 /* but for now will assume that it matches */
13211 valid_find = 1;
13212 } else {
13213 /* Exact Match requested */
13214 /* How are directories handled? - like a file */
13215 if ((e_len == we_len) && (n_len == wn_len)) {
13216 int t1;
13217 t1 = e_len;
13218 if (t1 > 0)
13219 t1 = strncmp(e_spec, we_spec, e_len);
13220 if (t1 == 0) {
13221 t1 = n_len;
13222 if (t1 > 0)
13223 t1 = strncmp(n_spec, we_spec, n_len);
13224 if (t1 == 0)
13225 valid_find = 1;
13226 }
13227 }
13228 }
13229
13230 if (valid_find) {
13231 found++;
13232
13233 if (hasdir) {
13234 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13235 begin = rstr;
13236 }
13237 else {
13238 /* Start with the name */
13239 begin = n_spec;
13240 }
13241 strcat(begin,"\n");
13242 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13243 }
dca5a913
JM		 13244 }
13245 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 13246
13247 if (!found) {
13248 /* Be POSIXish: return the input pattern when no matches */
a35dcc95 13249 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
2da7a6b5
CB		 13250 strcat(rstr,"\n");
13251 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 13252 }
13253
dca5a913
JM		 13254 if (ok && sts != RMS$_NMF &&
13255 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13256 if (!ok) {
13257 if (!(sts & 1)) {
13258 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13259 }
13260 PerlIO_close(tmpfp);
13261 fp = NULL;
13262 }
13263 else {
13264 PerlIO_rewind(tmpfp);
13265 IoTYPE(io) = IoTYPE_RDONLY;
13266 IoIFP(io) = fp = tmpfp;
13267 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13268 }
13269 }
13270 Safefree(vmsspec);
13271 Safefree(rslt);
13272 return fp;
13273}
13274
cd1191f1 13275
2497a41f 13276static char *
5c4d031a 13277mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 13278 int *utf8_fl);
2497a41f
JM		 13279
13280void
4d8d3a9c 13281unixrealpath_fromperl(pTHX_ CV *cv)
2497a41f 13282{
d584a1c6
JM		 13283 dXSARGS;
13284 char *fspec, *rslt_spec, *rslt;
13285 STRLEN n_a;
2497a41f 13286
d584a1c6 13287 if (!items || items != 1)
4d8d3a9c 13288 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
2497a41f 13289
d584a1c6
JM		 13290 fspec = SvPV(ST(0),n_a);
13291 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 13292
d584a1c6
JM		 13293 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13294 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13295
13296 ST(0) = sv_newmortal();
13297 if (rslt != NULL)
13298 sv_usepvn(ST(0),rslt,strlen(rslt));
13299 else
13300 Safefree(rslt_spec);
13301 XSRETURN(1);
2497a41f 13302}
2ee6e19d 13303
b1a8dcd7
JM		 13304static char *
13305mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13306 int *utf8_fl);
13307
13308void
4d8d3a9c 13309vmsrealpath_fromperl(pTHX_ CV *cv)
b1a8dcd7
JM		 13310{
13311 dXSARGS;
13312 char *fspec, *rslt_spec, *rslt;
13313 STRLEN n_a;
13314
13315 if (!items || items != 1)
4d8d3a9c 13316 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
b1a8dcd7
JM		 13317
13318 fspec = SvPV(ST(0),n_a);
13319 if (!fspec || !*fspec) XSRETURN_UNDEF;
13320
13321 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13322 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13323
13324 ST(0) = sv_newmortal();
13325 if (rslt != NULL)
13326 sv_usepvn(ST(0),rslt,strlen(rslt));
13327 else
13328 Safefree(rslt_spec);
13329 XSRETURN(1);
13330}
13331
13332#ifdef HAS_SYMLINK
2ee6e19d
CB		 13333/*
13334 * A thin wrapper around decc$symlink to make sure we follow the
cc9aafbd
CB		 13335 * standard and do not create a symlink with a zero-length name,
13336 * and convert the target to Unix format, as the CRTL can't handle
13337 * targets in VMS format.
2ee6e19d 13338 */
4148925f 13339/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
cc9aafbd
CB		 13340int
13341Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13342{
13343 int sts;
13344 char * utarget;
4148925f 13345
cc9aafbd
CB		 13346 if (!link_name || !*link_name) {
13347 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13348 return -1;
13349 }
4148925f 13350
c11536f5 13351 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
cc9aafbd
CB		 13352 /* An untranslatable filename should be passed through. */
13353 (void) int_tounixspec(contents, utarget, NULL);
13354 sts = symlink(utarget, link_name);
13355 PerlMem_free(utarget);
13356 return sts;
2ee6e19d
CB		 13357}
13358/*}}}*/
13359
13360#endif /* HAS_SYMLINK */
2497a41f 13361
2497a41f
JM		 13362int do_vms_case_tolerant(void);
13363
13364void
4d8d3a9c 13365case_tolerant_process_fromperl(pTHX_ CV *cv)
2497a41f
JM		 13366{
13367 dXSARGS;
13368 ST(0) = boolSV(do_vms_case_tolerant());
13369 XSRETURN(1);
13370}
2497a41f 13371
9ec7171b
CB		 13372#ifdef USE_ITHREADS
13373
96e176bf
CL		 13374void
13375Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13376 struct interp_intern *dst)
13377{
7918f24d
NC		 13378 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13379
96e176bf
CL		 13380 memcpy(dst,src,sizeof(struct interp_intern));
13381}
13382
9ec7171b
CB		 13383#endif
13384
96e176bf
CL		 13385void
13386Perl_sys_intern_clear(pTHX)
13387{
13388}
13389
13390void
13391Perl_sys_intern_init(pTHX)
13392{
3ff49832
CL		 13393 unsigned int ix = RAND_MAX;
13394 double x;
96e176bf
CL		 13395
13396 VMSISH_HUSHED = 0;
13397
1a3aec58 13398 MY_POSIX_EXIT = vms_posix_exit;
7a7fd8e0 13399
96e176bf
CL		 13400 x = (float)ix;
13401 MY_INV_RAND_MAX = 1./x;
ff7adb52 13402}
96e176bf
CL		 13403
13404void
f7ddb74a 13405init_os_extras(void)
748a9306 13406{
a69a6dba 13407 dTHX;
748a9306 13408 char* file = __FILE__;
988c775c 13409 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 13410 no_translate_barewords = TRUE;
13411 } else {
13412 no_translate_barewords = FALSE;
13413 }
748a9306 13414
740ce14c 13415 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13416 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13417 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13418 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13419 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13420 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13421 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13422 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13423 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13424 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13425 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
4d8d3a9c
CB		 13426 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13427 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13428 newXSproto("VMS::Filespec::case_tolerant_process",
13429 case_tolerant_process_fromperl,file,"");
17f28c40 13430
afd8f436 13431 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13432
748a9306
LW		 13433 return;
13434}
13435
f7ddb74a
JM		 13436#if __CRTL_VER == 80200000
13437/* This missed getting in to the DECC SDK for 8.2 */
13438char *realpath(const char *file_name, char * resolved_name, ...);
13439#endif
13440
13441/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13442/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13443 * The perl fallback routine to provide realpath() is not as efficient
13444 * on OpenVMS.
13445 */
d584a1c6 13446
c11536f5
CB		 13447#ifdef __cplusplus
13448extern "C" {
13449#endif
13450
d584a1c6
JM		 13451/* Hack, use old stat() as fastest way of getting ino_t and device */
13452int decc$stat(const char *name, void * statbuf);
054a3baf 13453#if __CRTL_VER >= 80200000
312ac60b
JM		 13454int decc$lstat(const char *name, void * statbuf);
13455#else
13456#define decc$lstat decc$stat
13457#endif
d584a1c6 13458
c11536f5
CB		 13459#ifdef __cplusplus
13460}
13461#endif
13462
d584a1c6
JM		 13463
13464/* Realpath is fragile. In 8.3 it does not work if the feature
13465 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13466 * links are implemented in RMS, not the CRTL. It also can fail if the
13467 * user does not have read/execute access to some of the directories.
13468 * So in order for Do What I Mean mode to work, if realpath() fails,
13469 * fall back to looking up the filename by the device name and FID.
13470 */
13471
312ac60b
JM		 13472int vms_fid_to_name(char * outname, int outlen,
13473 const char * name, int lstat_flag, mode_t * mode)
d584a1c6 13474{
312ac60b
JM		 13475#pragma message save
13476#pragma message disable MISALGNDSTRCT
13477#pragma message disable MISALGNDMEM
13478#pragma member_alignment save
13479#pragma nomember_alignment
ce12d4b7
CB		 13480 struct statbuf_t {
13481 char * st_dev;
13482 unsigned short st_ino[3];
13483 unsigned short old_st_mode;
13484 unsigned long padl[30]; /* plenty of room */
13485 } statbuf;
312ac60b
JM		 13486#pragma message restore
13487#pragma member_alignment restore
13488
13489 int sts;
13490 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13491 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13492 char *fileified;
13493 char *temp_fspec;
13494 char *ret_spec;
13495
13496 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13497 * unexpected answers
13498 */
13499
c11536f5 13500 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13501 if (fileified == NULL)
13502 _ckvmssts_noperl(SS$_INSFMEM);
13503
c11536f5 13504 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13505 if (temp_fspec == NULL)
13506 _ckvmssts_noperl(SS$_INSFMEM);
13507
13508 sts = -1;
13509 /* First need to try as a directory */
13510 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13511 if (ret_spec != NULL) {
13512 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13513 if (ret_spec != NULL) {
13514 if (lstat_flag == 0)
13515 sts = decc$stat(fileified, &statbuf);
13516 else
13517 sts = decc$lstat(fileified, &statbuf);
13518 }
13519 }
13520
13521 /* Then as a VMS file spec */
13522 if (sts != 0) {
13523 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13524 if (ret_spec != NULL) {
13525 if (lstat_flag == 0) {
13526 sts = decc$stat(temp_fspec, &statbuf);
13527 } else {
13528 sts = decc$lstat(temp_fspec, &statbuf);
13529 }
13530 }
13531 }
13532
13533 if (sts) {
13534 /* Next try - allow multiple dots with out EFS CHARSET */
13535 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13536 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13537 * enable it if it isn't already.
13538 */
312ac60b
JM		 13539 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13540 decc$feature_set_value(decc_efs_charset_index, 1, 1);
312ac60b
JM		 13541 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13542 if (lstat_flag == 0) {
13543 sts = decc$stat(name, &statbuf);
13544 } else {
13545 sts = decc$lstat(name, &statbuf);
13546 }
312ac60b
JM		 13547 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13548 decc$feature_set_value(decc_efs_charset_index, 1, 0);
312ac60b
JM		 13549 }
13550
13551
13552 /* and then because the Perl Unix to VMS conversion is not perfect */
13553 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13554 /* characters from filenames so we need to try it as-is */
13555 if (sts) {
13556 if (lstat_flag == 0) {
13557 sts = decc$stat(name, &statbuf);
13558 } else {
13559 sts = decc$lstat(name, &statbuf);
13560 }
13561 }
d584a1c6 13562
d584a1c6 13563 if (sts == 0) {
312ac60b 13564 int vms_sts;
d584a1c6
JM		 13565
13566 dvidsc.dsc$a_pointer=statbuf.st_dev;
d94c5a78 13567 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
d584a1c6
JM		 13568
13569 specdsc.dsc$a_pointer = outname;
13570 specdsc.dsc$w_length = outlen-1;
13571
d94c5a78 13572 vms_sts = lib$fid_to_name
d584a1c6 13573 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
d94c5a78 13574 if ($VMS_STATUS_SUCCESS(vms_sts)) {
d584a1c6 13575 outname[specdsc.dsc$w_length] = 0;
312ac60b
JM		 13576
13577 /* Return the mode */
13578 if (mode) {
13579 *mode = statbuf.old_st_mode;
13580 }
d584a1c6
JM		 13581 }
13582 }
9e2bec02
CB		 13583 PerlMem_free(temp_fspec);
13584 PerlMem_free(fileified);
d584a1c6
JM		 13585 return sts;
13586}
13587
13588
13589
f7ddb74a 13590static char *
5c4d031a 13591mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13592 int *utf8_fl)
f7ddb74a 13593{
d584a1c6
JM		 13594 char * rslt = NULL;
13595
b1a8dcd7
JM		 13596#ifdef HAS_SYMLINK
13597 if (decc_posix_compliant_pathnames > 0 ) {
13598 /* realpath currently only works if posix compliant pathnames are
13599 * enabled. It may start working when they are not, but in that
13600 * case we still want the fallback behavior for backwards compatibility
13601 */
d584a1c6 13602 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13603 }
13604#endif
d584a1c6
JM		 13605
13606 if (rslt == NULL) {
13607 char * vms_spec;
13608 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13609 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
312ac60b 13610 mode_t my_mode;
d584a1c6
JM		 13611
13612 /* Fall back to fid_to_name */
13613
13614 Newx(vms_spec, VMS_MAXRSS + 1, char);
13615
312ac60b 13616 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
4d8d3a9c 13617 if (sts == 0) {
d584a1c6
JM		 13618
13619
13620 /* Now need to trim the version off */
13621 sts = vms_split_path
13622 (vms_spec,
13623 &v_spec,
13624 &v_len,
13625 &r_spec,
13626 &r_len,
13627 &d_spec,
13628 &d_len,
13629 &n_spec,
13630 &n_len,
13631 &e_spec,
13632 &e_len,
13633 &vs_spec,
13634 &vs_len);
13635
13636
4d8d3a9c
CB		 13637 if (sts == 0) {
13638 int haslower = 0;
13639 const char *cp;
d584a1c6 13640
4d8d3a9c
CB		 13641 /* Trim off the version */
13642 int file_len = v_len + r_len + d_len + n_len + e_len;
13643 vms_spec[file_len] = 0;
d584a1c6 13644
f785e3a1
JM		 13645 /* Trim off the .DIR if this is a directory */
13646 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13647 if (S_ISDIR(my_mode)) {
13648 e_len = 0;
13649 e_spec[0] = 0;
13650 }
13651 }
13652
13653 /* Drop NULL extensions on UNIX file specification */
13654 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13655 e_len = 0;
13656 e_spec[0] = '\0';
13657 }
13658
4d8d3a9c 13659 /* The result is expected to be in UNIX format */
0e5ce2c7 13660 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
4d8d3a9c
CB		 13661
13662 /* Downcase if input had any lower case letters and
13663 * case preservation is not in effect.
13664 */
13665 if (!decc_efs_case_preserve) {
13666 for (cp = filespec; *cp; cp++)
13667 if (islower(*cp)) { haslower = 1; break; }
13668
13669 if (haslower) __mystrtolower(rslt);
13670 }
13671 }
643f470b
CB		 13672 } else {
13673
13674 /* Now for some hacks to deal with backwards and forward */
94ae10c0 13675 /* compatibility */
643f470b
CB		 13676 if (!decc_efs_charset) {
13677
13678 /* 1. ODS-2 mode wants to do a syntax only translation */
6fb6c614
JM		 13679 rslt = int_rmsexpand(filespec, outbuf,
13680 NULL, 0, NULL, utf8_fl);
643f470b
CB		 13681
13682 } else {
13683 if (decc_filename_unix_report) {
13684 char * dir_name;
13685 char * vms_dir_name;
13686 char * file_name;
13687
13688 /* 2. ODS-5 / UNIX report mode should return a failure */
13689 /* if the parent directory also does not exist */
13690 /* Otherwise, get the real path for the parent */
29475144 13691 /* and add the child to it. */
643f470b
CB		 13692
13693 /* basename / dirname only available for VMS 7.0+ */
13694 /* So we may need to implement them as common routines */
13695
13696 Newx(dir_name, VMS_MAXRSS + 1, char);
13697 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13698 dir_name[0] = '\0';
13699 file_name = NULL;
13700
13701 /* First try a VMS parse */
13702 sts = vms_split_path
13703 (filespec,
13704 &v_spec,
13705 &v_len,
13706 &r_spec,
13707 &r_len,
13708 &d_spec,
13709 &d_len,
13710 &n_spec,
13711 &n_len,
13712 &e_spec,
13713 &e_len,
13714 &vs_spec,
13715 &vs_len);
13716
13717 if (sts == 0) {
13718 /* This is VMS */
13719
13720 int dir_len = v_len + r_len + d_len + n_len;
13721 if (dir_len > 0) {
a35dcc95 13722 memcpy(dir_name, filespec, dir_len);
643f470b
CB		 13723 dir_name[dir_len] = '\0';
13724 file_name = (char *)&filespec[dir_len + 1];
13725 }
13726 } else {
13727 /* This must be UNIX */
13728 char * tchar;
13729
13730 tchar = strrchr(filespec, '/');
13731
4148925f
JM		 13732 if (tchar != NULL) {
13733 int dir_len = tchar - filespec;
a35dcc95 13734 memcpy(dir_name, filespec, dir_len);
4148925f
JM		 13735 dir_name[dir_len] = '\0';
13736 file_name = (char *) &filespec[dir_len + 1];
13737 }
13738 }
13739
13740 /* Dir name is defaulted */
13741 if (dir_name[0] == 0) {
13742 dir_name[0] = '.';
13743 dir_name[1] = '\0';
13744 }
13745
13746 /* Need realpath for the directory */
13747 sts = vms_fid_to_name(vms_dir_name,
13748 VMS_MAXRSS + 1,
312ac60b 13749 dir_name, 0, NULL);
4148925f
JM		 13750
13751 if (sts == 0) {
29475144 13752 /* Now need to pathify it. */
1fe570cc
JM		 13753 char *tdir = int_pathify_dirspec(vms_dir_name,
13754 outbuf);
4148925f
JM		 13755
13756 /* And now add the original filespec to it */
13757 if (file_name != NULL) {
a35dcc95 13758 my_strlcat(outbuf, file_name, VMS_MAXRSS);
4148925f
JM		 13759 }
13760 return outbuf;
13761 }
13762 Safefree(vms_dir_name);
13763 Safefree(dir_name);
13764 }
13765 }
643f470b 13766 }
d584a1c6
JM		 13767 Safefree(vms_spec);
13768 }
13769 return rslt;
f7ddb74a
JM		 13770}
13771
b1a8dcd7
JM		 13772static char *
13773mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13774 int *utf8_fl)
13775{
13776 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13777 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
b1a8dcd7
JM		 13778
13779 /* Fall back to fid_to_name */
13780
312ac60b 13781 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
cd43acd7
CB		 13782 if (sts != 0) {
13783 return NULL;
13784 }
13785 else {
b1a8dcd7
JM		 13786
13787
13788 /* Now need to trim the version off */
13789 sts = vms_split_path
13790 (outbuf,
13791 &v_spec,
13792 &v_len,
13793 &r_spec,
13794 &r_len,
13795 &d_spec,
13796 &d_len,
13797 &n_spec,
13798 &n_len,
13799 &e_spec,
13800 &e_len,
13801 &vs_spec,
13802 &vs_len);
13803
13804
13805 if (sts == 0) {
4d8d3a9c
CB		 13806 int haslower = 0;
13807 const char *cp;
13808
13809 /* Trim off the version */
13810 int file_len = v_len + r_len + d_len + n_len + e_len;
13811 outbuf[file_len] = 0;
b1a8dcd7 13812
4d8d3a9c
CB		 13813 /* Downcase if input had any lower case letters and
13814 * case preservation is not in effect.
13815 */
13816 if (!decc_efs_case_preserve) {
13817 for (cp = filespec; *cp; cp++)
13818 if (islower(*cp)) { haslower = 1; break; }
13819
13820 if (haslower) __mystrtolower(outbuf);
13821 }
b1a8dcd7
JM		 13822 }
13823 }
13824 return outbuf;
13825}
13826
13827
f7ddb74a
JM		 13828/*}}}*/
13829/* External entry points */
ce12d4b7
CB		 13830char *
13831Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13832{
13833 return do_vms_realpath(filespec, outbuf, utf8_fl);
13834}
f7ddb74a 13835
ce12d4b7
CB		 13836char *
13837Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13838{
13839 return do_vms_realname(filespec, outbuf, utf8_fl);
13840}
f7ddb74a 13841
f7ddb74a
JM		 13842/* case_tolerant */
13843
13844/*{{{int do_vms_case_tolerant(void)*/
13845/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13846 * controlled by a process setting.
13847 */
ce12d4b7
CB		 13848int
13849do_vms_case_tolerant(void)
f7ddb74a
JM		 13850{
13851 return vms_process_case_tolerant;
13852}
13853/*}}}*/
13854/* External entry points */
ce12d4b7
CB		 13855int
13856Perl_vms_case_tolerant(void)
13857{
ce12d4b7 13858 return do_vms_case_tolerant();
ce12d4b7 13859}
f7ddb74a
JM		 13860
13861 /* Start of DECC RTL Feature handling */
13862
4ddecfe9
CB		 13863static int
13864set_feature_default(const char *name, int value)
13865{
13866 int status;
13867 int index;
25d1c58b
CB		 13868 char val_str[10];
13869
13870 /* If the feature has been explicitly disabled in the environment,
13871 * then don't enable it here.
13872 */
13873 if (value > 0) {
13874 status = simple_trnlnm(name, val_str, sizeof(val_str));
9bd30c63 13875 if (status) {
25d1c58b
CB		 13876 val_str[0] = _toupper(val_str[0]);
13877 if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13878 return 0;
13879 }
13880 }
4ddecfe9
CB		 13881
13882 index = decc$feature_get_index(name);
13883
13884 status = decc$feature_set_value(index, 1, value);
13885 if (index == -1 || (status == -1)) {
13886 return -1;
13887 }
13888
13889 status = decc$feature_get_value(index, 1);
13890 if (status != value) {
13891 return -1;
13892 }
13893
13894 /* Various things may check for an environment setting
13895 * rather than the feature directly, so set that too.
13896 */
13897 vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13898
13899 return 0;
13900}
4ddecfe9 13901
f7ddb74a 13902
f7ddb74a
JM		 13903/* C RTL Feature settings */
13904
e2367aa8
CB		 13905#if defined(__DECC) || defined(__DECCXX)
13906
13907#ifdef __cplusplus
13908extern "C" {
13909#endif
13910
13911extern void
13912vmsperl_set_features(void)
f7ddb74a
JM		 13913{
13914 int status;
13915 int s;
f7ddb74a 13916 char val_str[10];
054a3baf 13917#if defined(JPI$_CASE_LOOKUP_PERM)
f7ddb74a
JM		 13918 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13919 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13920 unsigned long case_perm;
13921 unsigned long case_image;
3c841f20 13922#endif
f7ddb74a 13923
9c1171d1
JM		 13924 /* Allow an exception to bring Perl into the VMS debugger */
13925 vms_debug_on_exception = 0;
8dc9d339 13926 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
9bd30c63 13927 if (status) {
b53f3677 13928 val_str[0] = _toupper(val_str[0]);
9c1171d1
JM		 13929 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13930 vms_debug_on_exception = 1;
13931 else
13932 vms_debug_on_exception = 0;
13933 }
13934
b53f3677
JM		 13935 /* Debug unix/vms file translation routines */
13936 vms_debug_fileify = 0;
8dc9d339 13937 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
9bd30c63 13938 if (status) {
b53f3677
JM		 13939 val_str[0] = _toupper(val_str[0]);
13940 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13941 vms_debug_fileify = 1;
13942 else
13943 vms_debug_fileify = 0;
13944 }
13945
13946
13947 /* Historically PERL has been doing vmsify / stat differently than */
13948 /* the CRTL. In particular, under some conditions the CRTL will */
13949 /* remove some illegal characters like spaces from filenames */
13950 /* resulting in some differences. The stat()/lstat() wrapper has */
13951 /* been reporting such file names as invalid and fails to stat them */
13952 /* fixing this bug so that stat()/lstat() accept these like the */
13953 /* CRTL does will result in several tests failing. */
13954 /* This should really be fixed, but for now, set up a feature to */
13955 /* enable it so that the impact can be studied. */
13956 vms_bug_stat_filename = 0;
8dc9d339 13957 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
9bd30c63 13958 if (status) {
b53f3677
JM		 13959 val_str[0] = _toupper(val_str[0]);
13960 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13961 vms_bug_stat_filename = 1;
13962 else
13963 vms_bug_stat_filename = 0;
13964 }
13965
13966
38a44b82 13967 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5 13968 vms_vtf7_filenames = 0;
8dc9d339 13969 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
9bd30c63 13970 if (status) {
b53f3677 13971 val_str[0] = _toupper(val_str[0]);
360732b5
JM		 13972 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13973 vms_vtf7_filenames = 1;
13974 else
13975 vms_vtf7_filenames = 0;
13976 }
13977
e0e5e8d6 13978 /* unlink all versions on unlink() or rename() */
d584a1c6 13979 vms_unlink_all_versions = 0;
9bd30c63
CB		 13980 status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13981 if (status) {
b53f3677 13982 val_str[0] = _toupper(val_str[0]);
e0e5e8d6
JM		 13983 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13984 vms_unlink_all_versions = 1;
13985 else
13986 vms_unlink_all_versions = 0;
13987 }
13988
5ca74088 13989 /* Detect running under GNV Bash or other UNIX like shell */
360732b5 13990 gnv_unix_shell = 0;
8dc9d339 13991 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
9bd30c63 13992 if (status) {
360732b5 13993 gnv_unix_shell = 1;
360732b5
JM		 13994 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13995 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13996 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13997 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13998 vms_unlink_all_versions = 1;
1a3aec58 13999 vms_posix_exit = 1;
bc6f2746
CB		 14000 /* Reverse default ordering of PERL_ENV_TABLES. */
14001 defenv[0] = &crtlenvdsc;
14002 defenv[1] = &fildevdsc;
360732b5 14003 }
5ca74088
CB		 14004 /* Some reasonable defaults that are not CRTL defaults */
14005 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
c342cf44 14006 set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
012528a9 14007 set_feature_default("DECC$EFS_CHARSET", 1);
9c1171d1 14008
2497a41f
JM		 14009 /* hacks to see if known bugs are still present for testing */
14010
2497a41f 14011 /* PCP mode requires creating /dev/null special device file */
2623a4a6 14012 decc_bug_devnull = 0;
8dc9d339 14013 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
9bd30c63 14014 if (status) {
b53f3677 14015 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 14016 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14017 decc_bug_devnull = 1;
682e4b71
JM		 14018 else
14019 decc_bug_devnull = 0;
2497a41f
JM		 14020 }
14021
f7ddb74a
JM		 14022 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14023 if (s >= 0) {
14024 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14025 if (decc_disable_to_vms_logname_translation < 0)
14026 decc_disable_to_vms_logname_translation = 0;
14027 }
14028
14029 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14030 if (s >= 0) {
14031 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14032 if (decc_efs_case_preserve < 0)
14033 decc_efs_case_preserve = 0;
14034 }
14035
14036 s = decc$feature_get_index("DECC$EFS_CHARSET");
b53f3677 14037 decc_efs_charset_index = s;
f7ddb74a
JM		 14038 if (s >= 0) {
14039 decc_efs_charset = decc$feature_get_value(s, 1);
14040 if (decc_efs_charset < 0)
14041 decc_efs_charset = 0;
14042 }
14043
14044 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14045 if (s >= 0) {
14046 decc_filename_unix_report = decc$feature_get_value(s, 1);
1a3aec58 14047 if (decc_filename_unix_report > 0) {
f7ddb74a 14048 decc_filename_unix_report = 1;
1a3aec58
JM		 14049 vms_posix_exit = 1;
14050 }
f7ddb74a
JM		 14051 else
14052 decc_filename_unix_report = 0;
14053 }
14054
14055 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14056 if (s >= 0) {
14057 decc_filename_unix_only = decc$feature_get_value(s, 1);
14058 if (decc_filename_unix_only > 0) {
14059 decc_filename_unix_only = 1;
14060 }
14061 else {
14062 decc_filename_unix_only = 0;
14063 }
14064 }
14065
14066 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14067 if (s >= 0) {
14068 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14069 if (decc_filename_unix_no_version < 0)
14070 decc_filename_unix_no_version = 0;
14071 }
14072
14073 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14074 if (s >= 0) {
14075 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14076 if (decc_readdir_dropdotnotype < 0)
14077 decc_readdir_dropdotnotype = 0;
14078 }
14079
f7ddb74a
JM		 14080#if __CRTL_VER >= 80200000
14081 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14082 if (s >= 0) {
14083 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14084 if (decc_posix_compliant_pathnames < 0)
14085 decc_posix_compliant_pathnames = 0;
14086 if (decc_posix_compliant_pathnames > 4)
14087 decc_posix_compliant_pathnames = 0;
14088 }
14089
14090#endif
f7ddb74a 14091
054a3baf 14092#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
f7ddb74a
JM		 14093
14094 /* Report true case tolerance */
14095 /*----------------------------*/
14096 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14097 if (!$VMS_STATUS_SUCCESS(status))
14098 case_perm = PPROP$K_CASE_BLIND;
14099 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14100 if (!$VMS_STATUS_SUCCESS(status))
14101 case_image = PPROP$K_CASE_BLIND;
14102 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14103 (case_image == PPROP$K_CASE_SENSITIVE))
14104 vms_process_case_tolerant = 0;
14105
14106#endif
14107
1a3aec58 14108 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
94ae10c0 14109 /* for strict backward compatibility */
9bd30c63
CB		 14110 status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14111 if (status) {
b53f3677 14112 val_str[0] = _toupper(val_str[0]);
1a3aec58
JM		 14113 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14114 vms_posix_exit = 1;
14115 else
14116 vms_posix_exit = 0;
14117 }
c11536f5 14118}
f7ddb74a 14119
e2367aa8
CB		 14120/* Use 32-bit pointers because that's what the image activator
14121 * assumes for the LIB$INITIALZE psect.
14122 */
14123#if __INITIAL_POINTER_SIZE
14124#pragma pointer_size save
14125#pragma pointer_size 32
14126#endif
14127
14128/* Create a reference to the LIB$INITIALIZE function. */
14129extern void LIB$INITIALIZE(void);
14130extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14131
14132/* Create an array of pointers to the init functions in the special
14133 * LIB$INITIALIZE section. In our case, the array only has one entry.
14134 */
14135#pragma extern_model save
2646d7b3 14136#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
e2367aa8
CB		 14137extern void (* const vmsperl_unused_global_2[])() =
14138{
14139 vmsperl_set_features,
14140};
14141#pragma extern_model restore
14142
14143#if __INITIAL_POINTER_SIZE
14144#pragma pointer_size restore
14145#endif
14146
14147#ifdef __cplusplus
14148}
f7ddb74a
JM		 14149#endif
14150
e2367aa8 14151#endif /* defined(__DECC) || defined(__DECCXX) */
748a9306 14152/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.