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
Cast away Solaris Studio 12.3 warning.
[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]) &&
f675dbe5
CB		 923 !strncmp(environ[i],uplnm,eq - environ[i])) {
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;
1322 for (j = 0; environ[j]; j++) {
1323 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1324 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1325 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1326 }
1327 else {
1328 start++;
22be8b3c
CB		 1329 sv = newSVpv(start,0);
1330 SvTAINTED_on(sv);
1331 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1332 }
1333 }
1334 continue;
740ce14c 1335 }
f675dbe5
CB		 1336 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337 !str$case_blind_compare(&tmpdsc,&clisym)) {
a35dcc95 1338 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
f675dbe5
CB		 1339 cmddsc.dsc$w_length = 20;
1340 if (env_tables[i]->dsc$w_length == 12 &&
1341 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
a35dcc95 1342 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
f675dbe5
CB		 1343 flags = defflags | CLI$M_NOLOGNAM;
1344 }
1345 else {
a35dcc95 1346 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
f675dbe5 1347 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
a35dcc95 1348 my_strlcat(cmd," /Table=", sizeof(cmd));
88e3936f 1349 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
f675dbe5
CB		 1350 }
1351 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1352 flags = defflags | CLI$M_NOCLISYM;
1353 }
1354
1355 /* Create a new subprocess to execute each command, to exclude the
1356 * remote possibility that someone could subvert a mbx or file used
1357 * to write multiple commands to a single subprocess.
1358 */
1359 do {
1360 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1361 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1362 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1363 defflags &= ~CLI$M_TRUSTED;
1364 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1365 _ckvmssts(retsts);
a02a5408 1366 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1367 if (seenhv) SvREFCNT_dec(seenhv);
1368 seenhv = newHV();
1369 while (1) {
1370 char *cp1, *cp2, *key;
1371 unsigned long int sts, iosb[2], retlen, keylen;
eb578fdb 1372 U32 hash;
f675dbe5
CB		 1373
1374 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1375 if (sts & 1) sts = iosb[0] & 0xffff;
1376 if (sts == SS$_ENDOFFILE) {
1377 int wakect = 0;
1378 while (substs == 0) { sys$hiber(); wakect++;}
1379 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1380 _ckvmssts(substs);
1381 break;
1382 }
1383 _ckvmssts(sts);
1384 retlen = iosb[0] >> 16;
1385 if (!retlen) continue; /* blank line */
1386 buf[retlen] = '\0';
1387 if (iosb[1] != subpid) {
1388 if (iosb[1]) {
5c84aa53 1389 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1390 }
1391 continue;
1392 }
3eeba6fb 1393 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1394 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1395
1396 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1397 if (*cp1 == '(' || /* Logical name table name */
1398 *cp1 == '=' /* Next eqv of searchlist */) continue;
1399 if (*cp1 == '"') cp1++;
1400 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1401 key = cp1; keylen = cp2 - cp1;
1402 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1403 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1404 while (*cp2 && *cp2 == '=') cp2++;
1405 while (*cp2 && *cp2 == ' ') cp2++;
1406 if (*cp2 == '"') { /* String translation; may embed "" */
1407 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1408 cp2++; cp1--; /* Skip "" surrounding translation */
1409 }
1410 else { /* Numeric translation */
1411 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1412 cp1--; /* stop on last non-space char */
1413 }
1414 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1415 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1416 continue;
1417 }
5afd6d42 1418 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1419
1420 if (cp1 == cp2 && *cp2 == '.') {
1421 /* A single dot usually means an unprintable character, such as a null
1422 * to indicate a zero-length value. Get the actual value to make sure.
1423 */
1424 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1425 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1426 int trnlen;
ff79d39d 1427 strncpy(lnm, key, keylen);
0faef845 1428 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1429 sv = newSVpvn(eqv, strlen(eqv));
1430 }
1431 else {
1432 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1433 }
1434
22be8b3c
CB		 1435 SvTAINTED_on(sv);
1436 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1437 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1438 }
f675dbe5
CB		 1439 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1440 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1441 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1442 char eqv[LNM$C_NAMLENGTH+1];
1443 int trnlen, i;
1444 for (i = 0; ppfs[i]; i++) {
1445 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1446 sv = newSVpv(eqv,trnlen);
1447 SvTAINTED_on(sv);
1448 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1449 }
740ce14c 1450 }
1451 }
f675dbe5
CB		 1452 primed = 1;
1453 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1454 if (buf) Safefree(buf);
1455 if (seenhv) SvREFCNT_dec(seenhv);
1456 MUTEX_UNLOCK(&primenv_mutex);
1457 return;
1458
740ce14c 1459} /* end of prime_env_iter */
1460/*}}}*/
740ce14c 1461
f675dbe5 1462
2c590a56 1463/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1464/* Define or delete an element in the same "environment" as
1465 * vmstrnenv(). If an element is to be deleted, it's removed from
1466 * the first place it's found. If it's to be set, it's set in the
1467 * place designated by the first element of the table vector.
3eeba6fb 1468 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1469 */
f675dbe5 1470int
2c590a56 1471Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1472{
f7ddb74a
JM		 1473 const char *cp1;
1474 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1475 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1476 int nseg = 0, j;
a0d0e21e 1477 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1478 struct itmlst_3 *ile, *ilist;
a0d0e21e 1479 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1480 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1481 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1482 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1483 $DESCRIPTOR(local,"_LOCAL");
1484
ed253963
CB		 1485 if (!lnm) {
1486 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1487 return SS$_IVLOGNAM;
1488 }
1489
f7ddb74a 1490 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1491 *cp2 = _toupper(*cp1);
1492 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1493 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1494 return SS$_IVLOGNAM;
1495 }
1496 }
a0d0e21e 1497 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1498 if (!tabvec || !*tabvec) tabvec = env_tables;
1499
3eeba6fb 1500 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1501 for (curtab = 0; tabvec[curtab]; curtab++) {
1502 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1503 int i;
299d126a 1504 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1505 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1506 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1507 !strncmp(environ[i],lnm,cp1 - environ[i])) {
cda27dcf
CB		 1508 unsetenv(lnm);
1509 return 0;
f675dbe5
CB		 1510 }
1511 }
1512 ivenv = 1; retsts = SS$_NOLOGNAM;
f675dbe5
CB		 1513 }
1514 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1515 !str$case_blind_compare(&tmpdsc,&clisym)) {
1516 unsigned int symtype;
1517 if (tabvec[curtab]->dsc$w_length == 12 &&
1518 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1519 !str$case_blind_compare(&tmpdsc,&local))
1520 symtype = LIB$K_CLI_LOCAL_SYM;
1521 else symtype = LIB$K_CLI_GLOBAL_SYM;
1522 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1523 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1524 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1525 break;
1526 }
1527 else if (!ivlnm) {
1528 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1529 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1530 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1531 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1532 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1533 }
a0d0e21e
LW		 1534 }
1535 }
f675dbe5
CB		 1536 else { /* we're defining a value */
1537 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
3eeba6fb 1538 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5
CB		 1539 }
1540 else {
f7ddb74a 1541 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1542 eqvdsc.dsc$w_length = strlen(eqv);
1543 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1544 !str$case_blind_compare(&tmpdsc,&clisym)) {
1545 unsigned int symtype;
1546 if (tabvec[0]->dsc$w_length == 12 &&
1547 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1548 !str$case_blind_compare(&tmpdsc,&local))
1549 symtype = LIB$K_CLI_LOCAL_SYM;
1550 else symtype = LIB$K_CLI_GLOBAL_SYM;
1551 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1552 }
3eeba6fb
CB		 1553 else {
1554 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1555 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1556
1557 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1558 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1559 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1560 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1561 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1562 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1563 }
1564
a02a5408 1565 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1566 ile = ilist;
1567 if (!ile) {
1568 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1569 return SS$_INSFMEM;
a1dfe751 1570 }
fa537f88
CB		 1571 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1572
1573 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1574 ile->itmcode = LNM$_STRING;
1575 ile->bufadr = c;
1576 if ((j+1) == nseg) {
1577 ile->buflen = strlen(c);
1578 /* in case we are truncating one that's too long */
1579 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1580 }
1581 else {
1582 ile->buflen = LNM$C_NAMLENGTH;
1583 }
1584 }
1585
1586 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1587 Safefree (ilist);
1588 }
1589 else {
1590 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1591 }
3eeba6fb 1592 }
f675dbe5
CB		 1593 }
1594 }
1595 if (!(retsts & 1)) {
1596 switch (retsts) {
1597 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1598 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1599 set_errno(EVMSERR); break;
1600 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1601 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1602 set_errno(EINVAL); break;
1603 case SS$_NOPRIV:
7d2497bf 1604 set_errno(EACCES); break;
f675dbe5
CB		 1605 default:
1606 _ckvmssts(retsts);
1607 set_errno(EVMSERR);
1608 }
1609 set_vaxc_errno(retsts);
1610 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1611 }
3eeba6fb
CB		 1612 else {
1613 /* We reset error values on success because Perl does an hv_fetch()
1614 * before each hv_store(), and if the thing we're setting didn't
1615 * previously exist, we've got a leftover error message. (Of course,
1616 * this fails in the face of
1617 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1618 * in that the error reported in $! isn't spurious,
1619 * but it's right more often than not.)
1620 */
f675dbe5
CB		 1621 set_errno(0); set_vaxc_errno(retsts);
1622 return 0;
1623 }
1624
1625} /* end of vmssetenv() */
1626/*}}}*/
a0d0e21e 1627
2c590a56 1628/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1629/* This has to be a function since there's a prototype for it in proto.h */
1630void
2c590a56 1631Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1632{
bc10a425
CB		 1633 if (lnm && *lnm) {
1634 int len = strlen(lnm);
1635 if (len == 7) {
1636 char uplnm[8];
22d4bb9c
CB		 1637 int i;
1638 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1639 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1640 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1641 return;
1642 }
1643 }
22d4bb9c 1644 }
f675dbe5
CB		 1645 (void) vmssetenv(lnm,eqv,NULL);
1646}
a0d0e21e
LW		 1647/*}}}*/
1648
27c67b75 1649/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1650/* vmssetuserlnm
1651 * sets a user-mode logical in the process logical name table
1652 * used for redirection of sys$error
1653 */
1654void
0db50132 1655Perl_vmssetuserlnm(const char *name, const char *eqv)
0e06870b
CB		 1656{
1657 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1658 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1659 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1660 unsigned char acmode = PSL$C_USER;
1661 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1662 {0, 0, 0, 0}};
2fbb330f 1663 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1664 d_name.dsc$w_length = strlen(name);
1665
1666 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1667 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1668
1669 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1670 if (!(iss&1)) lib$signal(iss);
1671}
1672/*}}}*/
c07a80fd 1673
f675dbe5 1674
c07a80fd 1675/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1676/* my_crypt - VMS password hashing
1677 * my_crypt() provides an interface compatible with the Unix crypt()
1678 * C library function, and uses sys$hash_password() to perform VMS
1679 * password hashing. The quadword hashed password value is returned
1680 * as a NUL-terminated 8 character string. my_crypt() does not change
1681 * the case of its string arguments; in order to match the behavior
1682 * of LOGINOUT et al., alphabetic characters in both arguments must
1683 * be upcased by the caller.
2497a41f
JM		 1684 *
1685 * - fix me to call ACM services when available
c07a80fd 1686 */
1687char *
fd8cd3a3 1688Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1689{
1690# ifndef UAI$C_PREFERRED_ALGORITHM
1691# define UAI$C_PREFERRED_ALGORITHM 127
1692# endif
1693 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1694 unsigned short int salt = 0;
1695 unsigned long int sts;
1696 struct const_dsc {
1697 unsigned short int dsc$w_length;
1698 unsigned char dsc$b_type;
1699 unsigned char dsc$b_class;
1700 const char * dsc$a_pointer;
1701 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1702 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1703 struct itmlst_3 uailst[3] = {
1704 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1705 { sizeof salt, UAI$_SALT, &salt, 0},
1706 { 0, 0, NULL, NULL}};
1707 static char hash[9];
1708
1709 usrdsc.dsc$w_length = strlen(usrname);
1710 usrdsc.dsc$a_pointer = usrname;
1711 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1712 switch (sts) {
f282b18d 1713 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1714 set_errno(EACCES);
1715 break;
1716 case RMS$_RNF:
1717 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1718 break;
1719 default:
1720 set_errno(EVMSERR);
1721 }
1722 set_vaxc_errno(sts);
1723 if (sts != RMS$_RNF) return NULL;
1724 }
1725
1726 txtdsc.dsc$w_length = strlen(textpasswd);
1727 txtdsc.dsc$a_pointer = textpasswd;
1728 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1729 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1730 }
1731
1732 return (char *) hash;
1733
1734} /* end of my_crypt() */
1735/*}}}*/
1736
1737
360732b5
JM		 1738static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1739static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1740static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1741
e0e5e8d6
JM		 1742/* 8.3, remove() is now broken on symbolic links */
1743static int rms_erase(const char * vmsname);
1744
1745
2497a41f 1746/* mp_do_kill_file
94ae10c0 1747 * A little hack to get around a bug in some implementation of remove()
2497a41f
JM		 1748 * that do not know how to delete a directory
1749 *
1750 * Delete any file to which user has control access, regardless of whether
1751 * delete access is explicitly allowed.
1752 * Limitations: User must have write access to parent directory.
1753 * Does not block signals or ASTs; if interrupted in midstream
1754 * may leave file with an altered ACL.
1755 * HANDLE WITH CARE!
1756 */
1757/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1758static int
1759mp_do_kill_file(pTHX_ const char *name, int dirflag)
1760{
e0e5e8d6
JM		 1761 char *vmsname;
1762 char *rslt;
2497a41f 1763 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
81d2d377
CB		 1764 unsigned long int cxt = 0, aclsts, fndsts;
1765 int rmsts = -1;
2497a41f
JM		 1766 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1767 struct myacedef {
1768 unsigned char myace$b_length;
1769 unsigned char myace$b_type;
1770 unsigned short int myace$w_flags;
1771 unsigned long int myace$l_access;
1772 unsigned long int myace$l_ident;
1773 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1774 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1775 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1776 struct itmlst_3
1777 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1778 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1779 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1780 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1781 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1782 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1783
1784 /* Expand the input spec using RMS, since the CRTL remove() and
1785 * system services won't do this by themselves, so we may miss
1786 * a file "hiding" behind a logical name or search list. */
c11536f5 1787 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1788 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1789
6fb6c614 1790 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1791 if (rslt == NULL) {
c5375c28 1792 PerlMem_free(vmsname);
2497a41f
JM		 1793 return -1;
1794 }
c5375c28 1795
e0e5e8d6
JM		 1796 /* Erase the file */
1797 rmsts = rms_erase(vmsname);
2497a41f 1798
e0e5e8d6
JM		 1799 /* Did it succeed */
1800 if ($VMS_STATUS_SUCCESS(rmsts)) {
1801 PerlMem_free(vmsname);
1802 return 0;
2497a41f
JM		 1803 }
1804
1805 /* If not, can changing protections help? */
e0e5e8d6
JM		 1806 if (rmsts != RMS$_PRV) {
1807 set_vaxc_errno(rmsts);
1808 PerlMem_free(vmsname);
2497a41f
JM		 1809 return -1;
1810 }
1811
1812 /* No, so we get our own UIC to use as a rights identifier,
1813 * and the insert an ACE at the head of the ACL which allows us
1814 * to delete the file.
1815 */
ebd4d70b 1816 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1817 fildsc.dsc$w_length = strlen(vmsname);
1818 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1819 cxt = 0;
1820 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1821 rmsts = -1;
2497a41f
JM		 1822 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823 switch (aclsts) {
1824 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825 set_errno(ENOENT); break;
1826 case RMS$_DIR:
1827 set_errno(ENOTDIR); break;
1828 case RMS$_DEV:
1829 set_errno(ENODEV); break;
1830 case RMS$_SYN: case SS$_INVFILFOROP:
1831 set_errno(EINVAL); break;
1832 case RMS$_PRV:
1833 set_errno(EACCES); break;
1834 default:
ebd4d70b 1835 _ckvmssts_noperl(aclsts);
2497a41f
JM		 1836 }
1837 set_vaxc_errno(aclsts);
e0e5e8d6 1838 PerlMem_free(vmsname);
2497a41f
JM		 1839 return -1;
1840 }
1841 /* Grab any existing ACEs with this identifier in case we fail */
1842 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844 || fndsts == SS$_NOMOREACE ) {
1845 /* Add the new ACE . . . */
1846 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1847 goto yourroom;
1848
e0e5e8d6
JM		 1849 rmsts = rms_erase(vmsname);
1850 if ($VMS_STATUS_SUCCESS(rmsts)) {
1851 rmsts = 0;
2497a41f
JM		 1852 }
1853 else {
e0e5e8d6 1854 rmsts = -1;
2497a41f
JM		 1855 /* We blew it - dir with files in it, no write priv for
1856 * parent directory, etc. Put things back the way they were. */
1857 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1858 goto yourroom;
1859 if (fndsts & 1) {
1860 addlst[0].bufadr = &oldace;
1861 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1862 goto yourroom;
1863 }
1864 }
1865 }
1866
1867 yourroom:
1868 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1869 /* We just deleted it, so of course it's not there. Some versions of
1870 * VMS seem to return success on the unlock operation anyhow (after all
1871 * the unlock is successful), but others don't.
1872 */
1873 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1874 if (aclsts & 1) aclsts = fndsts;
1875 if (!(aclsts & 1)) {
1876 set_errno(EVMSERR);
1877 set_vaxc_errno(aclsts);
2497a41f
JM		 1878 }
1879
e0e5e8d6 1880 PerlMem_free(vmsname);
2497a41f
JM		 1881 return rmsts;
1882
1883} /* end of kill_file() */
1884/*}}}*/
1885
1886
a0d0e21e
LW		 1887/*{{{int do_rmdir(char *name)*/
1888int
b8ffc8df 1889Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1890{
e0e5e8d6 1891 char * dirfile;
a0d0e21e 1892 int retval;
61bb5906 1893 Stat_t st;
a0d0e21e 1894
d94c5a78
JM		 1895 /* lstat returns a VMS fileified specification of the name */
1896 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 1897
46c05374 1898 retval = flex_lstat(name, &st);
d94c5a78
JM		 1899 if (retval != 0) {
1900 char * ret_spec;
1901
1902 /* Due to a historical feature, flex_stat/lstat can not see some */
1903 /* Unix format file names that the rest of the CRTL can see */
1904 /* Fixing that feature will cause some perl tests to fail */
1905 /* So try this one more time. */
1906
1907 retval = lstat(name, &st.crtl_stat);
1908 if (retval != 0)
1909 return -1;
1910
1911 /* force it to a file spec for the kill file to work. */
1912 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1913 if (ret_spec == NULL) {
1914 errno = EIO;
1915 return -1;
1916 }
e0e5e8d6 1917 }
d94c5a78
JM		 1918
1919 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1920 errno = ENOTDIR;
1921 retval = -1;
1922 }
d94c5a78
JM		 1923 else {
1924 dirfile = st.st_devnam;
1925
1926 /* It may be possible for flex_stat to find a file and vmsify() to */
1927 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1928 /* with that case, so fail it */
1929 if (dirfile[0] == 0) {
1930 errno = EIO;
1931 return -1;
1932 }
1933
e0e5e8d6 1934 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 1935 }
e0e5e8d6 1936
a0d0e21e
LW		 1937 return retval;
1938
1939} /* end of do_rmdir */
1940/*}}}*/
1941
1942/* kill_file
1943 * Delete any file to which user has control access, regardless of whether
1944 * delete access is explicitly allowed.
1945 * Limitations: User must have write access to parent directory.
1946 * Does not block signals or ASTs; if interrupted in midstream
1947 * may leave file with an altered ACL.
1948 * HANDLE WITH CARE!
1949 */
1950/*{{{int kill_file(char *name)*/
1951int
b8ffc8df 1952Perl_kill_file(pTHX_ const char *name)
a0d0e21e 1953{
d94c5a78 1954 char * vmsfile;
e0e5e8d6
JM		 1955 Stat_t st;
1956 int rmsts;
a0d0e21e 1957
d94c5a78
JM		 1958 /* Convert the filename to VMS format and see if it is a directory */
1959 /* flex_lstat returns a vmsified file specification */
46c05374 1960 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 1961 if (rmsts != 0) {
1962
1963 /* Due to a historical feature, flex_stat/lstat can not see some */
1964 /* Unix format file names that the rest of the CRTL can see when */
1965 /* ODS-2 file specifications are in use. */
1966 /* Fixing that feature will cause some perl tests to fail */
1967 /* [.lib.ExtUtils.t]Manifest.t is one of them */
1968 st.st_mode = 0;
1969 vmsfile = (char *) name; /* cast ok */
1970
1971 } else {
1972 vmsfile = st.st_devnam;
1973 if (vmsfile[0] == 0) {
1974 /* It may be possible for flex_stat to find a file and vmsify() */
1975 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
1976 /* deal with that case, so fail it */
1977 errno = EIO;
1978 return -1;
1979 }
1980 }
1981
1982 /* Remove() is allowed to delete directories, according to the X/Open
1983 * specifications.
1984 * This may need special handling to work with the ACL hacks.
a0d0e21e 1985 */
d94c5a78
JM		 1986 if (S_ISDIR(st.st_mode)) {
1987 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
1988 return rmsts;
a0d0e21e
LW		 1989 }
1990
d94c5a78
JM		 1991 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
1992
1993 /* Need to delete all versions ? */
1994 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
1995 int i = 0;
1996
1997 /* Just use lstat() here as do not need st_dev */
1998 /* and we know that the file is in VMS format or that */
1999 /* because of a historical bug, flex_stat can not see the file */
2000 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2001 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2002 if (rmsts != 0)
2003 break;
2004 i++;
2005
2006 /* Make sure that we do not loop forever */
2007 if (i > 32767) {
2008 errno = EIO;
2009 rmsts = -1;
2010 break;
2011 }
2012 }
2013 }
a0d0e21e
LW		 2014
2015 return rmsts;
2016
2017} /* end of kill_file() */
2018/*}}}*/
2019
8cc95fdb 2020
84902520 2021/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2022int
b8ffc8df 2023Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2024{
2025 STRLEN dirlen = strlen(dir);
2026
a2a90019
CB		 2027 /* zero length string sometimes gives ACCVIO */
2028 if (dirlen == 0) return -1;
2029
8cc95fdb 2030 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2031 * null file name/type. However, it's commonplace under Unix,
2032 * so we'll allow it for a gain in portability.
2033 */
2034 if (dir[dirlen-1] == '/') {
2035 char *newdir = savepvn(dir,dirlen-1);
2036 int ret = mkdir(newdir,mode);
2037 Safefree(newdir);
2038 return ret;
2039 }
2040 else return mkdir(dir,mode);
2041} /* end of my_mkdir */
2042/*}}}*/
2043
ee8c7f54
CB		 2044/*{{{int my_chdir(char *)*/
2045int
b8ffc8df 2046Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2047{
2048 STRLEN dirlen = strlen(dir);
09f253ec 2049 const char *dir1 = dir;
ee8c7f54 2050
0fd91152 2051 /* POSIX says we should set ENOENT for zero length string. */
09f253ec 2052 if (dirlen == 0) {
0fd91152 2053 SETERRNO(ENOENT, RMS$_DNF);
09f253ec
CB		 2054 return -1;
2055 }
f7ddb74a
JM		 2056
2057 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2058 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2059 * so that existing scripts do not need to be changed.
2060 */
f7ddb74a
JM		 2061 while ((dirlen > 0) && (*dir1 == ' ')) {
2062 dir1++;
2063 dirlen--;
2064 }
ee8c7f54
CB		 2065
2066 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2067 * that implies
2068 * null file name/type. However, it's commonplace under Unix,
2069 * so we'll allow it for a gain in portability.
f7ddb74a 2070 *
4d9538c1 2071 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2072 */
f7ddb74a 2073 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2074 char *newdir;
2075 int ret;
c11536f5 2076 newdir = (char *)PerlMem_malloc(dirlen);
4d9538c1
JM		 2077 if (newdir ==NULL)
2078 _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 2079 memcpy(newdir, dir1, dirlen-1);
4d9538c1
JM		 2080 newdir[dirlen-1] = '\0';
2081 ret = chdir(newdir);
2082 PerlMem_free(newdir);
2083 return ret;
ee8c7f54 2084 }
dca5a913 2085 else return chdir(dir1);
ee8c7f54
CB		 2086} /* end of my_chdir */
2087/*}}}*/
8cc95fdb 2088
674d6c38 2089
f1db9cda
JM		 2090/*{{{int my_chmod(char *, mode_t)*/
2091int
2092Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2093{
4d9538c1
JM		 2094 Stat_t st;
2095 int ret = -1;
2096 char * changefile;
f1db9cda
JM		 2097 STRLEN speclen = strlen(file_spec);
2098
2099 /* zero length string sometimes gives ACCVIO */
2100 if (speclen == 0) return -1;
2101
2102 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2103 * that implies null file name/type. However, it's commonplace under Unix,
2104 * so we'll allow it for a gain in portability.
2105 *
2106 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2107 * in VMS file.dir notation.
2108 */
4d9538c1
JM		 2109 changefile = (char *) file_spec; /* cast ok */
2110 ret = flex_lstat(file_spec, &st);
2111 if (ret != 0) {
f1db9cda 2112
4d9538c1
JM		 2113 /* Due to a historical feature, flex_stat/lstat can not see some */
2114 /* Unix format file names that the rest of the CRTL can see when */
2115 /* ODS-2 file specifications are in use. */
2116 /* Fixing that feature will cause some perl tests to fail */
2117 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2118 st.st_mode = 0;
f1db9cda 2119
4d9538c1
JM		 2120 } else {
2121 /* It may be possible to get here with nothing in st_devname */
2122 /* chmod still may work though */
2123 if (st.st_devnam[0] != 0) {
2124 changefile = st.st_devnam;
2125 }
f1db9cda 2126 }
4d9538c1
JM		 2127 ret = chmod(changefile, mode);
2128 return ret;
f1db9cda
JM		 2129} /* end of my_chmod */
2130/*}}}*/
2131
2132
674d6c38
CB		 2133/*{{{FILE *my_tmpfile()*/
2134FILE *
2135my_tmpfile(void)
2136{
2137 FILE *fp;
2138 char *cp;
674d6c38
CB		 2139
2140 if ((fp = tmpfile())) return fp;
2141
c11536f5 2142 cp = (char *)PerlMem_malloc(L_tmpnam+24);
c5375c28
JM		 2143 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2144
2497a41f
JM		 2145 if (decc_filename_unix_only == 0)
2146 strcpy(cp,"Sys$Scratch:");
2147 else
2148 strcpy(cp,"/tmp/");
674d6c38
CB		 2149 tmpnam(cp+strlen(cp));
2150 strcat(cp,".Perltmp");
2151 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2152 PerlMem_free(cp);
674d6c38
CB		 2153 return fp;
2154}
2155/*}}}*/
2156
5c2d7af2 2157
5c2d7af2
CB		 2158/*
2159 * The C RTL's sigaction fails to check for invalid signal numbers so we
2160 * help it out a bit. The docs are correct, but the actual routine doesn't
2161 * do what the docs say it will.
2162 */
2163/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2164int
2165Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2166 struct sigaction* oact)
2167{
2168 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2169 SETERRNO(EINVAL, SS$_INVARG);
2170 return -1;
2171 }
2172 return sigaction(sig, act, oact);
2173}
2174/*}}}*/
5c2d7af2 2175
f2610a60
CL		 2176#include <errnodef.h>
2177
05c058bc
CB		 2178/* We implement our own kill() using the undocumented system service
2179 sys$sigprc for one of two reasons:
2180
2181 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2182 target process to do a sys$exit, which usually can't be handled
2183 gracefully...certainly not by Perl and the %SIG{} mechanism.
2184
05c058bc
CB		 2185 2.) If the kill() in the CRTL can't be called from a signal
2186 handler without disappearing into the ether, i.e., the signal
2187 it purportedly sends is never trapped. Still true as of VMS 7.3.
2188
2189 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2190 in the target process rather than calling sys$exit.
2191
2192 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2193 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2194 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2195 with condition codes C$_SIG0+nsig*8, catching the exception on the
2196 target process and resignaling with appropriate arguments.
2197
2198 But we don't have that VMS 7.0+ exception handler, so if you
2199 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2200
2201 Also note that SIGTERM is listed in the docs as being "unimplemented",
2202 yet always seems to be signaled with a VMS condition code of 4 (and
2203 correctly handled for that code). So we hardwire it in.
2204
2205 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2206 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2207 than signalling with an unrecognized (and unhandled by CRTL) code.
2208*/
2209
fe1de8ce 2210#define _MY_SIG_MAX 28
f2610a60 2211
9c1171d1
JM		 2212static unsigned int
2213Perl_sig_to_vmscondition_int(int sig)
f2610a60 2214{
2e34cc90 2215 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2216 {
2217 0, /* 0 ZERO */
2218 SS$_HANGUP, /* 1 SIGHUP */
2219 SS$_CONTROLC, /* 2 SIGINT */
2220 SS$_CONTROLY, /* 3 SIGQUIT */
2221 SS$_RADRMOD, /* 4 SIGILL */
2222 SS$_BREAK, /* 5 SIGTRAP */
2223 SS$_OPCCUS, /* 6 SIGABRT */
2224 SS$_COMPAT, /* 7 SIGEMT */
f2610a60 2225 SS$_HPARITH, /* 8 SIGFPE AXP */
f2610a60
CL		 2226 SS$_ABORT, /* 9 SIGKILL */
2227 SS$_ACCVIO, /* 10 SIGBUS */
2228 SS$_ACCVIO, /* 11 SIGSEGV */
2229 SS$_BADPARAM, /* 12 SIGSYS */
2230 SS$_NOMBX, /* 13 SIGPIPE */
2231 SS$_ASTFLT, /* 14 SIGALRM */
2232 4, /* 15 SIGTERM */
2233 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2234 0, /* 17 SIGUSR2 */
2235 0, /* 18 */
2236 0, /* 19 */
2237 0, /* 20 SIGCHLD */
2238 0, /* 21 SIGCONT */
2239 0, /* 22 SIGSTOP */
2240 0, /* 23 SIGTSTP */
2241 0, /* 24 SIGTTIN */
2242 0, /* 25 SIGTTOU */
2243 0, /* 26 */
2244 0, /* 27 */
2245 0 /* 28 SIGWINCH */
f2610a60
CL		 2246 };
2247
f2610a60
CL		 2248 static int initted = 0;
2249 if (!initted) {
2250 initted = 1;
2251 sig_code[16] = C$_SIGUSR1;
2252 sig_code[17] = C$_SIGUSR2;
fe1de8ce 2253 sig_code[20] = C$_SIGCHLD;
fe1de8ce 2254 sig_code[28] = C$_SIGWINCH;
f2610a60 2255 }
f2610a60 2256
2e34cc90
CL		 2257 if (sig < _SIG_MIN) return 0;
2258 if (sig > _MY_SIG_MAX) return 0;
2259 return sig_code[sig];
2260}
2261
9c1171d1
JM		 2262unsigned int
2263Perl_sig_to_vmscondition(int sig)
2264{
2265#ifdef SS$_DEBUG
2266 if (vms_debug_on_exception != 0)
2267 lib$signal(SS$_DEBUG);
2268#endif
2269 return Perl_sig_to_vmscondition_int(sig);
2270}
2271
2272
96f902ff 2273#ifdef KILL_BY_SIGPRC
c11536f5
CB		 2274#define sys$sigprc SYS$SIGPRC
2275#ifdef __cplusplus
2276extern "C" {
2277#endif
2278int sys$sigprc(unsigned int *pidadr,
2279 struct dsc$descriptor_s *prcname,
2280 unsigned int code);
2281#ifdef __cplusplus
2282}
2283#endif
2284
2e34cc90
CL		 2285int
2286Perl_my_kill(int pid, int sig)
2287{
2288 int iss;
2289 unsigned int code;
2e34cc90 2290
7a7fd8e0
JM		 2291 /* sig 0 means validate the PID */
2292 /*------------------------------*/
2293 if (sig == 0) {
2294 const unsigned long int jpicode = JPI$_PID;
2295 pid_t ret_pid;
2296 int status;
2297 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2298 if ($VMS_STATUS_SUCCESS(status))
2299 return 0;
2300 switch (status) {
2301 case SS$_NOSUCHNODE:
2302 case SS$_UNREACHABLE:
2303 case SS$_NONEXPR:
2304 errno = ESRCH;
2305 break;
2306 case SS$_NOPRIV:
2307 errno = EPERM;
2308 break;
2309 default:
2310 errno = EVMSERR;
2311 }
2312 vaxc$errno=status;
2313 return -1;
2314 }
2315
9c1171d1 2316 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2317
7a7fd8e0
JM		 2318 if (!code) {
2319 SETERRNO(EINVAL, SS$_BADPARAM);
2320 return -1;
2321 }
2322
96f902ff 2323 /* Per official UNIX specification: If pid = 0, or negative then
7a7fd8e0
JM		 2324 * signals are to be sent to multiple processes.
2325 * pid = 0 - all processes in group except ones that the system exempts
2326 * pid = -1 - all processes except ones that the system exempts
2327 * pid = -n - all processes in group (abs(n)) except ...
96f902ff
CB		 2328 *
2329 * Handle these via killpg, which is redundant for the -n case, since OP_KILL
2330 * in doio.c already does that. killpg currently does not support the -1 case.
7a7fd8e0
JM		 2331 */
2332
2333 if (pid <= 0) {
96f902ff 2334 return killpg(-pid, sig);
f2610a60
CL		 2335 }
2336
2e34cc90 2337 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2338 if (iss&1) return 0;
2339
2340 switch (iss) {
2341 case SS$_NOPRIV:
2342 set_errno(EPERM); break;
2343 case SS$_NONEXPR:
2344 case SS$_NOSUCHNODE:
2345 case SS$_UNREACHABLE:
2346 set_errno(ESRCH); break;
2347 case SS$_INSFMEM:
2348 set_errno(ENOMEM); break;
2349 default:
ebd4d70b 2350 _ckvmssts_noperl(iss);
f2610a60
CL		 2351 set_errno(EVMSERR);
2352 }
2353 set_vaxc_errno(iss);
2354
2355 return -1;
2356}
2357#endif
2358
96f902ff
CB		 2359int
2360Perl_my_killpg(pid_t master_pid, int signum)
2361{
2362 int pid, status, i;
2363 unsigned long int jpi_context;
2364 unsigned short int iosb[4];
2365 struct itmlst_3 il3[3];
2366
2367 /* All processes on the system? Seems dangerous, but it looks
2368 * like we could implement this pretty easily with a wildcard
2369 * input to sys$process_scan.
2370 */
2371 if (master_pid == -1) {
2372 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2373 return -1;
2374 }
2375
2376 /* All processes in the current process group; find the master
2377 * pid for the current process.
2378 */
2379 if (master_pid == 0) {
2380 i = 0;
2381 il3[i].buflen = sizeof( int );
2382 il3[i].itmcode = JPI$_MASTER_PID;
2383 il3[i].bufadr = &master_pid;
2384 il3[i++].retlen = NULL;
2385
2386 il3[i].buflen = 0;
2387 il3[i].itmcode = 0;
2388 il3[i].bufadr = NULL;
2389 il3[i++].retlen = NULL;
2390
2391 status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
2392 if ($VMS_STATUS_SUCCESS(status))
2393 status = iosb[0];
2394
2395 switch (status) {
2396 case SS$_NORMAL:
2397 break;
2398 case SS$_NOPRIV:
2399 case SS$_SUSPENDED:
2400 SETERRNO(EPERM, status);
2401 break;
2402 case SS$_NOMOREPROC:
2403 case SS$_NONEXPR:
2404 case SS$_NOSUCHNODE:
2405 case SS$_UNREACHABLE:
2406 SETERRNO(ESRCH, status);
2407 break;
2408 case SS$_ACCVIO:
2409 case SS$_BADPARAM:
2410 SETERRNO(EINVAL, status);
2411 break;
2412 default:
2413 SETERRNO(EVMSERR, status);
2414 }
2415 if (!$VMS_STATUS_SUCCESS(status))
2416 return -1;
2417 }
2418
2419 /* Set up a process context for those processes we will scan
2420 * with sys$getjpiw. Ask for all processes belonging to the
2421 * master pid.
2422 */
2423
2424 i = 0;
2425 il3[i].buflen = 0;
2426 il3[i].itmcode = PSCAN$_MASTER_PID;
2427 il3[i].bufadr = (void *)master_pid;
2428 il3[i++].retlen = NULL;
2429
2430 il3[i].buflen = 0;
2431 il3[i].itmcode = 0;
2432 il3[i].bufadr = NULL;
2433 il3[i++].retlen = NULL;
2434
2435 status = sys$process_scan(&jpi_context, il3);
2436 switch (status) {
2437 case SS$_NORMAL:
2438 break;
2439 case SS$_ACCVIO:
2440 case SS$_BADPARAM:
2441 case SS$_IVBUFLEN:
2442 case SS$_IVSSRQ:
2443 SETERRNO(EINVAL, status);
2444 break;
2445 default:
2446 SETERRNO(EVMSERR, status);
2447 }
2448 if (!$VMS_STATUS_SUCCESS(status))
2449 return -1;
2450
2451 i = 0;
2452 il3[i].buflen = sizeof(int);
2453 il3[i].itmcode = JPI$_PID;
2454 il3[i].bufadr = &pid;
2455 il3[i++].retlen = NULL;
2456
2457 il3[i].buflen = 0;
2458 il3[i].itmcode = 0;
2459 il3[i].bufadr = NULL;
2460 il3[i++].retlen = NULL;
2461
2462 /* Loop through the processes matching our specified criteria
2463 */
2464
2465 while (1) {
2466 /* Find the next process...
2467 */
2468 status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
2469 if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
2470
2471 switch (status) {
2472 case SS$_NORMAL:
2473 if (kill(pid, signum) == -1)
2474 break;
2475
2476 continue; /* next process */
2477 case SS$_NOPRIV:
2478 case SS$_SUSPENDED:
2479 SETERRNO(EPERM, status);
2480 break;
2481 case SS$_NOMOREPROC:
2482 break;
2483 case SS$_NONEXPR:
2484 case SS$_NOSUCHNODE:
2485 case SS$_UNREACHABLE:
2486 SETERRNO(ESRCH, status);
2487 break;
2488 case SS$_ACCVIO:
2489 case SS$_BADPARAM:
2490 SETERRNO(EINVAL, status);
2491 break;
2492 default:
2493 SETERRNO(EVMSERR, status);
2494 }
2495
2496 if (!$VMS_STATUS_SUCCESS(status))
2497 break;
2498 }
2499
2500 /* Release context-related resources.
2501 */
2502 (void) sys$process_scan(&jpi_context);
2503
2504 if (status != SS$_NOMOREPROC)
2505 return -1;
2506
2507 return 0;
2508}
2509
2fbb330f
JM		 2510/* Routine to convert a VMS status code to a UNIX status code.
2511** More tricky than it appears because of conflicting conventions with
2512** existing code.
2513**
2514** VMS status codes are a bit mask, with the least significant bit set for
2515** success.
2516**
2517** Special UNIX status of EVMSERR indicates that no translation is currently
2518** available, and programs should check the VMS status code.
2519**
2520** Programs compiled with _POSIX_EXIT have a special encoding that requires
2521** decoding.
2522*/
2523
2524#ifndef C_FACILITY_NO
2525#define C_FACILITY_NO 0x350000
2526#endif
2527#ifndef DCL_IVVERB
2528#define DCL_IVVERB 0x38090
2529#endif
2530
ce12d4b7
CB		 2531int
2532Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f 2533{
ce12d4b7
CB		 2534 int facility;
2535 int fac_sp;
2536 int msg_no;
2537 int msg_status;
2538 int unix_status;
2fbb330f
JM		 2539
2540 /* Assume the best or the worst */
2541 if (vms_status & STS$M_SUCCESS)
2542 unix_status = 0;
2543 else
2544 unix_status = EVMSERR;
2545
2546 msg_status = vms_status & ~STS$M_CONTROL;
2547
2548 facility = vms_status & STS$M_FAC_NO;
2549 fac_sp = vms_status & STS$M_FAC_SP;
2550 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2551
0968cdad 2552 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2553 switch(msg_no) {
2554 case SS$_NORMAL:
2555 unix_status = 0;
2556 break;
2557 case SS$_ACCVIO:
2558 unix_status = EFAULT;
2559 break;
7a7fd8e0
JM		 2560 case SS$_DEVOFFLINE:
2561 unix_status = EBUSY;
2562 break;
2563 case SS$_CLEARED:
2564 unix_status = ENOTCONN;
2565 break;
2566 case SS$_IVCHAN:
2fbb330f
JM		 2567 case SS$_IVLOGNAM:
2568 case SS$_BADPARAM:
2569 case SS$_IVLOGTAB:
2570 case SS$_NOLOGNAM:
2571 case SS$_NOLOGTAB:
2572 case SS$_INVFILFOROP:
2573 case SS$_INVARG:
2574 case SS$_NOSUCHID:
2575 case SS$_IVIDENT:
2576 unix_status = EINVAL;
2577 break;
7a7fd8e0
JM		 2578 case SS$_UNSUPPORTED:
2579 unix_status = ENOTSUP;
2580 break;
2fbb330f
JM		 2581 case SS$_FILACCERR:
2582 case SS$_NOGRPPRV:
2583 case SS$_NOSYSPRV:
2584 unix_status = EACCES;
2585 break;
2586 case SS$_DEVICEFULL:
2587 unix_status = ENOSPC;
2588 break;
2589 case SS$_NOSUCHDEV:
2590 unix_status = ENODEV;
2591 break;
2592 case SS$_NOSUCHFILE:
2593 case SS$_NOSUCHOBJECT:
2594 unix_status = ENOENT;
2595 break;
fb38d079
JM		 2596 case SS$_ABORT: /* Fatal case */
2597 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2598 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2599 unix_status = EINTR;
2600 break;
2601 case SS$_BUFFEROVF:
2602 unix_status = E2BIG;
2603 break;
2604 case SS$_INSFMEM:
2605 unix_status = ENOMEM;
2606 break;
2607 case SS$_NOPRIV:
2608 unix_status = EPERM;
2609 break;
2610 case SS$_NOSUCHNODE:
2611 case SS$_UNREACHABLE:
2612 unix_status = ESRCH;
2613 break;
2614 case SS$_NONEXPR:
2615 unix_status = ECHILD;
2616 break;
2617 default:
2618 if ((facility == 0) && (msg_no < 8)) {
2619 /* These are not real VMS status codes so assume that they are
2620 ** already UNIX status codes
2621 */
2622 unix_status = msg_no;
2623 break;
2624 }
2625 }
2626 }
2627 else {
2628 /* Translate a POSIX exit code to a UNIX exit code */
2629 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2630 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2631 }
2632 else {
7a7fd8e0
JM		 2633
2634 /* Documented traditional behavior for handling VMS child exits */
2635 /*--------------------------------------------------------------*/
2636 if (child_flag != 0) {
2637
2638 /* Success / Informational return 0 */
2639 /*----------------------------------*/
2640 if (msg_no & STS$K_SUCCESS)
2641 return 0;
2642
2643 /* Warning returns 1 */
2644 /*-------------------*/
2645 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2646 return 1;
2647
2648 /* Everything else pass through the severity bits */
2649 /*------------------------------------------------*/
2650 return (msg_no & STS$M_SEVERITY);
2651 }
2652
2653 /* Normal VMS status to ERRNO mapping attempt */
2654 /*--------------------------------------------*/
2fbb330f
JM		 2655 switch(msg_status) {
2656 /* case RMS$_EOF: */ /* End of File */
2657 case RMS$_FNF: /* File Not Found */
2658 case RMS$_DNF: /* Dir Not Found */
2659 unix_status = ENOENT;
2660 break;
2661 case RMS$_RNF: /* Record Not Found */
2662 unix_status = ESRCH;
2663 break;
2664 case RMS$_DIR:
2665 unix_status = ENOTDIR;
2666 break;
2667 case RMS$_DEV:
2668 unix_status = ENODEV;
2669 break;
7a7fd8e0
JM		 2670 case RMS$_IFI:
2671 case RMS$_FAC:
2672 case RMS$_ISI:
2673 unix_status = EBADF;
2674 break;
2675 case RMS$_FEX:
2676 unix_status = EEXIST;
2677 break;
2fbb330f
JM		 2678 case RMS$_SYN:
2679 case RMS$_FNM:
2680 case LIB$_INVSTRDES:
2681 case LIB$_INVARG:
2682 case LIB$_NOSUCHSYM:
2683 case LIB$_INVSYMNAM:
2684 case DCL_IVVERB:
2685 unix_status = EINVAL;
2686 break;
2687 case CLI$_BUFOVF:
2688 case RMS$_RTB:
2689 case CLI$_TKNOVF:
2690 case CLI$_RSLOVF:
2691 unix_status = E2BIG;
2692 break;
2693 case RMS$_PRV: /* No privilege */
2694 case RMS$_ACC: /* ACP file access failed */
2695 case RMS$_WLK: /* Device write locked */
2696 unix_status = EACCES;
2697 break;
ed1b9de0
JM		 2698 case RMS$_MKD: /* Failed to mark for delete */
2699 unix_status = EPERM;
2700 break;
2fbb330f
JM		 2701 /* case RMS$_NMF: */ /* No more files */
2702 }
2703 }
2704 }
2705
2706 return unix_status;
2707}
2708
7a7fd8e0
JM		 2709/* Try to guess at what VMS error status should go with a UNIX errno
2710 * value. This is hard to do as there could be many possible VMS
2711 * error statuses that caused the errno value to be set.
2712 */
2713
ce12d4b7
CB		 2714int
2715Perl_unix_status_to_vms(int unix_status)
7a7fd8e0 2716{
ce12d4b7 2717 int test_unix_status;
7a7fd8e0
JM		 2718
2719 /* Trivial cases first */
2720 /*---------------------*/
2721 if (unix_status == EVMSERR)
2722 return vaxc$errno;
2723
2724 /* Is vaxc$errno sane? */
2725 /*---------------------*/
2726 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2727 if (test_unix_status == unix_status)
2728 return vaxc$errno;
2729
2730 /* If way out of range, must be VMS code already */
2731 /*-----------------------------------------------*/
2732 if (unix_status > EVMSERR)
2733 return unix_status;
2734
2735 /* If out of range, punt */
2736 /*-----------------------*/
2737 if (unix_status > __ERRNO_MAX)
2738 return SS$_ABORT;
2739
2740
2741 /* Ok, now we have to do it the hard way. */
2742 /*----------------------------------------*/
2743 switch(unix_status) {
2744 case 0: return SS$_NORMAL;
2745 case EPERM: return SS$_NOPRIV;
2746 case ENOENT: return SS$_NOSUCHOBJECT;
2747 case ESRCH: return SS$_UNREACHABLE;
2748 case EINTR: return SS$_ABORT;
2749 /* case EIO: */
2750 /* case ENXIO: */
2751 case E2BIG: return SS$_BUFFEROVF;
2752 /* case ENOEXEC */
2753 case EBADF: return RMS$_IFI;
2754 case ECHILD: return SS$_NONEXPR;
2755 /* case EAGAIN */
2756 case ENOMEM: return SS$_INSFMEM;
2757 case EACCES: return SS$_FILACCERR;
2758 case EFAULT: return SS$_ACCVIO;
2759 /* case ENOTBLK */
0968cdad 2760 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2761 case EEXIST: return RMS$_FEX;
2762 /* case EXDEV */
2763 case ENODEV: return SS$_NOSUCHDEV;
2764 case ENOTDIR: return RMS$_DIR;
2765 /* case EISDIR */
2766 case EINVAL: return SS$_INVARG;
2767 /* case ENFILE */
2768 /* case EMFILE */
2769 /* case ENOTTY */
2770 /* case ETXTBSY */
2771 /* case EFBIG */
2772 case ENOSPC: return SS$_DEVICEFULL;
2773 case ESPIPE: return LIB$_INVARG;
2774 /* case EROFS: */
2775 /* case EMLINK: */
2776 /* case EPIPE: */
2777 /* case EDOM */
2778 case ERANGE: return LIB$_INVARG;
2779 /* case EWOULDBLOCK */
2780 /* case EINPROGRESS */
2781 /* case EALREADY */
2782 /* case ENOTSOCK */
2783 /* case EDESTADDRREQ */
2784 /* case EMSGSIZE */
2785 /* case EPROTOTYPE */
2786 /* case ENOPROTOOPT */
2787 /* case EPROTONOSUPPORT */
2788 /* case ESOCKTNOSUPPORT */
2789 /* case EOPNOTSUPP */
2790 /* case EPFNOSUPPORT */
2791 /* case EAFNOSUPPORT */
2792 /* case EADDRINUSE */
2793 /* case EADDRNOTAVAIL */
2794 /* case ENETDOWN */
2795 /* case ENETUNREACH */
2796 /* case ENETRESET */
2797 /* case ECONNABORTED */
2798 /* case ECONNRESET */
2799 /* case ENOBUFS */
2800 /* case EISCONN */
2801 case ENOTCONN: return SS$_CLEARED;
2802 /* case ESHUTDOWN */
2803 /* case ETOOMANYREFS */
2804 /* case ETIMEDOUT */
2805 /* case ECONNREFUSED */
2806 /* case ELOOP */
2807 /* case ENAMETOOLONG */
2808 /* case EHOSTDOWN */
2809 /* case EHOSTUNREACH */
2810 /* case ENOTEMPTY */
2811 /* case EPROCLIM */
2812 /* case EUSERS */
2813 /* case EDQUOT */
2814 /* case ENOMSG */
2815 /* case EIDRM */
2816 /* case EALIGN */
2817 /* case ESTALE */
2818 /* case EREMOTE */
2819 /* case ENOLCK */
2820 /* case ENOSYS */
2821 /* case EFTYPE */
2822 /* case ECANCELED */
2823 /* case EFAIL */
2824 /* case EINPROG */
2825 case ENOTSUP:
2826 return SS$_UNSUPPORTED;
2827 /* case EDEADLK */
2828 /* case ENWAIT */
2829 /* case EILSEQ */
2830 /* case EBADCAT */
2831 /* case EBADMSG */
2832 /* case EABANDONED */
2833 default:
2834 return SS$_ABORT; /* punt */
2835 }
7a7fd8e0 2836}
2fbb330f
JM		 2837
2838
22d4bb9c 2839/* default piping mailbox size */
054a3baf 2840#define PERL_BUFSIZ 8192
22d4bb9c 2841
674d6c38 2842
a0d0e21e 2843static void
8a646e0b 2844create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2845{
22d4bb9c
CB		 2846 unsigned long int mbxbufsiz;
2847 static unsigned long int syssize = 0;
2848 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2849 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2850 int sts;
2851
22d4bb9c
CB		 2852 if (!syssize) {
2853 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2854 /*
22d4bb9c
CB		 2855 * Get the SYSGEN parameter MAXBUF
2856 *
2857 * If the logical 'PERL_MBX_SIZE' is defined
2858 * use the value of the logical instead of PERL_BUFSIZ, but
2859 * keep the size between 128 and MAXBUF.
2860 *
a0d0e21e 2861 */
ebd4d70b 2862 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2863 }
2864
2865 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2866 mbxbufsiz = atoi(csize);
2867 } else {
2868 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2869 }
22d4bb9c
CB		 2870 if (mbxbufsiz < 128) mbxbufsiz = 128;
2871 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2872
ebd4d70b 2873 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2874
ebd4d70b
JM		 2875 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2876 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2877 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2878
2879} /* end of create_mbx() */
2880
22d4bb9c 2881
a0d0e21e 2882/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2883
2884typedef struct _iosb IOSB;
2885typedef struct _iosb* pIOSB;
2886typedef struct _pipe Pipe;
2887typedef struct _pipe* pPipe;
2888typedef struct pipe_details Info;
2889typedef struct pipe_details* pInfo;
2890typedef struct _srqp RQE;
2891typedef struct _srqp* pRQE;
2892typedef struct _tochildbuf CBuf;
2893typedef struct _tochildbuf* pCBuf;
2894
2895struct _iosb {
2896 unsigned short status;
2897 unsigned short count;
2898 unsigned long dvispec;
2899};
2900
2901#pragma member_alignment save
2902#pragma nomember_alignment quadword
2903struct _srqp { /* VMS self-relative queue entry */
2904 unsigned long qptr[2];
2905};
2906#pragma member_alignment restore
2907static RQE RQE_ZERO = {0,0};
2908
2909struct _tochildbuf {
2910 RQE q;
2911 int eof;
2912 unsigned short size;
2913 char *buf;
2914};
2915
2916struct _pipe {
2917 RQE free;
2918 RQE wait;
2919 int fd_out;
2920 unsigned short chan_in;
2921 unsigned short chan_out;
2922 char *buf;
2923 unsigned int bufsize;
2924 IOSB iosb;
2925 IOSB iosb2;
2926 int *pipe_done;
2927 int retry;
2928 int type;
2929 int shut_on_empty;
2930 int need_wake;
2931 pPipe *home;
2932 pInfo info;
2933 pCBuf curr;
2934 pCBuf curr2;
fd8cd3a3
DS		 2935#if defined(PERL_IMPLICIT_CONTEXT)
2936 void *thx; /* Either a thread or an interpreter */
2937 /* pointer, depending on how we're built */
2938#endif
22d4bb9c
CB		 2939};
2940
2941
a0d0e21e
LW		 2942struct pipe_details
2943{
22d4bb9c 2944 pInfo next;
ff7adb52
CL		 2945 PerlIO *fp; /* file pointer to pipe mailbox */
2946 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2947 int pid; /* PID of subprocess */
2948 int mode; /* == 'r' if pipe open for reading */
2949 int done; /* subprocess has completed */
ff7adb52 2950 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2951 int closing; /* my_pclose is closing this pipe */
2952 unsigned long completion; /* termination status of subprocess */
2953 pPipe in; /* pipe in to sub */
2954 pPipe out; /* pipe out of sub */
2955 pPipe err; /* pipe of sub's sys$error */
2956 int in_done; /* true when in pipe finished */
2957 int out_done;
2958 int err_done;
cd1191f1
CB		 2959 unsigned short xchan; /* channel to debug xterm */
2960 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2961};
2962
748a9306
LW		 2963struct exit_control_block
2964{
2965 struct exit_control_block *flink;
f7c699a0 2966 unsigned long int (*exit_routine)(void);
748a9306
LW		 2967 unsigned long int arg_count;
2968 unsigned long int *status_address;
2969 unsigned long int exit_status;
2970};
2971
d85f548a
JH		 2972typedef struct _closed_pipes Xpipe;
2973typedef struct _closed_pipes* pXpipe;
2974
2975struct _closed_pipes {
2976 int pid; /* PID of subprocess */
2977 unsigned long completion; /* termination status of subprocess */
2978};
2979#define NKEEPCLOSED 50
2980static Xpipe closed_list[NKEEPCLOSED];
2981static int closed_index = 0;
2982static int closed_num = 0;
2983
22d4bb9c
CB		 2984#define RETRY_DELAY "0 ::0.20"
2985#define MAX_RETRY 50
a0d0e21e 2986
22d4bb9c
CB		 2987static int pipe_ef = 0; /* first call to safe_popen inits these*/
2988static unsigned long mypid;
2989static unsigned long delaytime[2];
2990
2991static pInfo open_pipes = NULL;
2992static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2993
ff7adb52
CL		 2994#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2995
2996
3eeba6fb 2997
748a9306 2998static unsigned long int
f7c699a0 2999pipe_exit_routine(void)
748a9306 3000{
22d4bb9c 3001 pInfo info;
1e422769 3002 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
4e0c9737 3003 int sts, did_stuff, j;
ff7adb52 3004
5ce486e0
CB		 3005 /*
3006 * Flush any pending i/o, but since we are in process run-down, be
3007 * careful about referencing PerlIO structures that may already have
3008 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 3009 */
3010 info = open_pipes;
3011 while (info) {
3012 if (info->fp) {
ebd4d70b
JM		 3013#if defined(PERL_IMPLICIT_CONTEXT)
3014 /* We need to use the Perl context of the thread that created */
3015 /* the pipe. */
3016 pTHX;
3017 if (info->err)
3018 aTHX = info->err->thx;
3019 else if (info->out)
3020 aTHX = info->out->thx;
3021 else if (info->in)
3022 aTHX = info->in->thx;
3023#endif
5ce486e0
CB		 3024 if (!info->useFILE
3025#if defined(USE_ITHREADS)
3026 && my_perl
3027#endif
a24c654f
CB		 3028#ifdef USE_PERLIO
3029 && PL_perlio_fd_refcnt
3030#endif
3031 )
5ce486e0 3032 PerlIO_flush(info->fp);
ff7adb52
CL		 3033 else
3034 fflush((FILE *)info->fp);
3035 }
3036 info = info->next;
3037 }
3eeba6fb
CB		 3038
3039 /*
ff7adb52 3040 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 3041 don't hang
3042 */
3043 did_stuff = 0;
3044 info = open_pipes;
748a9306 3045
3eeba6fb 3046 while (info) {
d4c83939 3047 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 3048 if (info->in && !info->in->shut_on_empty) {
d4c83939 3049 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 3050 0, 0, 0, 0, 0, 0));
ff7adb52 3051 info->waiting = 1;
22d4bb9c 3052 did_stuff = 1;
748a9306 3053 }
d4c83939 3054 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3055 info = info->next;
3056 }
ff7adb52
CL		 3057
3058 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3059
3060 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3061 int nwait = 0;
3062
3063 info = open_pipes;
3064 while (info) {
d4c83939 3065 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3066 if (info->waiting && info->done)
3067 info->waiting = 0;
3068 nwait += info->waiting;
d4c83939 3069 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3070 info = info->next;
3071 }
3072 if (!nwait) break;
3073 sleep(1);
3074 }
3eeba6fb
CB		 3075
3076 did_stuff = 0;
3077 info = open_pipes;
3078 while (info) {
d4c83939 3079 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3080 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3081 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 3082 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 3083 did_stuff = 1;
3084 }
d4c83939 3085 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3086 info = info->next;
3087 }
ff7adb52
CL		 3088
3089 /* again, wait for effect */
3090
3091 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3092 int nwait = 0;
3093
3094 info = open_pipes;
3095 while (info) {
d4c83939 3096 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3097 if (info->waiting && info->done)
3098 info->waiting = 0;
3099 nwait += info->waiting;
d4c83939 3100 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3101 info = info->next;
3102 }
3103 if (!nwait) break;
3104 sleep(1);
3105 }
3eeba6fb
CB		 3106
3107 info = open_pipes;
3108 while (info) {
d4c83939 3109 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3110 if (!info->done) { /* We tried to be nice . . . */
3111 sts = sys$delprc(&info->pid,0);
d4c83939 3112 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3113 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3114 }
d4c83939 3115 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3116 info = info->next;
3117 }
3118
3119 while(open_pipes) {
ebd4d70b
JM		 3120
3121#if defined(PERL_IMPLICIT_CONTEXT)
3122 /* We need to use the Perl context of the thread that created */
3123 /* the pipe. */
3124 pTHX;
36b6faa8
CB		 3125 if (open_pipes->err)
3126 aTHX = open_pipes->err->thx;
3127 else if (open_pipes->out)
3128 aTHX = open_pipes->out->thx;
3129 else if (open_pipes->in)
3130 aTHX = open_pipes->in->thx;
ebd4d70b 3131#endif
1e422769 3132 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3133 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3134 }
3135 return retsts;
3136}
3137
3138static struct exit_control_block pipe_exitblock =
3139 {(struct exit_control_block *) 0,
3140 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3141
22d4bb9c
CB		 3142static void pipe_mbxtofd_ast(pPipe p);
3143static void pipe_tochild1_ast(pPipe p);
3144static void pipe_tochild2_ast(pPipe p);
748a9306 3145
a0d0e21e 3146static void
22d4bb9c 3147popen_completion_ast(pInfo info)
a0d0e21e 3148{
22d4bb9c
CB		 3149 pInfo i = open_pipes;
3150 int iss;
d85f548a
JH		 3151
3152 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3153 closed_list[closed_index].pid = info->pid;
3154 closed_list[closed_index].completion = info->completion;
3155 closed_index++;
3156 if (closed_index == NKEEPCLOSED)
3157 closed_index = 0;
3158 closed_num++;
22d4bb9c
CB		 3159
3160 while (i) {
3161 if (i == info) break;
3162 i = i->next;
3163 }
3164 if (!i) return; /* unlinked, probably freed too */
3165
22d4bb9c
CB		 3166 info->done = TRUE;
3167
3168/*
3169 Writing to subprocess ...
3170 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3171
3172 chan_out may be waiting for "done" flag, or hung waiting
3173 for i/o completion to child...cancel the i/o. This will
3174 put it into "snarf mode" (done but no EOF yet) that discards
3175 input.
3176
3177 Output from subprocess (stdout, stderr) needs to be flushed and
3178 shut down. We try sending an EOF, but if the mbx is full the pipe
3179 routine should still catch the "shut_on_empty" flag, telling it to
3180 use immediate-style reads so that "mbx empty" -> EOF.
3181
3182
3183*/
3184 if (info->in && !info->in_done) { /* only for mode=w */
3185 if (info->in->shut_on_empty && info->in->need_wake) {
3186 info->in->need_wake = FALSE;
fd8cd3a3 3187 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3188 } else {
fd8cd3a3 3189 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3190 }
3191 }
3192
3193 if (info->out && !info->out_done) { /* were we also piping output? */
3194 info->out->shut_on_empty = TRUE;
3195 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3196 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3197 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3198 }
3199
3200 if (info->err && !info->err_done) { /* we were piping stderr */
3201 info->err->shut_on_empty = TRUE;
3202 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3203 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3204 _ckvmssts_noperl(iss);
a0d0e21e 3205 }
fd8cd3a3 3206 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3207
a0d0e21e
LW		 3208}
3209
2fbb330f 3210static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3211static void vms_execfree(struct dsc$descriptor_s *vmscmd);
22d4bb9c
CB		 3212static void pipe_infromchild_ast(pPipe p);
3213
3214/*
3215 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3216 inside an AST routine without worrying about reentrancy and which Perl
3217 memory allocator is being used.
3218
3219 We read data and queue up the buffers, then spit them out one at a
3220 time to the output mailbox when the output mailbox is ready for one.
3221
3222*/
3223#define INITIAL_TOCHILDQUEUE 2
3224
3225static pPipe
fd8cd3a3 3226pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3227{
22d4bb9c
CB		 3228 pPipe p;
3229 pCBuf b;
3230 char mbx1[64], mbx2[64];
3231 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3232 DSC$K_CLASS_S, mbx1},
3233 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3234 DSC$K_CLASS_S, mbx2};
3235 unsigned int dviitm = DVI$_DEVBUFSIZ;
3236 int j, n;
3237
d4c83939 3238 n = sizeof(Pipe);
ebd4d70b 3239 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3240
8a646e0b
JM		 3241 create_mbx(&p->chan_in , &d_mbx1);
3242 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3243 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3244
3245 p->buf = 0;
3246 p->shut_on_empty = FALSE;
3247 p->need_wake = FALSE;
3248 p->type = 0;
3249 p->retry = 0;
3250 p->iosb.status = SS$_NORMAL;
3251 p->iosb2.status = SS$_NORMAL;
3252 p->free = RQE_ZERO;
3253 p->wait = RQE_ZERO;
3254 p->curr = 0;
3255 p->curr2 = 0;
3256 p->info = 0;
fd8cd3a3
DS		 3257#ifdef PERL_IMPLICIT_CONTEXT
3258 p->thx = aTHX;
3259#endif
22d4bb9c
CB		 3260
3261 n = sizeof(CBuf) + p->bufsize;
3262
3263 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3264 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3265 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3266 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3267 }
3268
3269 pipe_tochild2_ast(p);
3270 pipe_tochild1_ast(p);
3271 strcpy(wmbx, mbx1);
3272 strcpy(rmbx, mbx2);
3273 return p;
3274}
3275
3276/* reads the MBX Perl is writing, and queues */
3277
3278static void
3279pipe_tochild1_ast(pPipe p)
3280{
22d4bb9c
CB		 3281 pCBuf b = p->curr;
3282 int iss = p->iosb.status;
3283 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3284 int sts;
fd8cd3a3
DS		 3285#ifdef PERL_IMPLICIT_CONTEXT
3286 pTHX = p->thx;
3287#endif
22d4bb9c
CB		 3288
3289 if (p->retry) {
3290 if (eof) {
3291 p->shut_on_empty = TRUE;
3292 b->eof = TRUE;
ebd4d70b 3293 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3294 } else {
ebd4d70b 3295 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3296 }
3297
3298 b->eof = eof;
3299 b->size = p->iosb.count;
ebd4d70b 3300 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3301 if (p->need_wake) {
3302 p->need_wake = FALSE;
ebd4d70b 3303 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3304 }
3305 } else {
3306 p->retry = 1; /* initial call */
3307 }
3308
3309 if (eof) { /* flush the free queue, return when done */
3310 int n = sizeof(CBuf) + p->bufsize;
3311 while (1) {
3312 iss = lib$remqti(&p->free, &b);
3313 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3314 _ckvmssts_noperl(iss);
3315 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3316 }
3317 }
3318
3319 iss = lib$remqti(&p->free, &b);
3320 if (iss == LIB$_QUEWASEMP) {
3321 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3322 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3323 b->buf = (char *) b + sizeof(CBuf);
3324 } else {
ebd4d70b 3325 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3326 }
3327
3328 p->curr = b;
3329 iss = sys$qio(0,p->chan_in,
3330 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3331 &p->iosb,
3332 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3333 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3334 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3335}
3336
3337
3338/* writes queued buffers to output, waits for each to complete before
3339 doing the next */
3340
3341static void
3342pipe_tochild2_ast(pPipe p)
3343{
22d4bb9c
CB		 3344 pCBuf b = p->curr2;
3345 int iss = p->iosb2.status;
3346 int n = sizeof(CBuf) + p->bufsize;
3347 int done = (p->info && p->info->done) ||
3348 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3349#if defined(PERL_IMPLICIT_CONTEXT)
3350 pTHX = p->thx;
3351#endif
22d4bb9c
CB		 3352
3353 do {
3354 if (p->type) { /* type=1 has old buffer, dispose */
3355 if (p->shut_on_empty) {
ebd4d70b 3356 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3357 } else {
ebd4d70b 3358 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3359 }
3360 p->type = 0;
3361 }
3362
3363 iss = lib$remqti(&p->wait, &b);
3364 if (iss == LIB$_QUEWASEMP) {
3365 if (p->shut_on_empty) {
3366 if (done) {
ebd4d70b 3367 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3368 *p->pipe_done = TRUE;
ebd4d70b 3369 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3370 } else {
ebd4d70b 3371 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3372 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3373 }
3374 return;
3375 }
3376 p->need_wake = TRUE;
3377 return;
3378 }
ebd4d70b 3379 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3380 p->type = 1;
3381 } while (done);
3382
3383
3384 p->curr2 = b;
3385 if (b->eof) {
ebd4d70b 3386 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3387 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3388 } else {
ebd4d70b 3389 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3390 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3391 }
3392
3393 return;
3394
3395}
3396
3397
3398static pPipe
fd8cd3a3 3399pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3400{
22d4bb9c
CB		 3401 pPipe p;
3402 char mbx1[64], mbx2[64];
3403 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3404 DSC$K_CLASS_S, mbx1},
3405 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3406 DSC$K_CLASS_S, mbx2};
3407 unsigned int dviitm = DVI$_DEVBUFSIZ;
3408
d4c83939 3409 int n = sizeof(Pipe);
ebd4d70b 3410 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3411 create_mbx(&p->chan_in , &d_mbx1);
3412 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3413
ebd4d70b 3414 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3415 n = p->bufsize * sizeof(char);
ebd4d70b 3416 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3417 p->shut_on_empty = FALSE;
3418 p->info = 0;
3419 p->type = 0;
3420 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3421#if defined(PERL_IMPLICIT_CONTEXT)
3422 p->thx = aTHX;
3423#endif
22d4bb9c
CB		 3424 pipe_infromchild_ast(p);
3425
3426 strcpy(wmbx, mbx1);
3427 strcpy(rmbx, mbx2);
3428 return p;
3429}
3430
3431static void
3432pipe_infromchild_ast(pPipe p)
3433{
22d4bb9c
CB		 3434 int iss = p->iosb.status;
3435 int eof = (iss == SS$_ENDOFFILE);
3436 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3437 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3438#if defined(PERL_IMPLICIT_CONTEXT)
3439 pTHX = p->thx;
3440#endif
22d4bb9c
CB		 3441
3442 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3443 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3444 p->chan_out = 0;
3445 }
3446
3447 /* read completed:
3448 input shutdown if EOF from self (done or shut_on_empty)
3449 output shutdown if closing flag set (my_pclose)
3450 send data/eof from child or eof from self
3451 otherwise, re-read (snarf of data from child)
3452 */
3453
3454 if (p->type == 1) {
3455 p->type = 0;
3456 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3457 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3458 p->chan_in = 0;
3459 }
3460
3461 if (p->chan_out) {
3462 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3463 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3464 pipe_infromchild_ast, p,
3465 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3466 return;
3467 } else if (eof) { /* eat EOF --- fall through to read*/
3468
3469 } else { /* transmit data */
ebd4d70b
JM		 3470 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3471 pipe_infromchild_ast,p,
3472 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3473 return;
3474 }
3475 }
3476 }
3477
3478 /* everything shut? flag as done */
3479
3480 if (!p->chan_in && !p->chan_out) {
3481 *p->pipe_done = TRUE;
ebd4d70b 3482 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3483 return;
3484 }
3485
3486 /* write completed (or read, if snarfing from child)
3487 if still have input active,
3488 queue read...immediate mode if shut_on_empty so we get EOF if empty
3489 otherwise,
3490 check if Perl reading, generate EOFs as needed
3491 */
3492
3493 if (p->type == 0) {
3494 p->type = 1;
3495 if (p->chan_in) {
3496 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3497 pipe_infromchild_ast,p,
3498 p->buf, p->bufsize, 0, 0, 0, 0);
3499 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3500 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3501 } else { /* send EOFs for extra reads */
3502 p->iosb.status = SS$_ENDOFFILE;
3503 p->iosb.dvispec = 0;
ebd4d70b
JM		 3504 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3505 0, 0, 0,
3506 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3507 }
3508 }
3509}
3510
3511static pPipe
fd8cd3a3 3512pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3513{
22d4bb9c
CB		 3514 pPipe p;
3515 char mbx[64];
3516 unsigned long dviitm = DVI$_DEVBUFSIZ;
3517 struct stat s;
3518 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3519 DSC$K_CLASS_S, mbx};
a480973c 3520 int n = sizeof(Pipe);
22d4bb9c
CB		 3521
3522 /* things like terminals and mbx's don't need this filter */
3523 if (fd && fstat(fd,&s) == 0) {
4e0c9737 3524 unsigned long devchar;
cfcfe586
JM		 3525 char device[65];
3526 unsigned short dev_len;
3527 struct dsc$descriptor_s d_dev;
3528 char * cptr;
3529 struct item_list_3 items[3];
3530 int status;
3531 unsigned short dvi_iosb[4];
3532
3533 cptr = getname(fd, out, 1);
ebd4d70b 3534 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3535 d_dev.dsc$a_pointer = out;
3536 d_dev.dsc$w_length = strlen(out);
3537 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3538 d_dev.dsc$b_class = DSC$K_CLASS_S;
3539
3540 items[0].len = 4;
3541 items[0].code = DVI$_DEVCHAR;
3542 items[0].bufadr = &devchar;
3543 items[0].retadr = NULL;
3544 items[1].len = 64;
3545 items[1].code = DVI$_FULLDEVNAM;
3546 items[1].bufadr = device;
3547 items[1].retadr = &dev_len;
3548 items[2].len = 0;
3549 items[2].code = 0;
3550
3551 status = sys$getdviw
3552 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3553 _ckvmssts_noperl(status);
cfcfe586
JM		 3554 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3555 device[dev_len] = 0;
3556
3557 if (!(devchar & DEV$M_DIR)) {
3558 strcpy(out, device);
3559 return 0;
3560 }
3561 }
22d4bb9c
CB		 3562 }
3563
ebd4d70b 3564 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3565 p->fd_out = dup(fd);
8a646e0b 3566 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3567 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3568 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3569 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3570 p->shut_on_empty = FALSE;
3571 p->retry = 0;
3572 p->info = 0;
3573 strcpy(out, mbx);
3574
ebd4d70b
JM		 3575 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3576 pipe_mbxtofd_ast, p,
3577 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3578
3579 return p;
3580}
3581
3582static void
3583pipe_mbxtofd_ast(pPipe p)
3584{
22d4bb9c
CB		 3585 int iss = p->iosb.status;
3586 int done = p->info->done;
3587 int iss2;
3588 int eof = (iss == SS$_ENDOFFILE);
3589 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3590 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3591#if defined(PERL_IMPLICIT_CONTEXT)
3592 pTHX = p->thx;
3593#endif
22d4bb9c
CB		 3594
3595 if (done && myeof) { /* end piping */
3596 close(p->fd_out);
3597 sys$dassgn(p->chan_in);
3598 *p->pipe_done = TRUE;
ebd4d70b 3599 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3600 return;
3601 }
3602
3603 if (!err && !eof) { /* good data to send to file */
3604 p->buf[p->iosb.count] = '\n';
3605 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3606 if (iss2 < 0) {
3607 p->retry++;
3608 if (p->retry < MAX_RETRY) {
ebd4d70b 3609 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3610 return;
3611 }
3612 }
3613 p->retry = 0;
3614 } else if (err) {
ebd4d70b 3615 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3616 }
3617
3618
3619 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3620 pipe_mbxtofd_ast, p,
3621 p->buf, p->bufsize, 0, 0, 0, 0);
3622 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3623 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3624}
3625
3626
3627typedef struct _pipeloc PLOC;
3628typedef struct _pipeloc* pPLOC;
3629
3630struct _pipeloc {
3631 pPLOC next;
3632 char dir[NAM$C_MAXRSS+1];
3633};
3634static pPLOC head_PLOC = 0;
3635
5c0ae288 3636void
fd8cd3a3 3637free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3638{
3639 pPLOC p, pnext;
ff7adb52 3640 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3641
ff7adb52 3642 p = *pHead;
5c0ae288
CL		 3643 while (p) {
3644 pnext = p->next;
e0ef6b43 3645 PerlMem_free(p);
5c0ae288
CL		 3646 p = pnext;
3647 }
ff7adb52 3648 *pHead = 0;
5c0ae288 3649}
22d4bb9c
CB		 3650
3651static void
fd8cd3a3 3652store_pipelocs(pTHX)
22d4bb9c
CB		 3653{
3654 int i;
3655 pPLOC p;
ff7adb52 3656 AV *av = 0;
22d4bb9c 3657 SV *dirsv;
22d4bb9c
CB		 3658 char *dir, *x;
3659 char *unixdir;
3660 char temp[NAM$C_MAXRSS+1];
3661 STRLEN n_a;
3662
ff7adb52 3663 if (head_PLOC)
218fdd94 3664 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3665
22d4bb9c
CB		 3666/* the . directory from @INC comes last */
3667
e0ef6b43 3668 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3669 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3670 p->next = head_PLOC;
3671 head_PLOC = p;
3672 strcpy(p->dir,"./");
3673
3674/* get the directory from $^X */
3675
c11536f5 3676 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3677 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3678
218fdd94
CL		 3679#ifdef PERL_IMPLICIT_CONTEXT
3680 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3681#else
22d4bb9c 3682 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3683#endif
a35dcc95 3684 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
22d4bb9c 3685 x = strrchr(temp,']');
2497a41f
JM		 3686 if (x == NULL) {
3687 x = strrchr(temp,'>');
3688 if (x == NULL) {
3689 /* It could be a UNIX path */
3690 x = strrchr(temp,'/');
3691 }
3692 }
3693 if (x)
3694 x[1] = '\0';
3695 else {
3696 /* Got a bare name, so use default directory */
3697 temp[0] = '.';
3698 temp[1] = '\0';
3699 }
22d4bb9c 3700
4e205ed6 3701 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3702 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3703 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3704 p->next = head_PLOC;
3705 head_PLOC = p;
a35dcc95 3706 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
c5375c28 3707 }
22d4bb9c
CB		 3708 }
3709
3710/* reverse order of @INC entries, skip "." since entered above */
3711
218fdd94
CL		 3712#ifdef PERL_IMPLICIT_CONTEXT
3713 if (aTHX)
3714#endif
ff7adb52
CL		 3715 if (PL_incgv) av = GvAVn(PL_incgv);
3716
3717 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3718 dirsv = *av_fetch(av,i,TRUE);
3719
3720 if (SvROK(dirsv)) continue;
3721 dir = SvPVx(dirsv,n_a);
3722 if (strcmp(dir,".") == 0) continue;
4e205ed6 3723 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3724 continue;
3725
e0ef6b43 3726 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3727 p->next = head_PLOC;
3728 head_PLOC = p;
a35dcc95 3729 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3730 }
3731
3732/* most likely spot (ARCHLIB) put first in the list */
3733
3734#ifdef ARCHLIB_EXP
4e205ed6 3735 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3736 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3737 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3738 p->next = head_PLOC;
3739 head_PLOC = p;
a35dcc95 3740 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3741 }
3742#endif
c5375c28 3743 PerlMem_free(unixdir);
22d4bb9c
CB		 3744}
3745
ce12d4b7
CB		 3746static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
3747 const char *fname, int opts);
a1887106
JM		 3748#if !defined(PERL_IMPLICIT_CONTEXT)
3749#define cando_by_name_int Perl_cando_by_name_int
3750#else
3751#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3752#endif
22d4bb9c
CB		 3753
3754static char *
fd8cd3a3 3755find_vmspipe(pTHX)
22d4bb9c
CB		 3756{
3757 static int vmspipe_file_status = 0;
3758 static char vmspipe_file[NAM$C_MAXRSS+1];
3759
3760 /* already found? Check and use ... need read+execute permission */
3761
3762 if (vmspipe_file_status == 1) {
a1887106
JM		 3763 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3764 && cando_by_name_int
3765 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3766 return vmspipe_file;
3767 }
3768 vmspipe_file_status = 0;
3769 }
3770
3771 /* scan through stored @INC, $^X */
3772
3773 if (vmspipe_file_status == 0) {
3774 char file[NAM$C_MAXRSS+1];
3775 pPLOC p = head_PLOC;
3776
3777 while (p) {
2f4077ca 3778 char * exp_res;
4d743a9b 3779 int dirlen;
a35dcc95
CB		 3780 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3781 my_strlcat(file, "vmspipe.com", sizeof(file));
22d4bb9c
CB		 3782 p = p->next;
3783
6fb6c614 3784 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3785 if (!exp_res) continue;
22d4bb9c 3786
a1887106
JM		 3787 if (cando_by_name_int
3788 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3789 && cando_by_name_int
3790 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3791 vmspipe_file_status = 1;
3792 return vmspipe_file;
3793 }
3794 }
3795 vmspipe_file_status = -1; /* failed, use tempfiles */
3796 }
3797
3798 return 0;
3799}
3800
3801static FILE *
fd8cd3a3 3802vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3803{
3804 char file[NAM$C_MAXRSS+1];
3805 FILE *fp;
3806 static int index = 0;
2497a41f
JM		 3807 Stat_t s0, s1;
3808 int cmp_result;
22d4bb9c
CB		 3809
3810 /* create a tempfile */
3811
3812 /* we can't go from W, shr=get to R, shr=get without
3813 an intermediate vulnerable state, so don't bother trying...
3814
3815 and lib$spawn doesn't shr=put, so have to close the write
3816
3817 So... match up the creation date/time and the FID to
3818 make sure we're dealing with the same file
3819
3820 */
3821
3822 index++;
2497a41f
JM		 3823 if (!decc_filename_unix_only) {
3824 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3825 fp = fopen(file,"w");
3826 if (!fp) {
22d4bb9c
CB		 3827 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3828 fp = fopen(file,"w");
3829 if (!fp) {
3830 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3831 fp = fopen(file,"w");
2497a41f
JM		 3832 }
3833 }
3834 }
3835 else {
3836 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3837 fp = fopen(file,"w");
3838 if (!fp) {
3839 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3840 fp = fopen(file,"w");
3841 if (!fp) {
3842 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3843 fp = fopen(file,"w");
3844 }
3845 }
22d4bb9c
CB		 3846 }
3847 if (!fp) return 0; /* we're hosed */
3848
f9ecfa39 3849 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3850 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3851 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3852 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3853 fprintf(fp,"$ perl_on = \"set noon\"\n");
3854 fprintf(fp,"$ perl_exit = \"exit\"\n");
3855 fprintf(fp,"$ perl_del = \"delete\"\n");
3856 fprintf(fp,"$ pif = \"if\"\n");
3857 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3858 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3859 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3860 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3861 fprintf(fp,"$! --- build command line to get max possible length\n");
3862 fprintf(fp,"$c=perl_popen_cmd0\n");
3863 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3864 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3865 fprintf(fp,"$x=perl_popen_cmd3\n");
3866 fprintf(fp,"$c=c+x\n");
22d4bb9c 3867 fprintf(fp,"$ perl_on\n");
f9ecfa39 3868 fprintf(fp,"$ 'c'\n");
22d4bb9c 3869 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3870 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3871 fprintf(fp,"$ perl_exit 'perl_status'\n");
3872 fsync(fileno(fp));
3873
3874 fgetname(fp, file, 1);
312ac60b 3875 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3876 fclose(fp);
3877
2497a41f 3878 if (decc_filename_unix_only)
0e5ce2c7 3879 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3880 fp = fopen(file,"r","shr=get");
3881 if (!fp) return 0;
312ac60b 3882 fstat(fileno(fp), &s1.crtl_stat);
2497a41f 3883
682e4b71 3884 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3885 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3886 fclose(fp);
3887 return 0;
3888 }
3889
3890 return fp;
3891}
3892
3893
ce12d4b7
CB		 3894static int
3895vms_is_syscommand_xterm(void)
cd1191f1
CB		 3896{
3897 const static struct dsc$descriptor_s syscommand_dsc =
3898 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3899
3900 const static struct dsc$descriptor_s decwdisplay_dsc =
3901 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3902
3903 struct item_list_3 items[2];
3904 unsigned short dvi_iosb[4];
3905 unsigned long devchar;
3906 unsigned long devclass;
3907 int status;
3908
3909 /* Very simple check to guess if sys$command is a decterm? */
3910 /* First see if the DECW$DISPLAY: device exists */
3911 items[0].len = 4;
3912 items[0].code = DVI$_DEVCHAR;
3913 items[0].bufadr = &devchar;
3914 items[0].retadr = NULL;
3915 items[1].len = 0;
3916 items[1].code = 0;
3917
3918 status = sys$getdviw
3919 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3920
3921 if ($VMS_STATUS_SUCCESS(status)) {
3922 status = dvi_iosb[0];
3923 }
3924
3925 if (!$VMS_STATUS_SUCCESS(status)) {
3926 SETERRNO(EVMSERR, status);
3927 return -1;
3928 }
3929
3930 /* If it does, then for now assume that we are on a workstation */
3931 /* Now verify that SYS$COMMAND is a terminal */
3932 /* for creating the debugger DECTerm */
3933
3934 items[0].len = 4;
3935 items[0].code = DVI$_DEVCLASS;
3936 items[0].bufadr = &devclass;
3937 items[0].retadr = NULL;
3938 items[1].len = 0;
3939 items[1].code = 0;
3940
3941 status = sys$getdviw
3942 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3943
3944 if ($VMS_STATUS_SUCCESS(status)) {
3945 status = dvi_iosb[0];
3946 }
3947
3948 if (!$VMS_STATUS_SUCCESS(status)) {
3949 SETERRNO(EVMSERR, status);
3950 return -1;
3951 }
3952 else {
3953 if (devclass == DC$_TERM) {
3954 return 0;
3955 }
3956 }
3957 return -1;
3958}
3959
3960/* If we are on a DECTerm, we can pretend to fork xterms when requested */
ce12d4b7
CB		 3961static PerlIO*
3962create_forked_xterm(pTHX_ const char *cmd, const char *mode)
cd1191f1
CB		 3963{
3964 int status;
3965 int ret_stat;
3966 char * ret_char;
3967 char device_name[65];
3968 unsigned short device_name_len;
3969 struct dsc$descriptor_s customization_dsc;
3970 struct dsc$descriptor_s device_name_dsc;
3971 const char * cptr;
cd1191f1
CB		 3972 char customization[200];
3973 char title[40];
3974 pInfo info = NULL;
3975 char mbx1[64];
3976 unsigned short p_chan;
3977 int n;
3978 unsigned short iosb[4];
cd1191f1
CB		 3979 const char * cust_str =
3980 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3981 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3982 DSC$K_CLASS_S, mbx1};
3983
8cb5d3d5
JM		 3984 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3985 /*---------------------------------------*/
d30c1055 3986 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3987
3988
3989 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3990 ret_char = strstr(cmd," xterm ");
3991 if (ret_char == NULL)
3992 return NULL;
3993 cptr = ret_char + 7;
3994 ret_char = strstr(cmd,"tty");
3995 if (ret_char == NULL)
3996 return NULL;
3997 ret_char = strstr(cmd,"sleep");
3998 if (ret_char == NULL)
3999 return NULL;
4000
8cb5d3d5
JM		 4001 if (decw_term_port == 0) {
4002 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4003 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4004 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4005
d30c1055 4006 status = lib$find_image_symbol
8cb5d3d5
JM		 4007 (&filename1_dsc,
4008 &decw_term_port_dsc,
4009 (void *)&decw_term_port,
4010 NULL,
4011 0);
4012
4013 /* Try again with the other image name */
4014 if (!$VMS_STATUS_SUCCESS(status)) {
4015
d30c1055 4016 status = lib$find_image_symbol
8cb5d3d5
JM		 4017 (&filename2_dsc,
4018 &decw_term_port_dsc,
4019 (void *)&decw_term_port,
4020 NULL,
4021 0);
4022
4023 }
4024
4025 }
4026
4027
4028 /* No decw$term_port, give it up */
4029 if (!$VMS_STATUS_SUCCESS(status))
4030 return NULL;
4031
cd1191f1
CB		 4032 /* Are we on a workstation? */
4033 /* to do: capture the rows / columns and pass their properties */
4034 ret_stat = vms_is_syscommand_xterm();
4035 if (ret_stat < 0)
4036 return NULL;
4037
4038 /* Make the title: */
4039 ret_char = strstr(cptr,"-title");
4040 if (ret_char != NULL) {
4041 while ((*cptr != 0) && (*cptr != '\"')) {
4042 cptr++;
4043 }
4044 if (*cptr == '\"')
4045 cptr++;
4046 n = 0;
4047 while ((*cptr != 0) && (*cptr != '\"')) {
4048 title[n] = *cptr;
4049 n++;
4050 if (n == 39) {
07bee079 4051 title[39] = 0;
cd1191f1
CB		 4052 break;
4053 }
4054 cptr++;
4055 }
4056 title[n] = 0;
4057 }
4058 else {
4059 /* Default title */
4060 strcpy(title,"Perl Debug DECTerm");
4061 }
4062 sprintf(customization, cust_str, title);
4063
4064 customization_dsc.dsc$a_pointer = customization;
4065 customization_dsc.dsc$w_length = strlen(customization);
4066 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4067 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4068
4069 device_name_dsc.dsc$a_pointer = device_name;
4070 device_name_dsc.dsc$w_length = sizeof device_name -1;
4071 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4072 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4073
4074 device_name_len = 0;
4075
4076 /* Try to create the window */
8cb5d3d5 4077 status = (*decw_term_port)
cd1191f1
CB		 4078 (NULL,
4079 NULL,
4080 &customization_dsc,
4081 &device_name_dsc,
4082 &device_name_len,
4083 NULL,
4084 NULL,
4085 NULL);
4086 if (!$VMS_STATUS_SUCCESS(status)) {
4087 SETERRNO(EVMSERR, status);
4088 return NULL;
4089 }
4090
4091 device_name[device_name_len] = '\0';
4092
4093 /* Need to set this up to look like a pipe for cleanup */
4094 n = sizeof(Info);
4095 status = lib$get_vm(&n, &info);
4096 if (!$VMS_STATUS_SUCCESS(status)) {
4097 SETERRNO(ENOMEM, status);
4098 return NULL;
4099 }
4100
4101 info->mode = *mode;
4102 info->done = FALSE;
4103 info->completion = 0;
4104 info->closing = FALSE;
4105 info->in = 0;
4106 info->out = 0;
4107 info->err = 0;
4e205ed6 4108 info->fp = NULL;
cd1191f1
CB		 4109 info->useFILE = 0;
4110 info->waiting = 0;
4111 info->in_done = TRUE;
4112 info->out_done = TRUE;
4113 info->err_done = TRUE;
4114
4115 /* Assign a channel on this so that it will persist, and not login */
4116 /* We stash this channel in the info structure for reference. */
4117 /* The created xterm self destructs when the last channel is removed */
4118 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4119 /* So leave this assigned. */
4120 device_name_dsc.dsc$w_length = device_name_len;
4121 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4122 if (!$VMS_STATUS_SUCCESS(status)) {
4123 SETERRNO(EVMSERR, status);
4124 return NULL;
4125 }
4126 info->xchan_valid = 1;
4127
4128 /* Now create a mailbox to be read by the application */
4129
8a646e0b 4130 create_mbx(&p_chan, &d_mbx1);
cd1191f1
CB		 4131
4132 /* write the name of the created terminal to the mailbox */
4133 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4134 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4135
4136 if (!$VMS_STATUS_SUCCESS(status)) {
4137 SETERRNO(EVMSERR, status);
4138 return NULL;
4139 }
4140
4141 info->fp = PerlIO_open(mbx1, mode);
4142
4143 /* Done with this channel */
4144 sys$dassgn(p_chan);
4145
4146 /* If any errors, then clean up */
4147 if (!info->fp) {
4148 n = sizeof(Info);
ebd4d70b 4149 _ckvmssts_noperl(lib$free_vm(&n, &info));
cd1191f1
CB		 4150 return NULL;
4151 }
4152
4153 /* All done */
4154 return info->fp;
4155}
22d4bb9c 4156
ebd4d70b
JM		 4157static I32 my_pclose_pinfo(pTHX_ pInfo info);
4158
8fde5078 4159static PerlIO *
2fbb330f 4160safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4161{
748a9306 4162 static int handler_set_up = FALSE;
ebd4d70b 4163 PerlIO * ret_fp;
55f2b99c 4164 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4165 /* The use of a GLOBAL table (as was done previously) rendered
4166 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4167 * environment. Hence we've switched to LOCAL symbol table.
4168 */
4169 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4170 int j, wait = 0, n;
ff7adb52 4171 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4172 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4173 FILE *tpipe = 0;
4174 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4175 pInfo info = NULL;
48b5a746 4176 char cmd_sym_name[20];
22d4bb9c
CB		 4177 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4178 DSC$K_CLASS_S, symbol};
22d4bb9c 4179 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4180 DSC$K_CLASS_S, 0};
48b5a746
CL		 4181 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4182 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4183 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4184 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4185 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4186 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4187
cd1191f1
CB		 4188 /* Check here for Xterm create request. This means looking for
4189 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4190 * is possible to create an xterm.
4191 */
4192 if (*in_mode == 'r') {
4193 PerlIO * xterm_fd;
4194
4d9538c1
JM		 4195#if defined(PERL_IMPLICIT_CONTEXT)
4196 /* Can not fork an xterm with a NULL context */
4197 /* This probably could never happen */
4198 xterm_fd = NULL;
4199 if (aTHX != NULL)
4200#endif
cd1191f1 4201 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4e205ed6 4202 if (xterm_fd != NULL)
cd1191f1
CB		 4203 return xterm_fd;
4204 }
cd1191f1 4205
afd8f436
JH		 4206 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4207
22d4bb9c
CB		 4208 /* once-per-program initialization...
4209 note that the SETAST calls and the dual test of pipe_ef
4210 makes sure that only the FIRST thread through here does
4211 the initialization...all other threads wait until it's
4212 done.
4213
4214 Yeah, uglier than a pthread call, it's got all the stuff inline
4215 rather than in a separate routine.
4216 */
4217
4218 if (!pipe_ef) {
ebd4d70b 4219 _ckvmssts_noperl(sys$setast(0));
22d4bb9c
CB		 4220 if (!pipe_ef) {
4221 unsigned long int pidcode = JPI$_PID;
4222 $DESCRIPTOR(d_delay, RETRY_DELAY);
ebd4d70b
JM		 4223 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4224 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4225 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
22d4bb9c
CB		 4226 }
4227 if (!handler_set_up) {
ebd4d70b 4228 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
22d4bb9c
CB		 4229 handler_set_up = TRUE;
4230 }
ebd4d70b 4231 _ckvmssts_noperl(sys$setast(1));
22d4bb9c
CB		 4232 }
4233
4234 /* see if we can find a VMSPIPE.COM */
4235
4236 tfilebuf[0] = '@';
fd8cd3a3 4237 vmspipe = find_vmspipe(aTHX);
22d4bb9c 4238 if (vmspipe) {
a35dcc95 4239 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
22d4bb9c 4240 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4241 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4242 if (!tpipe) { /* a fish popular in Boston */
4243 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4244 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c 4245 }
4e205ed6 4246 return NULL;
22d4bb9c
CB		 4247 }
4248 fgetname(tpipe,tfilebuf+1,1);
a35dcc95 4249 vmspipedsc.dsc$w_length = strlen(tfilebuf);
22d4bb9c
CB		 4250 }
4251 vmspipedsc.dsc$a_pointer = tfilebuf;
a0d0e21e 4252
218fdd94 4253 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4254 if (!(sts & 1)) {
4255 switch (sts) {
4256 case RMS$_FNF: case RMS$_DNF:
4257 set_errno(ENOENT); break;
4258 case RMS$_DIR:
4259 set_errno(ENOTDIR); break;
4260 case RMS$_DEV:
4261 set_errno(ENODEV); break;
4262 case RMS$_PRV:
4263 set_errno(EACCES); break;
4264 case RMS$_SYN:
4265 set_errno(EINVAL); break;
4266 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4267 set_errno(E2BIG); break;
4268 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 4269 _ckvmssts_noperl(sts); /* fall through */
a2669cfc
JH		 4270 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4271 set_errno(EVMSERR);
4272 }
4273 set_vaxc_errno(sts);
cd1191f1 4274 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4275 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4276 }
ff7adb52 4277 *psts = sts;
4e205ed6 4278 return NULL;
a2669cfc 4279 }
d4c83939 4280 n = sizeof(Info);
ebd4d70b 4281 _ckvmssts_noperl(lib$get_vm(&n, &info));
22d4bb9c 4282
a35dcc95 4283 my_strlcpy(mode, in_mode, sizeof(mode));
22d4bb9c
CB		 4284 info->mode = *mode;
4285 info->done = FALSE;
4286 info->completion = 0;
4287 info->closing = FALSE;
4288 info->in = 0;
4289 info->out = 0;
4290 info->err = 0;
4e205ed6 4291 info->fp = NULL;
ff7adb52
CL		 4292 info->useFILE = 0;
4293 info->waiting = 0;
22d4bb9c
CB		 4294 info->in_done = TRUE;
4295 info->out_done = TRUE;
4296 info->err_done = TRUE;
cd1191f1
CB		 4297 info->xchan = 0;
4298 info->xchan_valid = 0;
cfcfe586 4299
c11536f5 4300 in = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4301 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4302 out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4303 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4304 err = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4305 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4306
0e06870b 4307 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4308
ff7adb52
CL		 4309 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4310 info->useFILE = 1;
4311 strcpy(p,p+1);
4312 }
4313 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4314 wait = 1;
4315 strcpy(p,p+1);
4316 }
4317
22d4bb9c 4318 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4319
fd8cd3a3 4320 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4321 if (info->out) {
4322 info->out->pipe_done = &info->out_done;
4323 info->out_done = FALSE;
4324 info->out->info = info;
4325 }
ff7adb52 4326 if (!info->useFILE) {
cd1191f1 4327 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4328 } else {
4329 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
0db50132 4330 vmssetuserlnm("SYS$INPUT", mbx);
ff7adb52
CL		 4331 }
4332
22d4bb9c
CB		 4333 if (!info->fp && info->out) {
4334 sys$cancel(info->out->chan_out);
4335
4336 while (!info->out_done) {
4337 int done;
ebd4d70b 4338 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4339 done = info->out_done;
ebd4d70b
JM		 4340 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4341 _ckvmssts_noperl(sys$setast(1));
4342 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
0e06870b 4343 }
22d4bb9c 4344
d4c83939
CB		 4345 if (info->out->buf) {
4346 n = info->out->bufsize * sizeof(char);
ebd4d70b 4347 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
d4c83939
CB		 4348 }
4349 n = sizeof(Pipe);
ebd4d70b 4350 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
d4c83939 4351 n = sizeof(Info);
ebd4d70b 4352 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4353 *psts = RMS$_FNF;
4e205ed6 4354 return NULL;
0e06870b 4355 }
22d4bb9c 4356
fd8cd3a3 4357 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4358 if (info->err) {
4359 info->err->pipe_done = &info->err_done;
4360 info->err_done = FALSE;
4361 info->err->info = info;
4362 }
a0d0e21e 4363
ff7adb52
CL		 4364 } else if (*mode == 'w') { /* piping to subroutine */
4365
4366 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4367 if (info->out) {
4368 info->out->pipe_done = &info->out_done;
4369 info->out_done = FALSE;
4370 info->out->info = info;
4371 }
4372
4373 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4374 if (info->err) {
4375 info->err->pipe_done = &info->err_done;
4376 info->err_done = FALSE;
4377 info->err->info = info;
4378 }
a0d0e21e 4379
fd8cd3a3 4380 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4381 if (!info->useFILE) {
a480973c 4382 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4383 } else {
4384 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
0db50132 4385 vmssetuserlnm("SYS$OUTPUT", mbx);
ff7adb52
CL		 4386 }
4387
22d4bb9c
CB		 4388 if (info->in) {
4389 info->in->pipe_done = &info->in_done;
4390 info->in_done = FALSE;
4391 info->in->info = info;
4392 }
a0d0e21e 4393
22d4bb9c
CB		 4394 /* error cleanup */
4395 if (!info->fp && info->in) {
4396 info->done = TRUE;
ebd4d70b
JM		 4397 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4398 0, 0, 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 4399
4400 while (!info->in_done) {
4401 int done;
ebd4d70b 4402 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4403 done = info->in_done;
ebd4d70b
JM		 4404 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4405 _ckvmssts_noperl(sys$setast(1));
4406 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
22d4bb9c 4407 }
a0d0e21e 4408
d4c83939
CB		 4409 if (info->in->buf) {
4410 n = info->in->bufsize * sizeof(char);
ebd4d70b 4411 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
d4c83939
CB		 4412 }
4413 n = sizeof(Pipe);
ebd4d70b 4414 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
d4c83939 4415 n = sizeof(Info);
ebd4d70b 4416 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4417 *psts = RMS$_FNF;
4e205ed6 4418 return NULL;
22d4bb9c 4419 }
a0d0e21e 4420
22d4bb9c 4421
ff7adb52 4422 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
e2d6c6fb
CB		 4423 /* Let the child inherit standard input, unless it's a directory. */
4424 Stat_t st;
3f80905d
CB		 4425 if (my_trnlnm("SYS$INPUT", in, 0)) {
4426 if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
4427 *in = '\0';
4428 }
e2d6c6fb 4429
fd8cd3a3 4430 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4431 if (info->out) {
4432 info->out->pipe_done = &info->out_done;
4433 info->out_done = FALSE;
4434 info->out->info = info;
4435 }
0e06870b 4436
fd8cd3a3 4437 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4438 if (info->err) {
4439 info->err->pipe_done = &info->err_done;
4440 info->err_done = FALSE;
4441 info->err->info = info;
4442 }
748a9306 4443 }
22d4bb9c 4444
a35dcc95 4445 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
ebd4d70b 4446 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
22d4bb9c 4447
a35dcc95 4448 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
ebd4d70b 4449 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
22d4bb9c 4450
a35dcc95 4451 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
ebd4d70b 4452 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4453
cfcfe586
JM		 4454 /* Done with the names for the pipes */
4455 PerlMem_free(err);
4456 PerlMem_free(out);
4457 PerlMem_free(in);
4458
218fdd94 4459 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4460 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4461 if (*p == '$') p++; /* remove leading $ */
4462 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4463
4464 for (j = 0; j < 4; j++) {
4465 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4466 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4467
a35dcc95 4468 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
ebd4d70b 4469 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
22d4bb9c 4470
48b5a746
CL		 4471 if (strlen(p) > MAX_DCL_SYMBOL) {
4472 p += MAX_DCL_SYMBOL;
4473 } else {
4474 p += strlen(p);
4475 }
4476 }
ebd4d70b 4477 _ckvmssts_noperl(sys$setast(0));
a0d0e21e
LW		 4478 info->next=open_pipes; /* prepend to list */
4479 open_pipes=info;
ebd4d70b 4480 _ckvmssts_noperl(sys$setast(1));
55f2b99c
CB		 4481 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4482 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4483 * have SYS$COMMAND if we need it.
4484 */
ebd4d70b 4485 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4486 0, &info->pid, &info->completion,
4487 0, popen_completion_ast,info,0,0,0));
4488
4489 /* if we were using a tempfile, close it now */
4490
4491 if (tpipe) fclose(tpipe);
4492
ff7adb52 4493 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4494 we can get rid of ours */
4495
48b5a746
CL		 4496 for (j = 0; j < 4; j++) {
4497 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4498 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
ebd4d70b 4499 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4500 }
ebd4d70b
JM		 4501 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4502 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4503 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4504 vms_execfree(vmscmd);
a0d0e21e 4505
218fdd94
CL		 4506#ifdef PERL_IMPLICIT_CONTEXT
4507 if (aTHX)
4508#endif
6b88bc9c 4509 PL_forkprocess = info->pid;
218fdd94 4510
ebd4d70b 4511 ret_fp = info->fp;
ff7adb52 4512 if (wait) {
ebd4d70b 4513 dSAVEDERRNO;
ff7adb52
CL		 4514 int done = 0;
4515 while (!done) {
ebd4d70b 4516 _ckvmssts_noperl(sys$setast(0));
ff7adb52 4517 done = info->done;
ebd4d70b
JM		 4518 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4519 _ckvmssts_noperl(sys$setast(1));
4520 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
ff7adb52
CL		 4521 }
4522 *psts = info->completion;
2fbb330f
JM		 4523/* Caller thinks it is open and tries to close it. */
4524/* This causes some problems, as it changes the error status */
4525/* my_pclose(info->fp); */
ebd4d70b
JM		 4526
4527 /* If we did not have a file pointer open, then we have to */
4528 /* clean up here or eventually we will run out of something */
4529 SAVE_ERRNO;
4530 if (info->fp == NULL) {
4531 my_pclose_pinfo(aTHX_ info);
4532 }
4533 RESTORE_ERRNO;
4534
ff7adb52 4535 } else {
eed5d6a1 4536 *psts = info->pid;
ff7adb52 4537 }
ebd4d70b 4538 return ret_fp;
1e422769 4539} /* end of safe_popen */
4540
4541
a15cef0c
CB		 4542/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4543PerlIO *
2fbb330f 4544Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4545{
ff7adb52 4546 int sts;
1e422769 4547 TAINT_ENV();
4548 TAINT_PROPER("popen");
45bc9206 4549 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4550 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4551}
1e422769 4552
a0d0e21e
LW		 4553/*}}}*/
4554
ebd4d70b
JM		 4555
4556/* Routine to close and cleanup a pipe info structure */
4557
ce12d4b7
CB		 4558static I32
4559my_pclose_pinfo(pTHX_ pInfo info) {
ebd4d70b 4560
748a9306 4561 unsigned long int retsts;
4e0c9737 4562 int done, n;
ebd4d70b 4563 pInfo next, last;
748a9306 4564
bbce6d69 4565 /* If we were writing to a subprocess, insure that someone reading from
4566 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4567 * produce an EOF record in the mailbox.
4568 *
4569 * well, at least sometimes it *does*, so we have to watch out for
4570 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4571 */
ff7adb52 4572 if (info->fp) {
5ce486e0
CB		 4573 if (!info->useFILE
4574#if defined(USE_ITHREADS)
4575 && my_perl
4576#endif
a24c654f
CB		 4577#ifdef USE_PERLIO
4578 && PL_perlio_fd_refcnt
4579#endif
4580 )
5ce486e0 4581 PerlIO_flush(info->fp);
ff7adb52
CL		 4582 else
4583 fflush((FILE *)info->fp);
4584 }
22d4bb9c 4585
b08af3f0 4586 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4587 info->closing = TRUE;
4588 done = info->done && info->in_done && info->out_done && info->err_done;
4589 /* hanging on write to Perl's input? cancel it */
4590 if (info->mode == 'r' && info->out && !info->out_done) {
4591 if (info->out->chan_out) {
4592 _ckvmssts(sys$cancel(info->out->chan_out));
4593 if (!info->out->chan_in) { /* EOF generation, need AST */
4594 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4595 }
4596 }
4597 }
4598 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4599 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4600 0, 0, 0, 0, 0, 0));
b08af3f0 4601 _ckvmssts(sys$setast(1));
ff7adb52 4602 if (info->fp) {
5ce486e0
CB		 4603 if (!info->useFILE
4604#if defined(USE_ITHREADS)
4605 && my_perl
4606#endif
a24c654f
CB		 4607#ifdef USE_PERLIO
4608 && PL_perlio_fd_refcnt
4609#endif
4610 )
d4c83939 4611 PerlIO_close(info->fp);
ff7adb52
CL		 4612 else
4613 fclose((FILE *)info->fp);
4614 }
22d4bb9c
CB		 4615 /*
4616 we have to wait until subprocess completes, but ALSO wait until all
4617 the i/o completes...otherwise we'll be freeing the "info" structure
4618 that the i/o ASTs could still be using...
4619 */
4620
4621 while (!done) {
4622 _ckvmssts(sys$setast(0));
4623 done = info->done && info->in_done && info->out_done && info->err_done;
4624 if (!done) _ckvmssts(sys$clref(pipe_ef));
4625 _ckvmssts(sys$setast(1));
4626 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4627 }
4628 retsts = info->completion;
a0d0e21e 4629
a0d0e21e 4630 /* remove from list of open pipes */
b08af3f0 4631 _ckvmssts(sys$setast(0));
ebd4d70b
JM		 4632 last = NULL;
4633 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4634 if (next == info)
4635 break;
4636 }
4637
4638 if (last)
4639 last->next = info->next;
4640 else
4641 open_pipes = info->next;
b08af3f0 4642 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4643
4644 /* free buffers and structures */
4645
4646 if (info->in) {
d4c83939
CB		 4647 if (info->in->buf) {
4648 n = info->in->bufsize * sizeof(char);
4649 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4650 }
4651 n = sizeof(Pipe);
4652 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4653 }
4654 if (info->out) {
d4c83939
CB		 4655 if (info->out->buf) {
4656 n = info->out->bufsize * sizeof(char);
4657 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4658 }
4659 n = sizeof(Pipe);
4660 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4661 }
4662 if (info->err) {
d4c83939
CB		 4663 if (info->err->buf) {
4664 n = info->err->bufsize * sizeof(char);
4665 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4666 }
4667 n = sizeof(Pipe);
4668 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4669 }
d4c83939
CB		 4670 n = sizeof(Info);
4671 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4672
4673 return retsts;
ebd4d70b
JM		 4674}
4675
4676
4677/*{{{ I32 my_pclose(PerlIO *fp)*/
4678I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4679{
4680 pInfo info, last = NULL;
4681 I32 ret_status;
4682
4683 /* Fixme - need ast and mutex protection here */
4684 for (info = open_pipes; info != NULL; last = info, info = info->next)
4685 if (info->fp == fp) break;
4686
4687 if (info == NULL) { /* no such pipe open */
4688 set_errno(ECHILD); /* quoth POSIX */
4689 set_vaxc_errno(SS$_NONEXPR);
4690 return -1;
4691 }
4692
4693 ret_status = my_pclose_pinfo(aTHX_ info);
4694
4695 return ret_status;
748a9306 4696
a0d0e21e
LW		 4697} /* end of my_pclose() */
4698
aeb5cf3c
CB		 4699 /* Roll our own prototype because we want this regardless of whether
4700 * _VMS_WAIT is defined.
4701 */
c11536f5
CB		 4702
4703#ifdef __cplusplus
4704extern "C" {
4705#endif
aeb5cf3c 4706 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
c11536f5
CB		 4707#ifdef __cplusplus
4708}
4709#endif
4710
aeb5cf3c
CB		 4711/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4712 created with popen(); otherwise partially emulate waitpid() unless
4713 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4714 Also check processes not considered by the CRTL waitpid().
4715 */
4fdae800 4716/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4717Pid_t
fd8cd3a3 4718Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4719{
22d4bb9c
CB		 4720 pInfo info;
4721 int done;
aeb5cf3c 4722 int sts;
d85f548a 4723 int j;
aeb5cf3c
CB		 4724
4725 if (statusp) *statusp = 0;
a0d0e21e
LW		 4726
4727 for (info = open_pipes; info != NULL; info = info->next)
4728 if (info->pid == pid) break;
4729
4730 if (info != NULL) { /* we know about this child */
748a9306 4731 while (!info->done) {
22d4bb9c
CB		 4732 _ckvmssts(sys$setast(0));
4733 done = info->done;
4734 if (!done) _ckvmssts(sys$clref(pipe_ef));
4735 _ckvmssts(sys$setast(1));
4736 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4737 }
4738
aeb5cf3c 4739 if (statusp) *statusp = info->completion;
a0d0e21e 4740 return pid;
d85f548a
JH		 4741 }
4742
4743 /* child that already terminated? */
aeb5cf3c 4744
d85f548a
JH		 4745 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4746 if (closed_list[j].pid == pid) {
4747 if (statusp) *statusp = closed_list[j].completion;
4748 return pid;
4749 }
a0d0e21e 4750 }
d85f548a
JH		 4751
4752 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4753
aeb5cf3c
CB		 4754 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4755 * in 7.2 did we get a version that fills in the VMS completion
4756 * status as Perl has always tried to do.
4757 */
4758
4759 sts = __vms_waitpid( pid, statusp, flags );
4760
4761 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4762 return sts;
4763
4764 /* If the real waitpid tells us the child does not exist, we
4765 * fall through here to implement waiting for a child that
4766 * was created by some means other than exec() (say, spawned
4767 * from DCL) or to wait for a process that is not a subprocess
4768 * of the current process.
4769 */
4770
21bc9d50 4771 {
a0d0e21e 4772 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4773 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4774 unsigned long int pidcode = JPI$_PID, mypid;
4775 unsigned long int interval[2];
aeb5cf3c 4776 unsigned int jpi_iosb[2];
d85f548a 4777 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4778 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4779 { 0, 0, 0, 0}
4780 };
aeb5cf3c
CB		 4781
4782 if (pid <= 0) {
4783 /* Sorry folks, we don't presently implement rooting around for
4784 the first child we can find, and we definitely don't want to
4785 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4786 */
4787 set_errno(ENOTSUP);
4788 return -1;
4789 }
4790
d85f548a
JH		 4791 /* Get the owner of the child so I can warn if it's not mine. If the
4792 * process doesn't exist or I don't have the privs to look at it,
4793 * I can go home early.
aeb5cf3c
CB		 4794 */
4795 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4796 if (sts & 1) sts = jpi_iosb[0];
4797 if (!(sts & 1)) {
4798 switch (sts) {
4799 case SS$_NONEXPR:
4800 set_errno(ECHILD);
4801 break;
4802 case SS$_NOPRIV:
4803 set_errno(EACCES);
4804 break;
4805 default:
4806 _ckvmssts(sts);
4807 }
4808 set_vaxc_errno(sts);
4809 return -1;
4810 }
a0d0e21e 4811
3eeba6fb 4812 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4813 /* remind folks they are asking for non-standard waitpid behavior */
4814 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4815 if (ownerpid != mypid)
f98bc0c6 4816 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4817 "waitpid: process %x is not a child of process %x",
4818 pid,mypid);
748a9306 4819 }
a0d0e21e 4820
d85f548a
JH		 4821 /* simply check on it once a second until it's not there anymore. */
4822
4823 _ckvmssts(sys$bintim(&intdsc,interval));
4824 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4825 _ckvmssts(sys$schdwk(0,0,interval,0));
4826 _ckvmssts(sys$hiber());
d85f548a
JH		 4827 }
4828 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4829
4830 _ckvmssts(sts);
a0d0e21e 4831 return pid;
21bc9d50 4832 }
a0d0e21e 4833} /* end of waitpid() */
a0d0e21e
LW		 4834/*}}}*/
4835/*}}}*/
4836/*}}}*/
4837
4838/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4839char *
4840my_gconvert(double val, int ndig, int trail, char *buf)
4841{
4842 static char __gcvtbuf[DBL_DIG+1];
4843 char *loc;
4844
4845 loc = buf ? buf : __gcvtbuf;
71be2cbc 4846
a0d0e21e
LW		 4847 if (val) {
4848 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4849 return gcvt(val,ndig,loc);
4850 }
4851 else {
4852 loc[0] = '0'; loc[1] = '\0';
4853 return loc;
4854 }
4855
4856}
4857/*}}}*/
4858
054a3baf 4859#if !defined(NAML$C_MAXRSS)
ce12d4b7
CB		 4860static int
4861rms_free_search_context(struct FAB * fab)
a480973c 4862{
ce12d4b7 4863 struct NAM * nam;
a480973c
JM		 4864
4865 nam = fab->fab$l_nam;
4866 nam->nam$b_nop |= NAM$M_SYNCHK;
4867 nam->nam$l_rlf = NULL;
4868 fab->fab$b_dns = 0;
4869 return sys$parse(fab, NULL, NULL);
4870}
4871
4872#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4873#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4874#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4875#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4876#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4877#define rms_nam_esll(nam) nam.nam$b_esl
4878#define rms_nam_esl(nam) nam.nam$b_esl
4879#define rms_nam_name(nam) nam.nam$l_name
4880#define rms_nam_namel(nam) nam.nam$l_name
4881#define rms_nam_type(nam) nam.nam$l_type
4882#define rms_nam_typel(nam) nam.nam$l_type
4883#define rms_nam_ver(nam) nam.nam$l_ver
4884#define rms_nam_verl(nam) nam.nam$l_ver
4885#define rms_nam_rsll(nam) nam.nam$b_rsl
4886#define rms_nam_rsl(nam) nam.nam$b_rsl
4887#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4888#define rms_set_fna(fab, nam, name, size) \
a1887106 4889 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4890#define rms_get_fna(fab, nam) fab.fab$l_fna
4891#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4892 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4893#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4894#define rms_set_esa(nam, name, size) \
a1887106 4895 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4896#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4897 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4898#define rms_set_rsa(nam, name, size) \
a1887106 4899 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4900#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4901 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4902#define rms_nam_name_type_l_size(nam) \
4903 (nam.nam$b_name + nam.nam$b_type)
a480973c 4904#else
ce12d4b7
CB		 4905static int
4906rms_free_search_context(struct FAB * fab)
a480973c 4907{
ce12d4b7 4908 struct NAML * nam;
a480973c
JM		 4909
4910 nam = fab->fab$l_naml;
4911 nam->naml$b_nop |= NAM$M_SYNCHK;
4912 nam->naml$l_rlf = NULL;
4913 nam->naml$l_long_defname_size = 0;
988c775c 4914
a480973c
JM		 4915 fab->fab$b_dns = 0;
4916 return sys$parse(fab, NULL, NULL);
4917}
4918
4919#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4920#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4921#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4922#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4923#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4924#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4925#define rms_nam_esl(nam) nam.naml$b_esl
4926#define rms_nam_name(nam) nam.naml$l_name
4927#define rms_nam_namel(nam) nam.naml$l_long_name
4928#define rms_nam_type(nam) nam.naml$l_type
4929#define rms_nam_typel(nam) nam.naml$l_long_type
4930#define rms_nam_ver(nam) nam.naml$l_ver
4931#define rms_nam_verl(nam) nam.naml$l_long_ver
4932#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4933#define rms_nam_rsl(nam) nam.naml$b_rsl
4934#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4935#define rms_set_fna(fab, nam, name, size) \
a1887106 4936 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4937 nam.naml$l_long_filename_size = size; \
a1887106 4938 nam.naml$l_long_filename = name;}
a480973c
JM		 4939#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4940#define rms_set_dna(fab, nam, name, size) \
a1887106 4941 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4942 nam.naml$l_long_defname_size = size; \
a1887106 4943 nam.naml$l_long_defname = name; }
a480973c 4944#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4945#define rms_set_esa(nam, name, size) \
a1887106 4946 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4947 nam.naml$l_long_expand_alloc = size; \
a1887106 4948 nam.naml$l_long_expand = name; }
a480973c 4949#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4950 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4951 nam.naml$l_long_expand = l_name; \
a1887106 4952 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4953#define rms_set_rsa(nam, name, size) \
a1887106 4954 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4955 nam.naml$l_long_result = name; \
a1887106 4956 nam.naml$l_long_result_alloc = size; }
a480973c 4957#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4958 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4959 nam.naml$l_long_result = l_name; \
a1887106
JM		 4960 nam.naml$l_long_result_alloc = l_size; }
4961#define rms_nam_name_type_l_size(nam) \
4962 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4963#endif
4964
4fdf8f88 4965
e0e5e8d6
JM		 4966/* rms_erase
4967 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4968 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4969 * them if one of the PCP modes is active.
e0e5e8d6 4970 */
ce12d4b7
CB		 4971static int
4972rms_erase(const char * vmsname)
e0e5e8d6
JM		 4973{
4974 int status;
4975 struct FAB myfab = cc$rms_fab;
4976 rms_setup_nam(mynam);
4977
4978 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4979 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4980
e0e5e8d6
JM		 4981#ifdef NAML$M_OPEN_SPECIAL
4982 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4983#endif
4984
d30c1055 4985 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 4986
4987 return status;
4988}
4989
bbce6d69 4990
4fdf8f88
JM		 4991static int
4992vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4993 const struct dsc$descriptor_s * vms_dst_dsc,
4994 unsigned long flags)
4995{
4996 /* VMS and UNIX handle file permissions differently and the
4997 * the same ACL trick may be needed for renaming files,
4998 * especially if they are directories.
4999 */
5000
5001 /* todo: get kill_file and rename to share common code */
5002 /* I can not find online documentation for $change_acl
5003 * it appears to be replaced by $set_security some time ago */
5004
ce12d4b7
CB		 5005 const unsigned int access_mode = 0;
5006 $DESCRIPTOR(obj_file_dsc,"FILE");
5007 char *vmsname;
5008 char *rslt;
5009 unsigned long int jpicode = JPI$_UIC;
5010 int aclsts, fndsts, rnsts = -1;
5011 unsigned int ctx = 0;
5012 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5013 struct dsc$descriptor_s * clean_dsc;
5014
5015 struct myacedef {
5016 unsigned char myace$b_length;
5017 unsigned char myace$b_type;
5018 unsigned short int myace$w_flags;
5019 unsigned long int myace$l_access;
5020 unsigned long int myace$l_ident;
5021 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5022 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5023 0},
5024 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5025
5026 struct item_list_3
4fdf8f88
JM		 5027 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5028 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5029 {0,0,0,0}},
5030 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5031 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5032 {0,0,0,0}};
5033
5034
5035 /* Expand the input spec using RMS, since we do not want to put
5036 * ACLs on the target of a symbolic link */
c11536f5 5037 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4fdf8f88
JM		 5038 if (vmsname == NULL)
5039 return SS$_INSFMEM;
5040
6fb6c614 5041 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4fdf8f88 5042 vmsname,
6fb6c614 5043 PERL_RMSEXPAND_M_SYMLINK);
4fdf8f88
JM		 5044 if (rslt == NULL) {
5045 PerlMem_free(vmsname);
5046 return SS$_INSFMEM;
5047 }
5048
5049 /* So we get our own UIC to use as a rights identifier,
5050 * and the insert an ACE at the head of the ACL which allows us
5051 * to delete the file.
5052 */
ebd4d70b 5053 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4fdf8f88
JM		 5054
5055 fildsc.dsc$w_length = strlen(vmsname);
5056 fildsc.dsc$a_pointer = vmsname;
5057 ctx = 0;
5058 newace.myace$l_ident = oldace.myace$l_ident;
5059 rnsts = SS$_ABORT;
5060
5061 /* Grab any existing ACEs with this identifier in case we fail */
5062 clean_dsc = &fildsc;
5063 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5064 &fildsc,
5065 NULL,
5066 OSS$M_WLOCK,
5067 findlst,
5068 &ctx,
5069 &access_mode);
5070
5071 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5072 /* Add the new ACE . . . */
5073
5074 /* if the sys$get_security succeeded, then ctx is valid, and the
5075 * object/file descriptors will be ignored. But otherwise they
5076 * are needed
5077 */
5078 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5079 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5080 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5081 set_errno(EVMSERR);
5082 set_vaxc_errno(aclsts);
5083 PerlMem_free(vmsname);
5084 return aclsts;
5085 }
5086
5087 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5088 NULL, NULL,
5089 &flags,
5090 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5091
5092 if ($VMS_STATUS_SUCCESS(rnsts)) {
5093 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5094 }
5095
5096 /* Put things back the way they were. */
5097 ctx = 0;
5098 aclsts = sys$get_security(&obj_file_dsc,
5099 clean_dsc,
5100 NULL,
5101 OSS$M_WLOCK,
5102 findlst,
5103 &ctx,
5104 &access_mode);
5105
5106 if ($VMS_STATUS_SUCCESS(aclsts)) {
5107 int sec_flags;
5108
5109 sec_flags = 0;
5110 if (!$VMS_STATUS_SUCCESS(fndsts))
5111 sec_flags = OSS$M_RELCTX;
5112
5113 /* Get rid of the new ACE */
5114 aclsts = sys$set_security(NULL, NULL, NULL,
5115 sec_flags, dellst, &ctx, &access_mode);
5116
5117 /* If there was an old ACE, put it back */
5118 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5119 addlst[0].bufadr = &oldace;
5120 aclsts = sys$set_security(NULL, NULL, NULL,
5121 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5122 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5123 set_errno(EVMSERR);
5124 set_vaxc_errno(aclsts);
5125 rnsts = aclsts;
5126 }
5127 } else {
5128 int aclsts2;
5129
5130 /* Try to clear the lock on the ACL list */
5131 aclsts2 = sys$set_security(NULL, NULL, NULL,
5132 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5133
5134 /* Rename errors are most important */
5135 if (!$VMS_STATUS_SUCCESS(rnsts))
5136 aclsts = rnsts;
5137 set_errno(EVMSERR);
5138 set_vaxc_errno(aclsts);
5139 rnsts = aclsts;
5140 }
5141 }
5142 else {
5143 if (aclsts != SS$_ACLEMPTY)
5144 rnsts = aclsts;
5145 }
5146 }
5147 else
5148 rnsts = fndsts;
5149
5150 PerlMem_free(vmsname);
5151 return rnsts;
5152}
5153
5154
5155/*{{{int rename(const char *, const char * */
5156/* Not exactly what X/Open says to do, but doing it absolutely right
5157 * and efficiently would require a lot more work. This should be close
5158 * enough to pass all but the most strict X/Open compliance test.
5159 */
5160int
5161Perl_rename(pTHX_ const char *src, const char * dst)
5162{
ce12d4b7
CB		 5163 int retval;
5164 int pre_delete = 0;
5165 int src_sts;
5166 int dst_sts;
5167 Stat_t src_st;
5168 Stat_t dst_st;
4fdf8f88
JM		 5169
5170 /* Validate the source file */
46c05374 5171 src_sts = flex_lstat(src, &src_st);
4fdf8f88
JM		 5172 if (src_sts != 0) {
5173
5174 /* No source file or other problem */
5175 return src_sts;
5176 }
b94a8c49
JM		 5177 if (src_st.st_devnam[0] == 0) {
5178 /* This may be possible so fail if it is seen. */
5179 errno = EIO;
5180 return -1;
5181 }
4fdf8f88 5182
46c05374 5183 dst_sts = flex_lstat(dst, &dst_st);
4fdf8f88
JM		 5184 if (dst_sts == 0) {
5185
5186 if (dst_st.st_dev != src_st.st_dev) {
5187 /* Must be on the same device */
5188 errno = EXDEV;
5189 return -1;
5190 }
5191
5192 /* VMS_INO_T_COMPARE is true if the inodes are different
5193 * to match the output of memcmp
5194 */
5195
5196 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5197 /* That was easy, the files are the same! */
5198 return 0;
5199 }
5200
5201 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5202 /* If source is a directory, so must be dest */
5203 errno = EISDIR;
5204 return -1;
5205 }
5206
5207 }
5208
5209
5210 if ((dst_sts == 0) &&
5211 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5212
5213 /* We have issues here if vms_unlink_all_versions is set
5214 * If the destination exists, and is not a directory, then
5215 * we must delete in advance.
5216 *
5217 * If the src is a directory, then we must always pre-delete
5218 * the destination.
5219 *
5220 * If we successfully delete the dst in advance, and the rename fails
5221 * X/Open requires that errno be EIO.
5222 *
5223 */
5224
5225 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5226 int d_sts;
46c05374 5227 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
b94a8c49
JM		 5228 S_ISDIR(dst_st.st_mode));
5229
5230 /* Need to delete all versions ? */
5231 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5232 int i = 0;
5233
5234 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
46c05374 5235 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
b94a8c49
JM		 5236 if (d_sts != 0)
5237 break;
5238 i++;
5239
5240 /* Make sure that we do not loop forever */
5241 if (i > 32767) {
5242 errno = EIO;
5243 d_sts = -1;
5244 break;
5245 }
5246 }
5247 }
5248
4fdf8f88
JM		 5249 if (d_sts != 0)
5250 return d_sts;
5251
5252 /* We killed the destination, so only errno now is EIO */
5253 pre_delete = 1;
5254 }
5255 }
5256
5257 /* Originally the idea was to call the CRTL rename() and only
5258 * try the lib$rename_file if it failed.
5259 * It turns out that there are too many variants in what the
5260 * the CRTL rename might do, so only use lib$rename_file
5261 */
5262 retval = -1;
5263
5264 {
5265 /* Is the source and dest both in VMS format */
5266 /* if the source is a directory, then need to fileify */
94ae10c0 5267 /* and dest must be a directory or non-existent. */
4fdf8f88 5268
4fdf8f88
JM		 5269 char * vms_dst;
5270 int sts;
5271 char * ret_str;
5272 unsigned long flags;
5273 struct dsc$descriptor_s old_file_dsc;
5274 struct dsc$descriptor_s new_file_dsc;
5275
5276 /* We need to modify the src and dst depending
5277 * on if one or more of them are directories.
5278 */
5279
c11536f5 5280 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5281 if (vms_dst == NULL)
ebd4d70b 5282 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5283
5284 if (S_ISDIR(src_st.st_mode)) {
5285 char * ret_str;
5286 char * vms_dir_file;
5287
c11536f5 5288 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5289 if (vms_dir_file == NULL)
ebd4d70b 5290 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88 5291
29475144 5292 /* If the dest is a directory, we must remove it */
4fdf8f88
JM		 5293 if (dst_sts == 0) {
5294 int d_sts;
46c05374 5295 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
4fdf8f88 5296 if (d_sts != 0) {
4fdf8f88
JM		 5297 PerlMem_free(vms_dst);
5298 errno = EIO;
29475144 5299 return d_sts;
4fdf8f88
JM		 5300 }
5301
5302 pre_delete = 1;
5303 }
5304
5305 /* The dest must be a VMS file specification */
df278665 5306 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5307 if (ret_str == NULL) {
4fdf8f88
JM		 5308 PerlMem_free(vms_dst);
5309 errno = EIO;
5310 return -1;
5311 }
5312
5313 /* The source must be a file specification */
4fdf8f88
JM		 5314 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5315 if (ret_str == NULL) {
4fdf8f88
JM		 5316 PerlMem_free(vms_dst);
5317 PerlMem_free(vms_dir_file);
5318 errno = EIO;
5319 return -1;
5320 }
5321 PerlMem_free(vms_dst);
5322 vms_dst = vms_dir_file;
5323
5324 } else {
5325 /* File to file or file to new dir */
5326
5327 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5328 /* VMS pathify a dir target */
4846f1d7 5329 ret_str = int_tovmspath(dst, vms_dst, NULL);
4fdf8f88 5330 if (ret_str == NULL) {
4fdf8f88
JM		 5331 PerlMem_free(vms_dst);
5332 errno = EIO;
5333 return -1;
5334 }
5335 } else {
b94a8c49
JM		 5336 char * v_spec, * r_spec, * d_spec, * n_spec;
5337 char * e_spec, * vs_spec;
5338 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
4fdf8f88
JM		 5339
5340 /* fileify a target VMS file specification */
df278665 5341 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5342 if (ret_str == NULL) {
4fdf8f88
JM		 5343 PerlMem_free(vms_dst);
5344 errno = EIO;
5345 return -1;
5346 }
b94a8c49
JM		 5347
5348 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5349 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5350 &e_len, &vs_spec, &vs_len);
5351 if (sts == 0) {
5352 if (e_len == 0) {
5353 /* Get rid of the version */
5354 if (vs_len != 0) {
5355 *vs_spec = '\0';
5356 }
5357 /* Need to specify a '.' so that the extension */
5358 /* is not inherited */
5359 strcat(vms_dst,".");
5360 }
5361 }
4fdf8f88
JM		 5362 }
5363 }
5364
b94a8c49
JM		 5365 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5366 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
4fdf8f88
JM		 5367 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5368 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5369
5370 new_file_dsc.dsc$a_pointer = vms_dst;
5371 new_file_dsc.dsc$w_length = strlen(vms_dst);
5372 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5373 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5374
5375 flags = 0;
054a3baf 5376#if defined(NAML$C_MAXRSS)
449de3c2 5377 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
4fdf8f88
JM		 5378#endif
5379
5380 sts = lib$rename_file(&old_file_dsc,
5381 &new_file_dsc,
5382 NULL, NULL,
5383 &flags,
5384 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5385 if (!$VMS_STATUS_SUCCESS(sts)) {
5386
5387 /* We could have failed because VMS style permissions do not
5388 * permit renames that UNIX will allow. Just like the hack
5389 * in for kill_file.
5390 */
5391 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5392 }
5393
4fdf8f88
JM		 5394 PerlMem_free(vms_dst);
5395 if (!$VMS_STATUS_SUCCESS(sts)) {
5396 errno = EIO;
5397 return -1;
5398 }
5399 retval = 0;
5400 }
5401
5402 if (vms_unlink_all_versions) {
5403 /* Now get rid of any previous versions of the source file that
5404 * might still exist
5405 */
b94a8c49
JM		 5406 int i = 0;
5407 dSAVEDERRNO;
5408 SAVE_ERRNO;
46c05374 5409 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5410 S_ISDIR(src_st.st_mode));
5411 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
46c05374 5412 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5413 S_ISDIR(src_st.st_mode));
5414 if (src_sts != 0)
5415 break;
5416 i++;
5417
5418 /* Make sure that we do not loop forever */
5419 if (i > 32767) {
5420 src_sts = -1;
5421 break;
5422 }
5423 }
5424 RESTORE_ERRNO;
4fdf8f88
JM		 5425 }
5426
5427 /* We deleted the destination, so must force the error to be EIO */
5428 if ((retval != 0) && (pre_delete != 0))
5429 errno = EIO;
5430
5431 return retval;
5432}
5433/*}}}*/
5434
5435
bbce6d69 5436/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5437/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5438 * to expand file specification. Allows for a single default file
5439 * specification and a simple mask of options. If outbuf is non-NULL,
5440 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5441 * the resultant file specification is placed. If outbuf is NULL, the
5442 * resultant file specification is placed into a static buffer.
5443 * The third argument, if non-NULL, is taken to be a default file
5444 * specification string. The fourth argument is unused at present.
5445 * rmesexpand() returns the address of the resultant string if
5446 * successful, and NULL on error.
e886094b
JM		 5447 *
5448 * New functionality for previously unused opts value:
5449 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5450 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5451 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5452 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5453 */
360732b5 5454static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5455
bbce6d69 5456static char *
6fb6c614
JM		 5457int_rmsexpand
5458 (const char *filespec,
360732b5 5459 char *outbuf,
360732b5
JM		 5460 const char *defspec,
5461 unsigned opts,
5462 int * fs_utf8,
5463 int * dfs_utf8)
bbce6d69 5464{
6fb6c614
JM		 5465 char * ret_spec;
5466 const char * in_spec;
5467 char * spec_buf;
5468 const char * def_spec;
5469 char * vmsfspec, *vmsdefspec;
5470 char * esa;
7566800d 5471 char * esal = NULL;
18a3d61e
JM		 5472 char * outbufl;
5473 struct FAB myfab = cc$rms_fab;
a480973c 5474 rms_setup_nam(mynam);
18a3d61e
JM		 5475 STRLEN speclen;
5476 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5477 int sts;
5478
360732b5
JM		 5479 /* temp hack until UTF8 is actually implemented */
5480 if (fs_utf8 != NULL)
5481 *fs_utf8 = 0;
5482
18a3d61e
JM		 5483 if (!filespec || !*filespec) {
5484 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5485 return NULL;
5486 }
18a3d61e
JM		 5487
5488 vmsfspec = NULL;
6fb6c614 5489 vmsdefspec = NULL;
18a3d61e 5490 outbufl = NULL;
a1887106 5491
6fb6c614 5492 in_spec = filespec;
a1887106
JM		 5493 isunix = 0;
5494 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
6fb6c614
JM		 5495 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5496 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5497
5498 /* If this is a UNIX file spec, convert it to VMS */
5499 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5500 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5501 &e_len, &vs_spec, &vs_len);
5502 if (sts != 0) {
5503 isunix = 1;
5504 char * ret_spec;
5505
c11536f5 5506 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5507 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5508 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5509 if (ret_spec == NULL) {
5510 PerlMem_free(vmsfspec);
5511 return NULL;
5512 }
5513 in_spec = (const char *)vmsfspec;
18a3d61e 5514
6fb6c614
JM		 5515 /* Unless we are forcing to VMS format, a UNIX input means
5516 * UNIX output, and that requires long names to be used
5517 */
5518 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
054a3baf 5519#if defined(NAML$C_MAXRSS)
6fb6c614 5520 opts |= PERL_RMSEXPAND_M_LONG;
778e045f
CB		 5521#else
5522 NOOP;
b1a8dcd7 5523#endif
6fb6c614
JM		 5524 else
5525 isunix = 0;
a1887106 5526 }
18a3d61e 5527
6fb6c614
JM		 5528 }
5529
5530 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
a480973c 5531 rms_bind_fab_nam(myfab, mynam);
18a3d61e 5532
6fb6c614
JM		 5533 /* Process the default file specification if present */
5534 def_spec = defspec;
18a3d61e
JM		 5535 if (defspec && *defspec) {
5536 int t_isunix;
5537 t_isunix = is_unix_filespec(defspec);
5538 if (t_isunix) {
c11536f5 5539 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5540 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5541 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5542
5543 if (ret_spec == NULL) {
5544 /* Clean up and bail */
5545 PerlMem_free(vmsdefspec);
5546 if (vmsfspec != NULL)
5547 PerlMem_free(vmsfspec);
5548 return NULL;
5549 }
5550 def_spec = (const char *)vmsdefspec;
18a3d61e 5551 }
6fb6c614
JM		 5552 rms_set_dna(myfab, mynam,
5553 (char *)def_spec, strlen(def_spec)); /* cast ok */
18a3d61e
JM		 5554 }
5555
6fb6c614 5556 /* Now we need the expansion buffers */
c11536f5 5557 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 5558 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
054a3baf 5559#if defined(NAML$C_MAXRSS)
c11536f5 5560 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5561 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5562#endif
a1887106 5563 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5564
d584a1c6
JM		 5565 /* If a NAML block is used RMS always writes to the long and short
5566 * addresses unless you suppress the short name.
5567 */
054a3baf 5568#if defined(NAML$C_MAXRSS)
c11536f5 5569 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5570 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5571#endif
d584a1c6 5572 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5573
f7ddb74a
JM		 5574#ifdef NAM$M_NO_SHORT_UPCASE
5575 if (decc_efs_case_preserve)
a480973c 5576 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5577#endif
18a3d61e 5578
e0e5e8d6
JM		 5579 /* We may not want to follow symbolic links */
5580#ifdef NAML$M_OPEN_SPECIAL
5581 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5582 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5583#endif
5584
18a3d61e
JM		 5585 /* First attempt to parse as an existing file */
5586 retsts = sys$parse(&myfab,0,0);
5587 if (!(retsts & STS$K_SUCCESS)) {
5588
5589 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5590 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
6fb6c614
JM		 5591 if (retsts == RMS$_DNF ||
5592 retsts == RMS$_DIR ||
5593 retsts == RMS$_DEV ||
5594 retsts == RMS$_PRV) {
18a3d61e 5595 retsts = sys$parse(&myfab,0,0);
6fb6c614 5596 if (retsts & STS$K_SUCCESS) goto int_expanded;
18a3d61e
JM		 5597 }
5598
5599 /* Still could not parse the file specification */
5600 /*----------------------------------------------*/
a480973c 5601 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5602 if (vmsdefspec != NULL)
5603 PerlMem_free(vmsdefspec);
18a3d61e 5604 if (vmsfspec != NULL)
c5375c28
JM		 5605 PerlMem_free(vmsfspec);
5606 if (outbufl != NULL)
5607 PerlMem_free(outbufl);
5608 PerlMem_free(esa);
7566800d
CB		 5609 if (esal != NULL)
5610 PerlMem_free(esal);
18a3d61e
JM		 5611 set_vaxc_errno(retsts);
5612 if (retsts == RMS$_PRV) set_errno(EACCES);
5613 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5614 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5615 else set_errno(EVMSERR);
5616 return NULL;
5617 }
5618 retsts = sys$search(&myfab,0,0);
5619 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5620 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5621 if (vmsdefspec != NULL)
5622 PerlMem_free(vmsdefspec);
18a3d61e 5623 if (vmsfspec != NULL)
c5375c28
JM		 5624 PerlMem_free(vmsfspec);
5625 if (outbufl != NULL)
5626 PerlMem_free(outbufl);
5627 PerlMem_free(esa);
7566800d
CB		 5628 if (esal != NULL)
5629 PerlMem_free(esal);
18a3d61e
JM		 5630 set_vaxc_errno(retsts);
5631 if (retsts == RMS$_PRV) set_errno(EACCES);
5632 else set_errno(EVMSERR);
5633 return NULL;
5634 }
5635
5636 /* If the input filespec contained any lowercase characters,
5637 * downcase the result for compatibility with Unix-minded code. */
6fb6c614 5638int_expanded:
18a3d61e 5639 if (!decc_efs_case_preserve) {
6fb6c614 5640 char * tbuf;
c5375c28
JM		 5641 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5642 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5643 }
5644
5645 /* Is a long or a short name expected */
5646 /*------------------------------------*/
6fb6c614 5647 spec_buf = NULL;
054a3baf 5648#if defined(NAML$C_MAXRSS)
18a3d61e 5649 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5650 if (rms_nam_rsll(mynam)) {
6fb6c614 5651 spec_buf = outbufl;
a480973c 5652 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5653 }
5654 else {
6fb6c614 5655 spec_buf = esal; /* Not esa */
a480973c 5656 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5657 }
5658 }
5659 else {
778e045f 5660#endif
a480973c 5661 if (rms_nam_rsl(mynam)) {
6fb6c614 5662 spec_buf = outbuf;
a480973c 5663 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5664 }
5665 else {
6fb6c614 5666 spec_buf = esa; /* Not esal */
a480973c 5667 speclen = rms_nam_esl(mynam);
18a3d61e 5668 }
054a3baf 5669#if defined(NAML$C_MAXRSS)
18a3d61e 5670 }
778e045f 5671#endif
6fb6c614 5672 spec_buf[speclen] = '\0';
4d743a9b 5673
18a3d61e
JM		 5674 /* Trim off null fields added by $PARSE
5675 * If type > 1 char, must have been specified in original or default spec
5676 * (not true for version; $SEARCH may have added version of existing file).
5677 */
a480973c 5678 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5679 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5680 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5681 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5682 }
5683 else {
a480973c
JM		 5684 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5685 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5686 }
5687 if (trimver || trimtype) {
5688 if (defspec && *defspec) {
5689 char *defesal = NULL;
d584a1c6 5690 char *defesa = NULL;
c11536f5 5691 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
d584a1c6 5692 if (defesa != NULL) {
6fb6c614 5693 struct FAB deffab = cc$rms_fab;
054a3baf 5694#if defined(NAML$C_MAXRSS)
c11536f5 5695 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5696 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 5697#endif
a480973c 5698 rms_setup_nam(defnam);
18a3d61e 5699
a480973c
JM		 5700 rms_bind_fab_nam(deffab, defnam);
5701
5702 /* Cast ok */
5703 rms_set_fna
5704 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5705
d584a1c6
JM		 5706 /* RMS needs the esa/esal as a work area if wildcards are involved */
5707 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5708
4d743a9b 5709 rms_clear_nam_nop(defnam);
a480973c 5710 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5711#ifdef NAM$M_NO_SHORT_UPCASE
5712 if (decc_efs_case_preserve)
a480973c 5713 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5714#endif
e0e5e8d6
JM		 5715#ifdef NAML$M_OPEN_SPECIAL
5716 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5717 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5718#endif
18a3d61e
JM		 5719 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5720 if (trimver) {
a480973c 5721 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5722 }
5723 if (trimtype) {
a480973c 5724 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5725 }
5726 }
d584a1c6
JM		 5727 if (defesal != NULL)
5728 PerlMem_free(defesal);
5729 PerlMem_free(defesa);
6fb6c614
JM		 5730 } else {
5731 _ckvmssts_noperl(SS$_INSFMEM);
18a3d61e
JM		 5732 }
5733 }
5734 if (trimver) {
5735 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5736 if (*(rms_nam_verl(mynam)) != '\"')
6fb6c614 5737 speclen = rms_nam_verl(mynam) - spec_buf;
18a3d61e
JM		 5738 }
5739 else {
a480973c 5740 if (*(rms_nam_ver(mynam)) != '\"')
6fb6c614 5741 speclen = rms_nam_ver(mynam) - spec_buf;
18a3d61e
JM		 5742 }
5743 }
5744 if (trimtype) {
5745 /* If we didn't already trim version, copy down */
5746 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
6fb6c614 5747 if (speclen > rms_nam_verl(mynam) - spec_buf)
18a3d61e 5748 memmove
a480973c
JM		 5749 (rms_nam_typel(mynam),
5750 rms_nam_verl(mynam),
6fb6c614 5751 speclen - (rms_nam_verl(mynam) - spec_buf));
a480973c 5752 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5753 }
5754 else {
6fb6c614 5755 if (speclen > rms_nam_ver(mynam) - spec_buf)
18a3d61e 5756 memmove
a480973c
JM		 5757 (rms_nam_type(mynam),
5758 rms_nam_ver(mynam),
6fb6c614 5759 speclen - (rms_nam_ver(mynam) - spec_buf));
a480973c 5760 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5761 }
5762 }
5763 }
5764
5765 /* Done with these copies of the input files */
5766 /*-------------------------------------------*/
5767 if (vmsfspec != NULL)
c5375c28 5768 PerlMem_free(vmsfspec);
6fb6c614
JM		 5769 if (vmsdefspec != NULL)
5770 PerlMem_free(vmsdefspec);
18a3d61e
JM		 5771
5772 /* If we just had a directory spec on input, $PARSE "helpfully"
5773 * adds an empty name and type for us */
054a3baf 5774#if defined(NAML$C_MAXRSS)
18a3d61e 5775 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5776 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5777 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5778 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5779 speclen = rms_nam_namel(mynam) - spec_buf;
18a3d61e 5780 }
d584a1c6
JM		 5781 else
5782#endif
5783 {
a480973c
JM		 5784 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5785 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5786 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5787 speclen = rms_nam_name(mynam) - spec_buf;
18a3d61e
JM		 5788 }
5789
5790 /* Posix format specifications must have matching quotes */
4d743a9b 5791 if (speclen < (VMS_MAXRSS - 1)) {
6fb6c614
JM		 5792 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5793 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5794 spec_buf[speclen] = '\"';
4d743a9b
JM		 5795 speclen++;
5796 }
18a3d61e
JM		 5797 }
5798 }
6fb6c614
JM		 5799 spec_buf[speclen] = '\0';
5800 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
18a3d61e
JM		 5801
5802 /* Have we been working with an expanded, but not resultant, spec? */
5803 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5804 {
5805 int rsl;
18a3d61e 5806
054a3baf 5807#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 5808 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5809 rsl = rms_nam_rsll(mynam);
5810 } else
5811#endif
5812 {
5813 rsl = rms_nam_rsl(mynam);
5814 }
5815 if (!rsl) {
6fb6c614
JM		 5816 /* rsl is not present, it means that spec_buf is either */
5817 /* esa or esal, and needs to be copied to outbuf */
5818 /* convert to Unix if desired */
d584a1c6 5819 if (isunix) {
6fb6c614
JM		 5820 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5821 } else {
5822 /* VMS file specs are not in UTF-8 */
5823 if (fs_utf8 != NULL)
5824 *fs_utf8 = 0;
a35dcc95 5825 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5826 ret_spec = outbuf;
18a3d61e
JM		 5827 }
5828 }
6fb6c614
JM		 5829 else {
5830 /* Now spec_buf is either outbuf or outbufl */
5831 /* We need the result into outbuf */
5832 if (isunix) {
5833 /* If we need this in UNIX, then we need another buffer */
5834 /* to keep things in order */
5835 char * src;
5836 char * new_src = NULL;
5837 if (spec_buf == outbuf) {
c11536f5 5838 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 5839 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
6fb6c614
JM		 5840 } else {
5841 src = spec_buf;
5842 }
5843 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5844 if (new_src) {
5845 PerlMem_free(new_src);
5846 }
5847 } else {
5848 /* VMS file specs are not in UTF-8 */
5849 if (fs_utf8 != NULL)
5850 *fs_utf8 = 0;
5851
5852 /* Copy the buffer if needed */
5853 if (outbuf != spec_buf)
a35dcc95 5854 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5855 ret_spec = outbuf;
d584a1c6 5856 }
18a3d61e 5857 }
18a3d61e 5858 }
6fb6c614
JM		 5859
5860 /* Need to clean up the search context */
a480973c
JM		 5861 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5862 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5863
5864 /* Clean up the extra buffers */
7566800d 5865 if (esal != NULL)
6fb6c614
JM		 5866 PerlMem_free(esal);
5867 PerlMem_free(esa);
c5375c28
JM		 5868 if (outbufl != NULL)
5869 PerlMem_free(outbufl);
6fb6c614
JM		 5870
5871 /* Return the result */
5872 return ret_spec;
5873}
5874
5875/* Common simple case - Expand an already VMS spec */
5876static char *
5877int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5878 opts |= PERL_RMSEXPAND_M_VMS_IN;
5879 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5880}
5881
5882/* Common simple case - Expand to a VMS spec */
5883static char *
5884int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5885 opts |= PERL_RMSEXPAND_M_VMS;
5886 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5887}
5888
5889
5890/* Entry point used by perl routines */
5891static char *
5892mp_do_rmsexpand
5893 (pTHX_ const char *filespec,
5894 char *outbuf,
5895 int ts,
5896 const char *defspec,
5897 unsigned opts,
5898 int * fs_utf8,
5899 int * dfs_utf8)
5900{
5901 static char __rmsexpand_retbuf[VMS_MAXRSS];
5902 char * expanded, *ret_spec, *ret_buf;
5903
5904 expanded = NULL;
5905 ret_buf = outbuf;
5906 if (ret_buf == NULL) {
5907 if (ts) {
5908 Newx(expanded, VMS_MAXRSS, char);
5909 if (expanded == NULL)
5910 _ckvmssts(SS$_INSFMEM);
5911 ret_buf = expanded;
5912 } else {
5913 ret_buf = __rmsexpand_retbuf;
5914 }
5915 }
5916
5917
5918 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5919 opts, fs_utf8, dfs_utf8);
5920
5921 if (ret_spec == NULL) {
5922 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5923 if (expanded)
5924 Safefree(expanded);
5925 }
5926
5927 return ret_spec;
bbce6d69 5928}
5929/*}}}*/
5930/* External entry points */
ce12d4b7
CB		 5931char *
5932Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5933{
5934 return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
5935}
5936
5937char *
5938Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5939{
5940 return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
5941}
5942
5943char *
5944Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
5945 unsigned opt, int * fs_utf8, int * dfs_utf8)
5946{
5947 return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
5948}
5949
5950char *
5951Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
5952 unsigned opt, int * fs_utf8, int * dfs_utf8)
5953{
5954 return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
5955}
bbce6d69 5956
5957
a0d0e21e
LW		 5958/*
5959** The following routines are provided to make life easier when
5960** converting among VMS-style and Unix-style directory specifications.
5961** All will take input specifications in either VMS or Unix syntax. On
5962** failure, all return NULL. If successful, the routines listed below
748a9306 5963** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5964** reformatted spec (and, therefore, subsequent calls to that routine
5965** will clobber the result), while the routines of the same names with
5966** a _ts suffix appended will return a pointer to a mallocd string
5967** containing the appropriately reformatted spec.
5968** In all cases, only explicit syntax is altered; no check is made that
5969** the resulting string is valid or that the directory in question
5970** actually exists.
5971**
5972** fileify_dirspec() - convert a directory spec into the name of the
5973** directory file (i.e. what you can stat() to see if it's a dir).
5974** The style (VMS or Unix) of the result is the same as the style
5975** of the parameter passed in.
5976** pathify_dirspec() - convert a directory spec into a path (i.e.
5977** what you prepend to a filename to indicate what directory it's in).
5978** The style (VMS or Unix) of the result is the same as the style
5979** of the parameter passed in.
5980** tounixpath() - convert a directory spec into a Unix-style path.
5981** tovmspath() - convert a directory spec into a VMS-style path.
5982** tounixspec() - convert any file spec into a Unix-style file spec.
5983** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5984** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5985**
bd3fa61c 5986** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5987** Permission is given to distribute this code as part of the Perl
5988** standard distribution under the terms of the GNU General Public
5989** License or the Perl Artistic License. Copies of each may be
5990** found in the Perl standard distribution.
a0d0e21e
LW		 5991 */
5992
a979ce91
JM		 5993/*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5994static char *
5995int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
a0d0e21e 5996{
4e0c9737 5997 unsigned long int dirlen, retlen, hasfilename = 0;
a979ce91 5998 char *cp1, *cp2, *lastdir;
a480973c 5999 char *trndir, *vmsdir;
2d9f3838 6000 unsigned short int trnlnm_iter_count;
f7ddb74a 6001 int sts;
360732b5
JM		 6002 if (utf8_fl != NULL)
6003 *utf8_fl = 0;
a0d0e21e 6004
c07a80fd 6005 if (!dir || !*dir) {
6006 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6007 }
a0d0e21e 6008 dirlen = strlen(dir);
a2a90019 6009 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 6010 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 6011 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6012 dir = "/sys$disk";
6013 dirlen = 9;
6014 }
6015 else
6016 dirlen = 1;
61bb5906 6017 }
a480973c
JM		 6018 if (dirlen > (VMS_MAXRSS - 1)) {
6019 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6020 return NULL;
c07a80fd 6021 }
c11536f5 6022 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6023 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 6024 if (!strpbrk(dir+1,"/]>:") &&
6025 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 6026 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 6027 trnlnm_iter_count = 0;
b8486b9d 6028 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 6029 trnlnm_iter_count++;
6030 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6031 }
b8ffc8df 6032 dirlen = strlen(trndir);
e518068a 6033 }
01b8edb6 6034 else {
a35dcc95 6035 memcpy(trndir, dir, dirlen);
01b8edb6 6036 trndir[dirlen] = '\0';
01b8edb6 6037 }
b8ffc8df
RGS		 6038
6039 /* At this point we are done with *dir and use *trndir which is a
6040 * copy that can be modified. *dir must not be modified.
6041 */
6042
c07a80fd 6043 /* If we were handed a rooted logical name or spec, treat it like a
6044 * simple directory, so that
6045 * $ Define myroot dev:[dir.]
6046 * ... do_fileify_dirspec("myroot",buf,1) ...
6047 * does something useful.
6048 */
b8ffc8df
RGS		 6049 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6050 trndir[--dirlen] = '\0';
6051 trndir[dirlen-1] = ']';
c07a80fd 6052 }
b8ffc8df
RGS		 6053 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6054 trndir[--dirlen] = '\0';
6055 trndir[dirlen-1] = '>';
46112e17 6056 }
e518068a 6057
b8ffc8df 6058 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 6059 /* If we've got an explicit filename, we can just shuffle the string. */
6060 if (*(cp1+1)) hasfilename = 1;
6061 /* Similarly, we can just back up a level if we've got multiple levels
6062 of explicit directories in a VMS spec which ends with directories. */
6063 else {
b8ffc8df 6064 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 6065 if (*cp2 == '.') {
6066 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 6067/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 6068 *cp2 = *cp1; *cp1 = '\0';
6069 hasfilename = 1;
6070 break;
6071 }
b7ae7a0d 6072 }
6073 if (*cp2 == '[' || *cp2 == '<') break;
6074 }
6075 }
6076 }
6077
c11536f5 6078 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 6079 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 6080 cp1 = strpbrk(trndir,"]:>");
60e5a54b
CB		 6081 if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
6082 cp1 = strpbrk(cp1+2,"]:>");
6083
a979ce91
JM		 6084 if (hasfilename || !cp1) { /* filename present or not VMS */
6085
b8ffc8df 6086 if (trndir[0] == '.') {
a480973c 6087 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 6088 PerlMem_free(trndir);
6089 PerlMem_free(vmsdir);
a979ce91 6090 return int_fileify_dirspec("[]", buf, NULL);
a480973c 6091 }
b8ffc8df 6092 else if (trndir[1] == '.' &&
a480973c 6093 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 6094 PerlMem_free(trndir);
6095 PerlMem_free(vmsdir);
a979ce91 6096 return int_fileify_dirspec("[-]", buf, NULL);
a480973c 6097 }
748a9306 6098 }
b8ffc8df 6099 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 6100 dirlen -= 1; /* to last element */
b8ffc8df 6101 lastdir = strrchr(trndir,'/');
a0d0e21e 6102 }
b8ffc8df 6103 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 6104 /* If we have "/." or "/..", VMSify it and let the VMS code
6105 * below expand it, rather than repeating the code to handle
6106 * relative components of a filespec here */
4633a7c4
LW		 6107 do {
6108 if (*(cp1+2) == '.') cp1++;
6109 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 6110 char * ret_chr;
df278665 6111 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
c5375c28
JM		 6112 PerlMem_free(trndir);
6113 PerlMem_free(vmsdir);
a480973c
JM		 6114 return NULL;
6115 }
fc1ce8cc 6116 if (strchr(vmsdir,'/') != NULL) {
df278665 6117 /* If int_tovmsspec() returned it, it must have VMS syntax
fc1ce8cc
CB		 6118 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6119 * the time to check this here only so we avoid a recursion
6120 * loop; otherwise, gigo.
6121 */
c5375c28
JM		 6122 PerlMem_free(trndir);
6123 PerlMem_free(vmsdir);
a480973c
JM		 6124 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6125 return NULL;
fc1ce8cc 6126 }
a979ce91 6127 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6128 PerlMem_free(trndir);
6129 PerlMem_free(vmsdir);
a480973c
JM		 6130 return NULL;
6131 }
0e5ce2c7 6132 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6133 PerlMem_free(trndir);
6134 PerlMem_free(vmsdir);
a480973c 6135 return ret_chr;
4633a7c4
LW		 6136 }
6137 cp1++;
6138 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 6139 lastdir = strrchr(trndir,'/');
748a9306 6140 }
b8ffc8df 6141 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 6142 char * ret_chr;
61bb5906
CB		 6143 /* Ditto for specs that end in an MFD -- let the VMS code
6144 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 6145
6146 /* This should not happen any more. Allowing the fake /000000
6147 * in a UNIX pathname causes all sorts of problems when trying
6148 * to run in UNIX emulation. So the VMS to UNIX conversions
6149 * now remove the fake /000000 directories.
6150 */
6151
b8ffc8df 6152 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
df278665 6153 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
c5375c28
JM		 6154 PerlMem_free(trndir);
6155 PerlMem_free(vmsdir);
a480973c
JM		 6156 return NULL;
6157 }
a979ce91 6158 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6159 PerlMem_free(trndir);
6160 PerlMem_free(vmsdir);
a480973c
JM		 6161 return NULL;
6162 }
0e5ce2c7 6163 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6164 PerlMem_free(trndir);
6165 PerlMem_free(vmsdir);
a480973c 6166 return ret_chr;
61bb5906 6167 }
a0d0e21e 6168 else {
f7ddb74a 6169
b8ffc8df
RGS		 6170 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6171 !(lastdir = cp1 = strrchr(trndir,']')) &&
6172 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
f7ddb74a 6173
a979ce91
JM		 6174 cp2 = strrchr(cp1,'.');
6175 if (cp2) {
6176 int e_len, vs_len = 0;
6177 int is_dir = 0;
6178 char * cp3;
6179 cp3 = strchr(cp2,';');
6180 e_len = strlen(cp2);
6181 if (cp3) {
6182 vs_len = strlen(cp3);
6183 e_len = e_len - vs_len;
6184 }
6185 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6186 if (!is_dir) {
6187 if (!decc_efs_charset) {
6188 /* If this is not EFS, then not a directory */
6189 PerlMem_free(trndir);
6190 PerlMem_free(vmsdir);
6191 set_errno(ENOTDIR);
6192 set_vaxc_errno(RMS$_DIR);
6193 return NULL;
6194 }
6195 } else {
6196 /* Ok, here we have an issue, technically if a .dir shows */
6197 /* from inside a directory, then we should treat it as */
6198 /* xxx^.dir.dir. But we do not have that context at this */
6199 /* point unless this is totally restructured, so we remove */
6200 /* The .dir for now, and fix this better later */
6201 dirlen = cp2 - trndir;
6202 }
37769287
CB		 6203 if (decc_efs_charset && !strchr(trndir,'/')) {
6204 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
a9fac63d
CB		 6205 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6206
6207 for (; cp4 > cp1; cp4--) {
6208 if (*cp4 == '.') {
6209 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6210 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6211 *cp4 = '^';
6212 dirlen++;
6213 }
6214 }
6215 }
6216 }
a0d0e21e 6217 }
a979ce91 6218
748a9306 6219 }
f7ddb74a
JM		 6220
6221 retlen = dirlen + 6;
a979ce91
JM		 6222 memcpy(buf, trndir, dirlen);
6223 buf[dirlen] = '\0';
f7ddb74a 6224
a0d0e21e
LW		 6225 /* We've picked up everything up to the directory file name.
6226 Now just add the type and version, and we're set. */
839e16da 6227 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6e2e048b 6228 strcat(buf,".dir");
839e16da 6229 else
6e2e048b
CB		 6230 strcat(buf,".DIR");
6231 if (!decc_filename_unix_no_version)
6232 strcat(buf,";1");
c5375c28
JM		 6233 PerlMem_free(trndir);
6234 PerlMem_free(vmsdir);
a979ce91 6235 return buf;
a0d0e21e
LW		 6236 }
6237 else { /* VMS-style directory spec */
a480973c 6238
d584a1c6
JM		 6239 char *esa, *esal, term, *cp;
6240 char *my_esa;
6241 int my_esa_len;
4e0c9737 6242 unsigned long int cmplen, haslower = 0;
a0d0e21e 6243 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6244 rms_setup_nam(savnam);
6245 rms_setup_nam(dirnam);
6246
c11536f5 6247 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 6248 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6249 esal = NULL;
054a3baf 6250#if defined(NAML$C_MAXRSS)
c11536f5 6251 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6252 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6253#endif
a480973c
JM		 6254 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6255 rms_bind_fab_nam(dirfab, dirnam);
6256 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 6257 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 6258#ifdef NAM$M_NO_SHORT_UPCASE
6259 if (decc_efs_case_preserve)
a480973c 6260 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6261#endif
01b8edb6 6262
b8ffc8df 6263 for (cp = trndir; *cp; cp++)
01b8edb6 6264 if (islower(*cp)) { haslower = 1; break; }
a480973c 6265 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
a979ce91
JM		 6266 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6267 (dirfab.fab$l_sts == RMS$_DNF) ||
6268 (dirfab.fab$l_sts == RMS$_PRV)) {
6269 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6270 sts = sys$parse(&dirfab);
e518068a 6271 }
6272 if (!sts) {
c5375c28 6273 PerlMem_free(esa);
d584a1c6
JM		 6274 if (esal != NULL)
6275 PerlMem_free(esal);
c5375c28
JM		 6276 PerlMem_free(trndir);
6277 PerlMem_free(vmsdir);
748a9306
LW		 6278 set_errno(EVMSERR);
6279 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6280 return NULL;
6281 }
e518068a 6282 }
6283 else {
6284 savnam = dirnam;
a480973c
JM		 6285 /* Does the file really exist? */
6286 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6287 /* Yes; fake the fnb bits so we'll check type below */
a979ce91 6288 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6289 }
752635ea 6290 else { /* No; just work with potential name */
60e5a54b
CB		 6291 if (dirfab.fab$l_sts == RMS$_FNF
6292 || dirfab.fab$l_sts == RMS$_DNF
6293 || dirfab.fab$l_sts == RMS$_FND)
6294 dirnam = savnam;
752635ea 6295 else {
2623a4a6
JM		 6296 int fab_sts;
6297 fab_sts = dirfab.fab$l_sts;
6298 sts = rms_free_search_context(&dirfab);
c5375c28 6299 PerlMem_free(esa);
d584a1c6
JM		 6300 if (esal != NULL)
6301 PerlMem_free(esal);
c5375c28
JM		 6302 PerlMem_free(trndir);
6303 PerlMem_free(vmsdir);
2623a4a6 6304 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6305 return NULL;
6306 }
e518068a 6307 }
a0d0e21e 6308 }
d584a1c6
JM		 6309
6310 /* Make sure we are using the right buffer */
054a3baf 6311#if defined(NAML$C_MAXRSS)
d584a1c6
JM		 6312 if (esal != NULL) {
6313 my_esa = esal;
6314 my_esa_len = rms_nam_esll(dirnam);
6315 } else {
778e045f 6316#endif
d584a1c6
JM		 6317 my_esa = esa;
6318 my_esa_len = rms_nam_esl(dirnam);
054a3baf 6319#if defined(NAML$C_MAXRSS)
d584a1c6 6320 }
778e045f 6321#endif
d584a1c6 6322 my_esa[my_esa_len] = '\0';
a480973c 6323 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6324 cp1 = strchr(my_esa,']');
6325 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6326 if (cp1) { /* Should always be true */
d584a1c6
JM		 6327 my_esa_len -= cp1 - my_esa - 1;
6328 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6329 }
6330 }
a480973c 6331 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6332 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6333 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6334 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6335 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6336 sts = rms_free_search_context(&dirfab);
c5375c28 6337 PerlMem_free(esa);
d584a1c6
JM		 6338 if (esal != NULL)
6339 PerlMem_free(esal);
c5375c28
JM		 6340 PerlMem_free(trndir);
6341 PerlMem_free(vmsdir);
748a9306
LW		 6342 set_errno(ENOTDIR);
6343 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6344 return NULL;
6345 }
748a9306 6346 }
ae6d78fe 6347
a480973c 6348 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306 6349 /* They provided at least the name; we added the type, if necessary, */
a35dcc95 6350 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a480973c 6351 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6352 PerlMem_free(trndir);
6353 PerlMem_free(esa);
d584a1c6
JM		 6354 if (esal != NULL)
6355 PerlMem_free(esal);
c5375c28 6356 PerlMem_free(vmsdir);
a979ce91 6357 return buf;
748a9306 6358 }
c07a80fd 6359 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6360 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6361 *cp1 = '\0';
d584a1c6 6362 my_esa_len -= 9;
c07a80fd 6363 }
d584a1c6 6364 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6365 if (cp1 == NULL) { /* should never happen */
a480973c 6366 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6367 PerlMem_free(trndir);
6368 PerlMem_free(esa);
d584a1c6
JM		 6369 if (esal != NULL)
6370 PerlMem_free(esal);
c5375c28 6371 PerlMem_free(vmsdir);
752635ea
CB		 6372 return NULL;
6373 }
748a9306
LW		 6374 term = *cp1;
6375 *cp1 = '\0';
d584a1c6
JM		 6376 retlen = strlen(my_esa);
6377 cp1 = strrchr(my_esa,'.');
f7ddb74a 6378 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6379 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6380 while (cp1 != NULL) {
d584a1c6 6381 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6382 break;
6383 else {
6384 cp1--;
d584a1c6 6385 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6386 cp1--;
6387 }
d584a1c6 6388 if (cp1 == my_esa)
f7ddb74a
JM		 6389 cp1 = NULL;
6390 }
6391
6392 if ((cp1) != NULL) {
748a9306
LW		 6393 /* There's more than one directory in the path. Just roll back. */
6394 *cp1 = term;
a35dcc95 6395 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a0d0e21e
LW		 6396 }
6397 else {
a480973c 6398 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6399 /* Go back and expand rooted logical name */
a480973c 6400 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6401#ifdef NAM$M_NO_SHORT_UPCASE
6402 if (decc_efs_case_preserve)
a480973c 6403 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6404#endif
a480973c
JM		 6405 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6406 sts = rms_free_search_context(&dirfab);
c5375c28 6407 PerlMem_free(esa);
d584a1c6
JM		 6408 if (esal != NULL)
6409 PerlMem_free(esal);
c5375c28
JM		 6410 PerlMem_free(trndir);
6411 PerlMem_free(vmsdir);
748a9306
LW		 6412 set_errno(EVMSERR);
6413 set_vaxc_errno(dirfab.fab$l_sts);
6414 return NULL;
6415 }
d584a1c6
JM		 6416
6417 /* This changes the length of the string of course */
6418 if (esal != NULL) {
6419 my_esa_len = rms_nam_esll(dirnam);
6420 } else {
6421 my_esa_len = rms_nam_esl(dirnam);
6422 }
6423
6424 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
d584a1c6
JM		 6425 cp1 = strstr(my_esa,"][");
6426 if (!cp1) cp1 = strstr(my_esa,"]<");
6427 dirlen = cp1 - my_esa;
a979ce91 6428 memcpy(buf, my_esa, dirlen);
748a9306 6429 if (!strncmp(cp1+2,"000000]",7)) {
a979ce91 6430 buf[dirlen-1] = '\0';
657054d4 6431 /* fix-me Not full ODS-5, just extra dots in directories for now */
a979ce91
JM		 6432 cp1 = buf + dirlen - 1;
6433 while (cp1 > buf)
f7ddb74a
JM		 6434 {
6435 if (*cp1 == '[')
6436 break;
6437 if (*cp1 == '.') {
6438 if (*(cp1-1) != '^')
6439 break;
6440 }
6441 cp1--;
6442 }
4633a7c4
LW		 6443 if (*cp1 == '.') *cp1 = ']';
6444 else {
a979ce91 6445 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6446 memmove(cp1+1,"000000]",7);
4633a7c4 6447 }
748a9306
LW		 6448 }
6449 else {
a979ce91
JM		 6450 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6451 buf[retlen] = '\0';
748a9306 6452 /* Convert last '.' to ']' */
a979ce91 6453 cp1 = buf+retlen-1;
f7ddb74a
JM		 6454 while (*cp != '[') {
6455 cp1--;
6456 if (*cp1 == '.') {
6457 /* Do not trip on extra dots in ODS-5 directories */
a979ce91 6458 if ((cp1 == buf) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6459 break;
6460 }
6461 }
4633a7c4
LW		 6462 if (*cp1 == '.') *cp1 = ']';
6463 else {
a979ce91 6464 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6465 memmove(cp1+1,"000000]",7);
4633a7c4 6466 }
748a9306 6467 }
a0d0e21e 6468 }
748a9306 6469 else { /* This is a top-level dir. Add the MFD to the path. */
60e5a54b
CB		 6470 cp1 = strrchr(my_esa, ':');
6471 assert(cp1);
6472 memmove(buf, my_esa, cp1 - my_esa + 1);
6473 memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
6474 memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
6475 buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
a0d0e21e 6476 }
748a9306 6477 }
a480973c 6478 sts = rms_free_search_context(&dirfab);
748a9306 6479 /* We've set up the string up through the filename. Add the
a0d0e21e 6480 type and version, and we're done. */
a979ce91 6481 strcat(buf,".DIR;1");
01b8edb6 6482
6483 /* $PARSE may have upcased filespec, so convert output to lower
6484 * case if input contained any lowercase characters. */
a979ce91 6485 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
c5375c28
JM		 6486 PerlMem_free(trndir);
6487 PerlMem_free(esa);
d584a1c6
JM		 6488 if (esal != NULL)
6489 PerlMem_free(esal);
c5375c28 6490 PerlMem_free(vmsdir);
a979ce91 6491 return buf;
a0d0e21e 6492 }
a979ce91
JM		 6493} /* end of int_fileify_dirspec() */
6494
6495
6496/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 6497static char *
6498mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
a979ce91
JM		 6499{
6500 static char __fileify_retbuf[VMS_MAXRSS];
6501 char * fileified, *ret_spec, *ret_buf;
6502
6503 fileified = NULL;
6504 ret_buf = buf;
6505 if (ret_buf == NULL) {
6506 if (ts) {
6507 Newx(fileified, VMS_MAXRSS, char);
6508 if (fileified == NULL)
6509 _ckvmssts(SS$_INSFMEM);
6510 ret_buf = fileified;
6511 } else {
6512 ret_buf = __fileify_retbuf;
6513 }
6514 }
6515
6516 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6517
6518 if (ret_spec == NULL) {
6519 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6520 if (fileified)
6521 Safefree(fileified);
6522 }
6523
6524 return ret_spec;
a0d0e21e
LW		 6525} /* end of do_fileify_dirspec() */
6526/*}}}*/
a979ce91 6527
a0d0e21e 6528/* External entry points */
ce12d4b7
CB		 6529char *
6530Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6531{
6532 return do_fileify_dirspec(dir, buf, 0, NULL);
6533}
6534
6535char *
6536Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6537{
6538 return do_fileify_dirspec(dir, buf, 1, NULL);
6539}
6540
6541char *
6542Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6543{
6544 return do_fileify_dirspec(dir, buf, 0, utf8_fl);
6545}
6546
6547char *
6548Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6549{
6550 return do_fileify_dirspec(dir, buf, 1, utf8_fl);
6551}
6552
6553static char *
6554int_pathify_dirspec_simple(const char * dir, char * buf,
1fe570cc
JM		 6555 char * v_spec, int v_len, char * r_spec, int r_len,
6556 char * d_spec, int d_len, char * n_spec, int n_len,
ce12d4b7
CB		 6557 char * e_spec, int e_len, char * vs_spec, int vs_len)
6558{
1fe570cc
JM		 6559
6560 /* VMS specification - Try to do this the simple way */
6561 if ((v_len + r_len > 0) || (d_len > 0)) {
6562 int is_dir;
6563
6564 /* No name or extension component, already a directory */
6565 if ((n_len + e_len + vs_len) == 0) {
6566 strcpy(buf, dir);
6567 return buf;
6568 }
6569
6570 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6571 /* This results from catfile() being used instead of catdir() */
6572 /* So even though it should not work, we need to allow it */
6573
6574 /* If this is .DIR;1 then do a simple conversion */
6575 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6576 if (is_dir || (e_len == 0) && (d_len > 0)) {
6577 int len;
6578 len = v_len + r_len + d_len - 1;
6579 char dclose = d_spec[d_len - 1];
a35dcc95 6580 memcpy(buf, dir, len);
1fe570cc
JM		 6581 buf[len] = '.';
6582 len++;
a35dcc95 6583 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6584 len += n_len;
6585 buf[len] = dclose;
6586 buf[len + 1] = '\0';
6587 return buf;
6588 }
6589
6590#ifdef HAS_SYMLINK
6591 else if (d_len > 0) {
6592 /* In the olden days, a directory needed to have a .DIR */
6593 /* extension to be a valid directory, but now it could */
6594 /* be a symbolic link */
6595 int len;
6596 len = v_len + r_len + d_len - 1;
6597 char dclose = d_spec[d_len - 1];
a35dcc95 6598 memcpy(buf, dir, len);
1fe570cc
JM		 6599 buf[len] = '.';
6600 len++;
a35dcc95 6601 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6602 len += n_len;
6603 if (e_len > 0) {
6604 if (decc_efs_charset) {
07531283
CB		 6605 if (e_len == 4
6606 && (toupper(e_spec[1]) == 'D')
6607 && (toupper(e_spec[2]) == 'I')
6608 && (toupper(e_spec[3]) == 'R')) {
6609
6610 /* Corner case: directory spec with invalid version.
6611 * Valid would have followed is_dir path above.
6612 */
6613 SETERRNO(ENOTDIR, RMS$_DIR);
6614 return NULL;
6615 }
6616 else {
6617 buf[len] = '^';
6618 len++;
6619 memcpy(&buf[len], e_spec, e_len);
6620 len += e_len;
6621 }
6622 }
6623 else {
6624 SETERRNO(ENOTDIR, RMS$_DIR);
1fe570cc
JM		 6625 return NULL;
6626 }
6627 }
6628 buf[len] = dclose;
6629 buf[len + 1] = '\0';
6630 return buf;
6631 }
6632#else
6633 else {
6634 set_vaxc_errno(RMS$_DIR);
6635 set_errno(ENOTDIR);
6636 return NULL;
6637 }
6638#endif
6639 }
6640 set_vaxc_errno(RMS$_DIR);
6641 set_errno(ENOTDIR);
6642 return NULL;
6643}
6644
6645
6646/* Internal routine to make sure or convert a directory to be in a */
6647/* path specification. No utf8 flag because it is not changed or used */
ce12d4b7
CB		 6648static char *
6649int_pathify_dirspec(const char *dir, char *buf)
a0d0e21e 6650{
1fe570cc
JM		 6651 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6652 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6653 char * exp_spec, *ret_spec;
6654 char * trndir;
2d9f3838 6655 unsigned short int trnlnm_iter_count;
baf3cf9c 6656 STRLEN trnlen;
1fe570cc
JM		 6657 int need_to_lower;
6658
6659 if (vms_debug_fileify) {
6660 if (dir == NULL)
6661 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6662 else
6663 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6664 }
6665
6666 /* We may need to lower case the result if we translated */
6667 /* a logical name or got the current working directory */
6668 need_to_lower = 0;
a0d0e21e 6669
c07a80fd 6670 if (!dir || !*dir) {
1fe570cc
JM		 6671 set_errno(EINVAL);
6672 set_vaxc_errno(SS$_BADPARAM);
6673 return NULL;
c07a80fd 6674 }
6675
c11536f5 6676 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6677 if (trndir == NULL)
6678 _ckvmssts_noperl(SS$_INSFMEM);
c07a80fd 6679
1fe570cc
JM		 6680 /* If no directory specified use the current default */
6681 if (*dir)
a35dcc95 6682 my_strlcpy(trndir, dir, VMS_MAXRSS);
1fe570cc
JM		 6683 else {
6684 getcwd(trndir, VMS_MAXRSS - 1);
6685 need_to_lower = 1;
6686 }
6687
6688 /* now deal with bare names that could be logical names */
2d9f3838 6689 trnlnm_iter_count = 0;
93948341 6690 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1fe570cc
JM		 6691 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6692 trnlnm_iter_count++;
6693 need_to_lower = 1;
6694 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6695 break;
6696 trnlen = strlen(trndir);
6697
6698 /* Trap simple rooted lnms, and return lnm:[000000] */
6699 if (!strcmp(trndir+trnlen-2,".]")) {
a35dcc95 6700 my_strlcpy(buf, dir, VMS_MAXRSS);
1fe570cc
JM		 6701 strcat(buf, ":[000000]");
6702 PerlMem_free(trndir);
6703
6704 if (vms_debug_fileify) {
6705 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6706 }
6707 return buf;
6708 }
c07a80fd 6709 }
748a9306 6710
1fe570cc 6711 /* At this point we do not work with *dir, but the copy in *trndir */
b8ffc8df 6712
1fe570cc
JM		 6713 if (need_to_lower && !decc_efs_case_preserve) {
6714 /* Legacy mode, lower case the returned value */
6715 __mystrtolower(trndir);
6716 }
f7ddb74a 6717
1fe570cc
JM		 6718
6719 /* Some special cases, '..', '.' */
6720 sts = 0;
6721 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6722 /* Force UNIX filespec */
6723 sts = 1;
6724
6725 } else {
6726 /* Is this Unix or VMS format? */
6727 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6728 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6729 &e_len, &vs_spec, &vs_len);
6730 if (sts == 0) {
6731
6732 /* Just a filename? */
6733 if ((v_len + r_len + d_len) == 0) {
6734
6735 /* Now we have a problem, this could be Unix or VMS */
6736 /* We have to guess. .DIR usually means VMS */
6737
6738 /* In UNIX report mode, the .DIR extension is removed */
6739 /* if one shows up, it is for a non-directory or a directory */
6740 /* in EFS charset mode */
6741
6742 /* So if we are in Unix report mode, assume that this */
6743 /* is a relative Unix directory specification */
6744
6745 sts = 1;
6746 if (!decc_filename_unix_report && decc_efs_charset) {
6747 int is_dir;
6748 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6749
6750 if (is_dir) {
6751 /* Traditional mode, assume .DIR is directory */
6752 buf[0] = '[';
6753 buf[1] = '.';
a35dcc95 6754 memcpy(&buf[2], n_spec, n_len);
1fe570cc
JM		 6755 buf[n_len + 2] = ']';
6756 buf[n_len + 3] = '\0';
6757 PerlMem_free(trndir);
6758 if (vms_debug_fileify) {
6759 fprintf(stderr,
6760 "int_pathify_dirspec: buf = %s\n",
6761 buf);
6762 }
6763 return buf;
6764 }
6765 }
6766 }
a0d0e21e 6767 }
a0d0e21e 6768 }
1fe570cc
JM		 6769 if (sts == 0) {
6770 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6771 v_spec, v_len, r_spec, r_len,
6772 d_spec, d_len, n_spec, n_len,
6773 e_spec, e_len, vs_spec, vs_len);
a0d0e21e 6774
1fe570cc
JM		 6775 if (ret_spec != NULL) {
6776 PerlMem_free(trndir);
6777 if (vms_debug_fileify) {
6778 fprintf(stderr,
6779 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6780 }
6781 return ret_spec;
b7ae7a0d 6782 }
1fe570cc
JM		 6783
6784 /* Simple way did not work, which means that a logical name */
6785 /* was present for the directory specification. */
6786 /* Need to use an rmsexpand variant to decode it completely */
c11536f5 6787 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6788 if (exp_spec == NULL)
6789 _ckvmssts_noperl(SS$_INSFMEM);
6790
6791 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6792 if (ret_spec != NULL) {
6793 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6794 &r_spec, &r_len, &d_spec, &d_len,
6795 &n_spec, &n_len, &e_spec,
6796 &e_len, &vs_spec, &vs_len);
6797 if (sts == 0) {
6798 ret_spec = int_pathify_dirspec_simple(
6799 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6800 d_spec, d_len, n_spec, n_len,
6801 e_spec, e_len, vs_spec, vs_len);
6802
6803 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6804 /* Legacy mode, lower case the returned value */
6805 __mystrtolower(ret_spec);
6806 }
6807 } else {
6808 set_vaxc_errno(RMS$_DIR);
6809 set_errno(ENOTDIR);
6810 ret_spec = NULL;
6811 }
b7ae7a0d 6812 }
1fe570cc
JM		 6813 PerlMem_free(exp_spec);
6814 PerlMem_free(trndir);
6815 if (vms_debug_fileify) {
6816 if (ret_spec == NULL)
6817 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6818 else
6819 fprintf(stderr,
6820 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6821 }
6822 return ret_spec;
a480973c 6823
1fe570cc 6824 } else {
bd1901c6
CB		 6825 /* Unix specification, Could be trivial conversion, */
6826 /* but have to deal with trailing '.dir' or extra '.' */
1fe570cc 6827
bd1901c6
CB		 6828 char * lastdot;
6829 char * lastslash;
6830 int is_dir;
6831 STRLEN dir_len = strlen(trndir);
1fe570cc 6832
bd1901c6
CB		 6833 lastslash = strrchr(trndir, '/');
6834 if (lastslash == NULL)
6835 lastslash = trndir;
6836 else
6837 lastslash++;
6838
6839 lastdot = NULL;
6840
6841 /* '..' or '.' are valid directory components */
6842 is_dir = 0;
6843 if (lastslash[0] == '.') {
6844 if (lastslash[1] == '\0') {
6845 is_dir = 1;
6846 } else if (lastslash[1] == '.') {
6847 if (lastslash[2] == '\0') {
6848 is_dir = 1;
6849 } else {
6850 /* And finally allow '...' */
6851 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
1fe570cc 6852 is_dir = 1;
1fe570cc
JM		 6853 }
6854 }
6855 }
bd1901c6 6856 }
01b8edb6 6857
bd1901c6
CB		 6858 if (!is_dir) {
6859 lastdot = strrchr(lastslash, '.');
6860 }
6861 if (lastdot != NULL) {
6862 STRLEN e_len;
6863 /* '.dir' is discarded, and any other '.' is invalid */
6864 e_len = strlen(lastdot);
1fe570cc 6865
bd1901c6 6866 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
1fe570cc 6867
bd1901c6
CB		 6868 if (is_dir) {
6869 dir_len = dir_len - 4;
1fe570cc 6870 }
e518068a 6871 }
1fe570cc 6872
a35dcc95 6873 my_strlcpy(buf, trndir, VMS_MAXRSS);
1fe570cc
JM		 6874 if (buf[dir_len - 1] != '/') {
6875 buf[dir_len] = '/';
6876 buf[dir_len + 1] = '\0';
a0d0e21e 6877 }
1fe570cc
JM		 6878
6879 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6880 if (!decc_efs_charset) {
6881 int dir_start = 0;
6882 char * str = buf;
6883 if (str[0] == '.') {
6884 char * dots = str;
6885 int cnt = 1;
6886 while ((dots[cnt] == '.') && (cnt < 3))
6887 cnt++;
6888 if (cnt <= 3) {
6889 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6890 dir_start = 1;
6891 str += cnt;
6892 }
6893 }
6894 }
6895 for (; *str; ++str) {
6896 while (*str == '/') {
6897 dir_start = 1;
6898 *str++;
6899 }
6900 if (dir_start) {
6901
6902 /* Have to skip up to three dots which could be */
6903 /* directories, 3 dots being a VMS extension for Perl */
6904 char * dots = str;
6905 int cnt = 0;
6906 while ((dots[cnt] == '.') && (cnt < 3)) {
6907 cnt++;
6908 }
6909 if (dots[cnt] == '\0')
6910 break;
6911 if ((cnt > 1) && (dots[cnt] != '/')) {
6912 dir_start = 0;
6913 } else {
6914 str += cnt;
6915 }
6916
6917 /* too many dots? */
6918 if ((cnt == 0) || (cnt > 3)) {
6919 dir_start = 0;
6920 }
6921 }
6922 if (!dir_start && (*str == '.')) {
6923 *str = '_';
6924 }
6925 }
e518068a 6926 }
1fe570cc
JM		 6927 PerlMem_free(trndir);
6928 ret_spec = buf;
6929 if (vms_debug_fileify) {
6930 if (ret_spec == NULL)
6931 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6932 else
6933 fprintf(stderr,
6934 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
a0d0e21e 6935 }
1fe570cc
JM		 6936 return ret_spec;
6937 }
6938}
d584a1c6 6939
1fe570cc 6940/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
ce12d4b7
CB		 6941static char *
6942mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
1fe570cc
JM		 6943{
6944 static char __pathify_retbuf[VMS_MAXRSS];
6945 char * pathified, *ret_spec, *ret_buf;
6946
6947 pathified = NULL;
6948 ret_buf = buf;
6949 if (ret_buf == NULL) {
6950 if (ts) {
6951 Newx(pathified, VMS_MAXRSS, char);
6952 if (pathified == NULL)
6953 _ckvmssts(SS$_INSFMEM);
6954 ret_buf = pathified;
6955 } else {
6956 ret_buf = __pathify_retbuf;
6957 }
6958 }
d584a1c6 6959
1fe570cc
JM		 6960 ret_spec = int_pathify_dirspec(dir, ret_buf);
6961
6962 if (ret_spec == NULL) {
6963 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6964 if (pathified)
6965 Safefree(pathified);
a0d0e21e
LW		 6966 }
6967
1fe570cc
JM		 6968 return ret_spec;
6969
a0d0e21e 6970} /* end of do_pathify_dirspec() */
1fe570cc
JM		 6971
6972
a0d0e21e 6973/* External entry points */
ce12d4b7
CB		 6974char *
6975Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6976{
6977 return do_pathify_dirspec(dir, buf, 0, NULL);
6978}
6979
6980char *
6981Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6982{
6983 return do_pathify_dirspec(dir, buf, 1, NULL);
6984}
6985
6986char *
6987Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6988{
6989 return do_pathify_dirspec(dir, buf, 0, utf8_fl);
6990}
6991
6992char *
6993Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6994{
6995 return do_pathify_dirspec(dir, buf, 1, utf8_fl);
6996}
a0d0e21e 6997
0e5ce2c7
JM		 6998/* Internal tounixspec routine that does not use a thread context */
6999/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7000static char *
7001int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
a0d0e21e 7002{
0e5ce2c7 7003 char *dirend, *cp1, *cp3, *tmp;
b8ffc8df 7004 const char *cp2;
4e0c9737 7005 int dirlen;
2d9f3838 7006 unsigned short int trnlnm_iter_count;
b7ac4551 7007 int cmp_rslt, outchars_added;
360732b5
JM		 7008 if (utf8_fl != NULL)
7009 *utf8_fl = 0;
a0d0e21e 7010
0e5ce2c7
JM		 7011 if (vms_debug_fileify) {
7012 if (spec == NULL)
7013 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7014 else
7015 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7016 }
7017
7018
7019 if (spec == NULL) {
7020 set_errno(EINVAL);
7021 set_vaxc_errno(SS$_BADPARAM);
7022 return NULL;
7023 }
7024 if (strlen(spec) > (VMS_MAXRSS-1)) {
7025 set_errno(E2BIG);
7026 set_vaxc_errno(SS$_BUFFEROVF);
7027 return NULL;
e518068a 7028 }
f7ddb74a 7029
2497a41f
JM		 7030 /* New VMS specific format needs translation
7031 * glob passes filenames with trailing '\n' and expects this preserved.
7032 */
7033 if (decc_posix_compliant_pathnames) {
7034 if (strncmp(spec, "\"^UP^", 5) == 0) {
7035 char * uspec;
7036 char *tunix;
7037 int tunix_len;
7038 int nl_flag;
7039
c11536f5 7040 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7041 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 7042 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
2497a41f
JM		 7043 nl_flag = 0;
7044 if (tunix[tunix_len - 1] == '\n') {
7045 tunix[tunix_len - 1] = '\"';
7046 tunix[tunix_len] = '\0';
7047 tunix_len--;
7048 nl_flag = 1;
7049 }
7050 uspec = decc$translate_vms(tunix);
367e4b85 7051 PerlMem_free(tunix);
2497a41f 7052 if ((int)uspec > 0) {
a35dcc95 7053 my_strlcpy(rslt, uspec, VMS_MAXRSS);
2497a41f
JM		 7054 if (nl_flag) {
7055 strcat(rslt,"\n");
7056 }
7057 else {
7058 /* If we can not translate it, makemaker wants as-is */
a35dcc95 7059 my_strlcpy(rslt, spec, VMS_MAXRSS);
2497a41f
JM		 7060 }
7061 return rslt;
7062 }
7063 }
7064 }
7065
f7ddb74a
JM		 7066 cmp_rslt = 0; /* Presume VMS */
7067 cp1 = strchr(spec, '/');
7068 if (cp1 == NULL)
7069 cmp_rslt = 0;
7070
7071 /* Look for EFS ^/ */
7072 if (decc_efs_charset) {
7073 while (cp1 != NULL) {
7074 cp2 = cp1 - 1;
7075 if (*cp2 != '^') {
7076 /* Found illegal VMS, assume UNIX */
7077 cmp_rslt = 1;
7078 break;
7079 }
7080 cp1++;
7081 cp1 = strchr(cp1, '/');
7082 }
7083 }
7084
7085 /* Look for "." and ".." */
7086 if (decc_filename_unix_report) {
7087 if (spec[0] == '.') {
7088 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7089 cmp_rslt = 1;
7090 }
7091 else {
7092 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7093 cmp_rslt = 1;
7094 }
7095 }
7096 }
7097 }
b7ac4551
CB		 7098
7099 cp1 = rslt;
7100 cp2 = spec;
7101
7102 /* This is already UNIX or at least nothing VMS understands,
7103 * so all we can reasonably do is unescape extended chars.
7104 */
f7ddb74a 7105 if (cmp_rslt) {
b7ac4551
CB		 7106 while (*cp2) {
7107 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7108 cp1 += outchars_added;
7109 }
7110 *cp1 = '\0';
0e5ce2c7
JM		 7111 if (vms_debug_fileify) {
7112 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7113 }
a0d0e21e
LW		 7114 return rslt;
7115 }
7116
a0d0e21e
LW		 7117 dirend = strrchr(spec,']');
7118 if (dirend == NULL) dirend = strrchr(spec,'>');
7119 if (dirend == NULL) dirend = strchr(spec,':');
7120 if (dirend == NULL) {
09c9c44c 7121 while (*cp2) {
812e68ff
CB		 7122 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7123 cp1 += outchars_added;
09c9c44c
CB		 7124 }
7125 *cp1 = '\0';
0e5ce2c7
JM		 7126 if (vms_debug_fileify) {
7127 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7128 }
a0d0e21e
LW		 7129 return rslt;
7130 }
f7ddb74a
JM		 7131
7132 /* Special case 1 - sys$posix_root = / */
f7ddb74a
JM		 7133 if (!decc_disable_posix_root) {
7134 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7135 *cp1 = '/';
7136 cp1++;
7137 cp2 = cp2 + 15;
7138 }
7139 }
f7ddb74a
JM		 7140
7141 /* Special case 2 - Convert NLA0: to /dev/null */
f7ddb74a 7142 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
f7ddb74a
JM		 7143 if (cmp_rslt == 0) {
7144 strcpy(rslt, "/dev/null");
7145 cp1 = cp1 + 9;
7146 cp2 = cp2 + 5;
7147 if (spec[6] != '\0') {
07bee079 7148 cp1[9] = '/';
f7ddb74a
JM		 7149 cp1++;
7150 cp2++;
7151 }
7152 }
7153
7154 /* Also handle special case "SYS$SCRATCH:" */
f7ddb74a 7155 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
c11536f5 7156 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 7157 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 7158 if (cmp_rslt == 0) {
7159 int islnm;
7160
b8486b9d 7161 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
f7ddb74a
JM		 7162 if (!islnm) {
7163 strcpy(rslt, "/tmp");
7164 cp1 = cp1 + 4;
7165 cp2 = cp2 + 12;
7166 if (spec[12] != '\0') {
07bee079 7167 cp1[4] = '/';
f7ddb74a
JM		 7168 cp1++;
7169 cp2++;
7170 }
7171 }
7172 }
7173
a5f75d66 7174 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 7175 *(cp1++) = '/';
7176 }
7177 else { /* the VMS spec begins with directories */
7178 cp2++;
a5f75d66 7179 if (*cp2 == ']' || *cp2 == '>') {
f401ac15
CB		 7180 *(cp1++) = '.';
7181 *(cp1++) = '/';
a5f75d66 7182 }
f7ddb74a 7183 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 7184 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
367e4b85 7185 PerlMem_free(tmp);
0e5ce2c7
JM		 7186 if (vms_debug_fileify) {
7187 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7188 }
a0d0e21e
LW		 7189 return NULL;
7190 }
2d9f3838 7191 trnlnm_iter_count = 0;
a0d0e21e
LW		 7192 do {
7193 cp3 = tmp;
7194 while (*cp3 != ':' && *cp3) cp3++;
7195 *(cp3++) = '\0';
7196 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 7197 trnlnm_iter_count++;
7198 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 7199 } while (vmstrnenv(tmp,tmp,0,fildev,0));
0e5ce2c7 7200 cp1 = rslt;
f86702cc 7201 cp3 = tmp;
7202 *(cp1++) = '/';
7203 while (*cp3) {
7204 *(cp1++) = *(cp3++);
0e5ce2c7 7205 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
367e4b85 7206 PerlMem_free(tmp);
0e5ce2c7
JM		 7207 set_errno(ENAMETOOLONG);
7208 set_vaxc_errno(SS$_BUFFEROVF);
7209 if (vms_debug_fileify) {
7210 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7211 }
2f4077ca
JM		 7212 return NULL; /* No room */
7213 }
a0d0e21e 7214 }
f86702cc 7215 *(cp1++) = '/';
7216 }
f7ddb74a 7217 if ((*cp2 == '^')) {
812e68ff
CB		 7218 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7219 cp1 += outchars_added;
f7ddb74a 7220 }
f86702cc 7221 else if ( *cp2 == '.') {
7222 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7223 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7224 cp2 += 3;
7225 }
7226 else cp2++;
a0d0e21e 7227 }
a0d0e21e 7228 }
367e4b85 7229 PerlMem_free(tmp);
a0d0e21e 7230 for (; cp2 <= dirend; cp2++) {
f7ddb74a 7231 if ((*cp2 == '^')) {
9b2457c1
CB		 7232 /* EFS file escape -- unescape it. */
7233 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
7234 cp1 += outchars_added;
f7ddb74a 7235 }
9b2457c1 7236 else if (*cp2 == ':') {
a0d0e21e 7237 *(cp1++) = '/';
5ad5b34c 7238 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
a0d0e21e 7239 }
f86702cc 7240 else if (*cp2 == ']' || *cp2 == '>') {
7241 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7242 }
f7ddb74a 7243 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 7244 *(cp1++) = '/';
e518068a 7245 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7246 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7247 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7248 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7249 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7250 }
f86702cc 7251 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7252 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7253 cp2 += 2;
7254 }
a0d0e21e
LW		 7255 }
7256 else if (*cp2 == '-') {
7257 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7258 while (*cp2 == '-') {
7259 cp2++;
7260 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7261 }
7262 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
0e5ce2c7 7263 /* filespecs like */
01b8edb6 7264 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
0e5ce2c7
JM		 7265 if (vms_debug_fileify) {
7266 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7267 }
a0d0e21e
LW		 7268 return NULL;
7269 }
a0d0e21e
LW		 7270 }
7271 else *(cp1++) = *cp2;
7272 }
7273 else *(cp1++) = *cp2;
7274 }
0e5ce2c7 7275 /* Translate the rest of the filename. */
42cd432e 7276 while (*cp2) {
b7ac4551 7277 int dot_seen = 0;
0e5ce2c7
JM		 7278 switch(*cp2) {
7279 /* Fixme - for compatibility with the CRTL we should be removing */
7280 /* spaces from the file specifications, but this may show that */
7281 /* some tests that were appearing to pass are not really passing */
7282 case '%':
7283 cp2++;
7284 *(cp1++) = '?';
7285 break;
7286 case '^':
812e68ff
CB		 7287 cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
7288 cp1 += outchars_added;
0e5ce2c7
JM		 7289 break;
7290 case ';':
7291 if (decc_filename_unix_no_version) {
7292 /* Easy, drop the version */
7293 while (*cp2)
7294 cp2++;
7295 break;
7296 } else {
7297 /* Punt - passing the version as a dot will probably */
7298 /* break perl in weird ways, but so did passing */
7299 /* through the ; as a version. Follow the CRTL and */
7300 /* hope for the best. */
7301 cp2++;
7302 *(cp1++) = '.';
7303 }
7304 break;
7305 case '.':
7306 if (dot_seen) {
7307 /* We will need to fix this properly later */
7308 /* As Perl may be installed on an ODS-5 volume, but not */
7309 /* have the EFS_CHARSET enabled, it still may encounter */
7310 /* filenames with extra dots in them, and a precedent got */
7311 /* set which allowed them to work, that we will uphold here */
7312 /* If extra dots are present in a name and no ^ is on them */
7313 /* VMS assumes that the first one is the extension delimiter */
7314 /* the rest have an implied ^. */
7315
7316 /* this is also a conflict as the . is also a version */
7317 /* delimiter in VMS, */
7318
7319 *(cp1++) = *(cp2++);
7320 break;
7321 }
7322 dot_seen = 1;
7323 /* This is an extension */
7324 if (decc_readdir_dropdotnotype) {
7325 cp2++;
7326 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7327 /* Drop the dot for the extension */
7328 break;
7329 } else {
7330 *(cp1++) = '.';
7331 }
7332 break;
7333 }
7334 default:
7335 *(cp1++) = *(cp2++);
7336 }
42cd432e 7337 }
a0d0e21e
LW		 7338 *cp1 = '\0';
7339
f7ddb74a
JM		 7340 /* This still leaves /000000/ when working with a
7341 * VMS device root or concealed root.
7342 */
7343 {
ce12d4b7
CB		 7344 int ulen;
7345 char * zeros;
f7ddb74a
JM		 7346
7347 ulen = strlen(rslt);
7348
7349 /* Get rid of "000000/ in rooted filespecs */
7350 if (ulen > 7) {
7351 zeros = strstr(rslt, "/000000/");
7352 if (zeros != NULL) {
7353 int mlen;
7354 mlen = ulen - (zeros - rslt) - 7;
7355 memmove(zeros, &zeros[7], mlen);
7356 ulen = ulen - 7;
7357 rslt[ulen] = '\0';
7358 }
7359 }
7360 }
7361
0e5ce2c7
JM		 7362 if (vms_debug_fileify) {
7363 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7364 }
a0d0e21e
LW		 7365 return rslt;
7366
0e5ce2c7
JM		 7367} /* end of int_tounixspec() */
7368
7369
7370/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
ce12d4b7
CB		 7371static char *
7372mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
0e5ce2c7
JM		 7373{
7374 static char __tounixspec_retbuf[VMS_MAXRSS];
7375 char * unixspec, *ret_spec, *ret_buf;
7376
7377 unixspec = NULL;
7378 ret_buf = buf;
7379 if (ret_buf == NULL) {
7380 if (ts) {
7381 Newx(unixspec, VMS_MAXRSS, char);
7382 if (unixspec == NULL)
7383 _ckvmssts(SS$_INSFMEM);
7384 ret_buf = unixspec;
7385 } else {
7386 ret_buf = __tounixspec_retbuf;
7387 }
7388 }
7389
7390 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7391
7392 if (ret_spec == NULL) {
7393 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7394 if (unixspec)
7395 Safefree(unixspec);
7396 }
7397
7398 return ret_spec;
7399
a0d0e21e
LW		 7400} /* end of do_tounixspec() */
7401/*}}}*/
7402/* External entry points */
ce12d4b7
CB		 7403char *
7404Perl_tounixspec(pTHX_ const char *spec, char *buf)
7405{
7406 return do_tounixspec(spec, buf, 0, NULL);
7407}
7408
7409char *
7410Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7411{
7412 return do_tounixspec(spec,buf,1, NULL);
7413}
7414
7415char *
7416Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7417{
7418 return do_tounixspec(spec,buf,0, utf8_fl);
7419}
7420
7421char *
7422Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7423{
7424 return do_tounixspec(spec,buf,1, utf8_fl);
7425}
a0d0e21e 7426
360732b5
JM		 7427/*
7428 This procedure is used to identify if a path is based in either
7429 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7430 it returns the OpenVMS format directory for it.
7431
7432 It is expecting specifications of only '/' or '/xxxx/'
7433
7434 If a posix root does not exist, or 'xxxx' is not a directory
7435 in the posix root, it returns a failure.
7436
7437 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7438
7439 It is used only internally by posix_to_vmsspec_hardway().
7440 */
7441
ce12d4b7
CB		 7442static int
7443posix_root_to_vms(char *vmspath, int vmspath_len,
7444 const char *unixpath, const int * utf8_fl)
7445{
7446 int sts;
7447 struct FAB myfab = cc$rms_fab;
7448 rms_setup_nam(mynam);
7449 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7450 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7451 char * esa, * esal, * rsa, * rsal;
7452 int dir_flag;
7453 int unixlen;
7454
7455 dir_flag = 0;
7456 vmspath[0] = '\0';
7457 unixlen = strlen(unixpath);
7458 if (unixlen == 0) {
7459 return RMS$_FNF;
7460 }
360732b5
JM		 7461
7462#if __CRTL_VER >= 80200000
2497a41f 7463 /* If not a posix spec already, convert it */
360732b5
JM		 7464 if (decc_posix_compliant_pathnames) {
7465 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7466 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7467 }
7468 else {
7469 /* This is already a VMS specification, no conversion */
7470 unixlen--;
a35dcc95 7471 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
360732b5 7472 }
2497a41f 7473 }
360732b5
JM		 7474 else
7475#endif
7476 {
ce12d4b7
CB		 7477 int path_len;
7478 int i,j;
360732b5
JM		 7479
7480 /* Check to see if this is under the POSIX root */
7481 if (decc_disable_posix_root) {
7482 return RMS$_FNF;
7483 }
7484
7485 /* Skip leading / */
7486 if (unixpath[0] == '/') {
7487 unixpath++;
7488 unixlen--;
7489 }
7490
7491
7492 strcpy(vmspath,"SYS$POSIX_ROOT:");
7493
7494 /* If this is only the / , or blank, then... */
7495 if (unixpath[0] == '\0') {
7496 /* by definition, this is the answer */
7497 return SS$_NORMAL;
7498 }
7499
7500 /* Need to look up a directory */
7501 vmspath[15] = '[';
7502 vmspath[16] = '\0';
7503
7504 /* Copy and add '^' escape characters as needed */
7505 j = 16;
7506 i = 0;
7507 while (unixpath[i] != 0) {
7508 int k;
7509
7510 j += copy_expand_unix_filename_escape
7511 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7512 i += k;
7513 }
7514
7515 path_len = strlen(vmspath);
7516 if (vmspath[path_len - 1] == '/')
7517 path_len--;
7518 vmspath[path_len] = ']';
7519 path_len++;
7520 vmspath[path_len] = '\0';
7521
2497a41f
JM		 7522 }
7523 vmspath[vmspath_len] = 0;
7524 if (unixpath[unixlen - 1] == '/')
7525 dir_flag = 1;
c11536f5 7526 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7527 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7528 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 7529 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7530 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7531 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7532 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
d584a1c6
JM		 7533 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7534 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7535 rms_bind_fab_nam(myfab, mynam);
7536 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7537 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 7538 if (decc_efs_case_preserve)
7539 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 7540#ifdef NAML$M_OPEN_SPECIAL
2497a41f 7541 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 7542#endif
2497a41f
JM		 7543
7544 /* Set up the remaining naml fields */
7545 sts = sys$parse(&myfab);
7546
7547 /* It failed! Try again as a UNIX filespec */
7548 if (!(sts & 1)) {
d584a1c6 7549 PerlMem_free(esal);
367e4b85 7550 PerlMem_free(esa);
d584a1c6
JM		 7551 PerlMem_free(rsal);
7552 PerlMem_free(rsa);
2497a41f
JM		 7553 return sts;
7554 }
7555
7556 /* get the Device ID and the FID */
7557 sts = sys$search(&myfab);
d584a1c6
JM		 7558
7559 /* These are no longer needed */
7560 PerlMem_free(esa);
7561 PerlMem_free(rsal);
7562 PerlMem_free(rsa);
7563
2497a41f
JM		 7564 /* on any failure, returned the POSIX ^UP^ filespec */
7565 if (!(sts & 1)) {
d584a1c6 7566 PerlMem_free(esal);
2497a41f
JM		 7567 return sts;
7568 }
7569 specdsc.dsc$a_pointer = vmspath;
7570 specdsc.dsc$w_length = vmspath_len;
7571
7572 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7573 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7574 sts = lib$fid_to_name
7575 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7576
7577 /* on any failure, returned the POSIX ^UP^ filespec */
7578 if (!(sts & 1)) {
7579 /* This can happen if user does not have permission to read directories */
7580 if (strncmp(unixpath,"\"^UP^",5) != 0)
7581 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7582 else
a35dcc95 7583 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
2497a41f
JM		 7584 }
7585 else {
7586 vmspath[specdsc.dsc$w_length] = 0;
7587
7588 /* Are we expecting a directory? */
7589 if (dir_flag != 0) {
7590 int i;
7591 char *eptr;
7592
7593 eptr = NULL;
7594
7595 i = specdsc.dsc$w_length - 1;
7596 while (i > 0) {
7597 int zercnt;
7598 zercnt = 0;
7599 /* Version must be '1' */
7600 if (vmspath[i--] != '1')
7601 break;
7602 /* Version delimiter is one of ".;" */
7603 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7604 break;
7605 i--;
7606 if (vmspath[i--] != 'R')
7607 break;
7608 if (vmspath[i--] != 'I')
7609 break;
7610 if (vmspath[i--] != 'D')
7611 break;
7612 if (vmspath[i--] != '.')
7613 break;
7614 eptr = &vmspath[i+1];
7615 while (i > 0) {
7616 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7617 if (vmspath[i-1] != '^') {
7618 if (zercnt != 6) {
7619 *eptr = vmspath[i];
7620 eptr[1] = '\0';
7621 vmspath[i] = '.';
7622 break;
7623 }
7624 else {
7625 /* Get rid of 6 imaginary zero directory filename */
7626 vmspath[i+1] = '\0';
7627 }
7628 }
7629 }
7630 if (vmspath[i] == '0')
7631 zercnt++;
7632 else
7633 zercnt = 10;
7634 i--;
7635 }
7636 break;
7637 }
7638 }
7639 }
d584a1c6 7640 PerlMem_free(esal);
2497a41f
JM		 7641 return sts;
7642}
7643
360732b5
JM		 7644/* /dev/mumble needs to be handled special.
7645 /dev/null becomes NLA0:, And there is the potential for other stuff
7646 like /dev/tty which may need to be mapped to something.
7647*/
7648
7649static int
ce12d4b7 7650slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
360732b5 7651{
ce12d4b7
CB		 7652 char * nextslash;
7653 int len;
7654 int cmp;
360732b5
JM		 7655
7656 unixptr += 4;
7657 nextslash = strchr(unixptr, '/');
7658 len = strlen(unixptr);
7659 if (nextslash != NULL)
7660 len = nextslash - unixptr;
7661 cmp = strncmp("null", unixptr, 5);
7662 if (cmp == 0) {
7663 if (vmspath_len >= 6) {
7664 strcpy(vmspath, "_NLA0:");
7665 return SS$_NORMAL;
7666 }
7667 }
c5193628 7668 return 0;
360732b5
JM		 7669}
7670
7671
7672/* The built in routines do not understand perl's special needs, so
7673 doing a manual conversion from UNIX to VMS
7674
7675 If the utf8_fl is not null and points to a non-zero value, then
7676 treat 8 bit characters as UTF-8.
7677
7678 The sequence starting with '$(' and ending with ')' will be passed
7679 through with out interpretation instead of being escaped.
7680
7681 */
ce12d4b7
CB		 7682static int
7683posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
7684 int dir_flag, int * utf8_fl)
7685{
7686
7687 char *esa;
7688 const char *unixptr;
7689 const char *unixend;
7690 char *vmsptr;
7691 const char *lastslash;
7692 const char *lastdot;
7693 int unixlen;
7694 int vmslen;
7695 int dir_start;
7696 int dir_dot;
7697 int quoted;
7698 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7699 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7700
360732b5
JM		 7701 if (utf8_fl != NULL)
7702 *utf8_fl = 0;
2497a41f
JM		 7703
7704 unixptr = unixpath;
7705 dir_dot = 0;
7706
7707 /* Ignore leading "/" characters */
7708 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7709 unixptr++;
7710 }
7711 unixlen = strlen(unixptr);
7712
7713 /* Do nothing with blank paths */
7714 if (unixlen == 0) {
7715 vmspath[0] = '\0';
7716 return SS$_NORMAL;
7717 }
7718
360732b5
JM		 7719 quoted = 0;
7720 /* This could have a "^UP^ on the front */
7721 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7722 quoted = 1;
7723 unixptr+= 5;
7724 unixlen-= 5;
7725 }
7726
2497a41f
JM		 7727 lastslash = strrchr(unixptr,'/');
7728 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7729 unixend = strrchr(unixptr,'\"');
7730 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7731 unixend = unixptr + unixlen;
7732 }
2497a41f
JM		 7733
7734 /* last dot is last dot or past end of string */
7735 if (lastdot == NULL)
7736 lastdot = unixptr + unixlen;
7737
7738 /* if no directories, set last slash to beginning of string */
7739 if (lastslash == NULL) {
7740 lastslash = unixptr;
7741 }
7742 else {
7743 /* Watch out for trailing "." after last slash, still a directory */
7744 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7745 lastslash = unixptr + unixlen;
7746 }
7747
94ae10c0 7748 /* Watch out for trailing ".." after last slash, still a directory */
2497a41f
JM		 7749 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7750 lastslash = unixptr + unixlen;
7751 }
7752
7753 /* dots in directories are aways escaped */
7754 if (lastdot < lastslash)
7755 lastdot = unixptr + unixlen;
7756 }
7757
7758 /* if (unixptr < lastslash) then we are in a directory */
7759
7760 dir_start = 0;
2497a41f
JM		 7761
7762 vmsptr = vmspath;
7763 vmslen = 0;
7764
2497a41f
JM		 7765 /* Start with the UNIX path */
7766 if (*unixptr != '/') {
7767 /* relative paths */
360732b5
JM		 7768
7769 /* If allowing logical names on relative pathnames, then handle here */
7770 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7771 !decc_posix_compliant_pathnames) {
7772 char * nextslash;
7773 int seg_len;
7774 char * trn;
7775 int islnm;
7776
7777 /* Find the next slash */
7778 nextslash = strchr(unixptr,'/');
7779
c11536f5 7780 esa = (char *)PerlMem_malloc(vmspath_len);
360732b5
JM		 7781 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7782
c11536f5 7783 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
360732b5
JM		 7784 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7785
7786 if (nextslash != NULL) {
7787
7788 seg_len = nextslash - unixptr;
a35dcc95 7789 memcpy(esa, unixptr, seg_len);
360732b5
JM		 7790 esa[seg_len] = 0;
7791 }
7792 else {
a35dcc95 7793 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
360732b5
JM		 7794 }
7795 /* trnlnm(section) */
7796 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7797
7798 if (islnm) {
7799 /* Now fix up the directory */
7800
7801 /* Split up the path to find the components */
7802 sts = vms_split_path
7803 (trn,
7804 &v_spec,
7805 &v_len,
7806 &r_spec,
7807 &r_len,
7808 &d_spec,
7809 &d_len,
7810 &n_spec,
7811 &n_len,
7812 &e_spec,
7813 &e_len,
7814 &vs_spec,
7815 &vs_len);
7816
7817 while (sts == 0) {
360732b5
JM		 7818 int cmp;
7819
7820 /* A logical name must be a directory or the full
7821 specification. It is only a full specification if
7822 it is the only component */
7823 if ((unixptr[seg_len] == '\0') ||
7824 (unixptr[seg_len+1] == '\0')) {
7825
7826 /* Is a directory being required? */
7827 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7828 /* Not a logical name */
7829 break;
7830 }
7831
7832
7833 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7834 /* This must be a directory */
7835 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
a35dcc95 7836 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
360732b5
JM		 7837 vmsptr[vmslen] = ':';
7838 vmslen++;
7839 vmsptr[vmslen] = '\0';
7840 return SS$_NORMAL;
7841 }
7842 }
7843
7844 }
7845
7846
7847 /* must be dev/directory - ignore version */
7848 if ((n_len + e_len) != 0)
7849 break;
7850
7851 /* transfer the volume */
7852 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
a35dcc95 7853 memcpy(vmsptr, v_spec, v_len);
360732b5
JM		 7854 vmsptr += v_len;
7855 vmsptr[0] = '\0';
7856 vmslen += v_len;
7857 }
7858
7859 /* unroot the rooted directory */
7860 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7861 r_spec[0] = '[';
7862 r_spec[r_len - 1] = ']';
7863
7864 /* This should not be there, but nothing is perfect */
7865 if (r_len > 9) {
7866 cmp = strcmp(&r_spec[1], "000000.");
7867 if (cmp == 0) {
7868 r_spec += 7;
7869 r_spec[7] = '[';
7870 r_len -= 7;
7871 if (r_len == 2)
7872 r_len = 0;
7873 }
7874 }
7875 if (r_len > 0) {
a35dcc95 7876 memcpy(vmsptr, r_spec, r_len);
360732b5
JM		 7877 vmsptr += r_len;
7878 vmslen += r_len;
7879 vmsptr[0] = '\0';
7880 }
7881 }
7882 /* Bring over the directory. */
7883 if ((d_len > 0) &&
7884 ((d_len + vmslen) < vmspath_len)) {
7885 d_spec[0] = '[';
7886 d_spec[d_len - 1] = ']';
7887 if (d_len > 9) {
7888 cmp = strcmp(&d_spec[1], "000000.");
7889 if (cmp == 0) {
7890 d_spec += 7;
7891 d_spec[7] = '[';
7892 d_len -= 7;
7893 if (d_len == 2)
7894 d_len = 0;
7895 }
7896 }
7897
7898 if (r_len > 0) {
7899 /* Remove the redundant root */
7900 if (r_len > 0) {
7901 /* remove the ][ */
7902 vmsptr--;
7903 vmslen--;
7904 d_spec++;
7905 d_len--;
7906 }
a35dcc95 7907 memcpy(vmsptr, d_spec, d_len);
360732b5
JM		 7908 vmsptr += d_len;
7909 vmslen += d_len;
7910 vmsptr[0] = '\0';
7911 }
7912 }
7913 break;
7914 }
7915 }
7916
7917 PerlMem_free(esa);
7918 PerlMem_free(trn);
7919 }
7920
2497a41f
JM		 7921 if (lastslash > unixptr) {
7922 int dotdir_seen;
7923
7924 /* skip leading ./ */
7925 dotdir_seen = 0;
7926 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7927 dotdir_seen = 1;
7928 unixptr++;
7929 unixptr++;
7930 }
7931
7932 /* Are we still in a directory? */
7933 if (unixptr <= lastslash) {
7934 *vmsptr++ = '[';
7935 vmslen = 1;
7936 dir_start = 1;
7937
7938 /* if not backing up, then it is relative forward. */
7939 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7940 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7941 *vmsptr++ = '.';
7942 vmslen++;
7943 dir_dot = 1;
360732b5 7944 }
2497a41f
JM		 7945 }
7946 else {
7947 if (dotdir_seen) {
7948 /* Perl wants an empty directory here to tell the difference
94ae10c0 7949 * between a DCL command and a filename
2497a41f
JM		 7950 */
7951 *vmsptr++ = '[';
7952 *vmsptr++ = ']';
7953 vmslen = 2;
7954 }
7955 }
7956 }
7957 else {
7958 /* Handle two special files . and .. */
7959 if (unixptr[0] == '.') {
360732b5 7960 if (&unixptr[1] == unixend) {
2497a41f
JM		 7961 *vmsptr++ = '[';
7962 *vmsptr++ = ']';
7963 vmslen += 2;
7964 *vmsptr++ = '\0';
7965 return SS$_NORMAL;
7966 }
360732b5 7967 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7968 *vmsptr++ = '[';
7969 *vmsptr++ = '-';
7970 *vmsptr++ = ']';
7971 vmslen += 3;
7972 *vmsptr++ = '\0';
7973 return SS$_NORMAL;
7974 }
7975 }
7976 }
7977 }
7978 else { /* Absolute PATH handling */
7979 int sts;
7980 char * nextslash;
7981 int seg_len;
7982 /* Need to find out where root is */
7983
7984 /* In theory, this procedure should never get an absolute POSIX pathname
7985 * that can not be found on the POSIX root.
7986 * In practice, that can not be relied on, and things will show up
7987 * here that are a VMS device name or concealed logical name instead.
7988 * So to make things work, this procedure must be tolerant.
7989 */
c11536f5 7990 esa = (char *)PerlMem_malloc(vmspath_len);
c5375c28 7991 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7992
7993 sts = SS$_NORMAL;
7994 nextslash = strchr(&unixptr[1],'/');
7995 seg_len = 0;
7996 if (nextslash != NULL) {
db4c2905 7997 int cmp;
2497a41f 7998 seg_len = nextslash - &unixptr[1];
db4c2905 7999 my_strlcpy(vmspath, unixptr, seg_len + 2);
360732b5
JM		 8000 cmp = 1;
8001 if (seg_len == 3) {
8002 cmp = strncmp(vmspath, "dev", 4);
8003 if (cmp == 0) {
8004 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
07bee079 8005 if (sts == SS$_NORMAL)
360732b5
JM		 8006 return SS$_NORMAL;
8007 }
8008 }
8009 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 8010 }
8011
360732b5 8012 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 8013 /* This is verified to be a real path */
8014
360732b5
JM		 8015 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8016 if ($VMS_STATUS_SUCCESS(sts)) {
a35dcc95 8017 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
360732b5
JM		 8018 vmsptr = vmspath + vmslen;
8019 unixptr++;
8020 if (unixptr < lastslash) {
8021 char * rptr;
8022 vmsptr--;
8023 *vmsptr++ = '.';
8024 dir_start = 1;
8025 dir_dot = 1;
8026 if (vmslen > 7) {
8027 int cmp;
8028 rptr = vmsptr - 7;
8029 cmp = strcmp(rptr,"000000.");
8030 if (cmp == 0) {
8031 vmslen -= 7;
8032 vmsptr -= 7;
8033 vmsptr[1] = '\0';
8034 } /* removing 6 zeros */
8035 } /* vmslen < 7, no 6 zeros possible */
8036 } /* Not in a directory */
8037 } /* Posix root found */
8038 else {
8039 /* No posix root, fall back to default directory */
8040 strcpy(vmspath, "SYS$DISK:[");
8041 vmsptr = &vmspath[10];
8042 vmslen = 10;
8043 if (unixptr > lastslash) {
8044 *vmsptr = ']';
8045 vmsptr++;
8046 vmslen++;
8047 }
8048 else {
8049 dir_start = 1;
8050 }
8051 }
2497a41f
JM		 8052 } /* end of verified real path handling */
8053 else {
8054 int add_6zero;
8055 int islnm;
8056
8057 /* Ok, we have a device or a concealed root that is not in POSIX
8058 * or we have garbage. Make the best of it.
8059 */
8060
8061 /* Posix to VMS destroyed this, so copy it again */
db4c2905
CB		 8062 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
8063 vmslen = strlen(vmspath); /* We know we're truncating. */
2497a41f
JM		 8064 vmsptr = &vmsptr[vmslen];
8065 islnm = 0;
8066
8067 /* Now do we need to add the fake 6 zero directory to it? */
8068 add_6zero = 1;
8069 if ((*lastslash == '/') && (nextslash < lastslash)) {
8070 /* No there is another directory */
8071 add_6zero = 0;
8072 }
8073 else {
8074 int trnend;
360732b5 8075 int cmp;
2497a41f
JM		 8076
8077 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 8078 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 8079
8080 if (!islnm && !decc_posix_compliant_pathnames) {
8081
8082 cmp = strncmp("bin", vmspath, 4);
8083 if (cmp == 0) {
8084 /* bin => SYS$SYSTEM: */
8085 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8086 }
8087 else {
8088 /* tmp => SYS$SCRATCH: */
8089 cmp = strncmp("tmp", vmspath, 4);
8090 if (cmp == 0) {
8091 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8092 }
8093 }
8094 }
8095
7ded3206 8096 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 8097
8098 /* if this was a logical name, ']' or '>' must be present */
8099 /* if not a logical name, then assume a device and hope. */
8100 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8101
8102 /* if log name and trailing '.' then rooted - treat as device */
8103 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8104
8105 /* Fix me, if not a logical name, a device lookup should be
8106 * done to see if the device is file structured. If the device
8107 * is not file structured, the 6 zeros should not be put on.
8108 *
8109 * As it is, perl is occasionally looking for dev:[000000]tty.
8110 * which looks a little strange.
360732b5
JM		 8111 *
8112 * Not that easy to detect as "/dev" may be file structured with
8113 * special device files.
2497a41f
JM		 8114 */
8115
30e68285 8116 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
360732b5 8117 (&nextslash[1] == unixend)) {
2497a41f
JM		 8118 /* No real directory present */
8119 add_6zero = 1;
8120 }
8121 }
8122
8123 /* Put the device delimiter on */
8124 *vmsptr++ = ':';
8125 vmslen++;
8126 unixptr = nextslash;
8127 unixptr++;
8128
8129 /* Start directory if needed */
8130 if (!islnm || add_6zero) {
8131 *vmsptr++ = '[';
8132 vmslen++;
8133 dir_start = 1;
8134 }
8135
8136 /* add fake 000000] if needed */
8137 if (add_6zero) {
8138 *vmsptr++ = '0';
8139 *vmsptr++ = '0';
8140 *vmsptr++ = '0';
8141 *vmsptr++ = '0';
8142 *vmsptr++ = '0';
8143 *vmsptr++ = '0';
8144 *vmsptr++ = ']';
8145 vmslen += 7;
8146 dir_start = 0;
8147 }
8148
8149 } /* non-POSIX translation */
367e4b85 8150 PerlMem_free(esa);
2497a41f
JM		 8151 } /* End of relative/absolute path handling */
8152
360732b5 8153 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
ce12d4b7
CB		 8154 int dash_flag;
8155 int in_cnt;
8156 int out_cnt;
2497a41f
JM		 8157
8158 dash_flag = 0;
8159
8160 if (dir_start != 0) {
8161
8162 /* First characters in a directory are handled special */
8163 while ((*unixptr == '/') ||
8164 ((*unixptr == '.') &&
360732b5
JM		 8165 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8166 (&unixptr[1]==unixend)))) {
2497a41f
JM		 8167 int loop_flag;
8168
8169 loop_flag = 0;
8170
8171 /* Skip redundant / in specification */
8172 while ((*unixptr == '/') && (dir_start != 0)) {
8173 loop_flag = 1;
8174 unixptr++;
8175 if (unixptr == lastslash)
8176 break;
8177 }
8178 if (unixptr == lastslash)
8179 break;
8180
8181 /* Skip redundant ./ characters */
8182 while ((*unixptr == '.') &&
360732b5 8183 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 8184 loop_flag = 1;
8185 unixptr++;
8186 if (unixptr == lastslash)
8187 break;
8188 if (*unixptr == '/')
8189 unixptr++;
8190 }
8191 if (unixptr == lastslash)
8192 break;
8193
8194 /* Skip redundant ../ characters */
8195 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 8196 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 8197 /* Set the backing up flag */
8198 loop_flag = 1;
8199 dir_dot = 0;
8200 dash_flag = 1;
8201 *vmsptr++ = '-';
8202 vmslen++;
8203 unixptr++; /* first . */
8204 unixptr++; /* second . */
8205 if (unixptr == lastslash)
8206 break;
8207 if (*unixptr == '/') /* The slash */
8208 unixptr++;
8209 }
8210 if (unixptr == lastslash)
8211 break;
8212
8213 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8214 /* Not needed when VMS is pretending to be UNIX. */
8215
8216 /* Is this loop stuck because of too many dots? */
8217 if (loop_flag == 0) {
8218 /* Exit the loop and pass the rest through */
8219 break;
8220 }
8221 }
8222
8223 /* Are we done with directories yet? */
8224 if (unixptr >= lastslash) {
8225
8226 /* Watch out for trailing dots */
8227 if (dir_dot != 0) {
8228 vmslen --;
8229 vmsptr--;
8230 }
8231 *vmsptr++ = ']';
8232 vmslen++;
8233 dash_flag = 0;
8234 dir_start = 0;
8235 if (*unixptr == '/')
8236 unixptr++;
8237 }
8238 else {
8239 /* Have we stopped backing up? */
8240 if (dash_flag) {
8241 *vmsptr++ = '.';
8242 vmslen++;
8243 dash_flag = 0;
8244 /* dir_start continues to be = 1 */
8245 }
8246 if (*unixptr == '-') {
8247 *vmsptr++ = '^';
8248 *vmsptr++ = *unixptr++;
8249 vmslen += 2;
8250 dir_start = 0;
8251
8252 /* Now are we done with directories yet? */
8253 if (unixptr >= lastslash) {
8254
8255 /* Watch out for trailing dots */
8256 if (dir_dot != 0) {
8257 vmslen --;
8258 vmsptr--;
8259 }
8260
8261 *vmsptr++ = ']';
8262 vmslen++;
8263 dash_flag = 0;
8264 dir_start = 0;
8265 }
8266 }
8267 }
8268 }
8269
8270 /* All done? */
360732b5 8271 if (unixptr >= unixend)
2497a41f
JM		 8272 break;
8273
8274 /* Normal characters - More EFS work probably needed */
8275 dir_start = 0;
8276 dir_dot = 0;
8277
8278 switch(*unixptr) {
8279 case '/':
8280 /* remove multiple / */
8281 while (unixptr[1] == '/') {
8282 unixptr++;
8283 }
8284 if (unixptr == lastslash) {
8285 /* Watch out for trailing dots */
8286 if (dir_dot != 0) {
8287 vmslen --;
8288 vmsptr--;
8289 }
8290 *vmsptr++ = ']';
8291 }
8292 else {
8293 dir_start = 1;
8294 *vmsptr++ = '.';
8295 dir_dot = 1;
8296
8297 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8298 /* Not needed when VMS is pretending to be UNIX. */
8299
8300 }
8301 dash_flag = 0;
360732b5 8302 if (unixptr != unixend)
2497a41f
JM		 8303 unixptr++;
8304 vmslen++;
8305 break;
2497a41f 8306 case '.':
360732b5
JM		 8307 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8308 (&unixptr[1] == unixend)) {
2497a41f
JM		 8309 *vmsptr++ = '^';
8310 *vmsptr++ = '.';
8311 vmslen += 2;
8312 unixptr++;
8313
8314 /* trailing dot ==> '^..' on VMS */
360732b5 8315 if (unixptr == unixend) {
2497a41f
JM		 8316 *vmsptr++ = '.';
8317 vmslen++;
360732b5 8318 unixptr++;
2497a41f 8319 }
2497a41f
JM		 8320 break;
8321 }
360732b5 8322
2497a41f 8323 *vmsptr++ = *unixptr++;
360732b5
JM		 8324 vmslen ++;
8325 break;
8326 case '"':
8327 if (quoted && (&unixptr[1] == unixend)) {
8328 unixptr++;
8329 break;
8330 }
8331 in_cnt = copy_expand_unix_filename_escape
8332 (vmsptr, unixptr, &out_cnt, utf8_fl);
8333 vmsptr += out_cnt;
8334 unixptr += in_cnt;
2497a41f
JM		 8335 break;
8336 case '~':
8337 case ';':
8338 case '\\':
360732b5
JM		 8339 case '?':
8340 case ' ':
2497a41f 8341 default:
360732b5
JM		 8342 in_cnt = copy_expand_unix_filename_escape
8343 (vmsptr, unixptr, &out_cnt, utf8_fl);
8344 vmsptr += out_cnt;
8345 unixptr += in_cnt;
2497a41f
JM		 8346 break;
8347 }
8348 }
8349
8350 /* Make sure directory is closed */
8351 if (unixptr == lastslash) {
8352 char *vmsptr2;
8353 vmsptr2 = vmsptr - 1;
8354
8355 if (*vmsptr2 != ']') {
8356 *vmsptr2--;
8357
8358 /* directories do not end in a dot bracket */
8359 if (*vmsptr2 == '.') {
8360 vmsptr2--;
8361
8362 /* ^. is allowed */
8363 if (*vmsptr2 != '^') {
8364 vmsptr--; /* back up over the dot */
8365 }
8366 }
8367 *vmsptr++ = ']';
8368 }
8369 }
8370 else {
8371 char *vmsptr2;
8372 /* Add a trailing dot if a file with no extension */
8373 vmsptr2 = vmsptr - 1;
360732b5
JM		 8374 if ((vmslen > 1) &&
8375 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
30e68285 8376 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
2497a41f
JM		 8377 *vmsptr++ = '.';
8378 vmslen++;
8379 }
8380 }
8381
8382 *vmsptr = '\0';
8383 return SS$_NORMAL;
8384}
2497a41f 8385
b7bc7afb
CB		 8386/* A convenience macro for copying dots in filenames and escaping
8387 * them when they haven't already been escaped, with guards to
8388 * avoid checking before the start of the buffer or advancing
8389 * beyond the end of it (allowing room for the NUL terminator).
c1abd561 8390 */
b7bc7afb 8391#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
c1abd561
CB		 8392 if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
8393 || ((vmsefsdot) == (vmsefsbuf))) \
b7bc7afb 8394 && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
c1abd561
CB		 8395 ) { \
8396 *((vmsefsdot)++) = '^'; \
c1abd561 8397 } \
b7bc7afb
CB		 8398 if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
8399 *((vmsefsdot)++) = '.'; \
c1abd561 8400} STMT_END
df278665 8401
360732b5 8402/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8403static char *
8404int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
8405{
df278665 8406 char *dirend;
f7ddb74a 8407 char *lastdot;
eb578fdb 8408 char *cp1;
b8ffc8df 8409 const char *cp2;
e518068a 8410 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 8411 int rslt_len;
8412 int no_type_seen;
360732b5
JM		 8413 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8414 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 8415
df278665
JM		 8416 if (vms_debug_fileify) {
8417 if (path == NULL)
8418 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8419 else
8420 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8421 }
8422
8423 if (path == NULL) {
8424 /* If we fail, we should be setting errno */
8425 set_errno(EINVAL);
8426 set_vaxc_errno(SS$_BADPARAM);
8427 return NULL;
8428 }
4d743a9b 8429 rslt_len = VMS_MAXRSS-1;
360732b5
JM		 8430
8431 /* '.' and '..' are "[]" and "[-]" for a quick check */
8432 if (path[0] == '.') {
8433 if (path[1] == '\0') {
8434 strcpy(rslt,"[]");
8435 if (utf8_flag != NULL)
8436 *utf8_flag = 0;
8437 return rslt;
8438 }
8439 else {
8440 if (path[1] == '.' && path[2] == '\0') {
8441 strcpy(rslt,"[-]");
8442 if (utf8_flag != NULL)
8443 *utf8_flag = 0;
8444 return rslt;
8445 }
8446 }
a0d0e21e 8447 }
f7ddb74a 8448
2497a41f
JM		 8449 /* Posix specifications are now a native VMS format */
8450 /*--------------------------------------------------*/
054a3baf 8451#if __CRTL_VER >= 80200000
2497a41f
JM		 8452 if (decc_posix_compliant_pathnames) {
8453 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 8454 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 8455 return rslt;
8456 }
8457 }
8458#endif
8459
360732b5
JM		 8460 /* This is really the only way to see if this is already in VMS format */
8461 sts = vms_split_path
8462 (path,
8463 &v_spec,
8464 &v_len,
8465 &r_spec,
8466 &r_len,
8467 &d_spec,
8468 &d_len,
8469 &n_spec,
8470 &n_len,
8471 &e_spec,
8472 &e_len,
8473 &vs_spec,
8474 &vs_len);
8475 if (sts == 0) {
8476 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8477 replacement, because the above parse just took care of most of
8478 what is needed to do vmspath when the specification is already
8479 in VMS format.
8480
8481 And if it is not already, it is easier to do the conversion as
8482 part of this routine than to call this routine and then work on
8483 the result.
8484 */
2497a41f 8485
360732b5
JM		 8486 /* If VMS punctuation was found, it is already VMS format */
8487 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8488 if (utf8_flag != NULL)
8489 *utf8_flag = 0;
a35dcc95 8490 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8491 if (vms_debug_fileify) {
8492 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8493 }
360732b5
JM		 8494 return rslt;
8495 }
8496 /* Now, what to do with trailing "." cases where there is no
8497 extension? If this is a UNIX specification, and EFS characters
8498 are enabled, then the trailing "." should be converted to a "^.".
8499 But if this was already a VMS specification, then it should be
8500 left alone.
2497a41f 8501
360732b5
JM		 8502 So in the case of ambiguity, leave the specification alone.
8503 */
2497a41f 8504
2497a41f 8505
360732b5
JM		 8506 /* If there is a possibility of UTF8, then if any UTF8 characters
8507 are present, then they must be converted to VTF-7
8508 */
8509 if (utf8_flag != NULL)
8510 *utf8_flag = 0;
a35dcc95 8511 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8512 if (vms_debug_fileify) {
8513 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8514 }
2497a41f
JM		 8515 return rslt;
8516 }
8517
360732b5
JM		 8518 dirend = strrchr(path,'/');
8519
8520 if (dirend == NULL) {
db2284bc
CB		 8521 /* If we get here with no Unix directory delimiters, then this is an
8522 * ambiguous file specification, such as a Unix glob specification, a
8523 * shell or make macro, or a filespec that would be valid except for
8524 * unescaped extended characters. The safest thing if it's a macro
8525 * is to pass it through as-is.
360732b5 8526 */
db2284bc
CB		 8527 if (strstr(path, "$(")) {
8528 my_strlcpy(rslt, path, VMS_MAXRSS);
8529 if (vms_debug_fileify) {
8530 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8531 }
8532 return rslt;
df278665 8533 }
db2284bc 8534 hasdir = 0;
360732b5 8535 }
e645f6f8 8536 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 8537 if (!*(dirend+2)) dirend +=2;
8538 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
06099f79 8539 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
748a9306 8540 }
f7ddb74a 8541
a0d0e21e
LW		 8542 cp1 = rslt;
8543 cp2 = path;
f7ddb74a 8544 lastdot = strrchr(cp2,'.');
a0d0e21e 8545 if (*cp2 == '/') {
a480973c 8546 char *trndev;
e518068a 8547 int islnm, rooted;
8548 STRLEN trnend;
8549
b7ae7a0d 8550 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 8551 if (!*(cp2+1)) {
f7ddb74a
JM		 8552 if (decc_disable_posix_root) {
8553 strcpy(rslt,"sys$disk:[000000]");
8554 }
8555 else {
8556 strcpy(rslt,"sys$posix_root:[000000]");
8557 }
360732b5
JM		 8558 if (utf8_flag != NULL)
8559 *utf8_flag = 0;
df278665
JM		 8560 if (vms_debug_fileify) {
8561 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8562 }
61bb5906
CB		 8563 return rslt;
8564 }
a0d0e21e 8565 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 8566 *cp1 = '\0';
c11536f5 8567 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 8568 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
b8486b9d 8569 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8570
8571 /* DECC special handling */
8572 if (!islnm) {
8573 if (strcmp(rslt,"bin") == 0) {
8574 strcpy(rslt,"sys$system");
8575 cp1 = rslt + 10;
8576 *cp1 = 0;
b8486b9d 8577 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8578 }
8579 else if (strcmp(rslt,"tmp") == 0) {
8580 strcpy(rslt,"sys$scratch");
8581 cp1 = rslt + 11;
8582 *cp1 = 0;
b8486b9d 8583 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8584 }
8585 else if (!decc_disable_posix_root) {
8586 strcpy(rslt, "sys$posix_root");
b8486b9d 8587 cp1 = rslt + 14;
f7ddb74a
JM		 8588 *cp1 = 0;
8589 cp2 = path;
8590 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
b8486b9d 8591 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8592 }
8593 else if (strcmp(rslt,"dev") == 0) {
8594 if (strncmp(cp2,"/null", 5) == 0) {
8595 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8596 strcpy(rslt,"NLA0");
8597 cp1 = rslt + 4;
8598 *cp1 = 0;
8599 cp2 = cp2 + 5;
b8486b9d 8600 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8601 }
8602 }
8603 }
8604 }
8605
e518068a 8606 trnend = islnm ? strlen(trndev) - 1 : 0;
8607 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8608 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8609 /* If the first element of the path is a logical name, determine
8610 * whether it has to be translated so we can add more directories. */
8611 if (!islnm || rooted) {
8612 *(cp1++) = ':';
8613 *(cp1++) = '[';
8614 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8615 else cp2++;
8616 }
8617 else {
8618 if (cp2 != dirend) {
a35dcc95 8619 my_strlcpy(rslt, trndev, VMS_MAXRSS);
e518068a 8620 cp1 = rslt + trnend;
755b3d5d
JM		 8621 if (*cp2 != 0) {
8622 *(cp1++) = '.';
8623 cp2++;
8624 }
e518068a 8625 }
8626 else {
f7ddb74a
JM		 8627 if (decc_disable_posix_root) {
8628 *(cp1++) = ':';
8629 hasdir = 0;
8630 }
e518068a 8631 }
8632 }
367e4b85 8633 PerlMem_free(trndev);
748a9306 8634 }
59247333 8635 else if (hasdir) {
a0d0e21e 8636 *(cp1++) = '[';
748a9306
LW		 8637 if (*cp2 == '.') {
8638 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8639 cp2 += 2; /* skip over "./" - it's redundant */
8640 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8641 }
8642 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8643 *(cp1++) = '-'; /* "../" --> "-" */
8644 cp2 += 3;
8645 }
f86702cc 8646 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8647 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8648 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8649 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8650 cp2 += 4;
8651 }
f7ddb74a
JM		 8652 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8653 /* Escape the extra dots in EFS file specifications */
8654 *(cp1++) = '^';
8655 }
748a9306
LW		 8656 if (cp2 > dirend) cp2 = dirend;
8657 }
8658 else *(cp1++) = '.';
8659 }
8660 for (; cp2 < dirend; cp2++) {
8661 if (*cp2 == '/') {
01b8edb6 8662 if (*(cp2-1) == '/') continue;
59247333 8663 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
748a9306
LW		 8664 infront = 0;
8665 }
8666 else if (!infront && *cp2 == '.') {
01b8edb6 8667 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8668 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9 8669 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
59247333
CB		 8670 if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
8671 else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
4ab1eb56
CB		 8672 else {
8673 *(cp1++) = '-';
748a9306
LW		 8674 }
8675 cp2 += 2;
01b8edb6 8676 if (cp2 == dirend) break;
748a9306 8677 }
f86702cc 8678 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8679 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
59247333 8680 if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
f86702cc 8681 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8682 if (!*(cp2+3)) {
8683 *(cp1++) = '.'; /* Simulate trailing '/' */
8684 cp2 += 2; /* for loop will incr this to == dirend */
8685 }
8686 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8687 }
f7ddb74a 8688 else {
b7bc7afb 8689 if (decc_efs_charset == 0) {
59247333 8690 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8691 cp1--; /* remove the escape, if any */
f7ddb74a 8692 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
b7bc7afb 8693 }
f7ddb74a 8694 else {
b7bc7afb 8695 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8696 }
8697 }
748a9306
LW		 8698 }
8699 else {
59247333 8700 if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a 8701 if (*cp2 == '.') {
b7bc7afb 8702 if (decc_efs_charset == 0) {
59247333 8703 if (cp1 > rslt && *(cp1-1) == '^')
b7bc7afb 8704 cp1--; /* remove the escape, if any */
f7ddb74a 8705 *(cp1++) = '_';
b7bc7afb 8706 }
f7ddb74a 8707 else {
b7bc7afb 8708 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8709 }
8710 }
e283d9f3
CB		 8711 else {
8712 int out_cnt;
8713 cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
8714 cp2--; /* we're in a loop that will increment this */
8715 cp1 += out_cnt;
8716 }
748a9306
LW		 8717 infront = 1;
8718 }
a0d0e21e 8719 }
59247333 8720 if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8721 if (hasdir) *(cp1++) = ']';
2e82b6ce 8722 if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
f7ddb74a
JM		 8723 no_type_seen = 0;
8724 if (cp2 > lastdot)
8725 no_type_seen = 1;
8726 while (*cp2) {
8727 switch(*cp2) {
8728 case '?':
360732b5
JM		 8729 if (decc_efs_charset == 0)
8730 *(cp1++) = '%';
8731 else
8732 *(cp1++) = '?';
f7ddb74a
JM		 8733 cp2++;
8734 case ' ':
2e82b6ce 8735 if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
c434e88d 8736 *(cp1)++ = '^';
f7ddb74a
JM		 8737 *(cp1)++ = '_';
8738 cp2++;
8739 break;
8740 case '.':
8741 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8742 decc_readdir_dropdotnotype) {
b7bc7afb 8743 VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
f7ddb74a
JM		 8744 cp2++;
8745
8746 /* trailing dot ==> '^..' on VMS */
8747 if (*cp2 == '\0') {
8748 *(cp1++) = '.';
8749 no_type_seen = 0;
8750 }
8751 }
8752 else {
8753 *(cp1++) = *(cp2++);
8754 no_type_seen = 0;
8755 }
8756 break;
360732b5
JM		 8757 case '$':
8758 /* This could be a macro to be passed through */
8759 *(cp1++) = *(cp2++);
8760 if (*cp2 == '(') {
8761 const char * save_cp2;
8762 char * save_cp1;
8763 int is_macro;
8764
8765 /* paranoid check */
8766 save_cp2 = cp2;
8767 save_cp1 = cp1;
8768 is_macro = 0;
8769
8770 /* Test through */
8771 *(cp1++) = *(cp2++);
8772 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8773 *(cp1++) = *(cp2++);
8774 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8775 *(cp1++) = *(cp2++);
8776 }
8777 if (*cp2 == ')') {
8778 *(cp1++) = *(cp2++);
8779 is_macro = 1;
8780 }
8781 }
8782 if (is_macro == 0) {
8783 /* Not really a macro - never mind */
8784 cp2 = save_cp2;
8785 cp1 = save_cp1;
8786 }
8787 }
8788 break;
f7ddb74a
JM		 8789 case '\"':
8790 case '~':
8791 case '`':
8792 case '!':
8793 case '#':
8794 case '%':
8795 case '^':
adc11f0b
CB		 8796 /* Don't escape again if following character is
8797 * already something we escape.
8798 */
8799 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8800 *(cp1++) = *(cp2++);
8801 break;
8802 }
8803 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8804 case '&':
8805 case '(':
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 '>':
676447f9 8820 if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
c434e88d 8821 *(cp1++) = '^';
f7ddb74a
JM		 8822 *(cp1++) = *(cp2++);
8823 break;
8824 case ';':
d5e61aaf 8825 /* If it doesn't look like the beginning of a version number,
6e2e048b 8826 * or we've been promised there are no version numbers, then
d5e61aaf
CB		 8827 * escape it.
8828 */
6e2e048b 8829 if (decc_filename_unix_no_version) {
f7ddb74a
JM		 8830 *(cp1++) = '^';
8831 }
6e2e048b
CB		 8832 else {
8833 size_t all_nums = strspn(cp2+1, "0123456789");
8834 if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
8835 *(cp1++) = '^';
8836 }
f7ddb74a
JM		 8837 *(cp1++) = *(cp2++);
8838 break;
8839 default:
8840 *(cp1++) = *(cp2++);
8841 }
8842 }
8843 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8844 char *lcp1;
8845 lcp1 = cp1;
8846 lcp1--;
8847 /* Fix me for "^]", but that requires making sure that you do
8848 * not back up past the start of the filename
8849 */
8850 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8851 *cp1++ = '.';
8852 }
a0d0e21e
LW		 8853 *cp1 = '\0';
8854
360732b5
JM		 8855 if (utf8_flag != NULL)
8856 *utf8_flag = 0;
df278665
JM		 8857 if (vms_debug_fileify) {
8858 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8859 }
a0d0e21e
LW		 8860 return rslt;
8861
df278665
JM		 8862} /* end of int_tovmsspec() */
8863
8864
8865/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
ce12d4b7
CB		 8866static char *
8867mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
8868{
8869 static char __tovmsspec_retbuf[VMS_MAXRSS];
df278665
JM		 8870 char * vmsspec, *ret_spec, *ret_buf;
8871
8872 vmsspec = NULL;
8873 ret_buf = buf;
8874 if (ret_buf == NULL) {
8875 if (ts) {
8876 Newx(vmsspec, VMS_MAXRSS, char);
8877 if (vmsspec == NULL)
8878 _ckvmssts(SS$_INSFMEM);
8879 ret_buf = vmsspec;
8880 } else {
8881 ret_buf = __tovmsspec_retbuf;
8882 }
8883 }
8884
8885 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8886
8887 if (ret_spec == NULL) {
8888 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8889 if (vmsspec)
8890 Safefree(vmsspec);
8891 }
8892
8893 return ret_spec;
8894
8895} /* end of mp_do_tovmsspec() */
a0d0e21e
LW		 8896/*}}}*/
8897/* External entry points */
ce12d4b7
CB		 8898char *
8899Perl_tovmsspec(pTHX_ const char *path, char *buf)
8900{
8901 return do_tovmsspec(path, buf, 0, NULL);
8902}
8903
8904char *
8905Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8906{
8907 return do_tovmsspec(path, buf, 1, NULL);
8908}
8909
8910char *
8911Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8912{
8913 return do_tovmsspec(path, buf, 0, utf8_fl);
8914}
8915
8916char *
8917Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8918{
8919 return do_tovmsspec(path, buf, 1, utf8_fl);
8920}
360732b5 8921
4846f1d7 8922/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
94ae10c0 8923/* Internal routine for use with out an explicit context present */
ce12d4b7
CB		 8924static char *
8925int_tovmspath(const char *path, char *buf, int * utf8_fl)
8926{
4846f1d7
JM		 8927 char * ret_spec, *pathified;
8928
8929 if (path == NULL)
8930 return NULL;
8931
c11536f5 8932 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
4846f1d7
JM		 8933 if (pathified == NULL)
8934 _ckvmssts_noperl(SS$_INSFMEM);
8935
8936 ret_spec = int_pathify_dirspec(path, pathified);
8937
8938 if (ret_spec == NULL) {
8939 PerlMem_free(pathified);
8940 return NULL;
8941 }
8942
8943 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8944
8945 PerlMem_free(pathified);
8946 return ret_spec;
8947
8948}
8949
360732b5 8950/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
ce12d4b7
CB		 8951static char *
8952mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
8953{
a480973c 8954 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8955 int vmslen;
a480973c 8956 char *pathified, *vmsified, *cp;
a0d0e21e 8957
748a9306 8958 if (path == NULL) return NULL;
c11536f5 8959 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 8960 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 8961 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 8962 PerlMem_free(pathified);
a480973c
JM		 8963 return NULL;
8964 }
c5375c28
JM		 8965
8966 vmsified = NULL;
8967 if (buf == NULL)
8968 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8969 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8970 PerlMem_free(pathified);
8971 if (vmsified) Safefree(vmsified);
a480973c
JM		 8972 return NULL;
8973 }
c5375c28 8974 PerlMem_free(pathified);
a480973c 8975 if (buf) {
a480973c
JM		 8976 return buf;
8977 }
a0d0e21e
LW		 8978 else if (ts) {
8979 vmslen = strlen(vmsified);
a02a5408 8980 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8981 memcpy(cp,vmsified,vmslen);
8982 cp[vmslen] = '\0';
a480973c 8983 Safefree(vmsified);
a0d0e21e
LW		 8984 return cp;
8985 }
8986 else {
a35dcc95 8987 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
a480973c 8988 Safefree(vmsified);
a0d0e21e
LW		 8989 return __tovmspath_retbuf;
8990 }
8991
8992} /* end of do_tovmspath() */
8993/*}}}*/
8994/* External entry points */
ce12d4b7
CB		 8995char *
8996Perl_tovmspath(pTHX_ const char *path, char *buf)
8997{
8998 return do_tovmspath(path, buf, 0, NULL);
8999}
9000
9001char *
9002Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9003{
9004 return do_tovmspath(path, buf, 1, NULL);
9005}
9006
9007char *
9008Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9009{
9010 return do_tovmspath(path, buf, 0, utf8_fl);
9011}
9012
9013char *
9014Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9015{
9016 return do_tovmspath(path, buf, 1, utf8_fl);
9017}
360732b5
JM		 9018
9019
9020/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
ce12d4b7
CB		 9021static char *
9022mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
9023{
a480973c 9024 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 9025 int unixlen;
a480973c 9026 char *pathified, *unixified, *cp;
a0d0e21e 9027
748a9306 9028 if (path == NULL) return NULL;
c11536f5 9029 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9030 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 9031 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 9032 PerlMem_free(pathified);
a480973c
JM		 9033 return NULL;
9034 }
c5375c28
JM		 9035
9036 unixified = NULL;
9037 if (buf == NULL) {
9038 Newx(unixified, VMS_MAXRSS, char);
9039 }
360732b5 9040 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 9041 PerlMem_free(pathified);
9042 if (unixified) Safefree(unixified);
a480973c
JM		 9043 return NULL;
9044 }
c5375c28 9045 PerlMem_free(pathified);
a480973c 9046 if (buf) {
a480973c
JM		 9047 return buf;
9048 }
a0d0e21e
LW		 9049 else if (ts) {
9050 unixlen = strlen(unixified);
a02a5408 9051 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 9052 memcpy(cp,unixified,unixlen);
9053 cp[unixlen] = '\0';
a480973c 9054 Safefree(unixified);
a0d0e21e
LW		 9055 return cp;
9056 }
9057 else {
a35dcc95 9058 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
a480973c 9059 Safefree(unixified);
a0d0e21e
LW		 9060 return __tounixpath_retbuf;
9061 }
9062
9063} /* end of do_tounixpath() */
9064/*}}}*/
9065/* External entry points */
ce12d4b7
CB		 9066char *
9067Perl_tounixpath(pTHX_ const char *path, char *buf)
9068{
9069 return do_tounixpath(path, buf, 0, NULL);
9070}
9071
9072char *
9073Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9074{
9075 return do_tounixpath(path, buf, 1, NULL);
9076}
9077
9078char *
9079Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9080{
9081 return do_tounixpath(path, buf, 0, utf8_fl);
9082}
9083
9084char *
9085Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9086{
9087 return do_tounixpath(path, buf, 1, utf8_fl);
9088}
a0d0e21e
LW		 9089
9090/*
cbb8049c 9091 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9092 *
9093 *****************************************************************************
9094 * *
cbb8049c 9095 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 9096 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9097 * *
cbb8049c
MP		 9098 * Permission is hereby granted for the reproduction of this software *
9099 * on condition that this copyright notice is included in source *
9100 * distributions of the software. The code may be modified and *
9101 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 9102 * *
9103 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 9104 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 9105 *****************************************************************************
9106 */
9107
9108/*
9109 * getredirection() is intended to aid in porting C programs
9110 * to VMS (Vax-11 C). The native VMS environment does not support
9111 * '>' and '<' I/O redirection, or command line wild card expansion,
9112 * or a command line pipe mechanism using the '|' AND background
9113 * command execution '&'. All of these capabilities are provided to any
9114 * C program which calls this procedure as the first thing in the
9115 * main program.
9116 * The piping mechanism will probably work with almost any 'filter' type
9117 * of program. With suitable modification, it may useful for other
9118 * portability problems as well.
9119 *
cbb8049c 9120 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 9121 */
9122struct list_item
9123 {
9124 struct list_item *next;
9125 char *value;
9126 };
9127
9128static void add_item(struct list_item **head,
9129 struct list_item **tail,
9130 char *value,
9131 int *count);
9132
4b19af01
CB		 9133static void mp_expand_wild_cards(pTHX_ char *item,
9134 struct list_item **head,
9135 struct list_item **tail,
9136 int *count);
a0d0e21e 9137
8df869cb 9138static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 9139
fd8cd3a3 9140static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 9141
9142/*{{{ void getredirection(int *ac, char ***av)*/
84902520 9143static void
4b19af01 9144mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 9145/*
9146 * Process vms redirection arg's. Exit if any error is seen.
9147 * If getredirection() processes an argument, it is erased
9148 * from the vector. getredirection() returns a new argc and argv value.
9149 * In the event that a background command is requested (by a trailing "&"),
9150 * this routine creates a background subprocess, and simply exits the program.
9151 *
9152 * Warning: do not try to simplify the code for vms. The code
9153 * presupposes that getredirection() is called before any data is
9154 * read from stdin or written to stdout.
9155 *
9156 * Normal usage is as follows:
9157 *
9158 * main(argc, argv)
9159 * int argc;
9160 * char *argv[];
9161 * {
9162 * getredirection(&argc, &argv);
9163 * }
9164 */
9165{
9166 int argc = *ac; /* Argument Count */
9167 char **argv = *av; /* Argument Vector */
9168 char *ap; /* Argument pointer */
9169 int j; /* argv[] index */
9170 int item_count = 0; /* Count of Items in List */
9171 struct list_item *list_head = 0; /* First Item in List */
9172 struct list_item *list_tail; /* Last Item in List */
9173 char *in = NULL; /* Input File Name */
9174 char *out = NULL; /* Output File Name */
9175 char *outmode = "w"; /* Mode to Open Output File */
9176 char *err = NULL; /* Error File Name */
9177 char *errmode = "w"; /* Mode to Open Error File */
9178 int cmargc = 0; /* Piped Command Arg Count */
9179 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 9180
9181 /*
9182 * First handle the case where the last thing on the line ends with
9183 * a '&'. This indicates the desire for the command to be run in a
9184 * subprocess, so we satisfy that desire.
9185 */
9186 ap = argv[argc-1];
9187 if (0 == strcmp("&", ap))
8c3eed29 9188 exit(background_process(aTHX_ --argc, argv));
e518068a 9189 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 9190 {
9191 ap[strlen(ap)-1] = '\0';
8c3eed29 9192 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 9193 }
9194 /*
9195 * Now we handle the general redirection cases that involve '>', '>>',
9196 * '<', and pipes '|'.
9197 */
9198 for (j = 0; j < argc; ++j)
9199 {
9200 if (0 == strcmp("<", argv[j]))
9201 {
9202 if (j+1 >= argc)
9203 {
fd71b04b 9204 fprintf(stderr,"No input file after < on command line");
748a9306 9205 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9206 }
9207 in = argv[++j];
9208 continue;
9209 }
9210 if ('<' == *(ap = argv[j]))
9211 {
9212 in = 1 + ap;
9213 continue;
9214 }
9215 if (0 == strcmp(">", ap))
9216 {
9217 if (j+1 >= argc)
9218 {
fd71b04b 9219 fprintf(stderr,"No output file after > on command line");
748a9306 9220 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9221 }
9222 out = argv[++j];
9223 continue;
9224 }
9225 if ('>' == *ap)
9226 {
9227 if ('>' == ap[1])
9228 {
9229 outmode = "a";
9230 if ('\0' == ap[2])
9231 out = argv[++j];
9232 else
9233 out = 2 + ap;
9234 }
9235 else
9236 out = 1 + ap;
9237 if (j >= argc)
9238 {
fd71b04b 9239 fprintf(stderr,"No output file after > or >> on command line");
748a9306 9240 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9241 }
9242 continue;
9243 }
9244 if (('2' == *ap) && ('>' == ap[1]))
9245 {
9246 if ('>' == ap[2])
9247 {
9248 errmode = "a";
9249 if ('\0' == ap[3])
9250 err = argv[++j];
9251 else
9252 err = 3 + ap;
9253 }
9254 else
9255 if ('\0' == ap[2])
9256 err = argv[++j];
9257 else
748a9306 9258 err = 2 + ap;
a0d0e21e
LW		 9259 if (j >= argc)
9260 {
fd71b04b 9261 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 9262 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9263 }
9264 continue;
9265 }
9266 if (0 == strcmp("|", argv[j]))
9267 {
9268 if (j+1 >= argc)
9269 {
fd71b04b 9270 fprintf(stderr,"No command into which to pipe on command line");
748a9306 9271 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9272 }
9273 cmargc = argc-(j+1);
9274 cmargv = &argv[j+1];
9275 argc = j;
9276 continue;
9277 }
9278 if ('|' == *(ap = argv[j]))
9279 {
9280 ++argv[j];
9281 cmargc = argc-j;
9282 cmargv = &argv[j];
9283 argc = j;
9284 continue;
9285 }
9286 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9287 }
9288 /*
9289 * Allocate and fill in the new argument vector, Some Unix's terminate
9290 * the list with an extra null pointer.
9291 */
e0ef6b43 9292 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 9293 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9294 *av = argv;
9295 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9296 argv[j] = list_head->value;
9297 *ac = item_count;
9298 if (cmargv != NULL)
9299 {
9300 if (out != NULL)
9301 {
fd71b04b 9302 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 9303 exit(LIB$_INVARGORD);
a0d0e21e 9304 }
fd8cd3a3 9305 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 9306 }
9307
9308 /* Check for input from a pipe (mailbox) */
9309
a5f75d66 9310 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 9311 {
9312 char mbxname[L_tmpnam];
9313 long int bufsize;
9314 long int dvi_item = DVI$_DEVBUFSIZ;
9315 $DESCRIPTOR(mbxnam, "");
9316 $DESCRIPTOR(mbxdevnam, "");
9317
9318 /* Input from a pipe, reopen it in binary mode to disable */
9319 /* carriage control processing. */
9320
bf8d1304 9321 fgetname(stdin, mbxname, 1);
a0d0e21e
LW		 9322 mbxnam.dsc$a_pointer = mbxname;
9323 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9324 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9325 mbxdevnam.dsc$a_pointer = mbxname;
9326 mbxdevnam.dsc$w_length = sizeof(mbxname);
9327 dvi_item = DVI$_DEVNAM;
9328 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9329 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 9330 set_errno(0);
9331 set_vaxc_errno(1);
a0d0e21e
LW		 9332 freopen(mbxname, "rb", stdin);
9333 if (errno != 0)
9334 {
fd71b04b 9335 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 9336 exit(vaxc$errno);
a0d0e21e
LW		 9337 }
9338 }
9339 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9340 {
fd71b04b 9341 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 9342 exit(vaxc$errno);
a0d0e21e
LW		 9343 }
9344 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9345 {
fd71b04b 9346 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 9347 exit(vaxc$errno);
a0d0e21e 9348 }
0db50132 9349 if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
0e06870b 9350
748a9306 9351 if (err != NULL) {
71d7ec5d 9352 if (strcmp(err,"&1") == 0) {
a15cef0c 9353 dup2(fileno(stdout), fileno(stderr));
0db50132 9354 vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
71d7ec5d 9355 } else {
748a9306
LW		 9356 FILE *tmperr;
9357 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9358 {
fd71b04b 9359 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 9360 exit(vaxc$errno);
9361 }
9362 fclose(tmperr);
a15cef0c 9363 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 9364 {
9365 exit(vaxc$errno);
9366 }
0db50132 9367 vmssetuserlnm("SYS$ERROR", err);
a0d0e21e 9368 }
71d7ec5d 9369 }
a0d0e21e 9370#ifdef ARGPROC_DEBUG
740ce14c 9371 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 9372 for (j = 0; j < *ac; ++j)
740ce14c 9373 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 9374#endif
b7ae7a0d 9375 /* Clear errors we may have hit expanding wildcards, so they don't
9376 show up in Perl's $! later */
9377 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 9378} /* end of getredirection() */
9379/*}}}*/
9380
ce12d4b7
CB		 9381static void
9382add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
a0d0e21e
LW		 9383{
9384 if (*head == 0)
9385 {
e0ef6b43 9386 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9387 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9388 *tail = *head;
9389 }
9390 else {
e0ef6b43 9391 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9392 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9393 *tail = (*tail)->next;
9394 }
9395 (*tail)->value = value;
9396 ++(*count);
9397}
9398
ce12d4b7
CB		 9399static void
9400mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
9401 struct list_item **tail, int *count)
9402{
9403 int expcount = 0;
9404 unsigned long int context = 0;
9405 int isunix = 0;
9406 int item_len = 0;
9407 char *had_version;
9408 char *had_device;
9409 int had_directory;
9410 char *devdir,*cp;
9411 char *vmsspec;
9412 $DESCRIPTOR(filespec, "");
9413 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9414 $DESCRIPTOR(resultspec, "");
9415 unsigned long int lff_flags = 0;
9416 int sts;
9417 int rms_sts;
a480973c
JM		 9418
9419#ifdef VMS_LONGNAME_SUPPORT
9420 lff_flags = LIB$M_FIL_LONG_NAMES;
9421#endif
a0d0e21e 9422
f675dbe5
CB		 9423 for (cp = item; *cp; cp++) {
9424 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9425 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9426 }
9427 if (!*cp || isspace(*cp))
a0d0e21e
LW		 9428 {
9429 add_item(head, tail, item, count);
9430 return;
9431 }
773da73d
JH		 9432 else
9433 {
9434 /* "double quoted" wild card expressions pass as is */
9435 /* From DCL that means using e.g.: */
9436 /* perl program """perl.*""" */
9437 item_len = strlen(item);
9438 if ( '"' == *item && '"' == item[item_len-1] )
9439 {
9440 item++;
9441 item[item_len-2] = '\0';
9442 add_item(head, tail, item, count);
9443 return;
9444 }
9445 }
a0d0e21e
LW		 9446 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9447 resultspec.dsc$b_class = DSC$K_CLASS_D;
9448 resultspec.dsc$a_pointer = NULL;
c11536f5 9449 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9450 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 9451 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
df278665 9452 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
a0d0e21e
LW		 9453 if (!isunix || !filespec.dsc$a_pointer)
9454 filespec.dsc$a_pointer = item;
9455 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9456 /*
9457 * Only return version specs, if the caller specified a version
9458 */
9459 had_version = strchr(item, ';');
9460 /*
94ae10c0 9461 * Only return device and directory specs, if the caller specified either.
a0d0e21e
LW		 9462 */
9463 had_device = strchr(item, ':');
9464 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9465
a480973c
JM		 9466 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9467 (&filespec, &resultspec, &context,
dca5a913 9468 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 9469 {
9470 char *string;
9471 char *c;
9472
c11536f5 9473 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
c5375c28 9474 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
db4c2905 9475 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
a0d0e21e 9476 if (NULL == had_version)
f7ddb74a 9477 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 9478 if ((!had_directory) && (had_device == NULL))
9479 {
9480 if (NULL == (devdir = strrchr(string, ']')))
9481 devdir = strrchr(string, '>');
db4c2905 9482 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
a0d0e21e
LW		 9483 }
9484 /*
9485 * Be consistent with what the C RTL has already done to the rest of
9486 * the argv items and lowercase all of these names.
9487 */
f7ddb74a
JM		 9488 if (!decc_efs_case_preserve) {
9489 for (c = string; *c; ++c)
a0d0e21e
LW		 9490 if (isupper(*c))
9491 *c = tolower(*c);
f7ddb74a 9492 }
f86702cc 9493 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 9494 add_item(head, tail, string, count);
9495 ++expcount;
a480973c 9496 }
367e4b85 9497 PerlMem_free(vmsspec);
c07a80fd 9498 if (sts != RMS$_NMF)
9499 {
9500 set_vaxc_errno(sts);
9501 switch (sts)
9502 {
f282b18d 9503 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9504 set_errno(ENOENT); break;
f282b18d
CB		 9505 case RMS$_DIR:
9506 set_errno(ENOTDIR); break;
c07a80fd 9507 case RMS$_DEV:
9508 set_errno(ENODEV); break;
f282b18d 9509 case RMS$_FNM: case RMS$_SYN:
c07a80fd 9510 set_errno(EINVAL); break;
9511 case RMS$_PRV:
9512 set_errno(EACCES); break;
9513 default:
b7ae7a0d 9514 _ckvmssts_noperl(sts);
c07a80fd 9515 }
9516 }
a0d0e21e
LW		 9517 if (expcount == 0)
9518 add_item(head, tail, item, count);
b7ae7a0d 9519 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9520 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 9521}
9522
a0d0e21e 9523
ff7adb52
CL		 9524static void
9525pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 9526{
ff7adb52 9527 PerlIO *fp;
218fdd94 9528 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 9529 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9530 int sts, j, l, ismcr, quote, tquote = 0;
9531
218fdd94
CL		 9532 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9533 vms_execfree(vmscmd);
ff7adb52
CL		 9534
9535 j = l = 0;
9536 p = subcmd;
9537 q = cmargv[0];
9538 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9539 && toupper(*(q+2)) == 'R' && !*(q+3);
9540
9541 while (q && l < MAX_DCL_LINE_LENGTH) {
9542 if (!*q) {
9543 if (j > 0 && quote) {
9544 *p++ = '"';
9545 l++;
9546 }
9547 q = cmargv[++j];
9548 if (q) {
9549 if (ismcr && j > 1) quote = 1;
9550 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9551 *p++ = ' ';
9552 l++;
9553 if (quote || tquote) {
9554 *p++ = '"';
9555 l++;
9556 }
988c775c 9557 }
ff7adb52
CL		 9558 } else {
9559 if ((quote||tquote) && *q == '"') {
9560 *p++ = '"';
9561 l++;
988c775c 9562 }
ff7adb52
CL		 9563 *p++ = *q++;
9564 l++;
9565 }
9566 }
9567 *p = '\0';
a0d0e21e 9568
218fdd94 9569 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4e205ed6 9570 if (fp == NULL) {
ff7adb52 9571 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 9572 }
a0d0e21e
LW		 9573}
9574
ce12d4b7
CB		 9575static int
9576background_process(pTHX_ int argc, char **argv)
9577{
9578 char command[MAX_DCL_SYMBOL + 1] = "$";
9579 $DESCRIPTOR(value, "");
9580 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9581 static $DESCRIPTOR(null, "NLA0:");
9582 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9583 char pidstring[80];
9584 $DESCRIPTOR(pidstr, "");
9585 int pid;
9586 unsigned long int flags = 17, one = 1, retsts;
9587 int len;
a0d0e21e 9588
a35dcc95 9589 len = my_strlcat(command, argv[0], sizeof(command));
a480973c 9590 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e 9591 {
a35dcc95
CB		 9592 my_strlcat(command, " \"", sizeof(command));
9593 my_strlcat(command, *(++argv), sizeof(command));
9594 len = my_strlcat(command, "\"", sizeof(command));
a0d0e21e
LW		 9595 }
9596 value.dsc$a_pointer = command;
9597 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 9598 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 9599 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9600 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 9601 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 9602 }
9603 else {
b7ae7a0d 9604 _ckvmssts_noperl(retsts);
748a9306 9605 }
a0d0e21e 9606#ifdef ARGPROC_DEBUG
740ce14c 9607 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 9608#endif
9609 sprintf(pidstring, "%08X", pid);
740ce14c 9610 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 9611 pidstr.dsc$a_pointer = pidstring;
9612 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9613 lib$set_symbol(&pidsymbol, &pidstr);
9614 return(SS$_NORMAL);
9615}
9616/*}}}*/
9617/***** End of code taken from Mark Pizzolato's argproc.c package *****/
9618
84902520
TB		 9619
9620/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 9621/* Older VAXC header files lack these constants */
9622#ifndef JPI$_RIGHTS_SIZE
9623# define JPI$_RIGHTS_SIZE 817
9624#endif
9625#ifndef KGB$M_SUBSYSTEM
9626# define KGB$M_SUBSYSTEM 0x8
9627#endif
a480973c 9628
e0ef6b43
CB		 9629/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9630
84902520
TB		 9631/*{{{void vms_image_init(int *, char ***)*/
9632void
9633vms_image_init(int *argcp, char ***argvp)
9634{
b53f3677 9635 int status;
f675dbe5
CB		 9636 char eqv[LNM$C_NAMLENGTH+1] = "";
9637 unsigned int len, tabct = 8, tabidx = 0;
9638 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 9639 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9640 unsigned short int dummy, rlen;
f675dbe5 9641 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 9642#if defined(PERL_IMPLICIT_CONTEXT)
9643 pTHX = NULL;
9644#endif
61bb5906
CB		 9645 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9646 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9647 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9648 { 0, 0, 0, 0} };
84902520 9649
2e34cc90 9650#ifdef KILL_BY_SIGPRC
f7ddb74a 9651 Perl_csighandler_init();
2e34cc90
CL		 9652#endif
9653
b53f3677
JM		 9654 /* This was moved from the pre-image init handler because on threaded */
9655 /* Perl it was always returning 0 for the default value. */
98c7875d 9656 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
b53f3677
JM		 9657 if (status > 0) {
9658 int s;
9659 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9660 if (s > 0) {
9661 int initial;
9662 initial = decc$feature_get_value(s, 4);
98c7875d
CB		 9663 if (initial > 0) {
9664 /* initial is: 0 if nothing has set the feature */
9665 /* -1 if initialized to default */
9666 /* 1 if set by logical name */
9667 /* 2 if set by decc$feature_set_value */
b53f3677
JM		 9668 decc_disable_posix_root = decc$feature_get_value(s, 1);
9669
9670 /* If the value is not valid, force the feature off */
9671 if (decc_disable_posix_root < 0) {
9672 decc$feature_set_value(s, 1, 1);
9673 decc_disable_posix_root = 1;
9674 }
9675 }
9676 else {
98c7875d 9677 /* Nothing has asked for it explicitly, so use our own default. */
b53f3677
JM		 9678 decc_disable_posix_root = 1;
9679 decc$feature_set_value(s, 1, 1);
9680 }
9681 }
9682 }
b53f3677 9683
fd8cd3a3
DS		 9684 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9685 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9686 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9687 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 9688 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 9689 will_taint = TRUE;
84902520
TB		 9690 break;
9691 }
9692 }
61bb5906 9693 /* Rights identifiers might trigger tainting as well. */
f675dbe5 9694 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 9695 while (rlen < rsz) {
9696 /* We didn't get all the identifiers on the first pass. Allocate a
9697 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9698 * were needed to hold all identifiers at time of last call; we'll
9699 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 9700 * If it gave us less than it wanted to despite ample buffer space,
9701 * something's broken. Is your system missing a system identifier?
61bb5906 9702 */
22d4bb9c
CB		 9703 if (rsz <= jpilist[1].buflen) {
9704 /* Perl_croak accvios when used this early in startup. */
9705 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9706 rsz, (unsigned long) jpilist[1].buflen,
9707 "Check your rights database for corruption.\n");
9708 exit(SS$_ABORT);
9709 }
e0ef6b43
CB		 9710 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9711 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9712 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9713 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9714 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9715 _ckvmssts_noperl(iosb[0]);
61bb5906 9716 }
c11536f5 9717 mask = (unsigned long int *)jpilist[1].bufadr;
61bb5906
CB		 9718 /* Check attribute flags for each identifier (2nd longword); protected
9719 * subsystem identifiers trigger tainting.
9720 */
9721 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9722 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9723 will_taint = TRUE;
61bb5906
CB		 9724 break;
9725 }
9726 }
367e4b85 9727 if (mask != rlst) PerlMem_free(mask);
61bb5906 9728 }
f7ddb74a
JM		 9729
9730 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9731 * logical, some versions of the CRTL will add a phanthom /000000/
9732 * directory. This needs to be removed.
9733 */
9734 if (decc_filename_unix_report) {
ce12d4b7
CB		 9735 char * zeros;
9736 int ulen;
f7ddb74a
JM		 9737 ulen = strlen(argvp[0][0]);
9738 if (ulen > 7) {
9739 zeros = strstr(argvp[0][0], "/000000/");
9740 if (zeros != NULL) {
9741 int mlen;
9742 mlen = ulen - (zeros - argvp[0][0]) - 7;
9743 memmove(zeros, &zeros[7], mlen);
9744 ulen = ulen - 7;
9745 argvp[0][0][ulen] = '\0';
9746 }
9747 }
9748 /* It also may have a trailing dot that needs to be removed otherwise
9749 * it will be converted to VMS mode incorrectly.
9750 */
9751 ulen--;
9752 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9753 argvp[0][0][ulen] = '\0';
9754 }
9755
61bb5906 9756 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9757 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9758 * hasn't been allocated when vms_image_init() is called.
9759 */
f675dbe5 9760 if (will_taint) {
ec618cdf
CB		 9761 char **newargv, **oldargv;
9762 oldargv = *argvp;
e0ef6b43 9763 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9764 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9765 newargv[0] = oldargv[0];
c11536f5 9766 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
c5375c28 9767 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9768 strcpy(newargv[1], "-T");
9769 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9770 (*argcp)++;
9771 newargv[*argcp] = NULL;
61bb5906
CB		 9772 /* We orphan the old argv, since we don't know where it's come from,
9773 * so we don't know how to free it.
9774 */
ec618cdf 9775 *argvp = newargv;
61bb5906 9776 }
f675dbe5
CB		 9777 else { /* Did user explicitly request tainting? */
9778 int i;
9779 char *cp, **av = *argvp;
9780 for (i = 1; i < *argcp; i++) {
9781 if (*av[i] != '-') break;
9782 for (cp = av[i]+1; *cp; cp++) {
9783 if (*cp == 'T') { will_taint = 1; break; }
9784 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9785 strchr("DFIiMmx",*cp)) break;
9786 }
9787 if (will_taint) break;
9788 }
9789 }
9790
9791 for (tabidx = 0;
9792 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9793 tabidx++) {
c5375c28
JM		 9794 if (!tabidx) {
9795 tabvec = (struct dsc$descriptor_s **)
9796 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9797 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9798 }
f675dbe5
CB		 9799 else if (tabidx >= tabct) {
9800 tabct += 8;
e0ef6b43 9801 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9802 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9803 }
e0ef6b43 9804 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9805 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
88e3936f 9806 tabvec[tabidx]->dsc$w_length = len;
f675dbe5 9807 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
88e3936f 9808 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
4f119521 9809 tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
88e3936f
CB		 9810 if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9811 my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
f675dbe5
CB		 9812 }
9813 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9814
84902520 9815 getredirection(argcp,argvp);
3bc25146
CB		 9816#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9817 {
9818# include <reentrancy.h>
f7ddb74a 9819 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9820 }
9821#endif
84902520
TB		 9822 return;
9823}
9824/*}}}*/
9825
9826
a0d0e21e
LW		 9827/* trim_unixpath()
9828 * Trim Unix-style prefix off filespec, so it looks like what a shell
9829 * glob expansion would return (i.e. from specified prefix on, not
9830 * full path). Note that returned filespec is Unix-style, regardless
9831 * of whether input filespec was VMS-style or Unix-style.
9832 *
a3e9d8c9 9833 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9834 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9835 * vector of options; at present, only bit 0 is used, and if set tells
9836 * trim unixpath to try the current default directory as a prefix when
9837 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9838 *
9839 * Returns !=0 on success, with trimmed filespec replacing contents of
9840 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9841 */
f86702cc 9842/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9843int
2fbb330f 9844Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9845{
c11536f5 9846 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
eb578fdb 9847 int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9848
a3e9d8c9 9849 if (!wildspec || !fspec) return 0;
ebd4d70b 9850
c11536f5 9851 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9852 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9853 tplate = unixwild;
a3e9d8c9 9854 if (strpbrk(wildspec,"]>:") != NULL) {
0e5ce2c7 9855 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
367e4b85 9856 PerlMem_free(unixwild);
a480973c
JM		 9857 return 0;
9858 }
a3e9d8c9 9859 }
2fbb330f 9860 else {
a35dcc95 9861 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
2fbb330f 9862 }
c11536f5 9863 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9864 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e 9865 if (strpbrk(fspec,"]>:") != NULL) {
0e5ce2c7 9866 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
367e4b85
JM		 9867 PerlMem_free(unixwild);
9868 PerlMem_free(unixified);
a480973c
JM		 9869 return 0;
9870 }
a0d0e21e 9871 else base = unixified;
a3e9d8c9 9872 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9873 * check to see that final result fits into (isn't longer than) fspec */
9874 reslen = strlen(fspec);
a0d0e21e
LW		 9875 }
9876 else base = fspec;
a3e9d8c9 9877
9878 /* No prefix or absolute path on wildcard, so nothing to remove */
c11536f5 9879 if (!*tplate || *tplate == '/') {
367e4b85 9880 PerlMem_free(unixwild);
a480973c 9881 if (base == fspec) {
367e4b85 9882 PerlMem_free(unixified);
a480973c
JM		 9883 return 1;
9884 }
a3e9d8c9 9885 tmplen = strlen(unixified);
a480973c 9886 if (tmplen > reslen) {
367e4b85 9887 PerlMem_free(unixified);
a480973c
JM		 9888 return 0; /* not enough space */
9889 }
a3e9d8c9 9890 /* Copy unixified resultant, including trailing NUL */
9891 memmove(fspec,unixified,tmplen+1);
367e4b85 9892 PerlMem_free(unixified);
a3e9d8c9 9893 return 1;
9894 }
a0d0e21e 9895
f86702cc 9896 for (end = base; *end; end++) ; /* Find end of resultant filespec */
c11536f5
CB		 9897 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9898 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
f86702cc 9899 for (cp1 = end ;cp1 >= base; cp1--)
9900 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9901 { cp1++; break; }
9902 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9903 PerlMem_free(unixified);
9904 PerlMem_free(unixwild);
a3e9d8c9 9905 return 1;
9906 }
f86702cc 9907 else {
a480973c 9908 char *tpl, *lcres;
f86702cc 9909 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9910 int ells = 1, totells, segdirs, match;
a480973c 9911 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9912 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9913
9914 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9915 totells = ells;
9916 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
c11536f5 9917 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9918 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9919 if (ellipsis == tplate && opts & 1) {
f86702cc 9920 /* Template begins with an ellipsis. Since we can't tell how many
9921 * directory names at the front of the resultant to keep for an
9922 * arbitrary starting point, we arbitrarily choose the current
9923 * default directory as a starting point. If it's there as a prefix,
9924 * clip it off. If not, fall through and act as if the leading
9925 * ellipsis weren't there (i.e. return shortest possible path that
9926 * could match template).
9927 */
a480973c 9928 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9929 PerlMem_free(tpl);
9930 PerlMem_free(unixified);
9931 PerlMem_free(unixwild);
a480973c
JM		 9932 return 0;
9933 }
f7ddb74a
JM		 9934 if (!decc_efs_case_preserve) {
9935 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9936 if (_tolower(*cp1) != _tolower(*cp2)) break;
9937 }
f86702cc 9938 segdirs = dirs - totells; /* Min # of dirs we must have left */
9939 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9940 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9941 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9942 PerlMem_free(tpl);
9943 PerlMem_free(unixified);
9944 PerlMem_free(unixwild);
f86702cc 9945 return 1;
a3e9d8c9 9946 }
a3e9d8c9 9947 }
f86702cc 9948 /* First off, back up over constant elements at end of path */
9949 if (dirs) {
9950 for (front = end ; front >= base; front--)
9951 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9952 }
c11536f5 9953 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9954 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9955 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
a480973c
JM		 9956 cp1++,cp2++) {
9957 if (!decc_efs_case_preserve) {
9958 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9959 }
9960 else {
9961 *cp2 = *cp1;
9962 }
9963 }
9964 if (cp1 != '\0') {
367e4b85
JM		 9965 PerlMem_free(tpl);
9966 PerlMem_free(unixified);
9967 PerlMem_free(unixwild);
c5375c28 9968 PerlMem_free(lcres);
a480973c 9969 return 0; /* Path too long. */
f7ddb74a 9970 }
f86702cc 9971 lcend = cp2;
9972 *cp2 = '\0'; /* Pick up with memcpy later */
9973 lcfront = lcres + (front - base);
9974 /* Now skip over each ellipsis and try to match the path in front of it. */
9975 while (ells--) {
c11536f5 9976 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
f86702cc 9977 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9978 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
c11536f5 9979 if (cp1 < tplate) break; /* template started with an ellipsis */
f86702cc 9980 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9981 ellipsis = cp1; continue;
9982 }
a480973c 9983 wilddsc.dsc$a_pointer = tpl;
f86702cc 9984 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9985 nextell = cp1;
9986 for (segdirs = 0, cp2 = tpl;
a480973c 9987 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9988 cp1++, cp2++) {
9989 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9990 else {
9991 if (!decc_efs_case_preserve) {
9992 *cp2 = _tolower(*cp1); /* else lowercase for match */
9993 }
9994 else {
9995 *cp2 = *cp1; /* else preserve case for match */
9996 }
9997 }
f86702cc 9998 if (*cp2 == '/') segdirs++;
9999 }
a480973c 10000 if (cp1 != ellipsis - 1) {
367e4b85
JM		 10001 PerlMem_free(tpl);
10002 PerlMem_free(unixified);
10003 PerlMem_free(unixwild);
10004 PerlMem_free(lcres);
a480973c
JM		 10005 return 0; /* Path too long */
10006 }
f86702cc 10007 /* Back up at least as many dirs as in template before matching */
10008 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10009 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10010 for (match = 0; cp1 > lcres;) {
10011 resdsc.dsc$a_pointer = cp1;
10012 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10013 match++;
10014 if (match == 1) lcfront = cp1;
10015 }
10016 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10017 }
a480973c 10018 if (!match) {
367e4b85
JM		 10019 PerlMem_free(tpl);
10020 PerlMem_free(unixified);
10021 PerlMem_free(unixwild);
10022 PerlMem_free(lcres);
a480973c
JM		 10023 return 0; /* Can't find prefix ??? */
10024 }
f86702cc 10025 if (match > 1 && opts & 1) {
10026 /* This ... wildcard could cover more than one set of dirs (i.e.
10027 * a set of similar dir names is repeated). If the template
10028 * contains more than 1 ..., upstream elements could resolve the
10029 * ambiguity, but it's not worth a full backtracking setup here.
10030 * As a quick heuristic, clip off the current default directory
10031 * if it's present to find the trimmed spec, else use the
10032 * shortest string that this ... could cover.
10033 */
10034 char def[NAM$C_MAXRSS+1], *st;
10035
a480973c 10036 if (getcwd(def, sizeof def,0) == NULL) {
827f156d
JM		 10037 PerlMem_free(unixified);
10038 PerlMem_free(unixwild);
10039 PerlMem_free(lcres);
10040 PerlMem_free(tpl);
a480973c
JM		 10041 return 0;
10042 }
f7ddb74a
JM		 10043 if (!decc_efs_case_preserve) {
10044 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10045 if (_tolower(*cp1) != _tolower(*cp2)) break;
10046 }
f86702cc 10047 segdirs = dirs - totells; /* Min # of dirs we must have left */
10048 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10049 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 10050 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 10051 PerlMem_free(tpl);
10052 PerlMem_free(unixified);
10053 PerlMem_free(unixwild);
10054 PerlMem_free(lcres);
f86702cc 10055 return 1;
10056 }
10057 /* Nope -- stick with lcfront from above and keep going. */
10058 }
10059 }
18a3d61e 10060 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 10061 PerlMem_free(tpl);
10062 PerlMem_free(unixified);
10063 PerlMem_free(unixwild);
10064 PerlMem_free(lcres);
a3e9d8c9 10065 return 1;
a0d0e21e 10066 }
a0d0e21e
LW		 10067
10068} /* end of trim_unixpath() */
10069/*}}}*/
10070
a0d0e21e
LW		 10071
10072/*
10073 * VMS readdir() routines.
10074 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 10075 *
bd3fa61c 10076 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 10077 * Minor modifications to original routines.
10078 */
10079
a9852f7c
CB		 10080/* readdir may have been redefined by reentr.h, so make sure we get
10081 * the local version for what we do here.
10082 */
10083#ifdef readdir
10084# undef readdir
10085#endif
10086#if !defined(PERL_IMPLICIT_CONTEXT)
10087# define readdir Perl_readdir
10088#else
10089# define readdir(a) Perl_readdir(aTHX_ a)
10090#endif
10091
a0d0e21e
LW		 10092 /* Number of elements in vms_versions array */
10093#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10094
10095/*
10096 * Open a directory, return a handle for later use.
10097 */
10098/*{{{ DIR *opendir(char*name) */
ddcbaa1c 10099DIR *
b8ffc8df 10100Perl_opendir(pTHX_ const char *name)
a0d0e21e 10101{
ddcbaa1c 10102 DIR *dd;
657054d4 10103 char *dir;
61bb5906 10104 Stat_t sb;
657054d4
JM		 10105
10106 Newx(dir, VMS_MAXRSS, char);
4846f1d7 10107 if (int_tovmspath(name, dir, NULL) == NULL) {
657054d4 10108 Safefree(dir);
61bb5906 10109 return NULL;
a0d0e21e 10110 }
ada67d10
CB		 10111 /* Check access before stat; otherwise stat does not
10112 * accurately report whether it's a directory.
10113 */
0f669c9d
CB		 10114 if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
10115 && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 10116 /* cando_by_name has already set errno */
657054d4 10117 Safefree(dir);
ada67d10
CB		 10118 return NULL;
10119 }
61bb5906
CB		 10120 if (flex_stat(dir,&sb) == -1) return NULL;
10121 if (!S_ISDIR(sb.st_mode)) {
657054d4 10122 Safefree(dir);
61bb5906
CB		 10123 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10124 return NULL;
10125 }
61bb5906 10126 /* Get memory for the handle, and the pattern. */
ddcbaa1c 10127 Newx(dd,1,DIR);
a02a5408 10128 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 10129
10130 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 10131 sprintf(dd->pattern, "%s*.*",dir);
657054d4 10132 Safefree(dir);
a0d0e21e
LW		 10133 dd->context = 0;
10134 dd->count = 0;
657054d4 10135 dd->flags = 0;
6d53ee29
CB		 10136 /* By saying we want the result of readdir() in unix format, we are really
10137 * saying we want all the escapes removed, translating characters that
10138 * must be escaped in a VMS-format name to their unescaped form, which is
10139 * presumably allowed in a Unix-format name.
a096370a 10140 */
6d53ee29 10141 dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
a0d0e21e
LW		 10142 dd->pat.dsc$a_pointer = dd->pattern;
10143 dd->pat.dsc$w_length = strlen(dd->pattern);
10144 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10145 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 10146#if defined(USE_ITHREADS)
a02a5408 10147 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 10148 MUTEX_INIT( (perl_mutex *) dd->mutex );
10149#else
10150 dd->mutex = NULL;
10151#endif
a0d0e21e
LW		 10152
10153 return dd;
10154} /* end of opendir() */
10155/*}}}*/
10156
10157/*
10158 * Set the flag to indicate we want versions or not.
10159 */
10160/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10161void
ddcbaa1c 10162vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 10163{
657054d4
JM		 10164 if (flag)
10165 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10166 else
10167 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 10168}
10169/*}}}*/
10170
10171/*
10172 * Free up an opened directory.
10173 */
10174/*{{{ void closedir(DIR *dd)*/
10175void
ddcbaa1c 10176Perl_closedir(DIR *dd)
a0d0e21e 10177{
f7ddb74a
JM		 10178 int sts;
10179
10180 sts = lib$find_file_end(&dd->context);
a0d0e21e 10181 Safefree(dd->pattern);
3bc25146 10182#if defined(USE_ITHREADS)
a9852f7c
CB		 10183 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10184 Safefree(dd->mutex);
10185#endif
f7ddb74a 10186 Safefree(dd);
a0d0e21e
LW		 10187}
10188/*}}}*/
10189
10190/*
10191 * Collect all the version numbers for the current file.
10192 */
10193static void
ddcbaa1c 10194collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 10195{
10196 struct dsc$descriptor_s pat;
10197 struct dsc$descriptor_s res;
ddcbaa1c 10198 struct dirent *e;
657054d4 10199 char *p, *text, *buff;
a0d0e21e
LW		 10200 int i;
10201 unsigned long context, tmpsts;
10202
10203 /* Convenient shorthand. */
10204 e = &dd->entry;
10205
10206 /* Add the version wildcard, ignoring the "*.*" put on before */
10207 i = strlen(dd->pattern);
a02a5408 10208 Newx(text,i + e->d_namlen + 3,char);
a35dcc95 10209 my_strlcpy(text, dd->pattern, i + 1);
f7ddb74a 10210 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 10211
10212 /* Set up the pattern descriptor. */
10213 pat.dsc$a_pointer = text;
10214 pat.dsc$w_length = i + e->d_namlen - 1;
10215 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10216 pat.dsc$b_class = DSC$K_CLASS_S;
10217
10218 /* Set up result descriptor. */
657054d4 10219 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10220 res.dsc$a_pointer = buff;
657054d4 10221 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10222 res.dsc$b_dtype = DSC$K_DTYPE_T;
10223 res.dsc$b_class = DSC$K_CLASS_S;
10224
10225 /* Read files, collecting versions. */
10226 for (context = 0, e->vms_verscount = 0;
10227 e->vms_verscount < VERSIZE(e);
10228 e->vms_verscount++) {
657054d4
JM		 10229 unsigned long rsts;
10230 unsigned long flags = 0;
10231
10232#ifdef VMS_LONGNAME_SUPPORT
988c775c 10233 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10234#endif
10235 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 10236 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 10237 _ckvmssts(tmpsts);
657054d4 10238 buff[VMS_MAXRSS - 1] = '\0';
748a9306 10239 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 10240 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10241 else
10242 e->vms_versions[e->vms_verscount] = -1;
10243 }
10244
748a9306 10245 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 10246 Safefree(text);
657054d4 10247 Safefree(buff);
a0d0e21e
LW		 10248
10249} /* end of collectversions() */
10250
10251/*
10252 * Read the next entry from the directory.
10253 */
10254/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 10255struct dirent *
10256Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 10257{
10258 struct dsc$descriptor_s res;
657054d4 10259 char *p, *buff;
a0d0e21e 10260 unsigned long int tmpsts;
657054d4
JM		 10261 unsigned long rsts;
10262 unsigned long flags = 0;
dca5a913 10263 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 10264 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 10265
10266 /* Set up result descriptor, and get next file. */
657054d4 10267 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10268 res.dsc$a_pointer = buff;
657054d4 10269 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10270 res.dsc$b_dtype = DSC$K_DTYPE_T;
10271 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 10272
10273#ifdef VMS_LONGNAME_SUPPORT
988c775c 10274 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10275#endif
10276
10277 tmpsts = lib$find_file
10278 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
66facaa3
CB		 10279 if (dd->context == 0)
10280 tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
10281
4633a7c4 10282 if (!(tmpsts & 1)) {
4633a7c4 10283 switch (tmpsts) {
66facaa3
CB		 10284 case RMS$_NMF:
10285 break; /* no more files considered success */
4633a7c4 10286 case RMS$_PRV:
66facaa3 10287 SETERRNO(EACCES, tmpsts); break;
4633a7c4 10288 case RMS$_DEV:
66facaa3 10289 SETERRNO(ENODEV, tmpsts); break;
4633a7c4 10290 case RMS$_DIR:
66facaa3 10291 SETERRNO(ENOTDIR, tmpsts); break;
f282b18d 10292 case RMS$_FNF: case RMS$_DNF:
66facaa3 10293 SETERRNO(ENOENT, tmpsts); break;
4633a7c4 10294 default:
66facaa3 10295 SETERRNO(EVMSERR, tmpsts);
4633a7c4 10296 }
657054d4 10297 Safefree(buff);
4633a7c4
LW		 10298 return NULL;
10299 }
10300 dd->count++;
a0d0e21e 10301 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
c43a0d1c
CB		 10302 buff[res.dsc$w_length] = '\0';
10303 p = buff + res.dsc$w_length;
10304 while (--p >= buff) if (!isspace(*p)) break;
10305 *p = '\0';
f7ddb74a 10306 if (!decc_efs_case_preserve) {
f7ddb74a 10307 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a 10308 }
a0d0e21e
LW		 10309
10310 /* Skip any directory component and just copy the name. */
657054d4 10311 sts = vms_split_path
360732b5 10312 (buff,
657054d4
JM		 10313 &v_spec,
10314 &v_len,
10315 &r_spec,
10316 &r_len,
10317 &d_spec,
10318 &d_len,
10319 &n_spec,
10320 &n_len,
10321 &e_spec,
10322 &e_len,
10323 &vs_spec,
10324 &vs_len);
10325
0dddfaca
JM		 10326 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10327
10328 /* In Unix report mode, remove the ".dir;1" from the name */
10329 /* if it is a real directory. */
d5eaec22 10330 if (decc_filename_unix_report && decc_efs_charset) {
f785e3a1
JM		 10331 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10332 Stat_t statbuf;
10333 int ret_sts;
10334
10335 ret_sts = flex_lstat(buff, &statbuf);
10336 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10337 e_len = 0;
10338 e_spec[0] = 0;
0dddfaca
JM		 10339 }
10340 }
10341 }
10342
10343 /* Drop NULL extensions on UNIX file specification */
10344 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10345 e_len = 0;
10346 e_spec[0] = '\0';
10347 }
dca5a913
JM		 10348 }
10349
a35dcc95 10350 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
657054d4 10351 dd->entry.d_name[n_len + e_len] = '\0';
a84b1d1f 10352 dd->entry.d_namlen = n_len + e_len;
a0d0e21e 10353
657054d4
JM		 10354 /* Convert the filename to UNIX format if needed */
10355 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10356
10357 /* Translate the encoded characters. */
38a44b82 10358 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 10359 if (strchr(dd->entry.d_name, '^') != NULL) {
10360 char new_name[256];
10361 char * q;
657054d4
JM		 10362 p = dd->entry.d_name;
10363 q = new_name;
10364 while (*p != 0) {
f617045b
CB		 10365 int inchars_read, outchars_added;
10366 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10367 p += inchars_read;
10368 q += outchars_added;
dca5a913 10369 /* fix-me */
f617045b 10370 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 10371 /* Wide file specifications need to be passed in Perl */
38a44b82 10372 /* counted strings apparently with a Unicode flag */
657054d4
JM		 10373 }
10374 *q = 0;
a35dcc95 10375 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
657054d4 10376 }
657054d4 10377 }
a0d0e21e 10378
a0d0e21e 10379 dd->entry.vms_verscount = 0;
657054d4
JM		 10380 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10381 Safefree(buff);
a0d0e21e
LW		 10382 return &dd->entry;
10383
10384} /* end of readdir() */
10385/*}}}*/
10386
10387/*
a9852f7c
CB		 10388 * Read the next entry from the directory -- thread-safe version.
10389 */
10390/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10391int
ddcbaa1c 10392Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 10393{
10394 int retval;
10395
10396 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10397
7ded3206 10398 entry = readdir(dd);
a9852f7c
CB		 10399 *result = entry;
10400 retval = ( *result == NULL ? errno : 0 );
10401
10402 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10403
10404 return retval;
10405
10406} /* end of readdir_r() */
10407/*}}}*/
10408
10409/*
a0d0e21e
LW		 10410 * Return something that can be used in a seekdir later.
10411 */
10412/*{{{ long telldir(DIR *dd)*/
10413long
ddcbaa1c 10414Perl_telldir(DIR *dd)
a0d0e21e
LW		 10415{
10416 return dd->count;
10417}
10418/*}}}*/
10419
10420/*
10421 * Return to a spot where we used to be. Brute force.
10422 */
10423/*{{{ void seekdir(DIR *dd,long count)*/
10424void
ddcbaa1c 10425Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 10426{
657054d4 10427 int old_flags;
a0d0e21e
LW		 10428
10429 /* If we haven't done anything yet... */
10430 if (dd->count == 0)
10431 return;
10432
10433 /* Remember some state, and clear it. */
657054d4
JM		 10434 old_flags = dd->flags;
10435 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 10436 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 10437 dd->context = 0;
10438
10439 /* The increment is in readdir(). */
10440 for (dd->count = 0; dd->count < count; )
f7ddb74a 10441 readdir(dd);
a0d0e21e 10442
657054d4 10443 dd->flags = old_flags;
a0d0e21e
LW		 10444
10445} /* end of seekdir() */
10446/*}}}*/
10447
10448/* VMS subprocess management
10449 *
10450 * my_vfork() - just a vfork(), after setting a flag to record that
10451 * the current script is trying a Unix-style fork/exec.
10452 *
10453 * vms_do_aexec() and vms_do_exec() are called in response to the
10454 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 10455 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 10456 * execvp (for those who really want to try this under VMS).
10457 * Otherwise, they do exactly what the perl docs say exec should
10458 * do - terminate the current script and invoke a new command
10459 * (See below for notes on command syntax.)
10460 *
10461 * do_aspawn() and do_spawn() implement the VMS side of the perl
10462 * 'system' function.
10463 *
10464 * Note on command arguments to perl 'exec' and 'system': When handled
10465 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 10466 * are concatenated to form a DCL command string. If the first non-numeric
10467 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 10468 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 10469 * the first token of the command is taken as the filespec of an image
10470 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 10471 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 10472 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 10473 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 10474 * but I hope it will form a happy medium between what VMS folks expect
10475 * from lib$spawn and what Unix folks expect from exec.
10476 */
10477
10478static int vfork_called;
10479
f7c699a0 10480/*{{{int my_vfork(void)*/
a0d0e21e 10481int
f7c699a0 10482my_vfork(void)
a0d0e21e 10483{
748a9306 10484 vfork_called++;
a0d0e21e
LW		 10485 return vfork();
10486}
10487/*}}}*/
10488
4633a7c4 10489
a0d0e21e 10490static void
218fdd94
CL		 10491vms_execfree(struct dsc$descriptor_s *vmscmd)
10492{
10493 if (vmscmd) {
10494 if (vmscmd->dsc$a_pointer) {
c5375c28 10495 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 10496 }
c5375c28 10497 PerlMem_free(vmscmd);
4633a7c4
LW		 10498 }
10499}
10500
10501static char *
fd8cd3a3 10502setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 10503{
4e205ed6 10504 char *junk, *tmps = NULL;
eb578fdb 10505 size_t cmdlen = 0;
a0d0e21e 10506 size_t rlen;
eb578fdb 10507 SV **idx;
2d8e6c8d 10508 STRLEN n_a;
a0d0e21e
LW		 10509
10510 idx = mark;
4633a7c4
LW		 10511 if (really) {
10512 tmps = SvPV(really,rlen);
10513 if (*tmps) {
10514 cmdlen += rlen + 1;
10515 idx++;
10516 }
a0d0e21e
LW		 10517 }
10518
10519 for (idx++; idx <= sp; idx++) {
10520 if (*idx) {
10521 junk = SvPVx(*idx,rlen);
10522 cmdlen += rlen ? rlen + 1 : 0;
10523 }
10524 }
c5375c28 10525 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 10526
4633a7c4 10527 if (tmps && *tmps) {
a35dcc95 10528 my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
a0d0e21e
LW		 10529 mark++;
10530 }
6b88bc9c 10531 else *PL_Cmd = '\0';
a0d0e21e
LW		 10532 while (++mark <= sp) {
10533 if (*mark) {
3eeba6fb
CB		 10534 char *s = SvPVx(*mark,n_a);
10535 if (!*s) continue;
a35dcc95
CB		 10536 if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10537 my_strlcat(PL_Cmd, s, cmdlen+1);
a0d0e21e
LW		 10538 }
10539 }
6b88bc9c 10540 return PL_Cmd;
a0d0e21e
LW		 10541
10542} /* end of setup_argstr() */
10543
4633a7c4 10544
a0d0e21e 10545static unsigned long int
2fbb330f 10546setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 10547 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 10548{
e919cd19
JM		 10549 char * vmsspec;
10550 char * resspec;
e886094b
JM		 10551 char image_name[NAM$C_MAXRSS+1];
10552 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 10553 $DESCRIPTOR(defdsc,".EXE");
8012a33e 10554 $DESCRIPTOR(defdsc2,".");
e919cd19 10555 struct dsc$descriptor_s resdsc;
218fdd94 10556 struct dsc$descriptor_s *vmscmd;
a0d0e21e 10557 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 10558 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
eb578fdb 10559 char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 10560 char * cmd;
10561 int cmdlen;
eb578fdb 10562 int isdcl;
a0d0e21e 10563
426fe37a 10564 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
ebd4d70b 10565 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 10566
e919cd19 10567 /* vmsspec is a DCL command buffer, not just a filename */
c11536f5 10568 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
e919cd19
JM		 10569 if (vmsspec == NULL)
10570 _ckvmssts_noperl(SS$_INSFMEM);
10571
c11536f5 10572 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
e919cd19
JM		 10573 if (resspec == NULL)
10574 _ckvmssts_noperl(SS$_INSFMEM);
10575
2fbb330f
JM		 10576 /* Make a copy for modification */
10577 cmdlen = strlen(incmd);
c11536f5 10578 cmd = (char *)PerlMem_malloc(cmdlen+1);
ebd4d70b 10579 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 10580 my_strlcpy(cmd, incmd, cmdlen + 1);
e886094b
JM		 10581 image_name[0] = 0;
10582 image_argv[0] = 0;
2fbb330f 10583
e919cd19
JM		 10584 resdsc.dsc$a_pointer = resspec;
10585 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10586 resdsc.dsc$b_class = DSC$K_CLASS_S;
10587 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10588
218fdd94
CL		 10589 vmscmd->dsc$a_pointer = NULL;
10590 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10591 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10592 vmscmd->dsc$w_length = 0;
10593 if (pvmscmd) *pvmscmd = vmscmd;
10594
ff7adb52
CL		 10595 if (suggest_quote) *suggest_quote = 0;
10596
2fbb330f 10597 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 10598 PerlMem_free(cmd);
e919cd19
JM		 10599 PerlMem_free(vmsspec);
10600 PerlMem_free(resspec);
a2669cfc 10601 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 10602 }
10603
a0d0e21e 10604 s = cmd;
2fbb330f 10605
a0d0e21e 10606 while (*s && isspace(*s)) s++;
aa779de1
CB		 10607
10608 if (*s == '@' || *s == '$') {
10609 vmsspec[0] = *s; rest = s + 1;
10610 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10611 }
10612 else { cp = vmsspec; rest = s; }
22831cc5
CB		 10613
10614 /* If the first word is quoted, then we need to unquote it and
10615 * escape spaces within it. We'll expand into the resspec buffer,
10616 * then copy back into the cmd buffer, expanding the latter if
10617 * necessary.
10618 */
10619 if (*rest == '"') {
10620 char *cp2;
10621 char *r = rest;
10622 bool in_quote = 0;
10623 int clen = cmdlen;
10624 int soff = s - cmd;
10625
10626 for (cp2 = resspec;
10627 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10628 rest++) {
10629
10630 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10631 *cp2 = '^';
10632 *(++cp2) = '_';
10633 cp2++;
10634 clen++;
10635 }
10636 else if (*rest == '"') {
10637 clen--;
10638 if (in_quote) { /* Must be closing quote. */
10639 rest++;
10640 break;
10641 }
10642 in_quote = 1;
10643 }
10644 else {
10645 *cp2 = *rest;
10646 cp2++;
10647 }
10648 }
10649 *cp2 = '\0';
10650
10651 /* Expand the command buffer if necessary. */
10652 if (clen > cmdlen) {
223c162b 10653 cmd = (char *)PerlMem_realloc(cmd, clen);
22831cc5
CB		 10654 if (cmd == NULL)
10655 _ckvmssts_noperl(SS$_INSFMEM);
10656 /* Where we are may have changed, so recompute offsets */
10657 r = cmd + (r - s - soff);
10658 rest = cmd + (rest - s - soff);
10659 s = cmd + soff;
10660 }
10661
10662 /* Shift the non-verb portion of the command (if any) up or
10663 * down as necessary.
10664 */
10665 if (*rest)
10666 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10667
10668 /* Copy the unquoted and escaped command verb into place. */
10669 memcpy(r, resspec, cp2 - resspec);
10670 cmd[clen] = '\0';
10671 cmdlen = clen;
10672 rest = r; /* Rewind for subsequent operations. */
10673 }
10674
aa779de1
CB		 10675 if (*rest == '.' || *rest == '/') {
10676 char *cp2;
10677 for (cp2 = resspec;
e919cd19 10678 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
aa779de1
CB		 10679 rest++, cp2++) *cp2 = *rest;
10680 *cp2 = '\0';
df278665 10681 if (int_tovmsspec(resspec, cp, 0, NULL)) {
aa779de1 10682 s = vmsspec;
cfbf46cd
JM		 10683
10684 /* When a UNIX spec with no file type is translated to VMS, */
10685 /* A trailing '.' is appended under ODS-5 rules. */
10686 /* Here we do not want that trailing "." as it prevents */
10687 /* Looking for a implied ".exe" type. */
10688 if (decc_efs_charset) {
10689 int i;
10690 i = strlen(vmsspec);
10691 if (vmsspec[i-1] == '.') {
10692 vmsspec[i-1] = '\0';
10693 }
10694 }
10695
aa779de1
CB		 10696 if (*rest) {
10697 for (cp2 = vmsspec + strlen(vmsspec);
e919cd19 10698 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
aa779de1
CB		 10699 rest++, cp2++) *cp2 = *rest;
10700 *cp2 = '\0';
a0d0e21e
LW		 10701 }
10702 }
10703 }
aa779de1
CB		 10704 /* Intuit whether verb (first word of cmd) is a DCL command:
10705 * - if first nonspace char is '@', it's a DCL indirection
10706 * otherwise
10707 * - if verb contains a filespec separator, it's not a DCL command
10708 * - if it doesn't, caller tells us whether to default to a DCL
10709 * command, or to a local image unless told it's DCL (by leading '$')
10710 */
ff7adb52
CL		 10711 if (*s == '@') {
10712 isdcl = 1;
10713 if (suggest_quote) *suggest_quote = 1;
10714 } else {
eb578fdb 10715 char *filespec = strpbrk(s,":<[.;");
aa779de1
CB		 10716 rest = wordbreak = strpbrk(s," \"\t/");
10717 if (!wordbreak) wordbreak = s + strlen(s);
10718 if (*s == '$') check_img = 0;
10719 if (filespec && (filespec < wordbreak)) isdcl = 0;
10720 else isdcl = !check_img;
10721 }
10722
3eeba6fb 10723 if (!isdcl) {
dca5a913 10724 int rsts;
aa779de1
CB		 10725 imgdsc.dsc$a_pointer = s;
10726 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 10727 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e 10728 if (!(retsts&1)) {
ebd4d70b 10729 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10730 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f 10731 if (!(retsts & 1) && *s == '$') {
ebd4d70b 10732 _ckvmssts_noperl(lib$find_file_end(&cxt));
2497a41f 10733 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 10734 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f 10735 if (!(retsts&1)) {
ebd4d70b 10736 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10737 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 10738 }
10739 }
aa779de1 10740 }
ebd4d70b 10741 _ckvmssts_noperl(lib$find_file_end(&cxt));
8012a33e 10742
aa779de1 10743 if (retsts & 1) {
8012a33e 10744 FILE *fp;
a0d0e21e
LW		 10745 s = resspec;
10746 while (*s && !isspace(*s)) s++;
10747 *s = '\0';
8012a33e
CB		 10748
10749 /* check that it's really not DCL with no file extension */
e886094b 10750 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 10751 if (fp) {
2497a41f
JM		 10752 char b[256] = {0,0,0,0};
10753 read(fileno(fp), b, 256);
8012a33e 10754 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 10755 if (isdcl) {
e886094b
JM		 10756 int shebang_len;
10757
2497a41f 10758 /* Check for script */
e886094b
JM		 10759 shebang_len = 0;
10760 if ((b[0] == '#') && (b[1] == '!'))
10761 shebang_len = 2;
10762#ifdef ALTERNATE_SHEBANG
10763 else {
10764 shebang_len = strlen(ALTERNATE_SHEBANG);
10765 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10766 char * perlstr;
10767 perlstr = strstr("perl",b);
10768 if (perlstr == NULL)
10769 shebang_len = 0;
10770 }
10771 else
10772 shebang_len = 0;
10773 }
10774#endif
10775
10776 if (shebang_len > 0) {
10777 int i;
10778 int j;
10779 char tmpspec[NAM$C_MAXRSS + 1];
10780
10781 i = shebang_len;
10782 /* Image is following after white space */
10783 /*--------------------------------------*/
10784 while (isprint(b[i]) && isspace(b[i]))
10785 i++;
10786
10787 j = 0;
10788 while (isprint(b[i]) && !isspace(b[i])) {
10789 tmpspec[j++] = b[i++];
10790 if (j >= NAM$C_MAXRSS)
10791 break;
10792 }
10793 tmpspec[j] = '\0';
10794
10795 /* There may be some default parameters to the image */
10796 /*---------------------------------------------------*/
10797 j = 0;
10798 while (isprint(b[i])) {
10799 image_argv[j++] = b[i++];
10800 if (j >= NAM$C_MAXRSS)
10801 break;
10802 }
10803 while ((j > 0) && !isprint(image_argv[j-1]))
10804 j--;
10805 image_argv[j] = 0;
10806
2497a41f 10807 /* It will need to be converted to VMS format and validated */
e886094b
JM		 10808 if (tmpspec[0] != '\0') {
10809 char * iname;
10810
10811 /* Try to find the exact program requested to be run */
10812 /*---------------------------------------------------*/
6fb6c614
JM		 10813 iname = int_rmsexpand
10814 (tmpspec, image_name, ".exe",
360732b5 10815 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10816 if (iname != NULL) {
a1887106
JM		 10817 if (cando_by_name_int
10818 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10819 /* MCR prefix needed */
10820 isdcl = 0;
10821 }
10822 else {
10823 /* Try again with a null type */
10824 /*----------------------------*/
6fb6c614
JM		 10825 iname = int_rmsexpand
10826 (tmpspec, image_name, ".",
360732b5 10827 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10828 if (iname != NULL) {
a1887106
JM		 10829 if (cando_by_name_int
10830 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10831 /* MCR prefix needed */
10832 isdcl = 0;
10833 }
10834 }
10835 }
10836
10837 /* Did we find the image to run the script? */
10838 /*------------------------------------------*/
10839 if (isdcl) {
10840 char *tchr;
10841
10842 /* Assume DCL or foreign command exists */
10843 /*--------------------------------------*/
10844 tchr = strrchr(tmpspec, '/');
10845 if (tchr != NULL) {
10846 tchr++;
10847 }
10848 else {
10849 tchr = tmpspec;
10850 }
a35dcc95 10851 my_strlcpy(image_name, tchr, sizeof(image_name));
e886094b
JM		 10852 }
10853 }
10854 }
2497a41f
JM		 10855 }
10856 }
8012a33e
CB		 10857 fclose(fp);
10858 }
e919cd19
JM		 10859 if (check_img && isdcl) {
10860 PerlMem_free(cmd);
10861 PerlMem_free(resspec);
10862 PerlMem_free(vmsspec);
10863 return RMS$_FNF;
10864 }
8012a33e 10865
3eeba6fb 10866 if (cando_by_name(S_IXUSR,0,resspec)) {
c11536f5 10867 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
ebd4d70b 10868 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012a33e 10869 if (!isdcl) {
a35dcc95 10870 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
e886094b 10871 if (image_name[0] != 0) {
a35dcc95
CB		 10872 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10873 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10874 }
10875 } else if (image_name[0] != 0) {
a35dcc95
CB		 10876 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10877 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
8012a33e 10878 } else {
a35dcc95 10879 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
8012a33e 10880 }
e886094b
JM		 10881 if (suggest_quote) *suggest_quote = 1;
10882
10883 /* If there is an image name, use original command */
10884 if (image_name[0] == 0)
a35dcc95 10885 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10886 else {
10887 rest = cmd;
10888 while (*rest && isspace(*rest)) rest++;
10889 }
10890
10891 if (image_argv[0] != 0) {
a35dcc95
CB		 10892 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10893 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10894 }
10895 if (rest) {
10896 int rest_len;
10897 int vmscmd_len;
10898
10899 rest_len = strlen(rest);
10900 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10901 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
a35dcc95 10902 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10903 else
10904 retsts = CLI$_BUFOVF;
10905 }
218fdd94 10906 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10907 PerlMem_free(cmd);
e919cd19
JM		 10908 PerlMem_free(vmsspec);
10909 PerlMem_free(resspec);
218fdd94 10910 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10911 }
c5375c28
JM		 10912 else
10913 retsts = RMS$_PRV;
a0d0e21e
LW		 10914 }
10915 }
3eeba6fb 10916 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10917 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10918
c11536f5 10919 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
a35dcc95 10920 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
c5375c28
JM		 10921
10922 PerlMem_free(cmd);
e919cd19
JM		 10923 PerlMem_free(resspec);
10924 PerlMem_free(vmsspec);
2fbb330f 10925
ff7adb52
CL		 10926 /* check if it's a symbol (for quoting purposes) */
10927 if (suggest_quote && !*suggest_quote) {
10928 int iss;
10929 char equiv[LNM$C_NAMLENGTH];
10930 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10931 eqvdsc.dsc$a_pointer = equiv;
10932
218fdd94 10933 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10934 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10935 }
3eeba6fb
CB		 10936 if (!(retsts & 1)) {
10937 /* just hand off status values likely to be due to user error */
10938 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10939 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10940 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
ebd4d70b 10941 else { _ckvmssts_noperl(retsts); }
3eeba6fb 10942 }
a0d0e21e 10943
218fdd94 10944 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10945
a0d0e21e
LW		 10946} /* end of setup_cmddsc() */
10947
a3e9d8c9 10948
a0d0e21e
LW		 10949/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10950bool
fd8cd3a3 10951Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10952{
ce12d4b7
CB		 10953 bool exec_sts;
10954 char * cmd;
c5375c28 10955
a0d0e21e
LW		 10956 if (sp > mark) {
10957 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10958 vfork_called--;
10959 if (vfork_called < 0) {
5c84aa53 10960 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10961 vfork_called = 0;
10962 }
10963 else return do_aexec(really,mark,sp);
a0d0e21e 10964 }
4633a7c4 10965 /* no vfork - act VMSish */
c5375c28
JM		 10966 cmd = setup_argstr(aTHX_ really,mark,sp);
10967 exec_sts = vms_do_exec(cmd);
10968 Safefree(cmd); /* Clean up from setup_argstr() */
10969 return exec_sts;
a0d0e21e
LW		 10970 }
10971
10972 return FALSE;
10973} /* end of vms_do_aexec() */
10974/*}}}*/
10975
10976/* {{{bool vms_do_exec(char *cmd) */
10977bool
2fbb330f 10978Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10979{
218fdd94 10980 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10981
10982 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10983 vfork_called--;
10984 if (vfork_called < 0) {
5c84aa53 10985 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10986 vfork_called = 0;
10987 }
10988 else return do_exec(cmd);
a0d0e21e 10989 }
748a9306
LW		 10990
10991 { /* no vfork - act VMSish */
748a9306 10992 unsigned long int retsts;
a0d0e21e 10993
1e422769 10994 TAINT_ENV();
10995 TAINT_PROPER("exec");
218fdd94
CL		 10996 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10997 retsts = lib$do_command(vmscmd);
a0d0e21e 10998
09b7f37c 10999 switch (retsts) {
f282b18d 11000 case RMS$_FNF: case RMS$_DNF:
09b7f37c 11001 set_errno(ENOENT); break;
f282b18d 11002 case RMS$_DIR:
09b7f37c 11003 set_errno(ENOTDIR); break;
f282b18d
CB		 11004 case RMS$_DEV:
11005 set_errno(ENODEV); break;
09b7f37c
CB		 11006 case RMS$_PRV:
11007 set_errno(EACCES); break;
11008 case RMS$_SYN:
11009 set_errno(EINVAL); break;
a2669cfc 11010 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 11011 set_errno(E2BIG); break;
11012 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 11013 _ckvmssts_noperl(retsts); /* fall through */
09b7f37c
CB		 11014 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11015 set_errno(EVMSERR);
11016 }
748a9306 11017 set_vaxc_errno(retsts);
3eeba6fb 11018 if (ckWARN(WARN_EXEC)) {
f98bc0c6 11019 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 11020 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 11021 }
218fdd94 11022 vms_execfree(vmscmd);
a0d0e21e
LW		 11023 }
11024
11025 return FALSE;
11026
11027} /* end of vms_do_exec() */
11028/*}}}*/
11029
9ec7171b 11030int do_spawn2(pTHX_ const char *, int);
a0d0e21e 11031
9ec7171b
CB		 11032int
11033Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
a0d0e21e 11034{
ce12d4b7
CB		 11035 unsigned long int sts;
11036 char * cmd;
11037 int flags = 0;
a0d0e21e 11038
c5375c28 11039 if (sp > mark) {
eed5d6a1
CB		 11040
11041 /* We'll copy the (undocumented?) Win32 behavior and allow a
11042 * numeric first argument. But the only value we'll support
11043 * through do_aspawn is a value of 1, which means spawn without
11044 * waiting for completion -- other values are ignored.
11045 */
9ec7171b 11046 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
eed5d6a1 11047 ++mark;
9ec7171b 11048 flags = SvIVx(*mark);
eed5d6a1
CB		 11049 }
11050
11051 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11052 flags = CLI$M_NOWAIT;
11053 else
11054 flags = 0;
11055
9ec7171b 11056 cmd = setup_argstr(aTHX_ really, mark, sp);
eed5d6a1 11057 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 11058 /* pp_sys will clean up cmd */
11059 return sts;
11060 }
a0d0e21e
LW		 11061 return SS$_ABORT;
11062} /* end of do_aspawn() */
11063/*}}}*/
11064
eed5d6a1 11065
9ec7171b
CB		 11066/* {{{int do_spawn(char* cmd) */
11067int
11068Perl_do_spawn(pTHX_ char* cmd)
a0d0e21e 11069{
7918f24d
NC		 11070 PERL_ARGS_ASSERT_DO_SPAWN;
11071
eed5d6a1
CB		 11072 return do_spawn2(aTHX_ cmd, 0);
11073}
11074/*}}}*/
11075
9ec7171b
CB		 11076/* {{{int do_spawn_nowait(char* cmd) */
11077int
11078Perl_do_spawn_nowait(pTHX_ char* cmd)
11079{
11080 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11081
11082 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11083}
11084/*}}}*/
11085
11086/* {{{int do_spawn2(char *cmd) */
11087int
eed5d6a1
CB		 11088do_spawn2(pTHX_ const char *cmd, int flags)
11089{
209030df 11090 unsigned long int sts, substs;
a0d0e21e 11091
c5375c28
JM		 11092 /* The caller of this routine expects to Safefree(PL_Cmd) */
11093 Newx(PL_Cmd,10,char);
11094
1e422769 11095 TAINT_ENV();
11096 TAINT_PROPER("spawn");
748a9306 11097 if (!cmd || !*cmd) {
eed5d6a1 11098 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 11099 if (!(sts & 1)) {
11100 switch (sts) {
209030df
JH		 11101 case RMS$_FNF: case RMS$_DNF:
11102 set_errno(ENOENT); break;
11103 case RMS$_DIR:
11104 set_errno(ENOTDIR); break;
11105 case RMS$_DEV:
11106 set_errno(ENODEV); break;
11107 case RMS$_PRV:
11108 set_errno(EACCES); break;
11109 case RMS$_SYN:
11110 set_errno(EINVAL); break;
11111 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11112 set_errno(E2BIG); break;
11113 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 11114 _ckvmssts_noperl(sts); /* fall through */
209030df
JH		 11115 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11116 set_errno(EVMSERR);
c8795d8b
JH		 11117 }
11118 set_vaxc_errno(sts);
11119 if (ckWARN(WARN_EXEC)) {
f98bc0c6 11120 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 11121 Strerror(errno));
11122 }
09b7f37c 11123 }
c8795d8b 11124 sts = substs;
48023aa8
CL		 11125 }
11126 else {
eed5d6a1 11127 char mode[3];
2fbb330f 11128 PerlIO * fp;
eed5d6a1
CB		 11129 if (flags & CLI$M_NOWAIT)
11130 strcpy(mode, "n");
11131 else
11132 strcpy(mode, "nW");
11133
11134 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 11135 if (fp != NULL)
11136 my_pclose(fp);
7d78c51a
CB		 11137 /* sts will be the pid in the nowait case, so leave a
11138 * hint saying not to do any bit shifting to it.
11139 */
11140 if (flags & CLI$M_NOWAIT)
11141 PL_statusvalue = -1;
48023aa8 11142 }
48023aa8 11143 return sts;
eed5d6a1 11144} /* end of do_spawn2() */
a0d0e21e
LW		 11145/*}}}*/
11146
bc10a425
CB		 11147
11148static unsigned int *sockflags, sockflagsize;
11149
11150/*
11151 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11152 * routines found in some versions of the CRTL can't deal with sockets.
11153 * We don't shim the other file open routines since a socket isn't
11154 * likely to be opened by a name.
11155 */
275feba9 11156/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
ce12d4b7
CB		 11157FILE *
11158my_fdopen(int fd, const char *mode)
bc10a425 11159{
f7ddb74a 11160 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 11161
11162 if (fp) {
11163 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 11164 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 11165 if (!sockflagsize || fdoff > sockflagsize) {
11166 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 11167 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 11168 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11169 sockflagsize = fdoff + 2;
11170 }
312ac60b 11171 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 11172 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11173 }
11174 return fp;
11175
11176}
11177/*}}}*/
11178
11179
11180/*
11181 * Clear the corresponding bit when the (possibly) socket stream is closed.
11182 * There still a small hole: we miss an implicit close which might occur
11183 * via freopen(). >> Todo
11184 */
11185/*{{{ int my_fclose(FILE *fp)*/
ce12d4b7
CB		 11186int
11187my_fclose(FILE *fp) {
bc10a425
CB		 11188 if (fp) {
11189 unsigned int fd = fileno(fp);
11190 unsigned int fdoff = fd / sizeof(unsigned int);
11191
e0951028 11192 if (sockflagsize && fdoff < sockflagsize)
bc10a425
CB		 11193 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11194 }
11195 return fclose(fp);
11196}
11197/*}}}*/
11198
11199
a0d0e21e
LW		 11200/*
11201 * A simple fwrite replacement which outputs itmsz*nitm chars without
11202 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 11203 * We are using fputs, which depends on a terminating null. We may
11204 * well be writing binary data, so we need to accommodate not only
11205 * data with nulls sprinkled in the middle but also data with no null
11206 * byte at the end.
a0d0e21e 11207 */
a15cef0c 11208/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 11209int
a15cef0c 11210my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 11211{
eb578fdb 11212 char *cp, *end, *cpd;
2e05a54c 11213 char *data;
eb578fdb
KW		 11214 unsigned int fd = fileno(dest);
11215 unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 11216 int retval;
bc10a425
CB		 11217 int bufsize = itmsz * nitm + 1;
11218
11219 if (fdoff < sockflagsize &&
11220 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11221 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11222 return nitm;
11223 }
22d4bb9c 11224
bc10a425 11225 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 11226 memcpy( data, src, itmsz*nitm );
11227 data[itmsz*nitm] = '\0';
a0d0e21e 11228
22d4bb9c
CB		 11229 end = data + itmsz * nitm;
11230 retval = (int) nitm; /* on success return # items written */
a0d0e21e 11231
22d4bb9c
CB		 11232 cpd = data;
11233 while (cpd <= end) {
11234 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11235 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 11236 if (cp < end)
22d4bb9c
CB		 11237 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11238 cpd = cp + 1;
a0d0e21e
LW		 11239 }
11240
bc10a425 11241 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 11242 return retval;
a0d0e21e
LW		 11243
11244} /* end of my_fwrite() */
11245/*}}}*/
11246
d27fe803
JH		 11247/*{{{ int my_flush(FILE *fp)*/
11248int
fd8cd3a3 11249Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 11250{
11251 int res;
93948341 11252 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 11253#ifdef VMS_DO_SOCKETS
61bb5906 11254 Stat_t s;
ed1b9de0 11255 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
d27fe803
JH		 11256#endif
11257 res = fsync(fileno(fp));
11258 }
22d4bb9c
CB		 11259/*
11260 * If the flush succeeded but set end-of-file, we need to clear
11261 * the error because our caller may check ferror(). BTW, this
11262 * probably means we just flushed an empty file.
11263 */
11264 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11265
d27fe803
JH		 11266 return res;
11267}
11268/*}}}*/
11269
bf8d1304
JM		 11270/* fgetname() is not returning the correct file specifications when
11271 * decc_filename_unix_report mode is active. So we have to have it
11272 * aways return filenames in VMS mode and convert it ourselves.
11273 */
11274
11275/*{{{ char * my_fgetname(FILE *fp, buf)*/
11276char *
11277Perl_my_fgetname(FILE *fp, char * buf) {
11278 char * retname;
11279 char * vms_name;
11280
11281 retname = fgetname(fp, buf, 1);
11282
11283 /* If we are in VMS mode, then we are done */
11284 if (!decc_filename_unix_report || (retname == NULL)) {
11285 return retname;
11286 }
11287
11288 /* Convert this to Unix format */
c11536f5 11289 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 11290 my_strlcpy(vms_name, retname, VMS_MAXRSS);
bf8d1304
JM		 11291 retname = int_tounixspec(vms_name, buf, NULL);
11292 PerlMem_free(vms_name);
11293
11294 return retname;
11295}
11296/*}}}*/
11297
748a9306
LW		 11298/*
11299 * Here are replacements for the following Unix routines in the VMS environment:
11300 * getpwuid Get information for a particular UIC or UID
11301 * getpwnam Get information for a named user
11302 * getpwent Get information for each user in the rights database
11303 * setpwent Reset search to the start of the rights database
11304 * endpwent Finish searching for users in the rights database
11305 *
11306 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11307 * (defined in pwd.h), which contains the following fields:-
11308 * struct passwd {
11309 * char *pw_name; Username (in lower case)
11310 * char *pw_passwd; Hashed password
11311 * unsigned int pw_uid; UIC
11312 * unsigned int pw_gid; UIC group number
11313 * char *pw_unixdir; Default device/directory (VMS-style)
11314 * char *pw_gecos; Owner name
11315 * char *pw_dir; Default device/directory (Unix-style)
11316 * char *pw_shell; Default CLI name (eg. DCL)
11317 * };
11318 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11319 *
11320 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11321 * not the UIC member number (eg. what's returned by getuid()),
11322 * getpwuid() can accept either as input (if uid is specified, the caller's
11323 * UIC group is used), though it won't recognise gid=0.
11324 *
11325 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11326 * information about other users in your group or in other groups, respectively.
11327 * If the required privilege is not available, then these routines fill only
11328 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11329 * string).
11330 *
11331 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11332 */
11333
11334/* sizes of various UAF record fields */
11335#define UAI$S_USERNAME 12
11336#define UAI$S_IDENT 31
11337#define UAI$S_OWNER 31
11338#define UAI$S_DEFDEV 31
11339#define UAI$S_DEFDIR 63
11340#define UAI$S_DEFCLI 31
11341#define UAI$S_PWD 8
11342
11343#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11344 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11345 (uic).uic$v_group != UIC$K_WILD_GROUP)
11346
4633a7c4
LW		 11347static char __empty[]= "";
11348static struct passwd __passwd_empty=
748a9306
LW		 11349 {(char *) __empty, (char *) __empty, 0, 0,
11350 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11351static int contxt= 0;
11352static struct passwd __pwdcache;
11353static char __pw_namecache[UAI$S_IDENT+1];
11354
748a9306
LW		 11355/*
11356 * This routine does most of the work extracting the user information.
11357 */
ce12d4b7
CB		 11358static int
11359fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 11360{
748a9306
LW		 11361 static struct {
11362 unsigned char length;
11363 char pw_gecos[UAI$S_OWNER+1];
11364 } owner;
11365 static union uicdef uic;
11366 static struct {
11367 unsigned char length;
11368 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11369 } defdev;
11370 static struct {
11371 unsigned char length;
11372 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11373 } defdir;
11374 static struct {
11375 unsigned char length;
11376 char pw_shell[UAI$S_DEFCLI+1];
11377 } defcli;
11378 static char pw_passwd[UAI$S_PWD+1];
11379
11380 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11381 struct dsc$descriptor_s name_desc;
c07a80fd 11382 unsigned long int sts;
748a9306 11383
4633a7c4 11384 static struct itmlst_3 itmlst[]= {
748a9306
LW		 11385 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11386 {sizeof(uic), UAI$_UIC, &uic, &luic},
11387 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11388 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11389 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11390 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11391 {0, 0, NULL, NULL}};
11392
11393 name_desc.dsc$w_length= strlen(name);
11394 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11395 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 11396 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 11397
11398/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 11399 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11400 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11401 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11402 }
11403 else { _ckvmssts(sts); }
11404 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 11405
11406 if ((int) owner.length < lowner) lowner= (int) owner.length;
11407 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11408 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11409 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11410 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11411 owner.pw_gecos[lowner]= '\0';
11412 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11413 defcli.pw_shell[ldefcli]= '\0';
11414 if (valid_uic(uic)) {
11415 pwd->pw_uid= uic.uic$l_uic;
11416 pwd->pw_gid= uic.uic$v_group;
11417 }
11418 else
5c84aa53 11419 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 11420 pwd->pw_passwd= pw_passwd;
11421 pwd->pw_gecos= owner.pw_gecos;
11422 pwd->pw_dir= defdev.pw_dir;
360732b5 11423 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 11424 pwd->pw_shell= defcli.pw_shell;
11425 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11426 int ldir;
11427 ldir= strlen(pwd->pw_unixdir) - 1;
11428 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11429 }
11430 else
a35dcc95 11431 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
f7ddb74a
JM		 11432 if (!decc_efs_case_preserve)
11433 __mystrtolower(pwd->pw_unixdir);
c07a80fd 11434 return 1;
a0d0e21e 11435}
748a9306
LW		 11436
11437/*
11438 * Get information for a named user.
11439*/
11440/*{{{struct passwd *getpwnam(char *name)*/
ce12d4b7
CB		 11441struct passwd *
11442Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 11443{
11444 struct dsc$descriptor_s name_desc;
11445 union uicdef uic;
4e0c9737 11446 unsigned long int sts;
748a9306
LW		 11447
11448 __pwdcache = __passwd_empty;
fd8cd3a3 11449 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 11450 /* We still may be able to determine pw_uid and pw_gid */
11451 name_desc.dsc$w_length= strlen(name);
11452 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11453 name_desc.dsc$b_class= DSC$K_CLASS_S;
11454 name_desc.dsc$a_pointer= (char *) name;
aa689395 11455 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 11456 __pwdcache.pw_uid= uic.uic$l_uic;
11457 __pwdcache.pw_gid= uic.uic$v_group;
11458 }
c07a80fd 11459 else {
aa689395 11460 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11461 set_vaxc_errno(sts);
11462 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 11463 return NULL;
11464 }
aa689395 11465 else { _ckvmssts(sts); }
c07a80fd 11466 }
748a9306 11467 }
a35dcc95 11468 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
748a9306
LW		 11469 __pwdcache.pw_name= __pw_namecache;
11470 return &__pwdcache;
11471} /* end of my_getpwnam() */
a0d0e21e
LW		 11472/*}}}*/
11473
748a9306
LW		 11474/*
11475 * Get information for a particular UIC or UID.
11476 * Called by my_getpwent with uid=-1 to list all users.
11477*/
11478/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
ce12d4b7
CB		 11479struct passwd *
11480Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 11481{
748a9306
LW		 11482 const $DESCRIPTOR(name_desc,__pw_namecache);
11483 unsigned short lname;
11484 union uicdef uic;
11485 unsigned long int status;
11486
11487 if (uid == (unsigned int) -1) {
11488 do {
11489 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11490 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 11491 set_vaxc_errno(status);
11492 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 11493 my_endpwent();
11494 return NULL;
11495 }
11496 else { _ckvmssts(status); }
11497 } while (!valid_uic (uic));
11498 }
11499 else {
11500 uic.uic$l_uic= uid;
c07a80fd 11501 if (!uic.uic$v_group)
76e3520e 11502 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 11503 if (valid_uic(uic))
11504 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11505 else status = SS$_IVIDENT;
c07a80fd 11506 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11507 status == RMS$_PRV) {
11508 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11509 return NULL;
11510 }
11511 else { _ckvmssts(status); }
748a9306
LW		 11512 }
11513 __pw_namecache[lname]= '\0';
01b8edb6 11514 __mystrtolower(__pw_namecache);
748a9306
LW		 11515
11516 __pwdcache = __passwd_empty;
11517 __pwdcache.pw_name = __pw_namecache;
11518
11519/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11520 The identifier's value is usually the UIC, but it doesn't have to be,
11521 so if we can, we let fillpasswd update this. */
11522 __pwdcache.pw_uid = uic.uic$l_uic;
11523 __pwdcache.pw_gid = uic.uic$v_group;
11524
fd8cd3a3 11525 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 11526 return &__pwdcache;
a0d0e21e 11527
748a9306
LW		 11528} /* end of my_getpwuid() */
11529/*}}}*/
11530
11531/*
11532 * Get information for next user.
11533*/
11534/*{{{struct passwd *my_getpwent()*/
ce12d4b7
CB		 11535struct passwd *
11536Perl_my_getpwent(pTHX)
748a9306
LW		 11537{
11538 return (my_getpwuid((unsigned int) -1));
11539}
11540/*}}}*/
a0d0e21e 11541
748a9306
LW		 11542/*
11543 * Finish searching rights database for users.
11544*/
11545/*{{{void my_endpwent()*/
ce12d4b7
CB		 11546void
11547Perl_my_endpwent(pTHX)
748a9306
LW		 11548{
11549 if (contxt) {
11550 _ckvmssts(sys$finish_rdb(&contxt));
11551 contxt= 0;
11552 }
a0d0e21e
LW		 11553}
11554/*}}}*/
748a9306 11555
ff0cee69 11556/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11557 * my_utime(), and flex_stat(), all of which operate on UTC unless
11558 * VMSISH_TIMES is true.
11559 */
11560/* method used to handle UTC conversions:
11561 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 11562 */
ff0cee69 11563static int gmtime_emulation_type;
11564/* number of secs to add to UTC POSIX-style time to get local time */
11565static long int utc_offset_secs;
e518068a 11566
ff0cee69 11567/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11568 * in vmsish.h. #undef them here so we can call the CRTL routines
11569 * directly.
e518068a 11570 */
11571#undef gmtime
ff0cee69 11572#undef localtime
11573#undef time
11574
61bb5906
CB		 11575
11576static time_t toutc_dst(time_t loc) {
11577 struct tm *rsltmp;
11578
f7c699a0 11579 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
61bb5906
CB		 11580 loc -= utc_offset_secs;
11581 if (rsltmp->tm_isdst) loc -= 3600;
11582 return loc;
11583}
32da55ab 11584#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11585 ((gmtime_emulation_type || my_time(NULL)), \
11586 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11587 ((secs) - utc_offset_secs))))
11588
11589static time_t toloc_dst(time_t utc) {
11590 struct tm *rsltmp;
11591
11592 utc += utc_offset_secs;
f7c699a0 11593 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
61bb5906
CB		 11594 if (rsltmp->tm_isdst) utc += 3600;
11595 return utc;
11596}
32da55ab 11597#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11598 ((gmtime_emulation_type || my_time(NULL)), \
11599 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11600 ((secs) + utc_offset_secs))))
11601
ff0cee69 11602/* my_time(), my_localtime(), my_gmtime()
61bb5906 11603 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11604 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11605 * Note: We need to use these functions even when the CRTL has working
11606 * UTC support, since they also handle C<use vmsish qw(times);>
11607 *
ff0cee69 11608 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11609 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11610 */
11611
11612/*{{{time_t my_time(time_t *timep)*/
ce12d4b7
CB		 11613time_t
11614Perl_my_time(pTHX_ time_t *timep)
e518068a 11615{
e518068a 11616 time_t when;
61bb5906 11617 struct tm *tm_p;
e518068a 11618
11619 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11620 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11621 /* results of calls to gmtime() and localtime() */
11622 /* for same &base */
ff0cee69 11623
e518068a 11624 gmtime_emulation_type++;
ff0cee69 11625 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11626 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11627
e518068a 11628 gmtime_emulation_type++;
f675dbe5 11629 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11630 gmtime_emulation_type++;
22d4bb9c 11631 utc_offset_secs = 0;
5c84aa53 11632 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11633 }
11634 else { utc_offset_secs = atol(off); }
e518068a 11635 }
ff0cee69 11636 else { /* We've got a working gmtime() */
11637 struct tm gmt, local;
e518068a 11638
ff0cee69 11639 gmt = *tm_p;
11640 tm_p = localtime(&base);
11641 local = *tm_p;
11642 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11643 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11644 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11645 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11646 }
e518068a 11647 }
ff0cee69 11648
11649 when = time(NULL);
61bb5906 11650# ifdef VMSISH_TIME
61bb5906 11651 if (VMSISH_TIME) when = _toloc(when);
61bb5906 11652# endif
ff0cee69 11653 if (timep != NULL) *timep = when;
11654 return when;
11655
11656} /* end of my_time() */
11657/*}}}*/
11658
11659
11660/*{{{struct tm *my_gmtime(const time_t *timep)*/
11661struct tm *
fd8cd3a3 11662Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11663{
ff0cee69 11664 time_t when;
61bb5906 11665 struct tm *rsltmp;
ff0cee69 11666
68dc0745 11667 if (timep == NULL) {
11668 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11669 return NULL;
11670 }
11671 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11672
11673 when = *timep;
11674# ifdef VMSISH_TIME
61bb5906
CB		 11675 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11676# endif
61bb5906 11677 return gmtime(&when);
e518068a 11678} /* end of my_gmtime() */
e518068a 11679/*}}}*/
11680
11681
ff0cee69 11682/*{{{struct tm *my_localtime(const time_t *timep)*/
11683struct tm *
fd8cd3a3 11684Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11685{
c11536f5 11686 time_t when;
ff0cee69 11687
68dc0745 11688 if (timep == NULL) {
11689 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11690 return NULL;
11691 }
11692 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11693 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11694
11695 when = *timep;
11696# ifdef VMSISH_TIME
61bb5906 11697 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11698# endif
61bb5906 11699 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11700 return localtime(&when);
ff0cee69 11701} /* end of my_localtime() */
11702/*}}}*/
11703
11704/* Reset definitions for later calls */
11705#define gmtime(t) my_gmtime(t)
11706#define localtime(t) my_localtime(t)
11707#define time(t) my_time(t)
11708
11709
941b3de1
CB		 11710/* my_utime - update modification/access time of a file
11711 *
941b3de1
CB		 11712 * Only the UTC translation is home-grown. The rest is handled by the
11713 * CRTL utime(), which will take into account the relevant feature
11714 * logicals and ODS-5 volume characteristics for true access times.
11715 *
ff0cee69 11716 */
11717
11718/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11719 * to VMS epoch (01-JAN-1858 00:00:00.00)
11720 * in 100 ns intervals.
11721 */
11722static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11723
94a11853 11724/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
ce12d4b7
CB		 11725int
11726Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11727{
941b3de1
CB		 11728 struct utimbuf utc_utimes, *utc_utimesp;
11729
11730 if (utimes != NULL) {
11731 utc_utimes.actime = utimes->actime;
11732 utc_utimes.modtime = utimes->modtime;
11733# ifdef VMSISH_TIME
11734 /* If input was local; convert to UTC for sys svc */
11735 if (VMSISH_TIME) {
11736 utc_utimes.actime = _toutc(utimes->actime);
11737 utc_utimes.modtime = _toutc(utimes->modtime);
11738 }
11739# endif
11740 utc_utimesp = &utc_utimes;
11741 }
11742 else {
11743 utc_utimesp = NULL;
11744 }
11745
11746 return utime(file, utc_utimesp);
11747
ff0cee69 11748} /* end of my_utime() */
11749/*}}}*/
11750
748a9306 11751/*
2497a41f 11752 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11753 * basic stat, but gets it right when asked to stat
11754 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11755 */
11756
2497a41f 11757#ifndef _USE_STD_STAT
748a9306
LW		 11758/* encode_dev packs a VMS device name string into an integer to allow
11759 * simple comparisons. This can be used, for example, to check whether two
11760 * files are located on the same device, by comparing their encoded device
11761 * names. Even a string comparison would not do, because stat() reuses the
11762 * device name buffer for each call; so without encode_dev, it would be
11763 * necessary to save the buffer and use strcmp (this would mean a number of
11764 * changes to the standard Perl code, to say nothing of what a Perl script
11765 * would have to do.
11766 *
11767 * The device lock id, if it exists, should be unique (unless perhaps compared
11768 * with lock ids transferred from other nodes). We have a lock id if the disk is
11769 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11770 * device names. Thus we use the lock id in preference, and only if that isn't
11771 * available, do we try to pack the device name into an integer (flagged by
11772 * the sign bit (LOCKID_MASK) being set).
11773 *
e518068a 11774 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11775 * name and its encoded form, but it seems very unlikely that we will find
11776 * two files on different disks that share the same encoded device names,
11777 * and even more remote that they will share the same file id (if the test
11778 * is to check for the same file).
11779 *
11780 * A better method might be to use sys$device_scan on the first call, and to
11781 * search for the device, returning an index into the cached array.
cb9e088c 11782 * The number returned would be more intelligible.
748a9306
LW		 11783 * This is probably not worth it, and anyway would take quite a bit longer
11784 * on the first call.
11785 */
11786#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
ce12d4b7
CB		 11787static mydev_t
11788encode_dev (pTHX_ const char *dev)
748a9306
LW		 11789{
11790 int i;
11791 unsigned long int f;
aa689395 11792 mydev_t enc;
748a9306
LW		 11793 char c;
11794 const char *q;
11795
11796 if (!dev || !dev[0]) return 0;
11797
11798#if LOCKID_MASK
11799 {
11800 struct dsc$descriptor_s dev_desc;
cb9e088c 11801 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11802
11803 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11804 can try that first. */
11805 dev_desc.dsc$w_length = strlen (dev);
11806 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11807 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11808 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11809 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11810 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11811 switch (status) {
11812 case SS$_NOSUCHDEV:
11813 SETERRNO(ENODEV, status);
11814 return 0;
11815 default:
11816 _ckvmssts(status);
11817 }
11818 }
748a9306
LW		 11819 if (lockid) return (lockid & ~LOCKID_MASK);
11820 }
a0d0e21e 11821#endif
748a9306
LW		 11822
11823 /* Otherwise we try to encode the device name */
11824 enc = 0;
11825 f = 1;
11826 i = 0;
11827 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11828 if (*q == ':')
11829 break;
748a9306
LW		 11830 if (isdigit (*q))
11831 c= (*q) - '0';
11832 else if (isalpha (toupper (*q)))
11833 c= toupper (*q) - 'A' + (char)10;
11834 else
11835 continue; /* Skip '$'s */
11836 i++;
11837 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11838 if (i>1) f *= 36;
11839 enc += f * (unsigned long int) c;
11840 }
11841 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11842
11843} /* end of encode_dev() */
cfcfe586
JM		 11844#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11845 device_no = encode_dev(aTHX_ devname)
11846#else
11847#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11848 device_no = new_dev_no
2497a41f 11849#endif
748a9306 11850
748a9306 11851static int
135577da 11852is_null_device(const char *name)
748a9306 11853{
2497a41f 11854 if (decc_bug_devnull != 0) {
682e4b71 11855 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 11856 return 1;
11857 }
748a9306
LW		 11858 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11859 The underscore prefix, controller letter, and unit number are
11860 independently optional; for our purposes, the colon punctuation
11861 is not. The colon can be trailed by optional directory and/or
11862 filename, but two consecutive colons indicates a nodename rather
11863 than a device. [pr] */
11864 if (*name == '_') ++name;
11865 if (tolower(*name++) != 'n') return 0;
11866 if (tolower(*name++) != 'l') return 0;
11867 if (tolower(*name) == 'a') ++name;
11868 if (*name == '0') ++name;
11869 return (*name++ == ':') && (*name != ':');
11870}
11871
312ac60b
JM		 11872static int
11873Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
c07a80fd 11874
46c05374
CB		 11875#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11876
a1887106 11877static I32
ce12d4b7 11878Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11879{
e538e23f
CB		 11880 char usrname[L_cuserid];
11881 struct dsc$descriptor_s usrdsc =
748a9306 11882 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11883 char *vmsname = NULL, *fileified = NULL;
597c27e2 11884 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11885 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11886 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11887 union prvdef curprv;
597c27e2
CB		 11888 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11889 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11890 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11891 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11892 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11893 {0,0,0,0}};
11894 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11895 {0,0,0,0}};
ada67d10 11896 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11897 Stat_t st;
6151c65c 11898 static int profile_context = -1;
748a9306
LW		 11899
11900 if (!fname || !*fname) return FALSE;
a1887106 11901
e538e23f 11902 /* Make sure we expand logical names, since sys$check_access doesn't */
c11536f5 11903 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11904 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f 11905 if (!strpbrk(fname,"/]>:")) {
a35dcc95 11906 my_strlcpy(fileified, fname, VMS_MAXRSS);
a1887106 11907 trnlnm_iter_count = 0;
e538e23f 11908 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11909 trnlnm_iter_count++;
11910 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11911 }
11912 fname = fileified;
e538e23f
CB		 11913 }
11914
c11536f5 11915 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11916 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f
CB		 11917 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11918 /* Don't know if already in VMS format, so make sure */
360732b5 11919 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11920 PerlMem_free(fileified);
e538e23f 11921 PerlMem_free(vmsname);
a1887106
JM		 11922 return FALSE;
11923 }
a1887106
JM		 11924 }
11925 else {
a35dcc95 11926 my_strlcpy(vmsname, fname, VMS_MAXRSS);
a5f75d66
AD		 11927 }
11928
858aded6 11929 /* sys$check_access needs a file spec, not a directory spec.
312ac60b 11930 * flex_stat now will handle a null thread context during startup.
858aded6 11931 */
e538e23f
CB		 11932
11933 retlen = namdsc.dsc$w_length = strlen(vmsname);
11934 if (vmsname[retlen-1] == ']'
11935 || vmsname[retlen-1] == '>'
858aded6 11936 || vmsname[retlen-1] == ':'
46c05374 11937 || (!flex_stat_int(vmsname, &st, 1) &&
312ac60b 11938 S_ISDIR(st.st_mode))) {
e538e23f 11939
a979ce91 11940 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
e538e23f
CB		 11941 PerlMem_free(fileified);
11942 PerlMem_free(vmsname);
11943 return FALSE;
11944 }
11945 fname = fileified;
11946 }
858aded6
CB		 11947 else {
11948 fname = vmsname;
11949 }
e538e23f
CB		 11950
11951 retlen = namdsc.dsc$w_length = strlen(fname);
11952 namdsc.dsc$a_pointer = (char *)fname;
11953
748a9306 11954 switch (bit) {
f282b18d 11955 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11956 access = ARM$M_EXECUTE;
597c27e2
CB		 11957 flags = CHP$M_READ;
11958 break;
f282b18d 11959 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11960 access = ARM$M_READ;
597c27e2
CB		 11961 flags = CHP$M_READ | CHP$M_USEREADALL;
11962 break;
f282b18d 11963 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11964 access = ARM$M_WRITE;
597c27e2
CB		 11965 flags = CHP$M_READ | CHP$M_WRITE;
11966 break;
f282b18d 11967 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11968 access = ARM$M_DELETE;
597c27e2
CB		 11969 flags = CHP$M_READ | CHP$M_WRITE;
11970 break;
748a9306 11971 default:
a1887106
JM		 11972 if (fileified != NULL)
11973 PerlMem_free(fileified);
e538e23f
CB		 11974 if (vmsname != NULL)
11975 PerlMem_free(vmsname);
748a9306
LW		 11976 return FALSE;
11977 }
11978
ada67d10
CB		 11979 /* Before we call $check_access, create a user profile with the current
11980 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11981 * UAF and might give false positives or negatives. This only works on
11982 * VMS versions v6.0 and later since that's when sys$create_user_profile
11983 * became available.
ada67d10
CB		 11984 */
11985
11986 /* get current process privs and username */
ebd4d70b
JM		 11987 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11988 _ckvmssts_noperl(iosb[0]);
ada67d10
CB		 11989
11990 /* find out the space required for the profile */
ebd4d70b 11991 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11992 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11993
11994 /* allocate space for the profile and get it filled in */
c11536f5 11995 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
ebd4d70b
JM		 11996 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11997 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 11998 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11999
12000 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 12001 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 12002 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 12003 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c 12004
bbce6d69 12005 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 12006 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 12007 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 12008 set_vaxc_errno(retsts);
12009 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12010 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12011 else set_errno(ENOENT);
a1887106
JM		 12012 if (fileified != NULL)
12013 PerlMem_free(fileified);
e538e23f
CB		 12014 if (vmsname != NULL)
12015 PerlMem_free(vmsname);
a3e9d8c9 12016 return FALSE;
12017 }
ada67d10 12018 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 12019 if (fileified != NULL)
12020 PerlMem_free(fileified);
e538e23f
CB		 12021 if (vmsname != NULL)
12022 PerlMem_free(vmsname);
3a385817
GS		 12023 return TRUE;
12024 }
ebd4d70b 12025 _ckvmssts_noperl(retsts);
748a9306 12026
a1887106
JM		 12027 if (fileified != NULL)
12028 PerlMem_free(fileified);
e538e23f
CB		 12029 if (vmsname != NULL)
12030 PerlMem_free(vmsname);
748a9306
LW		 12031 return FALSE; /* Should never get here */
12032
a1887106
JM		 12033}
12034
12035/* Do the permissions allow some operation? Assumes PL_statcache already set. */
12036/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12037 * subset of the applicable information.
12038 */
12039bool
12040Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12041{
12042 return cando_by_name_int
12043 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12044} /* end of cando() */
12045/*}}}*/
12046
12047
12048/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12049I32
12050Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12051{
12052 return cando_by_name_int(bit, effective, fname, 0);
12053
748a9306
LW		 12054} /* end of cando_by_name() */
12055/*}}}*/
12056
12057
61bb5906 12058/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 12059int
fd8cd3a3 12060Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 12061{
a1027d22 12062 dSAVE_ERRNO; /* fstat may set this even on success */
312ac60b 12063 if (!fstat(fd, &statbufp->crtl_stat)) {
75796008 12064 char *cptr;
988c775c 12065 char *vms_filename;
c11536f5 12066 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
988c775c 12067 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 12068
988c775c
JM		 12069 /* Save name for cando by name in VMS format */
12070 cptr = getname(fd, vms_filename, 1);
75796008 12071
988c775c
JM		 12072 /* This should not happen, but just in case */
12073 if (cptr == NULL) {
12074 statbufp->st_devnam[0] = 0;
12075 }
12076 else {
12077 /* Make sure that the saved name fits in 255 characters */
6fb6c614 12078 cptr = int_rmsexpand_vms
988c775c
JM		 12079 (vms_filename,
12080 statbufp->st_devnam,
6fb6c614 12081 0);
75796008 12082 if (cptr == NULL)
988c775c 12083 statbufp->st_devnam[0] = 0;
75796008 12084 }
988c775c 12085 PerlMem_free(vms_filename);
682e4b71
JM		 12086
12087 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12088 VMS_DEVICE_ENCODE
12089 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 12090
61bb5906
CB		 12091# ifdef VMSISH_TIME
12092 if (VMSISH_TIME) {
12093 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12094 statbufp->st_atime = _toloc(statbufp->st_atime);
12095 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12096 }
12097# endif
a1027d22 12098 RESTORE_ERRNO;
b7ae7a0d 12099 return 0;
12100 }
12101 return -1;
748a9306
LW		 12102
12103} /* end of flex_fstat() */
12104/*}}}*/
12105
2497a41f
JM		 12106static int
12107Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 12108{
9b9f19da
CB		 12109 char *temp_fspec = NULL;
12110 char *fileified = NULL;
312ac60b
JM		 12111 const char *save_spec;
12112 char *ret_spec;
bbce6d69 12113 int retval = -1;
cc5de3bd
CB		 12114 char efs_hack = 0;
12115 char already_fileified = 0;
4ee39169 12116 dSAVEDERRNO;
748a9306 12117
312ac60b
JM		 12118 if (!fspec) {
12119 errno = EINVAL;
12120 return retval;
12121 }
988c775c 12122
2497a41f 12123 if (decc_bug_devnull != 0) {
312ac60b 12124 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2497a41f 12125 memset(statbufp,0,sizeof *statbufp);
cfcfe586 12126 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 12127 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12128 statbufp->st_uid = 0x00010001;
12129 statbufp->st_gid = 0x0001;
12130 time((time_t *)&statbufp->st_mtime);
12131 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12132 return 0;
12133 }
748a9306
LW		 12134 }
12135
9b9f19da
CB		 12136 SAVE_ERRNO;
12137
054a3baf 12138#if __CRTL_VER >= 80200000
9b9f19da
CB		 12139 /*
12140 * If we are in POSIX filespec mode, accept the filename as is.
12141 */
12142 if (decc_posix_compliant_pathnames == 0) {
12143#endif
12144
12145 /* Try for a simple stat first. If fspec contains a filename without
61bb5906 12146 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9b9f19da 12147 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
bbce6d69 12148 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12149 * not sea:[wine.dark]., if the latter exists. If the intended target is
12150 * the file with null type, specify this by calling flex_stat() with
12151 * a '.' at the end of fspec.
12152 */
f36b279d 12153
9b9f19da
CB		 12154 if (lstat_flag == 0)
12155 retval = stat(fspec, &statbufp->crtl_stat);
12156 else
12157 retval = lstat(fspec, &statbufp->crtl_stat);
f36b279d 12158
cc5de3bd
CB		 12159 if (!retval) {
12160 save_spec = fspec;
12161 }
12162 else {
12163 /* In the odd case where we have write but not read access
12164 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12165 */
c11536f5 12166 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
cc5de3bd
CB		 12167 if (fileified == NULL)
12168 _ckvmssts_noperl(SS$_INSFMEM);
12169
12170 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12171 if (ret_spec != NULL) {
12172 if (lstat_flag == 0)
12173 retval = stat(fileified, &statbufp->crtl_stat);
12174 else
12175 retval = lstat(fileified, &statbufp->crtl_stat);
12176 save_spec = fileified;
12177 already_fileified = 1;
12178 }
12179 }
12180
312ac60b
JM		 12181 if (retval && vms_bug_stat_filename) {
12182
c11536f5 12183 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12184 if (temp_fspec == NULL)
12185 _ckvmssts_noperl(SS$_INSFMEM);
12186
12187 /* We should try again as a vmsified file specification. */
312ac60b
JM		 12188
12189 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12190 if (ret_spec != NULL) {
12191 if (lstat_flag == 0)
12192 retval = stat(temp_fspec, &statbufp->crtl_stat);
12193 else
12194 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12195 save_spec = temp_fspec;
12196 }
2497a41f 12197 }
312ac60b 12198
f1db9cda 12199 if (retval) {
9b9f19da 12200 /* Last chance - allow multiple dots without EFS CHARSET */
312ac60b
JM		 12201 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12202 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12203 * enable it if it isn't already.
12204 */
312ac60b
JM		 12205 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12206 decc$feature_set_value(decc_efs_charset_index, 1, 1);
312ac60b
JM		 12207 if (lstat_flag == 0)
12208 retval = stat(fspec, &statbufp->crtl_stat);
12209 else
12210 retval = lstat(fspec, &statbufp->crtl_stat);
12211 save_spec = fspec;
312ac60b
JM		 12212 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12213 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12214 efs_hack = 1;
12215 }
f1db9cda 12216 }
312ac60b 12217
054a3baf 12218#if __CRTL_VER >= 80200000
2497a41f
JM		 12219 } else {
12220 if (lstat_flag == 0)
312ac60b 12221 retval = stat(temp_fspec, &statbufp->crtl_stat);
2497a41f 12222 else
312ac60b 12223 retval = lstat(temp_fspec, &statbufp->crtl_stat);
988c775c 12224 save_spec = temp_fspec;
2497a41f
JM		 12225 }
12226#endif
f36b279d 12227
f36b279d
CB		 12228 /* As you were... */
12229 if (!decc_efs_charset)
12230 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
f36b279d 12231
ff0cee69 12232 if (!retval) {
9b9f19da
CB		 12233 char *cptr;
12234 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
d584a1c6
JM		 12235
12236 /* If this is an lstat, do not follow the link */
12237 if (lstat_flag)
12238 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12239
312ac60b
JM		 12240 /* If we used the efs_hack above, we must also use it here for */
12241 /* perl_cando to work */
12242 if (efs_hack && (decc_efs_charset_index > 0)) {
12243 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12244 }
9b9f19da
CB		 12245
12246 /* If we've got a directory, save a fileified, expanded version of it
12247 * in st_devnam. If not a directory, just an expanded version.
12248 */
cc5de3bd 12249 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
c11536f5 12250 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12251 if (fileified == NULL)
12252 _ckvmssts_noperl(SS$_INSFMEM);
12253
12254 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12255 if (cptr != NULL)
12256 save_spec = fileified;
12257 }
12258
12259 cptr = int_rmsexpand(save_spec,
12260 statbufp->st_devnam,
12261 NULL,
12262 rmsex_flags,
12263 0,
12264 0);
12265
312ac60b
JM		 12266 if (efs_hack && (decc_efs_charset_index > 0)) {
12267 decc$feature_set_value(decc_efs_charset, 1, 0);
12268 }
312ac60b
JM		 12269
12270 /* Fix me: If this is NULL then stat found a file, and we could */
12271 /* not convert the specification to VMS - Should never happen */
988c775c
JM		 12272 if (cptr == NULL)
12273 statbufp->st_devnam[0] = 0;
12274
682e4b71 12275 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12276 VMS_DEVICE_ENCODE
12277 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 12278# ifdef VMSISH_TIME
12279 if (VMSISH_TIME) {
12280 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12281 statbufp->st_atime = _toloc(statbufp->st_atime);
12282 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12283 }
12284# endif
ff0cee69 12285 }
9543c6b6 12286 /* If we were successful, leave errno where we found it */
4ee39169 12287 if (retval == 0) RESTORE_ERRNO;
9b9f19da
CB		 12288 if (temp_fspec)
12289 PerlMem_free(temp_fspec);
12290 if (fileified)
12291 PerlMem_free(fileified);
748a9306
LW		 12292 return retval;
12293
2497a41f
JM		 12294} /* end of flex_stat_int() */
12295
12296
12297/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12298int
12299Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12300{
7ded3206 12301 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12302}
12303/*}}}*/
12304
12305/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12306int
12307Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12308{
7ded3206 12309 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12310}
748a9306
LW		 12311/*}}}*/
12312
b7ae7a0d 12313
a5f75d66
AD		 12314/* rmscopy - copy a file using VMS RMS routines
12315 *
12316 * Copies contents and attributes of spec_in to spec_out, except owner
12317 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12318 * defaults for spec_out. The third parameter specifies whether rmscopy()
12319 * should try to propagate timestamps from the input file to the output file.
12320 * If it is less than 0, no timestamps are preserved. If it is 0, then
12321 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12322 * propagated to the output file at creation iff the output file specification
12323 * did not contain an explicit name or type, and the revision date is always
12324 * updated at the end of the copy operation. If it is greater than 0, then
12325 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12326 * other than the revision date should be propagated, and bit 1 indicates
12327 * that the revision date should be propagated.
12328 *
12329 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12330 *
bd3fa61c 12331 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12332 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12333 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12334 * as part of the Perl standard distribution under the terms of the
12335 * GNU General Public License or the Perl Artistic License. Copies
12336 * of each may be found in the Perl standard distribution.
a480973c 12337 */ /* FIXME */
a3e9d8c9 12338/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12339int
12340Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12341{
d584a1c6
JM		 12342 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12343 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
4e0c9737 12344 unsigned long int sts;
a1887106 12345 int dna_len;
a480973c
JM		 12346 struct FAB fab_in, fab_out;
12347 struct RAB rab_in, rab_out;
a1887106
JM		 12348 rms_setup_nam(nam);
12349 rms_setup_nam(nam_out);
a480973c
JM		 12350 struct XABDAT xabdat;
12351 struct XABFHC xabfhc;
12352 struct XABRDT xabrdt;
12353 struct XABSUM xabsum;
12354
c11536f5 12355 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12356 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12357 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12358 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665
JM		 12359 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12360 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
c5375c28
JM		 12361 PerlMem_free(vmsin);
12362 PerlMem_free(vmsout);
a480973c
JM		 12363 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12364 return 0;
12365 }
12366
c11536f5 12367 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12368 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12369 esal = NULL;
054a3baf 12370#if defined(NAML$C_MAXRSS)
c11536f5 12371 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12372 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12373#endif
a480973c 12374 fab_in = cc$rms_fab;
a1887106 12375 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12376 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12377 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12378 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12379 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12380 fab_in.fab$l_xab = (void *) &xabdat;
12381
c11536f5 12382 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12383 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12384 rsal = NULL;
054a3baf 12385#if defined(NAML$C_MAXRSS)
c11536f5 12386 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12387 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12388#endif
12389 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12390 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12391 rms_nam_esl(nam) = 0;
12392 rms_nam_rsl(nam) = 0;
12393 rms_nam_esll(nam) = 0;
12394 rms_nam_rsll(nam) = 0;
a480973c
JM		 12395#ifdef NAM$M_NO_SHORT_UPCASE
12396 if (decc_efs_case_preserve)
a1887106 12397 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12398#endif
12399
12400 xabdat = cc$rms_xabdat; /* To get creation date */
12401 xabdat.xab$l_nxt = (void *) &xabfhc;
12402
12403 xabfhc = cc$rms_xabfhc; /* To get record length */
12404 xabfhc.xab$l_nxt = (void *) &xabsum;
12405
12406 xabsum = cc$rms_xabsum; /* To get key and area information */
12407
12408 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12409 PerlMem_free(vmsin);
12410 PerlMem_free(vmsout);
12411 PerlMem_free(esa);
d584a1c6
JM		 12412 if (esal != NULL)
12413 PerlMem_free(esal);
c5375c28 12414 PerlMem_free(rsa);
d584a1c6
JM		 12415 if (rsal != NULL)
12416 PerlMem_free(rsal);
a480973c
JM		 12417 set_vaxc_errno(sts);
12418 switch (sts) {
12419 case RMS$_FNF: case RMS$_DNF:
12420 set_errno(ENOENT); break;
12421 case RMS$_DIR:
12422 set_errno(ENOTDIR); break;
12423 case RMS$_DEV:
12424 set_errno(ENODEV); break;
12425 case RMS$_SYN:
12426 set_errno(EINVAL); break;
12427 case RMS$_PRV:
12428 set_errno(EACCES); break;
12429 default:
12430 set_errno(EVMSERR);
12431 }
12432 return 0;
12433 }
12434
12435 nam_out = nam;
12436 fab_out = fab_in;
12437 fab_out.fab$w_ifi = 0;
12438 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12439 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12440 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12441 rms_bind_fab_nam(fab_out, nam_out);
12442 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12443 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12444 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
c11536f5 12445 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12446 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12447 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12448 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12449 esal_out = NULL;
12450 rsal_out = NULL;
054a3baf 12451#if defined(NAML$C_MAXRSS)
c11536f5 12452 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12453 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12454 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12455 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12456#endif
12457 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12458 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12459
12460 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12461 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12462 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12463 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12464 PerlMem_free(vmsin);
12465 PerlMem_free(vmsout);
12466 PerlMem_free(esa);
d584a1c6
JM		 12467 if (esal != NULL)
12468 PerlMem_free(esal);
c5375c28 12469 PerlMem_free(rsa);
d584a1c6
JM		 12470 if (rsal != NULL)
12471 PerlMem_free(rsal);
c5375c28 12472 PerlMem_free(esa_out);
d584a1c6
JM		 12473 if (esal_out != NULL)
12474 PerlMem_free(esal_out);
12475 PerlMem_free(rsa_out);
12476 if (rsal_out != NULL)
12477 PerlMem_free(rsal_out);
a480973c
JM		 12478 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12479 set_vaxc_errno(sts);
12480 return 0;
12481 }
12482 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12483 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12484 preserve_dates = 1;
a480973c
JM		 12485 }
12486 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12487 preserve_dates =0; /* bitmask from this point forward */
12488
12489 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12490 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12491 PerlMem_free(vmsin);
12492 PerlMem_free(vmsout);
12493 PerlMem_free(esa);
d584a1c6
JM		 12494 if (esal != NULL)
12495 PerlMem_free(esal);
c5375c28 12496 PerlMem_free(rsa);
d584a1c6
JM		 12497 if (rsal != NULL)
12498 PerlMem_free(rsal);
c5375c28 12499 PerlMem_free(esa_out);
d584a1c6
JM		 12500 if (esal_out != NULL)
12501 PerlMem_free(esal_out);
12502 PerlMem_free(rsa_out);
12503 if (rsal_out != NULL)
12504 PerlMem_free(rsal_out);
a480973c
JM		 12505 set_vaxc_errno(sts);
12506 switch (sts) {
12507 case RMS$_DNF:
12508 set_errno(ENOENT); break;
12509 case RMS$_DIR:
12510 set_errno(ENOTDIR); break;
12511 case RMS$_DEV:
12512 set_errno(ENODEV); break;
12513 case RMS$_SYN:
12514 set_errno(EINVAL); break;
12515 case RMS$_PRV:
12516 set_errno(EACCES); break;
12517 default:
12518 set_errno(EVMSERR);
12519 }
12520 return 0;
12521 }
12522 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12523 if (preserve_dates & 2) {
12524 /* sys$close() will process xabrdt, not xabdat */
12525 xabrdt = cc$rms_xabrdt;
a480973c 12526 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
a480973c
JM		 12527 fab_out.fab$l_xab = (void *) &xabrdt;
12528 }
12529
c11536f5 12530 ubf = (char *)PerlMem_malloc(32256);
ebd4d70b 12531 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 12532 rab_in = cc$rms_rab;
12533 rab_in.rab$l_fab = &fab_in;
12534 rab_in.rab$l_rop = RAB$M_BIO;
12535 rab_in.rab$l_ubf = ubf;
12536 rab_in.rab$w_usz = 32256;
12537 if (!((sts = sys$connect(&rab_in)) & 1)) {
12538 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12539 PerlMem_free(vmsin);
12540 PerlMem_free(vmsout);
c5375c28 12541 PerlMem_free(ubf);
d584a1c6
JM		 12542 PerlMem_free(esa);
12543 if (esal != NULL)
12544 PerlMem_free(esal);
c5375c28 12545 PerlMem_free(rsa);
d584a1c6
JM		 12546 if (rsal != NULL)
12547 PerlMem_free(rsal);
c5375c28 12548 PerlMem_free(esa_out);
d584a1c6
JM		 12549 if (esal_out != NULL)
12550 PerlMem_free(esal_out);
12551 PerlMem_free(rsa_out);
12552 if (rsal_out != NULL)
12553 PerlMem_free(rsal_out);
a480973c
JM		 12554 set_errno(EVMSERR); set_vaxc_errno(sts);
12555 return 0;
12556 }
12557
12558 rab_out = cc$rms_rab;
12559 rab_out.rab$l_fab = &fab_out;
12560 rab_out.rab$l_rbf = ubf;
12561 if (!((sts = sys$connect(&rab_out)) & 1)) {
12562 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12563 PerlMem_free(vmsin);
12564 PerlMem_free(vmsout);
c5375c28 12565 PerlMem_free(ubf);
d584a1c6
JM		 12566 PerlMem_free(esa);
12567 if (esal != NULL)
12568 PerlMem_free(esal);
c5375c28 12569 PerlMem_free(rsa);
d584a1c6
JM		 12570 if (rsal != NULL)
12571 PerlMem_free(rsal);
c5375c28 12572 PerlMem_free(esa_out);
d584a1c6
JM		 12573 if (esal_out != NULL)
12574 PerlMem_free(esal_out);
12575 PerlMem_free(rsa_out);
12576 if (rsal_out != NULL)
12577 PerlMem_free(rsal_out);
a480973c
JM		 12578 set_errno(EVMSERR); set_vaxc_errno(sts);
12579 return 0;
12580 }
12581
12582 while ((sts = sys$read(&rab_in))) { /* always true */
12583 if (sts == RMS$_EOF) break;
12584 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12585 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12586 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12587 PerlMem_free(vmsin);
12588 PerlMem_free(vmsout);
c5375c28 12589 PerlMem_free(ubf);
d584a1c6
JM		 12590 PerlMem_free(esa);
12591 if (esal != NULL)
12592 PerlMem_free(esal);
c5375c28 12593 PerlMem_free(rsa);
d584a1c6
JM		 12594 if (rsal != NULL)
12595 PerlMem_free(rsal);
c5375c28 12596 PerlMem_free(esa_out);
d584a1c6
JM		 12597 if (esal_out != NULL)
12598 PerlMem_free(esal_out);
12599 PerlMem_free(rsa_out);
12600 if (rsal_out != NULL)
12601 PerlMem_free(rsal_out);
a480973c
JM		 12602 set_errno(EVMSERR); set_vaxc_errno(sts);
12603 return 0;
12604 }
12605 }
12606
12607
12608 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12609 sys$close(&fab_in); sys$close(&fab_out);
12610 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12611
c5375c28
JM		 12612 PerlMem_free(vmsin);
12613 PerlMem_free(vmsout);
c5375c28 12614 PerlMem_free(ubf);
d584a1c6
JM		 12615 PerlMem_free(esa);
12616 if (esal != NULL)
12617 PerlMem_free(esal);
c5375c28 12618 PerlMem_free(rsa);
d584a1c6
JM		 12619 if (rsal != NULL)
12620 PerlMem_free(rsal);
c5375c28 12621 PerlMem_free(esa_out);
d584a1c6
JM		 12622 if (esal_out != NULL)
12623 PerlMem_free(esal_out);
12624 PerlMem_free(rsa_out);
12625 if (rsal_out != NULL)
12626 PerlMem_free(rsal_out);
12627
12628 if (!(sts & 1)) {
12629 set_errno(EVMSERR); set_vaxc_errno(sts);
12630 return 0;
12631 }
12632
a480973c
JM		 12633 return 1;
12634
12635} /* end of rmscopy() */
a5f75d66
AD		 12636/*}}}*/
12637
12638
748a9306
LW		 12639/*** The following glue provides 'hooks' to make some of the routines
12640 * from this file available from Perl. These routines are sufficiently
12641 * basic, and are required sufficiently early in the build process,
12642 * that's it's nice to have them available to miniperl as well as the
12643 * full Perl, so they're set up here instead of in an extension. The
12644 * Perl code which handles importation of these names into a given
12645 * package lives in [.VMS]Filespec.pm in @INC.
12646 */
12647
12648void
5c84aa53 12649rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12650{
12651 dXSARGS;
bbce6d69 12652 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12653 STRLEN n_a;
360732b5 12654 int fs_utf8, dfs_utf8;
01b8edb6 12655
360732b5
JM		 12656 fs_utf8 = 0;
12657 dfs_utf8 = 0;
bbce6d69 12658 if (!items || items > 2)
5c84aa53 12659 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12660 fspec = SvPV(ST(0),n_a);
360732b5 12661 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12662 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12663 if (items == 2) {
12664 defspec = SvPV(ST(1),n_a);
12665 dfs_utf8 = SvUTF8(ST(1));
12666 }
12667 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12668 ST(0) = sv_newmortal();
360732b5
JM		 12669 if (rslt != NULL) {
12670 sv_usepvn(ST(0),rslt,strlen(rslt));
12671 if (fs_utf8) {
12672 SvUTF8_on(ST(0));
12673 }
12674 }
740ce14c 12675 XSRETURN(1);
01b8edb6 12676}
12677
12678void
5c84aa53 12679vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12680{
12681 dXSARGS;
12682 char *vmsified;
2d8e6c8d 12683 STRLEN n_a;
360732b5 12684 int utf8_fl;
748a9306 12685
5c84aa53 12686 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12687 utf8_fl = SvUTF8(ST(0));
12688 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12689 ST(0) = sv_newmortal();
360732b5
JM		 12690 if (vmsified != NULL) {
12691 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12692 if (utf8_fl) {
12693 SvUTF8_on(ST(0));
12694 }
12695 }
748a9306
LW		 12696 XSRETURN(1);
12697}
12698
12699void
5c84aa53 12700unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12701{
12702 dXSARGS;
12703 char *unixified;
2d8e6c8d 12704 STRLEN n_a;
360732b5 12705 int utf8_fl;
748a9306 12706
5c84aa53 12707 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12708 utf8_fl = SvUTF8(ST(0));
12709 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12710 ST(0) = sv_newmortal();
360732b5
JM		 12711 if (unixified != NULL) {
12712 sv_usepvn(ST(0),unixified,strlen(unixified));
12713 if (utf8_fl) {
12714 SvUTF8_on(ST(0));
12715 }
12716 }
748a9306
LW		 12717 XSRETURN(1);
12718}
12719
12720void
5c84aa53 12721fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12722{
12723 dXSARGS;
12724 char *fileified;
2d8e6c8d 12725 STRLEN n_a;
360732b5 12726 int utf8_fl;
748a9306 12727
5c84aa53 12728 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12729 utf8_fl = SvUTF8(ST(0));
12730 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12731 ST(0) = sv_newmortal();
360732b5
JM		 12732 if (fileified != NULL) {
12733 sv_usepvn(ST(0),fileified,strlen(fileified));
12734 if (utf8_fl) {
12735 SvUTF8_on(ST(0));
12736 }
12737 }
748a9306
LW		 12738 XSRETURN(1);
12739}
12740
12741void
5c84aa53 12742pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12743{
12744 dXSARGS;
12745 char *pathified;
2d8e6c8d 12746 STRLEN n_a;
360732b5 12747 int utf8_fl;
748a9306 12748
5c84aa53 12749 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12750 utf8_fl = SvUTF8(ST(0));
12751 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12752 ST(0) = sv_newmortal();
360732b5
JM		 12753 if (pathified != NULL) {
12754 sv_usepvn(ST(0),pathified,strlen(pathified));
12755 if (utf8_fl) {
12756 SvUTF8_on(ST(0));
12757 }
12758 }
748a9306
LW		 12759 XSRETURN(1);
12760}
12761
12762void
5c84aa53 12763vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12764{
12765 dXSARGS;
12766 char *vmspath;
2d8e6c8d 12767 STRLEN n_a;
360732b5 12768 int utf8_fl;
748a9306 12769
5c84aa53 12770 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12771 utf8_fl = SvUTF8(ST(0));
12772 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12773 ST(0) = sv_newmortal();
360732b5
JM		 12774 if (vmspath != NULL) {
12775 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12776 if (utf8_fl) {
12777 SvUTF8_on(ST(0));
12778 }
12779 }
748a9306
LW		 12780 XSRETURN(1);
12781}
12782
12783void
5c84aa53 12784unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12785{
12786 dXSARGS;
12787 char *unixpath;
2d8e6c8d 12788 STRLEN n_a;
360732b5 12789 int utf8_fl;
748a9306 12790
5c84aa53 12791 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12792 utf8_fl = SvUTF8(ST(0));
12793 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12794 ST(0) = sv_newmortal();
360732b5
JM		 12795 if (unixpath != NULL) {
12796 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12797 if (utf8_fl) {
12798 SvUTF8_on(ST(0));
12799 }
12800 }
748a9306
LW		 12801 XSRETURN(1);
12802}
12803
12804void
5c84aa53 12805candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12806{
12807 dXSARGS;
988c775c 12808 char *fspec, *fsp;
a5f75d66
AD		 12809 SV *mysv;
12810 IO *io;
2d8e6c8d 12811 STRLEN n_a;
748a9306 12812
5c84aa53 12813 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12814
12815 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12816 Newx(fspec, VMS_MAXRSS, char);
12817 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
6d24fbd1 12818 if (isGV_with_GP(mysv)) {
a15cef0c 12819 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12820 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12821 ST(0) = &PL_sv_no;
988c775c 12822 Safefree(fspec);
a5f75d66
AD		 12823 XSRETURN(1);
12824 }
12825 fsp = fspec;
12826 }
12827 else {
2d8e6c8d 12828 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
a5f75d66 12829 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12830 ST(0) = &PL_sv_no;
988c775c 12831 Safefree(fspec);
a5f75d66
AD		 12832 XSRETURN(1);
12833 }
12834 }
12835
54310121 12836 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12837 Safefree(fspec);
a5f75d66
AD		 12838 XSRETURN(1);
12839}
12840
12841void
5c84aa53 12842rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12843{
12844 dXSARGS;
a480973c 12845 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12846 int date_flag;
a5f75d66
AD		 12847 SV *mysv;
12848 IO *io;
2d8e6c8d 12849 STRLEN n_a;
a5f75d66 12850
a3e9d8c9 12851 if (items < 2 || items > 3)
5c84aa53 12852 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12853
12854 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12855 Newx(inspec, VMS_MAXRSS, char);
6d24fbd1 12856 if (isGV_with_GP(mysv)) {
a15cef0c 12857 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12858 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12859 ST(0) = sv_2mortal(newSViv(0));
a480973c 12860 Safefree(inspec);
a5f75d66
AD		 12861 XSRETURN(1);
12862 }
12863 inp = inspec;
12864 }
12865 else {
2d8e6c8d 12866 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
a5f75d66 12867 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12868 ST(0) = sv_2mortal(newSViv(0));
a480973c 12869 Safefree(inspec);
a5f75d66
AD		 12870 XSRETURN(1);
12871 }
12872 }
12873 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12874 Newx(outspec, VMS_MAXRSS, char);
6d24fbd1 12875 if (isGV_with_GP(mysv)) {
a15cef0c 12876 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12877 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12878 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12879 Safefree(inspec);
12880 Safefree(outspec);
a5f75d66
AD		 12881 XSRETURN(1);
12882 }
12883 outp = outspec;
12884 }
12885 else {
2d8e6c8d 12886 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12887 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12888 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12889 Safefree(inspec);
12890 Safefree(outspec);
a5f75d66
AD		 12891 XSRETURN(1);
12892 }
12893 }
a3e9d8c9 12894 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12895
fd188159 12896 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
a480973c
JM		 12897 Safefree(inspec);
12898 Safefree(outspec);
748a9306
LW		 12899 XSRETURN(1);
12900}
12901
a480973c
JM		 12902/* The mod2fname is limited to shorter filenames by design, so it should
12903 * not be modified to support longer EFS pathnames
12904 */
4b19af01 12905void
fd8cd3a3 12906mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12907{
12908 dXSARGS;
12909 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12910 workbuff[NAM$C_MAXRSS*1 + 1];
c70927a6 12911 SSize_t counter, num_entries;
4b19af01
CB		 12912 /* ODS-5 ups this, but we want to be consistent, so... */
12913 int max_name_len = 39;
12914 AV *in_array = (AV *)SvRV(ST(0));
12915
b9f2b683 12916 num_entries = av_tindex(in_array);
4b19af01
CB		 12917
12918 /* All the names start with PL_. */
12919 strcpy(ultimate_name, "PL_");
12920
12921 /* Clean up our working buffer */
12922 Zero(work_name, sizeof(work_name), char);
12923
12924 /* Run through the entries and build up a working name */
12925 for(counter = 0; counter <= num_entries; counter++) {
12926 /* If it's not the first name then tack on a __ */
12927 if (counter) {
a35dcc95 12928 my_strlcat(work_name, "__", sizeof(work_name));
4b19af01 12929 }
a35dcc95 12930 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
4b19af01
CB		 12931 }
12932
12933 /* Check to see if we actually have to bother...*/
12934 if (strlen(work_name) + 3 <= max_name_len) {
a35dcc95 12935 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12936 } else {
12937 /* It's too darned big, so we need to go strip. We use the same */
12938 /* algorithm as xsubpp does. First, strip out doubled __ */
12939 char *source, *dest, last;
12940 dest = workbuff;
12941 last = 0;
12942 for (source = work_name; *source; source++) {
12943 if (last == *source && last == '_') {
12944 continue;
12945 }
12946 *dest++ = *source;
12947 last = *source;
12948 }
12949 /* Go put it back */
a35dcc95 12950 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12951 /* Is it still too big? */
12952 if (strlen(work_name) + 3 > max_name_len) {
12953 /* Strip duplicate letters */
12954 last = 0;
12955 dest = workbuff;
12956 for (source = work_name; *source; source++) {
12957 if (last == toupper(*source)) {
12958 continue;
12959 }
12960 *dest++ = *source;
12961 last = toupper(*source);
12962 }
a35dcc95 12963 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12964 }
12965
12966 /* Is it *still* too big? */
12967 if (strlen(work_name) + 3 > max_name_len) {
12968 /* Too bad, we truncate */
12969 work_name[max_name_len - 2] = 0;
12970 }
a35dcc95 12971 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12972 }
12973
12974 /* Okay, return it */
12975 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12976 XSRETURN(1);
12977}
12978
748a9306 12979void
96e176bf
CL		 12980hushexit_fromperl(pTHX_ CV *cv)
12981{
12982 dXSARGS;
12983
12984 if (items > 0) {
12985 VMSISH_HUSHED = SvTRUE(ST(0));
12986 }
12987 ST(0) = boolSV(VMSISH_HUSHED);
12988 XSRETURN(1);
12989}
12990
dca5a913
JM		 12991
12992PerlIO *
ce12d4b7 12993Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
dca5a913
JM		 12994{
12995 PerlIO *fp;
12996 struct vs_str_st *rslt;
12997 char *vmsspec;
12998 char *rstr;
12999 char *begin, *cp;
13000 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13001 PerlIO *tmpfp;
13002 STRLEN i;
13003 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13004 struct dsc$descriptor_vs rsdsc;
13005 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13006 unsigned long hasver = 0, isunix = 0;
13007 unsigned long int lff_flags = 0;
13008 int rms_sts;
85e7c9de 13009 int vms_old_glob = 1;
dca5a913 13010
83b907a4
CB		 13011 if (!SvOK(tmpglob)) {
13012 SETERRNO(ENOENT,RMS$_FNF);
13013 return NULL;
13014 }
13015
85e7c9de
JM		 13016 vms_old_glob = !decc_filename_unix_report;
13017
dca5a913
JM		 13018#ifdef VMS_LONGNAME_SUPPORT
13019 lff_flags = LIB$M_FIL_LONG_NAMES;
13020#endif
13021 /* The Newx macro will not allow me to assign a smaller array
13022 * to the rslt pointer, so we will assign it to the begin char pointer
13023 * and then copy the value into the rslt pointer.
13024 */
13025 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13026 rslt = (struct vs_str_st *)begin;
13027 rslt->length = 0;
13028 rstr = &rslt->str[0];
13029 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13030 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13031 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13032 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13033
13034 Newx(vmsspec, VMS_MAXRSS, char);
13035
13036 /* We could find out if there's an explicit dev/dir or version
13037 by peeking into lib$find_file's internal context at
13038 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13039 but that's unsupported, so I don't want to do it now and
13040 have it bite someone in the future. */
13041 /* Fix-me: vms_split_path() is the only way to do this, the
13042 existing method will fail with many legal EFS or UNIX specifications
13043 */
13044
13045 cp = SvPV(tmpglob,i);
13046
13047 for (; i; i--) {
13048 if (cp[i] == ';') hasver = 1;
13049 if (cp[i] == '.') {
13050 if (sts) hasver = 1;
13051 else sts = 1;
13052 }
13053 if (cp[i] == '/') {
13054 hasdir = isunix = 1;
13055 break;
13056 }
13057 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13058 hasdir = 1;
13059 break;
13060 }
13061 }
85e7c9de
JM		 13062
13063 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13064 if ((hasdir == 0) && decc_filename_unix_report) {
13065 isunix = 1;
13066 }
13067
dca5a913 13068 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
85e7c9de
JM		 13069 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13070 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13071 int wildstar = 0;
13072 int wildquery = 0;
990cad08 13073 int found = 0;
dca5a913
JM		 13074 Stat_t st;
13075 int stat_sts;
13076 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13077 if (!stat_sts && S_ISDIR(st.st_mode)) {
85e7c9de
JM		 13078 char * vms_dir;
13079 const char * fname;
13080 STRLEN fname_len;
13081
13082 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13083 /* path delimiter of ':>]', if so, then the old behavior has */
94ae10c0 13084 /* obviously been specifically requested */
85e7c9de
JM		 13085
13086 fname = SvPVX_const(tmpglob);
13087 fname_len = strlen(fname);
13088 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13089 if (vms_old_glob || (vms_dir != NULL)) {
13090 wilddsc.dsc$a_pointer = tovmspath_utf8(
13091 SvPVX(tmpglob),vmsspec,NULL);
13092 ok = (wilddsc.dsc$a_pointer != NULL);
13093 /* maybe passed 'foo' rather than '[.foo]', thus not
13094 detected above */
13095 hasdir = 1;
13096 } else {
13097 /* Operate just on the directory, the special stat/fstat for */
13098 /* leaves the fileified specification in the st_devnam */
13099 /* member. */
13100 wilddsc.dsc$a_pointer = st.st_devnam;
13101 ok = 1;
13102 }
dca5a913
JM		 13103 }
13104 else {
360732b5 13105 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 13106 ok = (wilddsc.dsc$a_pointer != NULL);
13107 }
13108 if (ok)
13109 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13110
13111 /* If not extended character set, replace ? with % */
13112 /* With extended character set, ? is a wildcard single character */
85e7c9de
JM		 13113 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13114 if (*cp == '?') {
13115 wildquery = 1;
998e0439 13116 if (!decc_efs_charset)
85e7c9de
JM		 13117 *cp = '%';
13118 } else if (*cp == '%') {
13119 wildquery = 1;
13120 } else if (*cp == '*') {
13121 wildstar = 1;
13122 }
dca5a913 13123 }
85e7c9de
JM		 13124
13125 if (ok) {
13126 wv_sts = vms_split_path(
13127 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13128 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13129 &wvs_spec, &wvs_len);
13130 } else {
13131 wn_spec = NULL;
13132 wn_len = 0;
13133 we_spec = NULL;
13134 we_len = 0;
13135 }
13136
dca5a913
JM		 13137 sts = SS$_NORMAL;
13138 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13139 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13140 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
85e7c9de 13141 int valid_find;
dca5a913 13142
85e7c9de 13143 valid_find = 0;
dca5a913
JM		 13144 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13145 &dfltdsc,NULL,&rms_sts,&lff_flags);
13146 if (!$VMS_STATUS_SUCCESS(sts))
13147 break;
13148
13149 /* with varying string, 1st word of buffer contains result length */
13150 rstr[rslt->length] = '\0';
13151
13152 /* Find where all the components are */
13153 v_sts = vms_split_path
360732b5 13154 (rstr,
dca5a913
JM		 13155 &v_spec,
13156 &v_len,
13157 &r_spec,
13158 &r_len,
13159 &d_spec,
13160 &d_len,
13161 &n_spec,
13162 &n_len,
13163 &e_spec,
13164 &e_len,
13165 &vs_spec,
13166 &vs_len);
13167
13168 /* If no version on input, truncate the version on output */
13169 if (!hasver && (vs_len > 0)) {
13170 *vs_spec = '\0';
13171 vs_len = 0;
85e7c9de
JM		 13172 }
13173
13174 if (isunix) {
13175
13176 /* In Unix report mode, remove the ".dir;1" from the name */
13177 /* if it is a real directory */
d5eaec22 13178 if (decc_filename_unix_report && decc_efs_charset) {
85e7c9de
JM		 13179 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13180 Stat_t statbuf;
13181 int ret_sts;
13182
13183 ret_sts = flex_lstat(rstr, &statbuf);
13184 if ((ret_sts == 0) &&
13185 S_ISDIR(statbuf.st_mode)) {
13186 e_len = 0;
13187 e_spec[0] = 0;
13188 }
13189 }
13190 }
dca5a913
JM		 13191
13192 /* No version & a null extension on UNIX handling */
85e7c9de 13193 if ((e_len == 1) && decc_readdir_dropdotnotype) {
dca5a913
JM		 13194 e_len = 0;
13195 *e_spec = '\0';
13196 }
13197 }
13198
13199 if (!decc_efs_case_preserve) {
13200 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13201 }
13202
85e7c9de
JM		 13203 /* Find File treats a Null extension as return all extensions */
13204 /* This is contrary to Perl expectations */
13205
13206 if (wildstar || wildquery || vms_old_glob) {
13207 /* really need to see if the returned file name matched */
13208 /* but for now will assume that it matches */
13209 valid_find = 1;
13210 } else {
13211 /* Exact Match requested */
13212 /* How are directories handled? - like a file */
13213 if ((e_len == we_len) && (n_len == wn_len)) {
13214 int t1;
13215 t1 = e_len;
13216 if (t1 > 0)
13217 t1 = strncmp(e_spec, we_spec, e_len);
13218 if (t1 == 0) {
13219 t1 = n_len;
13220 if (t1 > 0)
13221 t1 = strncmp(n_spec, we_spec, n_len);
13222 if (t1 == 0)
13223 valid_find = 1;
13224 }
13225 }
13226 }
13227
13228 if (valid_find) {
13229 found++;
13230
13231 if (hasdir) {
13232 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13233 begin = rstr;
13234 }
13235 else {
13236 /* Start with the name */
13237 begin = n_spec;
13238 }
13239 strcat(begin,"\n");
13240 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13241 }
dca5a913
JM		 13242 }
13243 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 13244
13245 if (!found) {
13246 /* Be POSIXish: return the input pattern when no matches */
a35dcc95 13247 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
2da7a6b5
CB		 13248 strcat(rstr,"\n");
13249 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 13250 }
13251
dca5a913
JM		 13252 if (ok && sts != RMS$_NMF &&
13253 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13254 if (!ok) {
13255 if (!(sts & 1)) {
13256 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13257 }
13258 PerlIO_close(tmpfp);
13259 fp = NULL;
13260 }
13261 else {
13262 PerlIO_rewind(tmpfp);
13263 IoTYPE(io) = IoTYPE_RDONLY;
13264 IoIFP(io) = fp = tmpfp;
13265 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13266 }
13267 }
13268 Safefree(vmsspec);
13269 Safefree(rslt);
13270 return fp;
13271}
13272
cd1191f1 13273
2497a41f 13274static char *
5c4d031a 13275mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 13276 int *utf8_fl);
2497a41f
JM		 13277
13278void
4d8d3a9c 13279unixrealpath_fromperl(pTHX_ CV *cv)
2497a41f 13280{
d584a1c6
JM		 13281 dXSARGS;
13282 char *fspec, *rslt_spec, *rslt;
13283 STRLEN n_a;
2497a41f 13284
d584a1c6 13285 if (!items || items != 1)
4d8d3a9c 13286 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
2497a41f 13287
d584a1c6
JM		 13288 fspec = SvPV(ST(0),n_a);
13289 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 13290
d584a1c6
JM		 13291 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13292 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13293
13294 ST(0) = sv_newmortal();
13295 if (rslt != NULL)
13296 sv_usepvn(ST(0),rslt,strlen(rslt));
13297 else
13298 Safefree(rslt_spec);
13299 XSRETURN(1);
2497a41f 13300}
2ee6e19d 13301
b1a8dcd7
JM		 13302static char *
13303mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13304 int *utf8_fl);
13305
13306void
4d8d3a9c 13307vmsrealpath_fromperl(pTHX_ CV *cv)
b1a8dcd7
JM		 13308{
13309 dXSARGS;
13310 char *fspec, *rslt_spec, *rslt;
13311 STRLEN n_a;
13312
13313 if (!items || items != 1)
4d8d3a9c 13314 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
b1a8dcd7
JM		 13315
13316 fspec = SvPV(ST(0),n_a);
13317 if (!fspec || !*fspec) XSRETURN_UNDEF;
13318
13319 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13320 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13321
13322 ST(0) = sv_newmortal();
13323 if (rslt != NULL)
13324 sv_usepvn(ST(0),rslt,strlen(rslt));
13325 else
13326 Safefree(rslt_spec);
13327 XSRETURN(1);
13328}
13329
13330#ifdef HAS_SYMLINK
2ee6e19d
CB		 13331/*
13332 * A thin wrapper around decc$symlink to make sure we follow the
cc9aafbd
CB		 13333 * standard and do not create a symlink with a zero-length name,
13334 * and convert the target to Unix format, as the CRTL can't handle
13335 * targets in VMS format.
2ee6e19d 13336 */
4148925f 13337/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
cc9aafbd
CB		 13338int
13339Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13340{
13341 int sts;
13342 char * utarget;
4148925f 13343
cc9aafbd
CB		 13344 if (!link_name || !*link_name) {
13345 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13346 return -1;
13347 }
4148925f 13348
c11536f5 13349 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
cc9aafbd
CB		 13350 /* An untranslatable filename should be passed through. */
13351 (void) int_tounixspec(contents, utarget, NULL);
13352 sts = symlink(utarget, link_name);
13353 PerlMem_free(utarget);
13354 return sts;
2ee6e19d
CB		 13355}
13356/*}}}*/
13357
13358#endif /* HAS_SYMLINK */
2497a41f 13359
2497a41f
JM		 13360int do_vms_case_tolerant(void);
13361
13362void
4d8d3a9c 13363case_tolerant_process_fromperl(pTHX_ CV *cv)
2497a41f
JM		 13364{
13365 dXSARGS;
13366 ST(0) = boolSV(do_vms_case_tolerant());
13367 XSRETURN(1);
13368}
2497a41f 13369
9ec7171b
CB		 13370#ifdef USE_ITHREADS
13371
96e176bf
CL		 13372void
13373Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13374 struct interp_intern *dst)
13375{
7918f24d
NC		 13376 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13377
96e176bf
CL		 13378 memcpy(dst,src,sizeof(struct interp_intern));
13379}
13380
9ec7171b
CB		 13381#endif
13382
96e176bf
CL		 13383void
13384Perl_sys_intern_clear(pTHX)
13385{
13386}
13387
13388void
13389Perl_sys_intern_init(pTHX)
13390{
3ff49832
CL		 13391 unsigned int ix = RAND_MAX;
13392 double x;
96e176bf
CL		 13393
13394 VMSISH_HUSHED = 0;
13395
1a3aec58 13396 MY_POSIX_EXIT = vms_posix_exit;
7a7fd8e0 13397
96e176bf
CL		 13398 x = (float)ix;
13399 MY_INV_RAND_MAX = 1./x;
ff7adb52 13400}
96e176bf
CL		 13401
13402void
f7ddb74a 13403init_os_extras(void)
748a9306 13404{
a69a6dba 13405 dTHX;
748a9306 13406 char* file = __FILE__;
988c775c 13407 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 13408 no_translate_barewords = TRUE;
13409 } else {
13410 no_translate_barewords = FALSE;
13411 }
748a9306 13412
740ce14c 13413 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13414 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13415 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13416 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13417 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13418 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13419 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13420 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13421 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13422 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13423 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
4d8d3a9c
CB		 13424 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13425 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13426 newXSproto("VMS::Filespec::case_tolerant_process",
13427 case_tolerant_process_fromperl,file,"");
17f28c40 13428
afd8f436 13429 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13430
748a9306
LW		 13431 return;
13432}
13433
f7ddb74a
JM		 13434#if __CRTL_VER == 80200000
13435/* This missed getting in to the DECC SDK for 8.2 */
13436char *realpath(const char *file_name, char * resolved_name, ...);
13437#endif
13438
13439/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13440/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13441 * The perl fallback routine to provide realpath() is not as efficient
13442 * on OpenVMS.
13443 */
d584a1c6 13444
c11536f5
CB		 13445#ifdef __cplusplus
13446extern "C" {
13447#endif
13448
d584a1c6
JM		 13449/* Hack, use old stat() as fastest way of getting ino_t and device */
13450int decc$stat(const char *name, void * statbuf);
054a3baf 13451#if __CRTL_VER >= 80200000
312ac60b
JM		 13452int decc$lstat(const char *name, void * statbuf);
13453#else
13454#define decc$lstat decc$stat
13455#endif
d584a1c6 13456
c11536f5
CB		 13457#ifdef __cplusplus
13458}
13459#endif
13460
d584a1c6
JM		 13461
13462/* Realpath is fragile. In 8.3 it does not work if the feature
13463 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13464 * links are implemented in RMS, not the CRTL. It also can fail if the
13465 * user does not have read/execute access to some of the directories.
13466 * So in order for Do What I Mean mode to work, if realpath() fails,
13467 * fall back to looking up the filename by the device name and FID.
13468 */
13469
312ac60b
JM		 13470int vms_fid_to_name(char * outname, int outlen,
13471 const char * name, int lstat_flag, mode_t * mode)
d584a1c6 13472{
312ac60b
JM		 13473#pragma message save
13474#pragma message disable MISALGNDSTRCT
13475#pragma message disable MISALGNDMEM
13476#pragma member_alignment save
13477#pragma nomember_alignment
ce12d4b7
CB		 13478 struct statbuf_t {
13479 char * st_dev;
13480 unsigned short st_ino[3];
13481 unsigned short old_st_mode;
13482 unsigned long padl[30]; /* plenty of room */
13483 } statbuf;
312ac60b
JM		 13484#pragma message restore
13485#pragma member_alignment restore
13486
13487 int sts;
13488 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13489 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13490 char *fileified;
13491 char *temp_fspec;
13492 char *ret_spec;
13493
13494 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13495 * unexpected answers
13496 */
13497
c11536f5 13498 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13499 if (fileified == NULL)
13500 _ckvmssts_noperl(SS$_INSFMEM);
13501
c11536f5 13502 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13503 if (temp_fspec == NULL)
13504 _ckvmssts_noperl(SS$_INSFMEM);
13505
13506 sts = -1;
13507 /* First need to try as a directory */
13508 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13509 if (ret_spec != NULL) {
13510 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13511 if (ret_spec != NULL) {
13512 if (lstat_flag == 0)
13513 sts = decc$stat(fileified, &statbuf);
13514 else
13515 sts = decc$lstat(fileified, &statbuf);
13516 }
13517 }
13518
13519 /* Then as a VMS file spec */
13520 if (sts != 0) {
13521 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13522 if (ret_spec != NULL) {
13523 if (lstat_flag == 0) {
13524 sts = decc$stat(temp_fspec, &statbuf);
13525 } else {
13526 sts = decc$lstat(temp_fspec, &statbuf);
13527 }
13528 }
13529 }
13530
13531 if (sts) {
13532 /* Next try - allow multiple dots with out EFS CHARSET */
13533 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13534 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13535 * enable it if it isn't already.
13536 */
312ac60b
JM		 13537 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13538 decc$feature_set_value(decc_efs_charset_index, 1, 1);
312ac60b
JM		 13539 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13540 if (lstat_flag == 0) {
13541 sts = decc$stat(name, &statbuf);
13542 } else {
13543 sts = decc$lstat(name, &statbuf);
13544 }
312ac60b
JM		 13545 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13546 decc$feature_set_value(decc_efs_charset_index, 1, 0);
312ac60b
JM		 13547 }
13548
13549
13550 /* and then because the Perl Unix to VMS conversion is not perfect */
13551 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13552 /* characters from filenames so we need to try it as-is */
13553 if (sts) {
13554 if (lstat_flag == 0) {
13555 sts = decc$stat(name, &statbuf);
13556 } else {
13557 sts = decc$lstat(name, &statbuf);
13558 }
13559 }
d584a1c6 13560
d584a1c6 13561 if (sts == 0) {
312ac60b 13562 int vms_sts;
d584a1c6
JM		 13563
13564 dvidsc.dsc$a_pointer=statbuf.st_dev;
d94c5a78 13565 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
d584a1c6
JM		 13566
13567 specdsc.dsc$a_pointer = outname;
13568 specdsc.dsc$w_length = outlen-1;
13569
d94c5a78 13570 vms_sts = lib$fid_to_name
d584a1c6 13571 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
d94c5a78 13572 if ($VMS_STATUS_SUCCESS(vms_sts)) {
d584a1c6 13573 outname[specdsc.dsc$w_length] = 0;
312ac60b
JM		 13574
13575 /* Return the mode */
13576 if (mode) {
13577 *mode = statbuf.old_st_mode;
13578 }
d584a1c6
JM		 13579 }
13580 }
9e2bec02
CB		 13581 PerlMem_free(temp_fspec);
13582 PerlMem_free(fileified);
d584a1c6
JM		 13583 return sts;
13584}
13585
13586
13587
f7ddb74a 13588static char *
5c4d031a 13589mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13590 int *utf8_fl)
f7ddb74a 13591{
d584a1c6
JM		 13592 char * rslt = NULL;
13593
b1a8dcd7
JM		 13594#ifdef HAS_SYMLINK
13595 if (decc_posix_compliant_pathnames > 0 ) {
13596 /* realpath currently only works if posix compliant pathnames are
13597 * enabled. It may start working when they are not, but in that
13598 * case we still want the fallback behavior for backwards compatibility
13599 */
d584a1c6 13600 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13601 }
13602#endif
d584a1c6
JM		 13603
13604 if (rslt == NULL) {
13605 char * vms_spec;
13606 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13607 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
312ac60b 13608 mode_t my_mode;
d584a1c6
JM		 13609
13610 /* Fall back to fid_to_name */
13611
13612 Newx(vms_spec, VMS_MAXRSS + 1, char);
13613
312ac60b 13614 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
4d8d3a9c 13615 if (sts == 0) {
d584a1c6
JM		 13616
13617
13618 /* Now need to trim the version off */
13619 sts = vms_split_path
13620 (vms_spec,
13621 &v_spec,
13622 &v_len,
13623 &r_spec,
13624 &r_len,
13625 &d_spec,
13626 &d_len,
13627 &n_spec,
13628 &n_len,
13629 &e_spec,
13630 &e_len,
13631 &vs_spec,
13632 &vs_len);
13633
13634
4d8d3a9c
CB		 13635 if (sts == 0) {
13636 int haslower = 0;
13637 const char *cp;
d584a1c6 13638
4d8d3a9c
CB		 13639 /* Trim off the version */
13640 int file_len = v_len + r_len + d_len + n_len + e_len;
13641 vms_spec[file_len] = 0;
d584a1c6 13642
f785e3a1
JM		 13643 /* Trim off the .DIR if this is a directory */
13644 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13645 if (S_ISDIR(my_mode)) {
13646 e_len = 0;
13647 e_spec[0] = 0;
13648 }
13649 }
13650
13651 /* Drop NULL extensions on UNIX file specification */
13652 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13653 e_len = 0;
13654 e_spec[0] = '\0';
13655 }
13656
4d8d3a9c 13657 /* The result is expected to be in UNIX format */
0e5ce2c7 13658 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
4d8d3a9c
CB		 13659
13660 /* Downcase if input had any lower case letters and
13661 * case preservation is not in effect.
13662 */
13663 if (!decc_efs_case_preserve) {
13664 for (cp = filespec; *cp; cp++)
13665 if (islower(*cp)) { haslower = 1; break; }
13666
13667 if (haslower) __mystrtolower(rslt);
13668 }
13669 }
643f470b
CB		 13670 } else {
13671
13672 /* Now for some hacks to deal with backwards and forward */
94ae10c0 13673 /* compatibility */
643f470b
CB		 13674 if (!decc_efs_charset) {
13675
13676 /* 1. ODS-2 mode wants to do a syntax only translation */
6fb6c614
JM		 13677 rslt = int_rmsexpand(filespec, outbuf,
13678 NULL, 0, NULL, utf8_fl);
643f470b
CB		 13679
13680 } else {
13681 if (decc_filename_unix_report) {
13682 char * dir_name;
13683 char * vms_dir_name;
13684 char * file_name;
13685
13686 /* 2. ODS-5 / UNIX report mode should return a failure */
13687 /* if the parent directory also does not exist */
13688 /* Otherwise, get the real path for the parent */
29475144 13689 /* and add the child to it. */
643f470b
CB		 13690
13691 /* basename / dirname only available for VMS 7.0+ */
13692 /* So we may need to implement them as common routines */
13693
13694 Newx(dir_name, VMS_MAXRSS + 1, char);
13695 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13696 dir_name[0] = '\0';
13697 file_name = NULL;
13698
13699 /* First try a VMS parse */
13700 sts = vms_split_path
13701 (filespec,
13702 &v_spec,
13703 &v_len,
13704 &r_spec,
13705 &r_len,
13706 &d_spec,
13707 &d_len,
13708 &n_spec,
13709 &n_len,
13710 &e_spec,
13711 &e_len,
13712 &vs_spec,
13713 &vs_len);
13714
13715 if (sts == 0) {
13716 /* This is VMS */
13717
13718 int dir_len = v_len + r_len + d_len + n_len;
13719 if (dir_len > 0) {
a35dcc95 13720 memcpy(dir_name, filespec, dir_len);
643f470b
CB		 13721 dir_name[dir_len] = '\0';
13722 file_name = (char *)&filespec[dir_len + 1];
13723 }
13724 } else {
13725 /* This must be UNIX */
13726 char * tchar;
13727
13728 tchar = strrchr(filespec, '/');
13729
4148925f
JM		 13730 if (tchar != NULL) {
13731 int dir_len = tchar - filespec;
a35dcc95 13732 memcpy(dir_name, filespec, dir_len);
4148925f
JM		 13733 dir_name[dir_len] = '\0';
13734 file_name = (char *) &filespec[dir_len + 1];
13735 }
13736 }
13737
13738 /* Dir name is defaulted */
13739 if (dir_name[0] == 0) {
13740 dir_name[0] = '.';
13741 dir_name[1] = '\0';
13742 }
13743
13744 /* Need realpath for the directory */
13745 sts = vms_fid_to_name(vms_dir_name,
13746 VMS_MAXRSS + 1,
312ac60b 13747 dir_name, 0, NULL);
4148925f
JM		 13748
13749 if (sts == 0) {
29475144 13750 /* Now need to pathify it. */
1fe570cc
JM		 13751 char *tdir = int_pathify_dirspec(vms_dir_name,
13752 outbuf);
4148925f
JM		 13753
13754 /* And now add the original filespec to it */
13755 if (file_name != NULL) {
a35dcc95 13756 my_strlcat(outbuf, file_name, VMS_MAXRSS);
4148925f
JM		 13757 }
13758 return outbuf;
13759 }
13760 Safefree(vms_dir_name);
13761 Safefree(dir_name);
13762 }
13763 }
643f470b 13764 }
d584a1c6
JM		 13765 Safefree(vms_spec);
13766 }
13767 return rslt;
f7ddb74a
JM		 13768}
13769
b1a8dcd7
JM		 13770static char *
13771mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13772 int *utf8_fl)
13773{
13774 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13775 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
b1a8dcd7
JM		 13776
13777 /* Fall back to fid_to_name */
13778
312ac60b 13779 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
cd43acd7
CB		 13780 if (sts != 0) {
13781 return NULL;
13782 }
13783 else {
b1a8dcd7
JM		 13784
13785
13786 /* Now need to trim the version off */
13787 sts = vms_split_path
13788 (outbuf,
13789 &v_spec,
13790 &v_len,
13791 &r_spec,
13792 &r_len,
13793 &d_spec,
13794 &d_len,
13795 &n_spec,
13796 &n_len,
13797 &e_spec,
13798 &e_len,
13799 &vs_spec,
13800 &vs_len);
13801
13802
13803 if (sts == 0) {
4d8d3a9c
CB		 13804 int haslower = 0;
13805 const char *cp;
13806
13807 /* Trim off the version */
13808 int file_len = v_len + r_len + d_len + n_len + e_len;
13809 outbuf[file_len] = 0;
b1a8dcd7 13810
4d8d3a9c
CB		 13811 /* Downcase if input had any lower case letters and
13812 * case preservation is not in effect.
13813 */
13814 if (!decc_efs_case_preserve) {
13815 for (cp = filespec; *cp; cp++)
13816 if (islower(*cp)) { haslower = 1; break; }
13817
13818 if (haslower) __mystrtolower(outbuf);
13819 }
b1a8dcd7
JM		 13820 }
13821 }
13822 return outbuf;
13823}
13824
13825
f7ddb74a
JM		 13826/*}}}*/
13827/* External entry points */
ce12d4b7
CB		 13828char *
13829Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13830{
13831 return do_vms_realpath(filespec, outbuf, utf8_fl);
13832}
f7ddb74a 13833
ce12d4b7
CB		 13834char *
13835Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13836{
13837 return do_vms_realname(filespec, outbuf, utf8_fl);
13838}
f7ddb74a 13839
f7ddb74a
JM		 13840/* case_tolerant */
13841
13842/*{{{int do_vms_case_tolerant(void)*/
13843/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13844 * controlled by a process setting.
13845 */
ce12d4b7
CB		 13846int
13847do_vms_case_tolerant(void)
f7ddb74a
JM		 13848{
13849 return vms_process_case_tolerant;
13850}
13851/*}}}*/
13852/* External entry points */
ce12d4b7
CB		 13853int
13854Perl_vms_case_tolerant(void)
13855{
ce12d4b7 13856 return do_vms_case_tolerant();
ce12d4b7 13857}
f7ddb74a
JM		 13858
13859 /* Start of DECC RTL Feature handling */
13860
4ddecfe9
CB		 13861static int
13862set_feature_default(const char *name, int value)
13863{
13864 int status;
13865 int index;
25d1c58b
CB		 13866 char val_str[10];
13867
13868 /* If the feature has been explicitly disabled in the environment,
13869 * then don't enable it here.
13870 */
13871 if (value > 0) {
13872 status = simple_trnlnm(name, val_str, sizeof(val_str));
9bd30c63 13873 if (status) {
25d1c58b
CB		 13874 val_str[0] = _toupper(val_str[0]);
13875 if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
13876 return 0;
13877 }
13878 }
4ddecfe9
CB		 13879
13880 index = decc$feature_get_index(name);
13881
13882 status = decc$feature_set_value(index, 1, value);
13883 if (index == -1 || (status == -1)) {
13884 return -1;
13885 }
13886
13887 status = decc$feature_get_value(index, 1);
13888 if (status != value) {
13889 return -1;
13890 }
13891
13892 /* Various things may check for an environment setting
13893 * rather than the feature directly, so set that too.
13894 */
13895 vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13896
13897 return 0;
13898}
4ddecfe9 13899
f7ddb74a 13900
f7ddb74a
JM		 13901/* C RTL Feature settings */
13902
e2367aa8
CB		 13903#if defined(__DECC) || defined(__DECCXX)
13904
13905#ifdef __cplusplus
13906extern "C" {
13907#endif
13908
13909extern void
13910vmsperl_set_features(void)
f7ddb74a
JM		 13911{
13912 int status;
13913 int s;
f7ddb74a 13914 char val_str[10];
054a3baf 13915#if defined(JPI$_CASE_LOOKUP_PERM)
f7ddb74a
JM		 13916 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13917 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13918 unsigned long case_perm;
13919 unsigned long case_image;
3c841f20 13920#endif
f7ddb74a 13921
9c1171d1
JM		 13922 /* Allow an exception to bring Perl into the VMS debugger */
13923 vms_debug_on_exception = 0;
8dc9d339 13924 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
9bd30c63 13925 if (status) {
b53f3677 13926 val_str[0] = _toupper(val_str[0]);
9c1171d1
JM		 13927 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13928 vms_debug_on_exception = 1;
13929 else
13930 vms_debug_on_exception = 0;
13931 }
13932
b53f3677
JM		 13933 /* Debug unix/vms file translation routines */
13934 vms_debug_fileify = 0;
8dc9d339 13935 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
9bd30c63 13936 if (status) {
b53f3677
JM		 13937 val_str[0] = _toupper(val_str[0]);
13938 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13939 vms_debug_fileify = 1;
13940 else
13941 vms_debug_fileify = 0;
13942 }
13943
13944
13945 /* Historically PERL has been doing vmsify / stat differently than */
13946 /* the CRTL. In particular, under some conditions the CRTL will */
13947 /* remove some illegal characters like spaces from filenames */
13948 /* resulting in some differences. The stat()/lstat() wrapper has */
13949 /* been reporting such file names as invalid and fails to stat them */
13950 /* fixing this bug so that stat()/lstat() accept these like the */
13951 /* CRTL does will result in several tests failing. */
13952 /* This should really be fixed, but for now, set up a feature to */
13953 /* enable it so that the impact can be studied. */
13954 vms_bug_stat_filename = 0;
8dc9d339 13955 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
9bd30c63 13956 if (status) {
b53f3677
JM		 13957 val_str[0] = _toupper(val_str[0]);
13958 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13959 vms_bug_stat_filename = 1;
13960 else
13961 vms_bug_stat_filename = 0;
13962 }
13963
13964
38a44b82 13965 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5 13966 vms_vtf7_filenames = 0;
8dc9d339 13967 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
9bd30c63 13968 if (status) {
b53f3677 13969 val_str[0] = _toupper(val_str[0]);
360732b5
JM		 13970 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13971 vms_vtf7_filenames = 1;
13972 else
13973 vms_vtf7_filenames = 0;
13974 }
13975
e0e5e8d6 13976 /* unlink all versions on unlink() or rename() */
d584a1c6 13977 vms_unlink_all_versions = 0;
9bd30c63
CB		 13978 status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13979 if (status) {
b53f3677 13980 val_str[0] = _toupper(val_str[0]);
e0e5e8d6
JM		 13981 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13982 vms_unlink_all_versions = 1;
13983 else
13984 vms_unlink_all_versions = 0;
13985 }
13986
5ca74088 13987 /* Detect running under GNV Bash or other UNIX like shell */
360732b5 13988 gnv_unix_shell = 0;
8dc9d339 13989 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
9bd30c63 13990 if (status) {
360732b5 13991 gnv_unix_shell = 1;
360732b5
JM		 13992 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13993 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13994 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13995 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13996 vms_unlink_all_versions = 1;
1a3aec58 13997 vms_posix_exit = 1;
bc6f2746
CB		 13998 /* Reverse default ordering of PERL_ENV_TABLES. */
13999 defenv[0] = &crtlenvdsc;
14000 defenv[1] = &fildevdsc;
360732b5 14001 }
5ca74088
CB		 14002 /* Some reasonable defaults that are not CRTL defaults */
14003 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
c342cf44 14004 set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
012528a9 14005 set_feature_default("DECC$EFS_CHARSET", 1);
9c1171d1 14006
2497a41f
JM		 14007 /* hacks to see if known bugs are still present for testing */
14008
2497a41f 14009 /* PCP mode requires creating /dev/null special device file */
2623a4a6 14010 decc_bug_devnull = 0;
8dc9d339 14011 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
9bd30c63 14012 if (status) {
b53f3677 14013 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 14014 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14015 decc_bug_devnull = 1;
682e4b71
JM		 14016 else
14017 decc_bug_devnull = 0;
2497a41f
JM		 14018 }
14019
f7ddb74a
JM		 14020 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14021 if (s >= 0) {
14022 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14023 if (decc_disable_to_vms_logname_translation < 0)
14024 decc_disable_to_vms_logname_translation = 0;
14025 }
14026
14027 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14028 if (s >= 0) {
14029 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14030 if (decc_efs_case_preserve < 0)
14031 decc_efs_case_preserve = 0;
14032 }
14033
14034 s = decc$feature_get_index("DECC$EFS_CHARSET");
b53f3677 14035 decc_efs_charset_index = s;
f7ddb74a
JM		 14036 if (s >= 0) {
14037 decc_efs_charset = decc$feature_get_value(s, 1);
14038 if (decc_efs_charset < 0)
14039 decc_efs_charset = 0;
14040 }
14041
14042 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14043 if (s >= 0) {
14044 decc_filename_unix_report = decc$feature_get_value(s, 1);
1a3aec58 14045 if (decc_filename_unix_report > 0) {
f7ddb74a 14046 decc_filename_unix_report = 1;
1a3aec58
JM		 14047 vms_posix_exit = 1;
14048 }
f7ddb74a
JM		 14049 else
14050 decc_filename_unix_report = 0;
14051 }
14052
14053 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14054 if (s >= 0) {
14055 decc_filename_unix_only = decc$feature_get_value(s, 1);
14056 if (decc_filename_unix_only > 0) {
14057 decc_filename_unix_only = 1;
14058 }
14059 else {
14060 decc_filename_unix_only = 0;
14061 }
14062 }
14063
14064 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14065 if (s >= 0) {
14066 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14067 if (decc_filename_unix_no_version < 0)
14068 decc_filename_unix_no_version = 0;
14069 }
14070
14071 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14072 if (s >= 0) {
14073 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14074 if (decc_readdir_dropdotnotype < 0)
14075 decc_readdir_dropdotnotype = 0;
14076 }
14077
f7ddb74a
JM		 14078#if __CRTL_VER >= 80200000
14079 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14080 if (s >= 0) {
14081 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14082 if (decc_posix_compliant_pathnames < 0)
14083 decc_posix_compliant_pathnames = 0;
14084 if (decc_posix_compliant_pathnames > 4)
14085 decc_posix_compliant_pathnames = 0;
14086 }
14087
14088#endif
f7ddb74a 14089
054a3baf 14090#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
f7ddb74a
JM		 14091
14092 /* Report true case tolerance */
14093 /*----------------------------*/
14094 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14095 if (!$VMS_STATUS_SUCCESS(status))
14096 case_perm = PPROP$K_CASE_BLIND;
14097 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14098 if (!$VMS_STATUS_SUCCESS(status))
14099 case_image = PPROP$K_CASE_BLIND;
14100 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14101 (case_image == PPROP$K_CASE_SENSITIVE))
14102 vms_process_case_tolerant = 0;
14103
14104#endif
14105
1a3aec58 14106 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
94ae10c0 14107 /* for strict backward compatibility */
9bd30c63
CB		 14108 status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14109 if (status) {
b53f3677 14110 val_str[0] = _toupper(val_str[0]);
1a3aec58
JM		 14111 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14112 vms_posix_exit = 1;
14113 else
14114 vms_posix_exit = 0;
14115 }
c11536f5 14116}
f7ddb74a 14117
e2367aa8
CB		 14118/* Use 32-bit pointers because that's what the image activator
14119 * assumes for the LIB$INITIALZE psect.
14120 */
14121#if __INITIAL_POINTER_SIZE
14122#pragma pointer_size save
14123#pragma pointer_size 32
14124#endif
14125
14126/* Create a reference to the LIB$INITIALIZE function. */
14127extern void LIB$INITIALIZE(void);
14128extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14129
14130/* Create an array of pointers to the init functions in the special
14131 * LIB$INITIALIZE section. In our case, the array only has one entry.
14132 */
14133#pragma extern_model save
2646d7b3 14134#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
e2367aa8
CB		 14135extern void (* const vmsperl_unused_global_2[])() =
14136{
14137 vmsperl_set_features,
14138};
14139#pragma extern_model restore
14140
14141#if __INITIAL_POINTER_SIZE
14142#pragma pointer_size restore
14143#endif
14144
14145#ifdef __cplusplus
14146}
f7ddb74a
JM		 14147#endif
14148
e2367aa8 14149#endif /* defined(__DECC) || defined(__DECCXX) */
748a9306 14150/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.