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
podcheck.t: Was always giving failure under -regen
[perl5.git] / vms / vms.c
CommitLineData
b429d381 1/* vms.c
a0d0e21e 2 *
82dd182c 3 * VMS-specific routines for perl5
748a9306 4 *
82dd182c
CB		 5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
7 *
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
10 *
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
a0d0e21e
LW		 12 */
13
7c884029 14/*
4ac71550
TC		 15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
21 * "The Lay of Leithian", Canto II, lines 135-40
7c884029 22 *
4ac71550 23 * [p.162 of _The Lays of Beleriand_]
7c884029
CB		 24 */
25
a0d0e21e
LW		 26#include <acedef.h>
27#include <acldef.h>
28#include <armdef.h>
3ce52d1b
CB		 29#if __CRTL_VER < 70300000
30/* needed for home-rolled utime() */
748a9306 31#include <atrdef.h>
3ce52d1b
CB		 32#include <fibdef.h>
33#endif
a0d0e21e 34#include <chpdef.h>
8fde5078 35#include <clidef.h>
a3e9d8c9 36#include <climsgdef.h>
cd1191f1 37#include <dcdef.h>
a0d0e21e 38#include <descrip.h>
22d4bb9c 39#include <devdef.h>
a0d0e21e
LW		 40#include <dvidef.h>
41#include <float.h>
42#include <fscndef.h>
43#include <iodef.h>
44#include <jpidef.h>
61bb5906 45#include <kgbdef.h>
f675dbe5 46#include <libclidef.h>
a0d0e21e
LW		 47#include <libdef.h>
48#include <lib$routines.h>
49#include <lnmdef.h>
4fdf8f88 50#include <ossdef.h>
f7ddb74a
JM		 51#if __CRTL_VER >= 70301000 && !defined(__VAX)
52#include <ppropdef.h>
53#endif
748a9306 54#include <prvdef.h>
a0d0e21e
LW		 55#include <psldef.h>
56#include <rms.h>
57#include <shrdef.h>
58#include <ssdef.h>
59#include <starlet.h>
f86702cc 60#include <strdef.h>
61#include <str$routines.h>
a0d0e21e 62#include <syidef.h>
748a9306
LW		 63#include <uaidef.h>
64#include <uicdef.h>
2fbb330f 65#include <stsdef.h>
cfcfe586
JM		 66#include <efndef.h>
67#define NO_EFN EFN$C_ENF
a0d0e21e 68
f7ddb74a
JM		 69#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
70int decc$feature_get_index(const char *name);
71char* decc$feature_get_name(int index);
72int decc$feature_get_value(int index, int mode);
73int decc$feature_set_value(int index, int mode, int value);
74#else
75#include <unixlib.h>
76#endif
77
cfcfe586
JM		 78#pragma member_alignment save
79#pragma nomember_alignment longword
80struct item_list_3 {
81 unsigned short len;
82 unsigned short code;
83 void * bufadr;
84 unsigned short * retadr;
85};
86#pragma member_alignment restore
87
740ce14c 88/* Older versions of ssdef.h don't have these */
89#ifndef SS$_INVFILFOROP
90# define SS$_INVFILFOROP 3930
91#endif
92#ifndef SS$_NOSUCHOBJECT
b7ae7a0d 93# define SS$_NOSUCHOBJECT 2696
94#endif
95
a15cef0c
CB		 96/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
97#define PERLIO_NOT_STDIO 0
98
2497a41f 99/* Don't replace system definitions of vfork, getenv, lstat, and stat,
aa689395 100 * code below needs to get to the underlying CRTL routines. */
101#define DONT_MASK_RTL_CALLS
a0d0e21e
LW		 102#include "EXTERN.h"
103#include "perl.h"
748a9306 104#include "XSUB.h"
3eeba6fb
CB		 105/* Anticipating future expansion in lexical warnings . . . */
106#ifndef WARN_INTERNAL
107# define WARN_INTERNAL WARN_MISC
108#endif
a0d0e21e 109
988c775c
JM		 110#ifdef VMS_LONGNAME_SUPPORT
111#include <libfildef.h>
112#endif
113
58472d87
CB		 114#if !defined(__VAX) && __CRTL_VER >= 80200000
115#ifdef lstat
116#undef lstat
117#endif
118#else
119#ifdef lstat
120#undef lstat
121#endif
122#define lstat(_x, _y) stat(_x, _y)
123#endif
124
5f1992ed
CB		 125/* Routine to create a decterm for use with the Perl debugger */
126/* No headers, this information was found in the Programming Concepts Manual */
127
8cb5d3d5 128static int (*decw_term_port)
5f1992ed
CB		 129 (const struct dsc$descriptor_s * display,
130 const struct dsc$descriptor_s * setup_file,
131 const struct dsc$descriptor_s * customization,
132 struct dsc$descriptor_s * result_device_name,
133 unsigned short * result_device_name_length,
134 void * controller,
135 void * char_buffer,
8cb5d3d5 136 void * char_change_buffer) = 0;
22d4bb9c 137
c07a80fd 138/* gcc's header files don't #define direct access macros
139 * corresponding to VAXC's variant structs */
140#ifdef __GNUC__
482b294c 141# define uic$v_format uic$r_uic_form.uic$v_format
142# define uic$v_group uic$r_uic_form.uic$v_group
143# define uic$v_member uic$r_uic_form.uic$v_member
c07a80fd 144# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
145# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
146# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
147# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
148#endif
149
c645ec3f
GS		 150#if defined(NEED_AN_H_ERRNO)
151dEXT int h_errno;
152#endif
c07a80fd 153
81bca5f9 154#if defined(__DECC) || defined(__DECCXX)
f7ddb74a
JM		 155#pragma member_alignment save
156#pragma nomember_alignment longword
157#pragma message save
158#pragma message disable misalgndmem
159#endif
a0d0e21e
LW		 160struct itmlst_3 {
161 unsigned short int buflen;
162 unsigned short int itmcode;
163 void *bufadr;
748a9306 164 unsigned short int *retlen;
a0d0e21e 165};
657054d4
JM		 166
167struct filescan_itmlst_2 {
168 unsigned short length;
169 unsigned short itmcode;
170 char * component;
171};
172
dca5a913
JM		 173struct vs_str_st {
174 unsigned short length;
7202b047
CB		 175 char str[VMS_MAXRSS];
176 unsigned short pad; /* for longword struct alignment */
dca5a913
JM		 177};
178
81bca5f9 179#if defined(__DECC) || defined(__DECCXX)
f7ddb74a
JM		 180#pragma message restore
181#pragma member_alignment restore
182#endif
a0d0e21e 183
360732b5
JM		 184#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
185#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
186#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
187#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
188#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
189#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
b1a8dcd7 190#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
360732b5
JM		 191#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
192#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
f7ddb74a 193#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
4b19af01
CB		 194#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
195#define getredirection(a,b) mp_getredirection(aTHX_ a,b)
196
360732b5
JM		 197static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
198static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
199static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
200static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
f7ddb74a 201
6fb6c614
JM		 202static char * int_rmsexpand_vms(
203 const char * filespec, char * outbuf, unsigned opts);
204static char * int_rmsexpand_tovms(
205 const char * filespec, char * outbuf, unsigned opts);
df278665
JM		 206static char *int_tovmsspec
207 (const char *path, char *buf, int dir_flag, int * utf8_flag);
a979ce91 208static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
0e5ce2c7 209static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
4846f1d7 210static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
df278665 211
0e06870b
CB		 212/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
213#define PERL_LNM_MAX_ALLOWED_INDEX 127
214
2d9f3838
CB		 215/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
216 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
217 * the Perl facility.
218 */
219#define PERL_LNM_MAX_ITER 10
220
2497a41f
JM		 221 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
222#if __CRTL_VER >= 70302000 && !defined(__VAX)
223#define MAX_DCL_SYMBOL (8192)
224#define MAX_DCL_LINE_LENGTH (4096 - 4)
225#else
226#define MAX_DCL_SYMBOL (1024)
227#define MAX_DCL_LINE_LENGTH (1024 - 4)
228#endif
ff7adb52 229
01b8edb6 230static char *__mystrtolower(char *str)
231{
232 if (str) for (; *str; ++str) *str= tolower(*str);
233 return str;
234}
235
f675dbe5
CB		 236static struct dsc$descriptor_s fildevdsc =
237 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
238static struct dsc$descriptor_s crtlenvdsc =
239 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
240static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
241static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
242static struct dsc$descriptor_s **env_tables = defenv;
243static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
244
93948341
CB		 245/* True if we shouldn't treat barewords as logicals during directory */
246/* munching */
247static int no_translate_barewords;
248
f7ddb74a
JM		 249/* DECC Features that may need to affect how Perl interprets
250 * displays filename information
251 */
252static int decc_disable_to_vms_logname_translation = 1;
253static int decc_disable_posix_root = 1;
254int decc_efs_case_preserve = 0;
255static int decc_efs_charset = 0;
b53f3677 256static int decc_efs_charset_index = -1;
f7ddb74a
JM		 257static int decc_filename_unix_no_version = 0;
258static int decc_filename_unix_only = 0;
259int decc_filename_unix_report = 0;
260int decc_posix_compliant_pathnames = 0;
261int decc_readdir_dropdotnotype = 0;
262static int vms_process_case_tolerant = 1;
360732b5
JM		 263int vms_vtf7_filenames = 0;
264int gnv_unix_shell = 0;
e0e5e8d6 265static int vms_unlink_all_versions = 0;
1a3aec58 266static int vms_posix_exit = 0;
f7ddb74a 267
2497a41f 268/* bug workarounds if needed */
682e4b71 269int decc_bug_devnull = 1;
2497a41f 270int decc_dir_barename = 0;
b53f3677 271int vms_bug_stat_filename = 0;
2497a41f 272
9c1171d1 273static int vms_debug_on_exception = 0;
b53f3677
JM		 274static int vms_debug_fileify = 0;
275
276/* Simple logical name translation */
277static int simple_trnlnm
278 (const char * logname,
279 char * value,
280 int value_len)
281{
282 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
283 const unsigned long attr = LNM$M_CASE_BLIND;
284 struct dsc$descriptor_s name_dsc;
285 int status;
286 unsigned short result;
287 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
288 {0, 0, 0, 0}};
289
290 name_dsc.dsc$w_length = strlen(logname);
291 name_dsc.dsc$a_pointer = (char *)logname;
292 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
293 name_dsc.dsc$b_class = DSC$K_CLASS_S;
294
295 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
296
297 if ($VMS_STATUS_SUCCESS(status)) {
298
299 /* Null terminate and return the string */
300 /*--------------------------------------*/
301 value[result] = 0;
302 return result;
303 }
304
305 return 0;
306}
307
9c1171d1 308
f7ddb74a
JM		 309/* Is this a UNIX file specification?
310 * No longer a simple check with EFS file specs
311 * For now, not a full check, but need to
312 * handle POSIX ^UP^ specifications
313 * Fixing to handle ^/ cases would require
314 * changes to many other conversion routines.
315 */
316
657054d4 317static int is_unix_filespec(const char *path)
f7ddb74a
JM		 318{
319int ret_val;
320const char * pch1;
321
322 ret_val = 0;
323 if (strncmp(path,"\"^UP^",5) != 0) {
324 pch1 = strchr(path, '/');
325 if (pch1 != NULL)
326 ret_val = 1;
327 else {
328
329 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
330 if (decc_filename_unix_report || decc_filename_unix_only) {
331 if (strcmp(path,".") == 0)
332 ret_val = 1;
333 }
334 }
335 }
336 return ret_val;
337}
338
360732b5
JM		 339/* This routine converts a UCS-2 character to be VTF-7 encoded.
340 */
341
342static void ucs2_to_vtf7
343 (char *outspec,
344 unsigned long ucs2_char,
345 int * output_cnt)
346{
347unsigned char * ucs_ptr;
348int hex;
349
350 ucs_ptr = (unsigned char *)&ucs2_char;
351
352 outspec[0] = '^';
353 outspec[1] = 'U';
354 hex = (ucs_ptr[1] >> 4) & 0xf;
355 if (hex < 0xA)
356 outspec[2] = hex + '0';
357 else
358 outspec[2] = (hex - 9) + 'A';
359 hex = ucs_ptr[1] & 0xF;
360 if (hex < 0xA)
361 outspec[3] = hex + '0';
362 else {
363 outspec[3] = (hex - 9) + 'A';
364 }
365 hex = (ucs_ptr[0] >> 4) & 0xf;
366 if (hex < 0xA)
367 outspec[4] = hex + '0';
368 else
369 outspec[4] = (hex - 9) + 'A';
370 hex = ucs_ptr[1] & 0xF;
371 if (hex < 0xA)
372 outspec[5] = hex + '0';
373 else {
374 outspec[5] = (hex - 9) + 'A';
375 }
376 *output_cnt = 6;
377}
378
379
380/* This handles the conversion of a UNIX extended character set to a ^
381 * escaped VMS character.
382 * in a UNIX file specification.
383 *
384 * The output count variable contains the number of characters added
385 * to the output string.
386 *
387 * The return value is the number of characters read from the input string
388 */
389static int copy_expand_unix_filename_escape
390 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
391{
392int count;
360732b5
JM		 393int utf8_flag;
394
395 utf8_flag = 0;
396 if (utf8_fl)
397 utf8_flag = *utf8_fl;
398
399 count = 0;
400 *output_cnt = 0;
401 if (*inspec >= 0x80) {
402 if (utf8_fl && vms_vtf7_filenames) {
403 unsigned long ucs_char;
404
405 ucs_char = 0;
406
407 if ((*inspec & 0xE0) == 0xC0) {
408 /* 2 byte Unicode */
409 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
410 if (ucs_char >= 0x80) {
411 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
412 return 2;
413 }
414 } else if ((*inspec & 0xF0) == 0xE0) {
415 /* 3 byte Unicode */
416 ucs_char = ((inspec[0] & 0xF) << 12) +
417 ((inspec[1] & 0x3f) << 6) +
418 (inspec[2] & 0x3f);
419 if (ucs_char >= 0x800) {
420 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
421 return 3;
422 }
423
424#if 0 /* I do not see longer sequences supported by OpenVMS */
425 /* Maybe some one can fix this later */
426 } else if ((*inspec & 0xF8) == 0xF0) {
427 /* 4 byte Unicode */
428 /* UCS-4 to UCS-2 */
429 } else if ((*inspec & 0xFC) == 0xF8) {
430 /* 5 byte Unicode */
431 /* UCS-4 to UCS-2 */
432 } else if ((*inspec & 0xFE) == 0xFC) {
433 /* 6 byte Unicode */
434 /* UCS-4 to UCS-2 */
435#endif
436 }
437 }
438
38a44b82 439 /* High bit set, but not a Unicode character! */
360732b5
JM		 440
441 /* Non printing DECMCS or ISO Latin-1 character? */
b931d62c
CB		 442 if ((unsigned char)*inspec <= 0x9F) {
443 int hex;
360732b5
JM		 444 outspec[0] = '^';
445 outspec++;
446 hex = (*inspec >> 4) & 0xF;
447 if (hex < 0xA)
448 outspec[1] = hex + '0';
449 else {
450 outspec[1] = (hex - 9) + 'A';
451 }
452 hex = *inspec & 0xF;
453 if (hex < 0xA)
454 outspec[2] = hex + '0';
455 else {
456 outspec[2] = (hex - 9) + 'A';
457 }
458 *output_cnt = 3;
459 return 1;
b931d62c 460 } else if ((unsigned char)*inspec == 0xA0) {
360732b5
JM		 461 outspec[0] = '^';
462 outspec[1] = 'A';
463 outspec[2] = '0';
464 *output_cnt = 3;
465 return 1;
b931d62c 466 } else if ((unsigned char)*inspec == 0xFF) {
360732b5
JM		 467 outspec[0] = '^';
468 outspec[1] = 'F';
469 outspec[2] = 'F';
470 *output_cnt = 3;
471 return 1;
472 }
473 *outspec = *inspec;
474 *output_cnt = 1;
475 return 1;
476 }
477
478 /* Is this a macro that needs to be passed through?
479 * Macros start with $( and an alpha character, followed
480 * by a string of alpha numeric characters ending with a )
481 * If this does not match, then encode it as ODS-5.
482 */
483 if ((inspec[0] == '$') && (inspec[1] == '(')) {
484 int tcnt;
485
486 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
487 tcnt = 3;
488 outspec[0] = inspec[0];
489 outspec[1] = inspec[1];
490 outspec[2] = inspec[2];
491
492 while(isalnum(inspec[tcnt]) ||
493 (inspec[2] == '.') || (inspec[2] == '_')) {
494 outspec[tcnt] = inspec[tcnt];
495 tcnt++;
496 }
497 if (inspec[tcnt] == ')') {
498 outspec[tcnt] = inspec[tcnt];
499 tcnt++;
500 *output_cnt = tcnt;
501 return tcnt;
502 }
503 }
504 }
505
506 switch (*inspec) {
507 case 0x7f:
508 outspec[0] = '^';
509 outspec[1] = '7';
510 outspec[2] = 'F';
511 *output_cnt = 3;
512 return 1;
513 break;
514 case '?':
515 if (decc_efs_charset == 0)
516 outspec[0] = '%';
517 else
518 outspec[0] = '?';
519 *output_cnt = 1;
520 return 1;
521 break;
522 case '.':
523 case '~':
524 case '!':
525 case '#':
526 case '&':
527 case '\'':
528 case '`':
529 case '(':
530 case ')':
531 case '+':
532 case '@':
533 case '{':
534 case '}':
535 case ',':
536 case ';':
537 case '[':
538 case ']':
539 case '%':
540 case '^':
449de3c2 541 case '\\':
adc11f0b
CB		 542 /* Don't escape again if following character is
543 * already something we escape.
544 */
449de3c2 545 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
adc11f0b
CB		 546 *outspec = *inspec;
547 *output_cnt = 1;
548 return 1;
549 break;
550 }
551 /* But otherwise fall through and escape it. */
360732b5
JM		 552 case '=':
553 /* Assume that this is to be escaped */
554 outspec[0] = '^';
555 outspec[1] = *inspec;
556 *output_cnt = 2;
557 return 1;
558 break;
559 case ' ': /* space */
560 /* Assume that this is to be escaped */
561 outspec[0] = '^';
562 outspec[1] = '_';
563 *output_cnt = 2;
564 return 1;
565 break;
566 default:
567 *outspec = *inspec;
568 *output_cnt = 1;
569 return 1;
570 break;
571 }
c11536f5 572 return 0;
360732b5
JM		 573}
574
575
657054d4
JM		 576/* This handles the expansion of a '^' prefix to the proper character
577 * in a UNIX file specification.
578 *
579 * The output count variable contains the number of characters added
580 * to the output string.
581 *
582 * The return value is the number of characters read from the input
583 * string
584 */
585static int copy_expand_vms_filename_escape
586 (char *outspec, const char *inspec, int *output_cnt)
587{
588int count;
589int scnt;
590
591 count = 0;
592 *output_cnt = 0;
593 if (*inspec == '^') {
594 inspec++;
595 switch (*inspec) {
adc11f0b
CB		 596 /* Spaces and non-trailing dots should just be passed through,
597 * but eat the escape character.
598 */
657054d4 599 case '.':
657054d4 600 *outspec = *inspec;
adc11f0b
CB		 601 count += 2;
602 (*output_cnt)++;
657054d4
JM		 603 break;
604 case '_': /* space */
605 *outspec = ' ';
adc11f0b 606 count += 2;
657054d4
JM		 607 (*output_cnt)++;
608 break;
adc11f0b
CB		 609 case '^':
610 /* Hmm. Better leave the escape escaped. */
611 outspec[0] = '^';
612 outspec[1] = '^';
613 count += 2;
614 (*output_cnt) += 2;
615 break;
360732b5 616 case 'U': /* Unicode - FIX-ME this is wrong. */
657054d4
JM		 617 inspec++;
618 count++;
619 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
620 if (scnt == 4) {
2f4077ca
JM		 621 unsigned int c1, c2;
622 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
9960802c
NK		 623 outspec[0] = c1 & 0xff;
624 outspec[1] = c2 & 0xff;
657054d4
JM		 625 if (scnt > 1) {
626 (*output_cnt) += 2;
627 count += 4;
628 }
629 }
630 else {
631 /* Error - do best we can to continue */
632 *outspec = 'U';
633 outspec++;
634 (*output_cnt++);
635 *outspec = *inspec;
636 count++;
637 (*output_cnt++);
638 }
639 break;
640 default:
641 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
642 if (scnt == 2) {
643 /* Hex encoded */
2f4077ca
JM		 644 unsigned int c1;
645 scnt = sscanf(inspec, "%2x", &c1);
646 outspec[0] = c1 & 0xff;
657054d4
JM		 647 if (scnt > 0) {
648 (*output_cnt++);
649 count += 2;
650 }
651 }
652 else {
653 *outspec = *inspec;
654 count++;
655 (*output_cnt++);
656 }
657 }
658 }
659 else {
660 *outspec = *inspec;
661 count++;
662 (*output_cnt)++;
663 }
664 return count;
665}
666
657054d4
JM		 667/* vms_split_path - Verify that the input file specification is a
668 * VMS format file specification, and provide pointers to the components of
669 * it. With EFS format filenames, this is virtually the only way to
670 * parse a VMS path specification into components.
671 *
672 * If the sum of the components do not add up to the length of the
673 * string, then the passed file specification is probably a UNIX style
674 * path.
675 */
676static int vms_split_path
360732b5 677 (const char * path,
dca5a913 678 char * * volume,
657054d4 679 int * vol_len,
dca5a913 680 char * * root,
657054d4 681 int * root_len,
dca5a913 682 char * * dir,
657054d4 683 int * dir_len,
dca5a913 684 char * * name,
657054d4 685 int * name_len,
dca5a913 686 char * * ext,
657054d4 687 int * ext_len,
dca5a913 688 char * * version,
657054d4
JM		 689 int * ver_len)
690{
691struct dsc$descriptor path_desc;
692int status;
693unsigned long flags;
694int ret_stat;
695struct filescan_itmlst_2 item_list[9];
696const int filespec = 0;
697const int nodespec = 1;
698const int devspec = 2;
699const int rootspec = 3;
700const int dirspec = 4;
701const int namespec = 5;
702const int typespec = 6;
703const int verspec = 7;
704
705 /* Assume the worst for an easy exit */
706 ret_stat = -1;
707 *volume = NULL;
708 *vol_len = 0;
709 *root = NULL;
710 *root_len = 0;
711 *dir = NULL;
657054d4
JM		 712 *name = NULL;
713 *name_len = 0;
714 *ext = NULL;
715 *ext_len = 0;
716 *version = NULL;
717 *ver_len = 0;
718
719 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
720 path_desc.dsc$w_length = strlen(path);
721 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
722 path_desc.dsc$b_class = DSC$K_CLASS_S;
723
724 /* Get the total length, if it is shorter than the string passed
725 * then this was probably not a VMS formatted file specification
726 */
727 item_list[filespec].itmcode = FSCN$_FILESPEC;
728 item_list[filespec].length = 0;
729 item_list[filespec].component = NULL;
730
731 /* If the node is present, then it gets considered as part of the
732 * volume name to hopefully make things simple.
733 */
734 item_list[nodespec].itmcode = FSCN$_NODE;
735 item_list[nodespec].length = 0;
736 item_list[nodespec].component = NULL;
737
738 item_list[devspec].itmcode = FSCN$_DEVICE;
739 item_list[devspec].length = 0;
740 item_list[devspec].component = NULL;
741
742 /* root is a special case, adding it to either the directory or
94ae10c0 743 * the device components will probably complicate things for the
657054d4
JM		 744 * callers of this routine, so leave it separate.
745 */
746 item_list[rootspec].itmcode = FSCN$_ROOT;
747 item_list[rootspec].length = 0;
748 item_list[rootspec].component = NULL;
749
750 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
751 item_list[dirspec].length = 0;
752 item_list[dirspec].component = NULL;
753
754 item_list[namespec].itmcode = FSCN$_NAME;
755 item_list[namespec].length = 0;
756 item_list[namespec].component = NULL;
757
758 item_list[typespec].itmcode = FSCN$_TYPE;
759 item_list[typespec].length = 0;
760 item_list[typespec].component = NULL;
761
762 item_list[verspec].itmcode = FSCN$_VERSION;
763 item_list[verspec].length = 0;
764 item_list[verspec].component = NULL;
765
766 item_list[8].itmcode = 0;
767 item_list[8].length = 0;
768 item_list[8].component = NULL;
769
7566800d 770 status = sys$filescan
657054d4
JM		 771 ((const struct dsc$descriptor_s *)&path_desc, item_list,
772 &flags, NULL, NULL);
360732b5 773 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
657054d4
JM		 774
775 /* If we parsed it successfully these two lengths should be the same */
776 if (path_desc.dsc$w_length != item_list[filespec].length)
777 return ret_stat;
778
779 /* If we got here, then it is a VMS file specification */
780 ret_stat = 0;
781
782 /* set the volume name */
783 if (item_list[nodespec].length > 0) {
784 *volume = item_list[nodespec].component;
785 *vol_len = item_list[nodespec].length + item_list[devspec].length;
786 }
787 else {
788 *volume = item_list[devspec].component;
789 *vol_len = item_list[devspec].length;
790 }
791
792 *root = item_list[rootspec].component;
793 *root_len = item_list[rootspec].length;
794
795 *dir = item_list[dirspec].component;
796 *dir_len = item_list[dirspec].length;
797
798 /* Now fun with versions and EFS file specifications
799 * The parser can not tell the difference when a "." is a version
800 * delimiter or a part of the file specification.
801 */
802 if ((decc_efs_charset) &&
803 (item_list[verspec].length > 0) &&
804 (item_list[verspec].component[0] == '.')) {
805 *name = item_list[namespec].component;
806 *name_len = item_list[namespec].length + item_list[typespec].length;
807 *ext = item_list[verspec].component;
808 *ext_len = item_list[verspec].length;
809 *version = NULL;
810 *ver_len = 0;
811 }
812 else {
813 *name = item_list[namespec].component;
814 *name_len = item_list[namespec].length;
815 *ext = item_list[typespec].component;
816 *ext_len = item_list[typespec].length;
817 *version = item_list[verspec].component;
818 *ver_len = item_list[verspec].length;
819 }
820 return ret_stat;
821}
822
df278665
JM		 823/* Routine to determine if the file specification ends with .dir */
824static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
825
826 /* e_len must be 4, and version must be <= 2 characters */
827 if (e_len != 4 || vs_len > 2)
828 return 0;
829
830 /* If a version number is present, it needs to be one */
831 if ((vs_len == 2) && (vs_spec[1] != '1'))
832 return 0;
833
834 /* Look for the DIR on the extension */
835 if (vms_process_case_tolerant) {
836 if ((toupper(e_spec[1]) == 'D') &&
837 (toupper(e_spec[2]) == 'I') &&
838 (toupper(e_spec[3]) == 'R')) {
839 return 1;
840 }
841 } else {
842 /* Directory extensions are supposed to be in upper case only */
843 /* I would not be surprised if this rule can not be enforced */
844 /* if and when someone fully debugs the case sensitive mode */
845 if ((e_spec[1] == 'D') &&
846 (e_spec[2] == 'I') &&
847 (e_spec[3] == 'R')) {
848 return 1;
849 }
850 }
851 return 0;
852}
853
f7ddb74a 854
fa537f88
CB		 855/* my_maxidx
856 * Routine to retrieve the maximum equivalence index for an input
857 * logical name. Some calls to this routine have no knowledge if
858 * the variable is a logical or not. So on error we return a max
859 * index of zero.
860 */
f7ddb74a 861/*{{{int my_maxidx(const char *lnm) */
fa537f88 862static int
f7ddb74a 863my_maxidx(const char *lnm)
fa537f88
CB		 864{
865 int status;
866 int midx;
867 int attr = LNM$M_CASE_BLIND;
868 struct dsc$descriptor lnmdsc;
869 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
870 {0, 0, 0, 0}};
871
872 lnmdsc.dsc$w_length = strlen(lnm);
873 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
874 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 875 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
fa537f88
CB		 876
877 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
878 if ((status & 1) == 0)
879 midx = 0;
880
881 return (midx);
882}
883/*}}}*/
884
f675dbe5 885/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
c07a80fd 886int
fd8cd3a3 887Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
f675dbe5 888 struct dsc$descriptor_s **tabvec, unsigned long int flags)
748a9306 889{
f7ddb74a
JM		 890 const char *cp1;
891 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
f675dbe5 892 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
748a9306 893 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
fa537f88 894 int midx;
f675dbe5
CB		 895 unsigned char acmode;
896 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
897 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
898 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
899 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
748a9306 900 {0, 0, 0, 0}};
f675dbe5 901 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
fd8cd3a3
DS		 902#if defined(PERL_IMPLICIT_CONTEXT)
903 pTHX = NULL;
fd8cd3a3
DS		 904 if (PL_curinterp) {
905 aTHX = PERL_GET_INTERP;
cc077a9f 906 } else {
fd8cd3a3 907 aTHX = NULL;
cc077a9f
HM		 908 }
909#endif
748a9306 910
fa537f88 911 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
b7ae7a0d 912 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
913 }
f7ddb74a 914 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 915 *cp2 = _toupper(*cp1);
916 if (cp1 - lnm > LNM$C_NAMLENGTH) {
917 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
918 return 0;
919 }
920 }
921 lnmdsc.dsc$w_length = cp1 - lnm;
922 lnmdsc.dsc$a_pointer = uplnm;
fd7385b9 923 uplnm[lnmdsc.dsc$w_length] = '\0';
f675dbe5
CB		 924 secure = flags & PERL__TRNENV_SECURE;
925 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
926 if (!tabvec || !*tabvec) tabvec = env_tables;
927
928 for (curtab = 0; tabvec[curtab]; curtab++) {
929 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
930 if (!ivenv && !secure) {
4e0c9737 931 char *eq;
f675dbe5
CB		 932 int i;
933 if (!environ) {
934 ivenv = 1;
ebd4d70b
JM		 935#if defined(PERL_IMPLICIT_CONTEXT)
936 if (aTHX == NULL) {
937 fprintf(stderr,
873f5ddf 938 "Can't read CRTL environ\n");
ebd4d70b
JM		 939 } else
940#endif
941 Perl_warn(aTHX_ "Can't read CRTL environ\n");
f675dbe5
CB		 942 continue;
943 }
944 retsts = SS$_NOLOGNAM;
945 for (i = 0; environ[i]; i++) {
946 if ((eq = strchr(environ[i],'=')) &&
299d126a 947 lnmdsc.dsc$w_length == (eq - environ[i]) &&
f675dbe5
CB		 948 !strncmp(environ[i],uplnm,eq - environ[i])) {
949 eq++;
950 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
951 if (!eqvlen) continue;
952 retsts = SS$_NORMAL;
953 break;
954 }
955 }
956 if (retsts != SS$_NOLOGNAM) break;
957 }
958 }
959 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
960 !str$case_blind_compare(&tmpdsc,&clisym)) {
961 if (!ivsym && !secure) {
962 unsigned short int deflen = LNM$C_NAMLENGTH;
963 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
94ae10c0 964 /* dynamic dsc to accommodate possible long value */
ebd4d70b 965 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
f675dbe5
CB		 966 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
967 if (retsts & 1) {
2497a41f 968 if (eqvlen > MAX_DCL_SYMBOL) {
f675dbe5 969 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
2497a41f 970 eqvlen = MAX_DCL_SYMBOL;
cc077a9f
HM		 971 /* Special hack--we might be called before the interpreter's */
972 /* fully initialized, in which case either thr or PL_curcop */
973 /* might be bogus. We have to check, since ckWARN needs them */
974 /* both to be valid if running threaded */
8a646e0b
JM		 975#if defined(PERL_IMPLICIT_CONTEXT)
976 if (aTHX == NULL) {
977 fprintf(stderr,
873f5ddf 978 "Value of CLI symbol \"%s\" too long",lnm);
8a646e0b
JM		 979 } else
980#endif
cc077a9f 981 if (ckWARN(WARN_MISC)) {
f98bc0c6 982 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
cc077a9f 983 }
f675dbe5
CB		 984 }
985 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
986 }
ebd4d70b 987 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
f675dbe5
CB		 988 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
989 if (retsts == LIB$_NOSUCHSYM) continue;
990 break;
991 }
992 }
993 else if (!ivlnm) {
843027b0 994 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
f7ddb74a
JM		 995 midx = my_maxidx(lnm);
996 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
997 lnmlst[1].bufadr = cp2;
fa537f88
CB		 998 eqvlen = 0;
999 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1000 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1001 if (retsts == SS$_NOLOGNAM) break;
1002 /* PPFs have a prefix */
1003 if (
fd7385b9 1004#if INTSIZE == 4
fa537f88 1005 *((int *)uplnm) == *((int *)"SYS$") &&
fd7385b9 1006#endif
fa537f88
CB		 1007 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1008 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1009 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1010 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1011 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
18a3d61e 1012 memmove(eqv,eqv+4,eqvlen-4);
fa537f88
CB		 1013 eqvlen -= 4;
1014 }
f7ddb74a
JM		 1015 cp2 += eqvlen;
1016 *cp2 = '\0';
fa537f88
CB		 1017 }
1018 if ((retsts == SS$_IVLOGNAM) ||
1019 (retsts == SS$_NOLOGNAM)) { continue; }
fd7385b9 1020 }
fa537f88 1021 else {
fa537f88
CB		 1022 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1023 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1024 if (retsts == SS$_NOLOGNAM) continue;
1025 eqv[eqvlen] = '\0';
1026 }
1027 eqvlen = strlen(eqv);
f675dbe5
CB		 1028 break;
1029 }
c07a80fd 1030 }
f675dbe5
CB		 1031 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1032 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1033 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1034 retsts == SS$_NOLOGNAM) {
1035 set_errno(EINVAL); set_vaxc_errno(retsts);
748a9306 1036 }
ebd4d70b 1037 else _ckvmssts_noperl(retsts);
f675dbe5
CB		 1038 return 0;
1039} /* end of vmstrnenv */
1040/*}}}*/
c07a80fd 1041
f675dbe5
CB		 1042/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1043/* Define as a function so we can access statics. */
4b19af01 1044int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
f675dbe5 1045{
8a646e0b
JM		 1046 int flags = 0;
1047
1048#if defined(PERL_IMPLICIT_CONTEXT)
1049 if (aTHX != NULL)
1050#endif
f675dbe5 1051#ifdef SECURE_INTERNAL_GETENV
284167a5 1052 flags = (PL_curinterp ? TAINTING_get : will_taint) ?
8a646e0b 1053 PERL__TRNENV_SECURE : 0;
f675dbe5 1054#endif
8a646e0b
JM		 1055
1056 return vmstrnenv(lnm, eqv, idx, fildev, flags);
f675dbe5
CB		 1057}
1058/*}}}*/
a0d0e21e
LW		 1059
1060/* my_getenv
61bb5906
CB		 1061 * Note: Uses Perl temp to store result so char * can be returned to
1062 * caller; this pointer will be invalidated at next Perl statement
1063 * transition.
a6c40364 1064 * We define this as a function rather than a macro in terms of my_getenv_len()
f675dbe5
CB		 1065 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1066 * allocate SVs).
a0d0e21e 1067 */
f675dbe5 1068/*{{{ char *my_getenv(const char *lnm, bool sys)*/
a0d0e21e 1069char *
5c84aa53 1070Perl_my_getenv(pTHX_ const char *lnm, bool sys)
a0d0e21e 1071{
f7ddb74a 1072 const char *cp1;
fa537f88 1073 static char *__my_getenv_eqv = NULL;
f7ddb74a 1074 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
c07a80fd 1075 unsigned long int idx = 0;
4e0c9737 1076 int success, secure, saverr, savvmserr;
843027b0 1077 int midx, flags;
61bb5906 1078 SV *tmpsv;
a0d0e21e 1079
f7ddb74a 1080 midx = my_maxidx(lnm) + 1;
fa537f88 1081
6b88bc9c 1082 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
61bb5906
CB		 1083 /* Set up a temporary buffer for the return value; Perl will
1084 * clean it up at the next statement transition */
fa537f88 1085 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
61bb5906
CB		 1086 if (!tmpsv) return NULL;
1087 eqv = SvPVX(tmpsv);
1088 }
fa537f88
CB		 1089 else {
1090 /* Assume no interpreter ==> single thread */
1091 if (__my_getenv_eqv != NULL) {
1092 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1093 }
1094 else {
a02a5408 1095 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1096 }
1097 eqv = __my_getenv_eqv;
1098 }
1099
f7ddb74a 1100 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1101 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
2497a41f 1102 int len;
61bb5906 1103 getcwd(eqv,LNM$C_NAMLENGTH);
2497a41f
JM		 1104
1105 len = strlen(eqv);
1106
1107 /* Get rid of "000000/ in rooted filespecs */
1108 if (len > 7) {
1109 char * zeros;
1110 zeros = strstr(eqv, "/000000/");
1111 if (zeros != NULL) {
1112 int mlen;
1113 mlen = len - (zeros - eqv) - 7;
1114 memmove(zeros, &zeros[7], mlen);
1115 len = len - 7;
1116 eqv[len] = '\0';
1117 }
1118 }
61bb5906 1119 return eqv;
748a9306 1120 }
a0d0e21e 1121 else {
2512681b 1122 /* Impose security constraints only if tainting */
bc10a425
CB		 1123 if (sys) {
1124 /* Impose security constraints only if tainting */
284167a5 1125 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425
CB		 1126 saverr = errno; savvmserr = vaxc$errno;
1127 }
843027b0
CB		 1128 else {
1129 secure = 0;
1130 }
1131
1132 flags =
f675dbe5 1133#ifdef SECURE_INTERNAL_GETENV
843027b0 1134 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1135#else
843027b0 1136 0
f675dbe5 1137#endif
843027b0
CB		 1138 ;
1139
1140 /* For the getenv interface we combine all the equivalence names
1141 * of a search list logical into one value to acquire a maximum
1142 * value length of 255*128 (assuming %ENV is using logicals).
1143 */
1144 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1145
1146 /* If the name contains a semicolon-delimited index, parse it
1147 * off and make sure we only retrieve the equivalence name for
1148 * that index. */
1149 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1150 my_strlcpy(uplnm, lnm, cp2 - lnm + 1);
843027b0
CB		 1151 idx = strtoul(cp2+1,NULL,0);
1152 lnm = uplnm;
1153 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1154 }
1155
1156 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1157
bc10a425
CB		 1158 /* Discard NOLOGNAM on internal calls since we're often looking
1159 * for an optional name, and this "error" often shows up as the
1160 * (bogus) exit status for a die() call later on. */
1161 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1162 return success ? eqv : NULL;
a0d0e21e 1163 }
a0d0e21e
LW		 1164
1165} /* end of my_getenv() */
1166/*}}}*/
1167
f675dbe5 1168
a6c40364
GS		 1169/*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1170char *
fd8cd3a3 1171Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
f675dbe5 1172{
f7ddb74a
JM		 1173 const char *cp1;
1174 char *buf, *cp2;
a6c40364 1175 unsigned long idx = 0;
843027b0 1176 int midx, flags;
fa537f88 1177 static char *__my_getenv_len_eqv = NULL;
bc10a425 1178 int secure, saverr, savvmserr;
cc077a9f
HM		 1179 SV *tmpsv;
1180
f7ddb74a 1181 midx = my_maxidx(lnm) + 1;
fa537f88 1182
cc077a9f
HM		 1183 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1184 /* Set up a temporary buffer for the return value; Perl will
1185 * clean it up at the next statement transition */
fa537f88 1186 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
cc077a9f
HM		 1187 if (!tmpsv) return NULL;
1188 buf = SvPVX(tmpsv);
1189 }
fa537f88
CB		 1190 else {
1191 /* Assume no interpreter ==> single thread */
1192 if (__my_getenv_len_eqv != NULL) {
1193 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1194 }
1195 else {
a02a5408 1196 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
fa537f88
CB		 1197 }
1198 buf = __my_getenv_len_eqv;
1199 }
1200
f7ddb74a 1201 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
f675dbe5 1202 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
f7ddb74a
JM		 1203 char * zeros;
1204
f675dbe5 1205 getcwd(buf,LNM$C_NAMLENGTH);
a6c40364 1206 *len = strlen(buf);
f7ddb74a
JM		 1207
1208 /* Get rid of "000000/ in rooted filespecs */
1209 if (*len > 7) {
1210 zeros = strstr(buf, "/000000/");
1211 if (zeros != NULL) {
1212 int mlen;
1213 mlen = *len - (zeros - buf) - 7;
1214 memmove(zeros, &zeros[7], mlen);
1215 *len = *len - 7;
1216 buf[*len] = '\0';
1217 }
1218 }
a6c40364 1219 return buf;
f675dbe5
CB		 1220 }
1221 else {
bc10a425
CB		 1222 if (sys) {
1223 /* Impose security constraints only if tainting */
284167a5 1224 secure = PL_curinterp ? TAINTING_get : will_taint;
bc10a425
CB		 1225 saverr = errno; savvmserr = vaxc$errno;
1226 }
843027b0
CB		 1227 else {
1228 secure = 0;
1229 }
1230
1231 flags =
f675dbe5 1232#ifdef SECURE_INTERNAL_GETENV
843027b0 1233 secure ? PERL__TRNENV_SECURE : 0
f675dbe5 1234#else
843027b0 1235 0
f675dbe5 1236#endif
843027b0
CB		 1237 ;
1238
1239 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1240
1241 if ((cp2 = strchr(lnm,';')) != NULL) {
a35dcc95 1242 my_strlcpy(buf, lnm, cp2 - lnm + 1);
843027b0
CB		 1243 idx = strtoul(cp2+1,NULL,0);
1244 lnm = buf;
1245 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1246 }
1247
1248 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1249
f7ddb74a
JM		 1250 /* Get rid of "000000/ in rooted filespecs */
1251 if (*len > 7) {
1252 char * zeros;
1253 zeros = strstr(buf, "/000000/");
1254 if (zeros != NULL) {
1255 int mlen;
1256 mlen = *len - (zeros - buf) - 7;
1257 memmove(zeros, &zeros[7], mlen);
1258 *len = *len - 7;
1259 buf[*len] = '\0';
1260 }
1261 }
1262
bc10a425
CB		 1263 /* Discard NOLOGNAM on internal calls since we're often looking
1264 * for an optional name, and this "error" often shows up as the
1265 * (bogus) exit status for a die() call later on. */
1266 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
4e205ed6 1267 return *len ? buf : NULL;
f675dbe5
CB		 1268 }
1269
a6c40364 1270} /* end of my_getenv_len() */
f675dbe5
CB		 1271/*}}}*/
1272
8a646e0b 1273static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
8fde5078
CB		 1274
1275static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1e422769 1276
740ce14c 1277/*{{{ void prime_env_iter() */
1278void
1279prime_env_iter(void)
1280/* Fill the %ENV associative array with all logical names we can
1281 * find, in preparation for iterating over it.
1282 */
1283{
17f28c40 1284 static int primed = 0;
3eeba6fb 1285 HV *seenhv = NULL, *envhv;
22be8b3c 1286 SV *sv = NULL;
4e205ed6 1287 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
8fde5078
CB		 1288 unsigned short int chan;
1289#ifndef CLI$M_TRUSTED
1290# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1291#endif
f675dbe5 1292 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
4e0c9737 1293 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0;
f675dbe5
CB		 1294 long int i;
1295 bool have_sym = FALSE, have_lnm = FALSE;
1296 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1297 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1298 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1299 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1300 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
fd8cd3a3
DS		 1301#if defined(PERL_IMPLICIT_CONTEXT)
1302 pTHX;
1303#endif
3db8f154 1304#if defined(USE_ITHREADS)
b2b3adea
HM		 1305 static perl_mutex primenv_mutex;
1306 MUTEX_INIT(&primenv_mutex);
61bb5906 1307#endif
740ce14c 1308
fd8cd3a3
DS		 1309#if defined(PERL_IMPLICIT_CONTEXT)
1310 /* We jump through these hoops because we can be called at */
1311 /* platform-specific initialization time, which is before anything is */
1312 /* set up--we can't even do a plain dTHX since that relies on the */
1313 /* interpreter structure to be initialized */
fd8cd3a3
DS		 1314 if (PL_curinterp) {
1315 aTHX = PERL_GET_INTERP;
1316 } else {
ebd4d70b
JM		 1317 /* we never get here because the NULL pointer will cause the */
1318 /* several of the routines called by this routine to access violate */
1319
1320 /* This routine is only called by hv.c/hv_iterinit which has a */
1321 /* context, so the real fix may be to pass it through instead of */
1322 /* the hoops above */
fd8cd3a3
DS		 1323 aTHX = NULL;
1324 }
1325#endif
fd8cd3a3 1326
3eeba6fb 1327 if (primed || !PL_envgv) return;
61bb5906
CB		 1328 MUTEX_LOCK(&primenv_mutex);
1329 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
3eeba6fb 1330 envhv = GvHVn(PL_envgv);
740ce14c 1331 /* Perform a dummy fetch as an lval to insure that the hash table is
8fde5078 1332 * set up. Otherwise, the hv_store() will turn into a nullop. */
740ce14c 1333 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
740ce14c 1334
f675dbe5
CB		 1335 for (i = 0; env_tables[i]; i++) {
1336 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1337 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
f02a1854 1338 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
8fde5078 1339 }
f675dbe5
CB		 1340 if (have_sym || have_lnm) {
1341 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1342 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1343 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1344 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
61bb5906 1345 }
f675dbe5
CB		 1346
1347 for (i--; i >= 0; i--) {
1348 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1349 char *start;
1350 int j;
1351 for (j = 0; environ[j]; j++) {
1352 if (!(start = strchr(environ[j],'='))) {
3eeba6fb 1353 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1354 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
f675dbe5
CB		 1355 }
1356 else {
1357 start++;
22be8b3c
CB		 1358 sv = newSVpv(start,0);
1359 SvTAINTED_on(sv);
1360 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
f675dbe5
CB		 1361 }
1362 }
1363 continue;
740ce14c 1364 }
f675dbe5
CB		 1365 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1366 !str$case_blind_compare(&tmpdsc,&clisym)) {
a35dcc95 1367 my_strlcpy(cmd, "Show Symbol/Global *", sizeof(cmd));
f675dbe5
CB		 1368 cmddsc.dsc$w_length = 20;
1369 if (env_tables[i]->dsc$w_length == 12 &&
1370 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
a35dcc95 1371 !str$case_blind_compare(&tmpdsc,&local)) my_strlcpy(cmd+12, "Local *", sizeof(cmd)-12);
f675dbe5
CB		 1372 flags = defflags | CLI$M_NOLOGNAM;
1373 }
1374 else {
a35dcc95 1375 my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
f675dbe5 1376 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
a35dcc95
CB		 1377 my_strlcat(cmd," /Table=", sizeof(cmd));
1378 cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
f675dbe5
CB		 1379 }
1380 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1381 flags = defflags | CLI$M_NOCLISYM;
1382 }
1383
1384 /* Create a new subprocess to execute each command, to exclude the
1385 * remote possibility that someone could subvert a mbx or file used
1386 * to write multiple commands to a single subprocess.
1387 */
1388 do {
1389 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1390 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1391 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1392 defflags &= ~CLI$M_TRUSTED;
1393 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1394 _ckvmssts(retsts);
a02a5408 1395 if (!buf) Newx(buf,mbxbufsiz + 1,char);
f675dbe5
CB		 1396 if (seenhv) SvREFCNT_dec(seenhv);
1397 seenhv = newHV();
1398 while (1) {
1399 char *cp1, *cp2, *key;
1400 unsigned long int sts, iosb[2], retlen, keylen;
eb578fdb 1401 U32 hash;
f675dbe5
CB		 1402
1403 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1404 if (sts & 1) sts = iosb[0] & 0xffff;
1405 if (sts == SS$_ENDOFFILE) {
1406 int wakect = 0;
1407 while (substs == 0) { sys$hiber(); wakect++;}
1408 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1409 _ckvmssts(substs);
1410 break;
1411 }
1412 _ckvmssts(sts);
1413 retlen = iosb[0] >> 16;
1414 if (!retlen) continue; /* blank line */
1415 buf[retlen] = '\0';
1416 if (iosb[1] != subpid) {
1417 if (iosb[1]) {
5c84aa53 1418 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
f675dbe5
CB		 1419 }
1420 continue;
1421 }
3eeba6fb 1422 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
f98bc0c6 1423 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
f675dbe5
CB		 1424
1425 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1426 if (*cp1 == '(' || /* Logical name table name */
1427 *cp1 == '=' /* Next eqv of searchlist */) continue;
1428 if (*cp1 == '"') cp1++;
1429 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1430 key = cp1; keylen = cp2 - cp1;
1431 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1432 while (*cp2 && *cp2 != '=') cp2++;
1f47e8e2
CB		 1433 while (*cp2 && *cp2 == '=') cp2++;
1434 while (*cp2 && *cp2 == ' ') cp2++;
1435 if (*cp2 == '"') { /* String translation; may embed "" */
1436 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1437 cp2++; cp1--; /* Skip "" surrounding translation */
1438 }
1439 else { /* Numeric translation */
1440 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1441 cp1--; /* stop on last non-space char */
1442 }
1443 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
f98bc0c6 1444 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
edc7bc49
CB		 1445 continue;
1446 }
5afd6d42 1447 PERL_HASH(hash,key,keylen);
ff79d39d
CB		 1448
1449 if (cp1 == cp2 && *cp2 == '.') {
1450 /* A single dot usually means an unprintable character, such as a null
1451 * to indicate a zero-length value. Get the actual value to make sure.
1452 */
1453 char lnm[LNM$C_NAMLENGTH+1];
2497a41f 1454 char eqv[MAX_DCL_SYMBOL+1];
0faef845 1455 int trnlen;
ff79d39d 1456 strncpy(lnm, key, keylen);
0faef845 1457 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
ff79d39d
CB		 1458 sv = newSVpvn(eqv, strlen(eqv));
1459 }
1460 else {
1461 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1462 }
1463
22be8b3c
CB		 1464 SvTAINTED_on(sv);
1465 hv_store(envhv,key,keylen,sv,hash);
f675dbe5 1466 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
edc7bc49 1467 }
f675dbe5
CB		 1468 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1469 /* get the PPFs for this process, not the subprocess */
f7ddb74a 1470 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
f675dbe5
CB		 1471 char eqv[LNM$C_NAMLENGTH+1];
1472 int trnlen, i;
1473 for (i = 0; ppfs[i]; i++) {
1474 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
22be8b3c
CB		 1475 sv = newSVpv(eqv,trnlen);
1476 SvTAINTED_on(sv);
1477 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
f675dbe5 1478 }
740ce14c 1479 }
1480 }
f675dbe5
CB		 1481 primed = 1;
1482 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1483 if (buf) Safefree(buf);
1484 if (seenhv) SvREFCNT_dec(seenhv);
1485 MUTEX_UNLOCK(&primenv_mutex);
1486 return;
1487
740ce14c 1488} /* end of prime_env_iter */
1489/*}}}*/
740ce14c 1490
f675dbe5 1491
2c590a56 1492/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1493/* Define or delete an element in the same "environment" as
1494 * vmstrnenv(). If an element is to be deleted, it's removed from
1495 * the first place it's found. If it's to be set, it's set in the
1496 * place designated by the first element of the table vector.
3eeba6fb 1497 * Like setenv() returns 0 for success, non-zero on error.
a0d0e21e 1498 */
f675dbe5 1499int
2c590a56 1500Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
a0d0e21e 1501{
f7ddb74a
JM		 1502 const char *cp1;
1503 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
f675dbe5 1504 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
fa537f88 1505 int nseg = 0, j;
a0d0e21e 1506 unsigned long int retsts, usermode = PSL$C_USER;
fa537f88 1507 struct itmlst_3 *ile, *ilist;
a0d0e21e 1508 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
f675dbe5
CB		 1509 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1510 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1511 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1512 $DESCRIPTOR(local,"_LOCAL");
1513
ed253963
CB		 1514 if (!lnm) {
1515 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1516 return SS$_IVLOGNAM;
1517 }
1518
f7ddb74a 1519 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
f675dbe5
CB		 1520 *cp2 = _toupper(*cp1);
1521 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1522 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1523 return SS$_IVLOGNAM;
1524 }
1525 }
a0d0e21e 1526 lnmdsc.dsc$w_length = cp1 - lnm;
f675dbe5
CB		 1527 if (!tabvec || !*tabvec) tabvec = env_tables;
1528
3eeba6fb 1529 if (!eqv) { /* we're deleting n element */
f675dbe5
CB		 1530 for (curtab = 0; tabvec[curtab]; curtab++) {
1531 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1532 int i;
299d126a 1533 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
f675dbe5 1534 if ((cp1 = strchr(environ[i],'=')) &&
299d126a 1535 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
f675dbe5 1536 !strncmp(environ[i],lnm,cp1 - environ[i])) {
3eeba6fb 1537#ifdef HAS_SETENV
0e06870b 1538 return setenv(lnm,"",1) ? vaxc$errno : 0;
f675dbe5
CB		 1539 }
1540 }
1541 ivenv = 1; retsts = SS$_NOLOGNAM;
1542#else
3eeba6fb 1543 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1544 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
3eeba6fb
CB		 1545 ivenv = 1; retsts = SS$_NOSUCHPGM;
1546 break;
1547 }
1548 }
f675dbe5
CB		 1549#endif
1550 }
1551 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1552 !str$case_blind_compare(&tmpdsc,&clisym)) {
1553 unsigned int symtype;
1554 if (tabvec[curtab]->dsc$w_length == 12 &&
1555 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1556 !str$case_blind_compare(&tmpdsc,&local))
1557 symtype = LIB$K_CLI_LOCAL_SYM;
1558 else symtype = LIB$K_CLI_GLOBAL_SYM;
1559 retsts = lib$delete_symbol(&lnmdsc,&symtype);
3eeba6fb
CB		 1560 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1561 if (retsts == LIB$_NOSUCHSYM) continue;
f675dbe5
CB		 1562 break;
1563 }
1564 else if (!ivlnm) {
1565 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1566 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1567 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1568 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1569 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1570 }
a0d0e21e
LW		 1571 }
1572 }
f675dbe5
CB		 1573 else { /* we're defining a value */
1574 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1575#ifdef HAS_SETENV
3eeba6fb 1576 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
f675dbe5 1577#else
3eeba6fb 1578 if (ckWARN(WARN_INTERNAL))
f98bc0c6 1579 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
f675dbe5
CB		 1580 retsts = SS$_NOSUCHPGM;
1581#endif
1582 }
1583 else {
f7ddb74a 1584 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
f675dbe5
CB		 1585 eqvdsc.dsc$w_length = strlen(eqv);
1586 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1587 !str$case_blind_compare(&tmpdsc,&clisym)) {
1588 unsigned int symtype;
1589 if (tabvec[0]->dsc$w_length == 12 &&
1590 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1591 !str$case_blind_compare(&tmpdsc,&local))
1592 symtype = LIB$K_CLI_LOCAL_SYM;
1593 else symtype = LIB$K_CLI_GLOBAL_SYM;
1594 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1595 }
3eeba6fb
CB		 1596 else {
1597 if (!*eqv) eqvdsc.dsc$w_length = 1;
a1dfe751 1598 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
fa537f88
CB		 1599
1600 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1601 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1602 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1603 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1604 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1605 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1606 }
1607
a02a5408 1608 Newx(ilist,nseg+1,struct itmlst_3);
fa537f88
CB		 1609 ile = ilist;
1610 if (!ile) {
1611 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1612 return SS$_INSFMEM;
a1dfe751 1613 }
fa537f88
CB		 1614 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1615
1616 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1617 ile->itmcode = LNM$_STRING;
1618 ile->bufadr = c;
1619 if ((j+1) == nseg) {
1620 ile->buflen = strlen(c);
1621 /* in case we are truncating one that's too long */
1622 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1623 }
1624 else {
1625 ile->buflen = LNM$C_NAMLENGTH;
1626 }
1627 }
1628
1629 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1630 Safefree (ilist);
1631 }
1632 else {
1633 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
a1dfe751 1634 }
3eeba6fb 1635 }
f675dbe5
CB		 1636 }
1637 }
1638 if (!(retsts & 1)) {
1639 switch (retsts) {
1640 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1641 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1642 set_errno(EVMSERR); break;
1643 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1644 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1645 set_errno(EINVAL); break;
1646 case SS$_NOPRIV:
7d2497bf 1647 set_errno(EACCES); break;
f675dbe5
CB		 1648 default:
1649 _ckvmssts(retsts);
1650 set_errno(EVMSERR);
1651 }
1652 set_vaxc_errno(retsts);
1653 return (int) retsts || 44; /* retsts should never be 0, but just in case */
a0d0e21e 1654 }
3eeba6fb
CB		 1655 else {
1656 /* We reset error values on success because Perl does an hv_fetch()
1657 * before each hv_store(), and if the thing we're setting didn't
1658 * previously exist, we've got a leftover error message. (Of course,
1659 * this fails in the face of
1660 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1661 * in that the error reported in $! isn't spurious,
1662 * but it's right more often than not.)
1663 */
f675dbe5
CB		 1664 set_errno(0); set_vaxc_errno(retsts);
1665 return 0;
1666 }
1667
1668} /* end of vmssetenv() */
1669/*}}}*/
a0d0e21e 1670
2c590a56 1671/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
f675dbe5
CB		 1672/* This has to be a function since there's a prototype for it in proto.h */
1673void
2c590a56 1674Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
f675dbe5 1675{
bc10a425
CB		 1676 if (lnm && *lnm) {
1677 int len = strlen(lnm);
1678 if (len == 7) {
1679 char uplnm[8];
22d4bb9c
CB		 1680 int i;
1681 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
bc10a425 1682 if (!strcmp(uplnm,"DEFAULT")) {
7ded3206 1683 if (eqv && *eqv) my_chdir(eqv);
bc10a425
CB		 1684 return;
1685 }
1686 }
22d4bb9c 1687 }
f675dbe5
CB		 1688 (void) vmssetenv(lnm,eqv,NULL);
1689}
a0d0e21e
LW		 1690/*}}}*/
1691
27c67b75 1692/*{{{static void vmssetuserlnm(char *name, char *eqv); */
0e06870b
CB		 1693/* vmssetuserlnm
1694 * sets a user-mode logical in the process logical name table
1695 * used for redirection of sys$error
1696 */
1697void
0db50132 1698Perl_vmssetuserlnm(const char *name, const char *eqv)
0e06870b
CB		 1699{
1700 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1701 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
2d5e9e5d 1702 unsigned long int iss, attr = LNM$M_CONFINE;
0e06870b
CB		 1703 unsigned char acmode = PSL$C_USER;
1704 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1705 {0, 0, 0, 0}};
2fbb330f 1706 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
0e06870b
CB		 1707 d_name.dsc$w_length = strlen(name);
1708
1709 lnmlst[0].buflen = strlen(eqv);
2fbb330f 1710 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
0e06870b
CB		 1711
1712 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1713 if (!(iss&1)) lib$signal(iss);
1714}
1715/*}}}*/
c07a80fd 1716
f675dbe5 1717
c07a80fd 1718/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1719/* my_crypt - VMS password hashing
1720 * my_crypt() provides an interface compatible with the Unix crypt()
1721 * C library function, and uses sys$hash_password() to perform VMS
1722 * password hashing. The quadword hashed password value is returned
1723 * as a NUL-terminated 8 character string. my_crypt() does not change
1724 * the case of its string arguments; in order to match the behavior
1725 * of LOGINOUT et al., alphabetic characters in both arguments must
1726 * be upcased by the caller.
2497a41f
JM		 1727 *
1728 * - fix me to call ACM services when available
c07a80fd 1729 */
1730char *
fd8cd3a3 1731Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
c07a80fd 1732{
1733# ifndef UAI$C_PREFERRED_ALGORITHM
1734# define UAI$C_PREFERRED_ALGORITHM 127
1735# endif
1736 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1737 unsigned short int salt = 0;
1738 unsigned long int sts;
1739 struct const_dsc {
1740 unsigned short int dsc$w_length;
1741 unsigned char dsc$b_type;
1742 unsigned char dsc$b_class;
1743 const char * dsc$a_pointer;
1744 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1745 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1746 struct itmlst_3 uailst[3] = {
1747 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1748 { sizeof salt, UAI$_SALT, &salt, 0},
1749 { 0, 0, NULL, NULL}};
1750 static char hash[9];
1751
1752 usrdsc.dsc$w_length = strlen(usrname);
1753 usrdsc.dsc$a_pointer = usrname;
1754 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1755 switch (sts) {
f282b18d 1756 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
c07a80fd 1757 set_errno(EACCES);
1758 break;
1759 case RMS$_RNF:
1760 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1761 break;
1762 default:
1763 set_errno(EVMSERR);
1764 }
1765 set_vaxc_errno(sts);
1766 if (sts != RMS$_RNF) return NULL;
1767 }
1768
1769 txtdsc.dsc$w_length = strlen(textpasswd);
1770 txtdsc.dsc$a_pointer = textpasswd;
1771 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1772 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1773 }
1774
1775 return (char *) hash;
1776
1777} /* end of my_crypt() */
1778/*}}}*/
1779
1780
360732b5
JM		 1781static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1782static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1783static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
a0d0e21e 1784
2497a41f
JM		 1785/* fixup barenames that are directories for internal use.
1786 * There have been problems with the consistent handling of UNIX
1787 * style directory names when routines are presented with a name that
94ae10c0 1788 * has no directory delimiters at all. So this routine will eventually
2497a41f
JM		 1789 * fix the issue.
1790 */
1791static char * fixup_bare_dirnames(const char * name)
1792{
1793 if (decc_disable_to_vms_logname_translation) {
1794/* fix me */
1795 }
1796 return NULL;
1797}
1798
e0e5e8d6
JM		 1799/* 8.3, remove() is now broken on symbolic links */
1800static int rms_erase(const char * vmsname);
1801
1802
2497a41f 1803/* mp_do_kill_file
94ae10c0 1804 * A little hack to get around a bug in some implementation of remove()
2497a41f
JM		 1805 * that do not know how to delete a directory
1806 *
1807 * Delete any file to which user has control access, regardless of whether
1808 * delete access is explicitly allowed.
1809 * Limitations: User must have write access to parent directory.
1810 * Does not block signals or ASTs; if interrupted in midstream
1811 * may leave file with an altered ACL.
1812 * HANDLE WITH CARE!
1813 */
1814/*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1815static int
1816mp_do_kill_file(pTHX_ const char *name, int dirflag)
1817{
e0e5e8d6
JM		 1818 char *vmsname;
1819 char *rslt;
2497a41f
JM		 1820 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1821 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1822 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1823 struct myacedef {
1824 unsigned char myace$b_length;
1825 unsigned char myace$b_type;
1826 unsigned short int myace$w_flags;
1827 unsigned long int myace$l_access;
1828 unsigned long int myace$l_ident;
1829 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1830 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1831 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1832 struct itmlst_3
1833 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1834 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1835 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1836 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1837 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1838 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1839
1840 /* Expand the input spec using RMS, since the CRTL remove() and
1841 * system services won't do this by themselves, so we may miss
1842 * a file "hiding" behind a logical name or search list. */
c11536f5 1843 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
ebd4d70b 1844 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 1845
6fb6c614 1846 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
e0e5e8d6 1847 if (rslt == NULL) {
c5375c28 1848 PerlMem_free(vmsname);
2497a41f
JM		 1849 return -1;
1850 }
c5375c28 1851
e0e5e8d6
JM		 1852 /* Erase the file */
1853 rmsts = rms_erase(vmsname);
2497a41f 1854
e0e5e8d6
JM		 1855 /* Did it succeed */
1856 if ($VMS_STATUS_SUCCESS(rmsts)) {
1857 PerlMem_free(vmsname);
1858 return 0;
2497a41f
JM		 1859 }
1860
1861 /* If not, can changing protections help? */
e0e5e8d6
JM		 1862 if (rmsts != RMS$_PRV) {
1863 set_vaxc_errno(rmsts);
1864 PerlMem_free(vmsname);
2497a41f
JM		 1865 return -1;
1866 }
1867
1868 /* No, so we get our own UIC to use as a rights identifier,
1869 * and the insert an ACE at the head of the ACL which allows us
1870 * to delete the file.
1871 */
ebd4d70b 1872 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
e0e5e8d6
JM		 1873 fildsc.dsc$w_length = strlen(vmsname);
1874 fildsc.dsc$a_pointer = vmsname;
2497a41f
JM		 1875 cxt = 0;
1876 newace.myace$l_ident = oldace.myace$l_ident;
e0e5e8d6 1877 rmsts = -1;
2497a41f
JM		 1878 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1879 switch (aclsts) {
1880 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1881 set_errno(ENOENT); break;
1882 case RMS$_DIR:
1883 set_errno(ENOTDIR); break;
1884 case RMS$_DEV:
1885 set_errno(ENODEV); break;
1886 case RMS$_SYN: case SS$_INVFILFOROP:
1887 set_errno(EINVAL); break;
1888 case RMS$_PRV:
1889 set_errno(EACCES); break;
1890 default:
ebd4d70b 1891 _ckvmssts_noperl(aclsts);
2497a41f
JM		 1892 }
1893 set_vaxc_errno(aclsts);
e0e5e8d6 1894 PerlMem_free(vmsname);
2497a41f
JM		 1895 return -1;
1896 }
1897 /* Grab any existing ACEs with this identifier in case we fail */
1898 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1899 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1900 || fndsts == SS$_NOMOREACE ) {
1901 /* Add the new ACE . . . */
1902 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1903 goto yourroom;
1904
e0e5e8d6
JM		 1905 rmsts = rms_erase(vmsname);
1906 if ($VMS_STATUS_SUCCESS(rmsts)) {
1907 rmsts = 0;
2497a41f
JM		 1908 }
1909 else {
e0e5e8d6 1910 rmsts = -1;
2497a41f
JM		 1911 /* We blew it - dir with files in it, no write priv for
1912 * parent directory, etc. Put things back the way they were. */
1913 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1914 goto yourroom;
1915 if (fndsts & 1) {
1916 addlst[0].bufadr = &oldace;
1917 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1918 goto yourroom;
1919 }
1920 }
1921 }
1922
1923 yourroom:
1924 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925 /* We just deleted it, so of course it's not there. Some versions of
1926 * VMS seem to return success on the unlock operation anyhow (after all
1927 * the unlock is successful), but others don't.
1928 */
1929 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930 if (aclsts & 1) aclsts = fndsts;
1931 if (!(aclsts & 1)) {
1932 set_errno(EVMSERR);
1933 set_vaxc_errno(aclsts);
2497a41f
JM		 1934 }
1935
e0e5e8d6 1936 PerlMem_free(vmsname);
2497a41f
JM		 1937 return rmsts;
1938
1939} /* end of kill_file() */
1940/*}}}*/
1941
1942
a0d0e21e
LW		 1943/*{{{int do_rmdir(char *name)*/
1944int
b8ffc8df 1945Perl_do_rmdir(pTHX_ const char *name)
a0d0e21e 1946{
e0e5e8d6 1947 char * dirfile;
a0d0e21e 1948 int retval;
61bb5906 1949 Stat_t st;
a0d0e21e 1950
d94c5a78
JM		 1951 /* lstat returns a VMS fileified specification of the name */
1952 /* that is looked up, and also lets verifies that this is a directory */
e0e5e8d6 1953
46c05374 1954 retval = flex_lstat(name, &st);
d94c5a78
JM		 1955 if (retval != 0) {
1956 char * ret_spec;
1957
1958 /* Due to a historical feature, flex_stat/lstat can not see some */
1959 /* Unix format file names that the rest of the CRTL can see */
1960 /* Fixing that feature will cause some perl tests to fail */
1961 /* So try this one more time. */
1962
1963 retval = lstat(name, &st.crtl_stat);
1964 if (retval != 0)
1965 return -1;
1966
1967 /* force it to a file spec for the kill file to work. */
1968 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
1969 if (ret_spec == NULL) {
1970 errno = EIO;
1971 return -1;
1972 }
e0e5e8d6 1973 }
d94c5a78
JM		 1974
1975 if (!S_ISDIR(st.st_mode)) {
e0e5e8d6
JM		 1976 errno = ENOTDIR;
1977 retval = -1;
1978 }
d94c5a78
JM		 1979 else {
1980 dirfile = st.st_devnam;
1981
1982 /* It may be possible for flex_stat to find a file and vmsify() to */
1983 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
1984 /* with that case, so fail it */
1985 if (dirfile[0] == 0) {
1986 errno = EIO;
1987 return -1;
1988 }
1989
e0e5e8d6 1990 retval = mp_do_kill_file(aTHX_ dirfile, 1);
d94c5a78 1991 }
e0e5e8d6 1992
a0d0e21e
LW		 1993 return retval;
1994
1995} /* end of do_rmdir */
1996/*}}}*/
1997
1998/* kill_file
1999 * Delete any file to which user has control access, regardless of whether
2000 * delete access is explicitly allowed.
2001 * Limitations: User must have write access to parent directory.
2002 * Does not block signals or ASTs; if interrupted in midstream
2003 * may leave file with an altered ACL.
2004 * HANDLE WITH CARE!
2005 */
2006/*{{{int kill_file(char *name)*/
2007int
b8ffc8df 2008Perl_kill_file(pTHX_ const char *name)
a0d0e21e 2009{
d94c5a78 2010 char * vmsfile;
e0e5e8d6
JM		 2011 Stat_t st;
2012 int rmsts;
a0d0e21e 2013
d94c5a78
JM		 2014 /* Convert the filename to VMS format and see if it is a directory */
2015 /* flex_lstat returns a vmsified file specification */
46c05374 2016 rmsts = flex_lstat(name, &st);
d94c5a78
JM		 2017 if (rmsts != 0) {
2018
2019 /* Due to a historical feature, flex_stat/lstat can not see some */
2020 /* Unix format file names that the rest of the CRTL can see when */
2021 /* ODS-2 file specifications are in use. */
2022 /* Fixing that feature will cause some perl tests to fail */
2023 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2024 st.st_mode = 0;
2025 vmsfile = (char *) name; /* cast ok */
2026
2027 } else {
2028 vmsfile = st.st_devnam;
2029 if (vmsfile[0] == 0) {
2030 /* It may be possible for flex_stat to find a file and vmsify() */
2031 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2032 /* deal with that case, so fail it */
2033 errno = EIO;
2034 return -1;
2035 }
2036 }
2037
2038 /* Remove() is allowed to delete directories, according to the X/Open
2039 * specifications.
2040 * This may need special handling to work with the ACL hacks.
a0d0e21e 2041 */
d94c5a78
JM		 2042 if (S_ISDIR(st.st_mode)) {
2043 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2044 return rmsts;
a0d0e21e
LW		 2045 }
2046
d94c5a78
JM		 2047 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2048
2049 /* Need to delete all versions ? */
2050 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2051 int i = 0;
2052
2053 /* Just use lstat() here as do not need st_dev */
2054 /* and we know that the file is in VMS format or that */
2055 /* because of a historical bug, flex_stat can not see the file */
2056 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2057 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2058 if (rmsts != 0)
2059 break;
2060 i++;
2061
2062 /* Make sure that we do not loop forever */
2063 if (i > 32767) {
2064 errno = EIO;
2065 rmsts = -1;
2066 break;
2067 }
2068 }
2069 }
a0d0e21e
LW		 2070
2071 return rmsts;
2072
2073} /* end of kill_file() */
2074/*}}}*/
2075
8cc95fdb 2076
84902520 2077/*{{{int my_mkdir(char *,Mode_t)*/
8cc95fdb 2078int
b8ffc8df 2079Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
8cc95fdb 2080{
2081 STRLEN dirlen = strlen(dir);
2082
a2a90019
CB		 2083 /* zero length string sometimes gives ACCVIO */
2084 if (dirlen == 0) return -1;
2085
8cc95fdb 2086 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2087 * null file name/type. However, it's commonplace under Unix,
2088 * so we'll allow it for a gain in portability.
2089 */
2090 if (dir[dirlen-1] == '/') {
2091 char *newdir = savepvn(dir,dirlen-1);
2092 int ret = mkdir(newdir,mode);
2093 Safefree(newdir);
2094 return ret;
2095 }
2096 else return mkdir(dir,mode);
2097} /* end of my_mkdir */
2098/*}}}*/
2099
ee8c7f54
CB		 2100/*{{{int my_chdir(char *)*/
2101int
b8ffc8df 2102Perl_my_chdir(pTHX_ const char *dir)
ee8c7f54
CB		 2103{
2104 STRLEN dirlen = strlen(dir);
ee8c7f54
CB		 2105
2106 /* zero length string sometimes gives ACCVIO */
2107 if (dirlen == 0) return -1;
f7ddb74a
JM		 2108 const char *dir1;
2109
2110 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2111 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2112 * so that existing scripts do not need to be changed.
2113 */
2114 dir1 = dir;
2115 while ((dirlen > 0) && (*dir1 == ' ')) {
2116 dir1++;
2117 dirlen--;
2118 }
ee8c7f54
CB		 2119
2120 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2121 * that implies
2122 * null file name/type. However, it's commonplace under Unix,
2123 * so we'll allow it for a gain in portability.
f7ddb74a 2124 *
4d9538c1 2125 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
ee8c7f54 2126 */
f7ddb74a 2127 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
4d9538c1
JM		 2128 char *newdir;
2129 int ret;
c11536f5 2130 newdir = (char *)PerlMem_malloc(dirlen);
4d9538c1
JM		 2131 if (newdir ==NULL)
2132 _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 2133 memcpy(newdir, dir1, dirlen-1);
4d9538c1
JM		 2134 newdir[dirlen-1] = '\0';
2135 ret = chdir(newdir);
2136 PerlMem_free(newdir);
2137 return ret;
ee8c7f54 2138 }
dca5a913 2139 else return chdir(dir1);
ee8c7f54
CB		 2140} /* end of my_chdir */
2141/*}}}*/
8cc95fdb 2142
674d6c38 2143
f1db9cda
JM		 2144/*{{{int my_chmod(char *, mode_t)*/
2145int
2146Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2147{
4d9538c1
JM		 2148 Stat_t st;
2149 int ret = -1;
2150 char * changefile;
f1db9cda
JM		 2151 STRLEN speclen = strlen(file_spec);
2152
2153 /* zero length string sometimes gives ACCVIO */
2154 if (speclen == 0) return -1;
2155
2156 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2157 * that implies null file name/type. However, it's commonplace under Unix,
2158 * so we'll allow it for a gain in portability.
2159 *
2160 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2161 * in VMS file.dir notation.
2162 */
4d9538c1
JM		 2163 changefile = (char *) file_spec; /* cast ok */
2164 ret = flex_lstat(file_spec, &st);
2165 if (ret != 0) {
f1db9cda 2166
4d9538c1
JM		 2167 /* Due to a historical feature, flex_stat/lstat can not see some */
2168 /* Unix format file names that the rest of the CRTL can see when */
2169 /* ODS-2 file specifications are in use. */
2170 /* Fixing that feature will cause some perl tests to fail */
2171 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2172 st.st_mode = 0;
f1db9cda 2173
4d9538c1
JM		 2174 } else {
2175 /* It may be possible to get here with nothing in st_devname */
2176 /* chmod still may work though */
2177 if (st.st_devnam[0] != 0) {
2178 changefile = st.st_devnam;
2179 }
f1db9cda 2180 }
4d9538c1
JM		 2181 ret = chmod(changefile, mode);
2182 return ret;
f1db9cda
JM		 2183} /* end of my_chmod */
2184/*}}}*/
2185
2186
674d6c38
CB		 2187/*{{{FILE *my_tmpfile()*/
2188FILE *
2189my_tmpfile(void)
2190{
2191 FILE *fp;
2192 char *cp;
674d6c38
CB		 2193
2194 if ((fp = tmpfile())) return fp;
2195
c11536f5 2196 cp = (char *)PerlMem_malloc(L_tmpnam+24);
c5375c28
JM		 2197 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2198
2497a41f
JM		 2199 if (decc_filename_unix_only == 0)
2200 strcpy(cp,"Sys$Scratch:");
2201 else
2202 strcpy(cp,"/tmp/");
674d6c38
CB		 2203 tmpnam(cp+strlen(cp));
2204 strcat(cp,".Perltmp");
2205 fp = fopen(cp,"w+","fop=dlt");
c5375c28 2206 PerlMem_free(cp);
674d6c38
CB		 2207 return fp;
2208}
2209/*}}}*/
2210
5c2d7af2 2211
5c2d7af2
CB		 2212/*
2213 * The C RTL's sigaction fails to check for invalid signal numbers so we
2214 * help it out a bit. The docs are correct, but the actual routine doesn't
2215 * do what the docs say it will.
2216 */
2217/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2218int
2219Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2220 struct sigaction* oact)
2221{
2222 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2223 SETERRNO(EINVAL, SS$_INVARG);
2224 return -1;
2225 }
2226 return sigaction(sig, act, oact);
2227}
2228/*}}}*/
5c2d7af2 2229
f2610a60
CL		 2230#ifdef KILL_BY_SIGPRC
2231#include <errnodef.h>
2232
05c058bc
CB		 2233/* We implement our own kill() using the undocumented system service
2234 sys$sigprc for one of two reasons:
2235
2236 1.) If the kill() in an older CRTL uses sys$forcex, causing the
f2610a60
CL		 2237 target process to do a sys$exit, which usually can't be handled
2238 gracefully...certainly not by Perl and the %SIG{} mechanism.
2239
05c058bc
CB		 2240 2.) If the kill() in the CRTL can't be called from a signal
2241 handler without disappearing into the ether, i.e., the signal
2242 it purportedly sends is never trapped. Still true as of VMS 7.3.
2243
2244 sys$sigprc has the same parameters as sys$forcex, but throws an exception
f2610a60
CL		 2245 in the target process rather than calling sys$exit.
2246
2247 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2248 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2249 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2250 with condition codes C$_SIG0+nsig*8, catching the exception on the
2251 target process and resignaling with appropriate arguments.
2252
2253 But we don't have that VMS 7.0+ exception handler, so if you
2254 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2255
2256 Also note that SIGTERM is listed in the docs as being "unimplemented",
2257 yet always seems to be signaled with a VMS condition code of 4 (and
2258 correctly handled for that code). So we hardwire it in.
2259
2260 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2261 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2262 than signalling with an unrecognized (and unhandled by CRTL) code.
2263*/
2264
fe1de8ce 2265#define _MY_SIG_MAX 28
f2610a60 2266
9c1171d1
JM		 2267static unsigned int
2268Perl_sig_to_vmscondition_int(int sig)
f2610a60 2269{
2e34cc90 2270 static unsigned int sig_code[_MY_SIG_MAX+1] =
f2610a60
CL		 2271 {
2272 0, /* 0 ZERO */
2273 SS$_HANGUP, /* 1 SIGHUP */
2274 SS$_CONTROLC, /* 2 SIGINT */
2275 SS$_CONTROLY, /* 3 SIGQUIT */
2276 SS$_RADRMOD, /* 4 SIGILL */
2277 SS$_BREAK, /* 5 SIGTRAP */
2278 SS$_OPCCUS, /* 6 SIGABRT */
2279 SS$_COMPAT, /* 7 SIGEMT */
2280#ifdef __VAX
2281 SS$_FLTOVF, /* 8 SIGFPE VAX */
2282#else
2283 SS$_HPARITH, /* 8 SIGFPE AXP */
2284#endif
2285 SS$_ABORT, /* 9 SIGKILL */
2286 SS$_ACCVIO, /* 10 SIGBUS */
2287 SS$_ACCVIO, /* 11 SIGSEGV */
2288 SS$_BADPARAM, /* 12 SIGSYS */
2289 SS$_NOMBX, /* 13 SIGPIPE */
2290 SS$_ASTFLT, /* 14 SIGALRM */
2291 4, /* 15 SIGTERM */
2292 0, /* 16 SIGUSR1 */
fe1de8ce
CB		 2293 0, /* 17 SIGUSR2 */
2294 0, /* 18 */
2295 0, /* 19 */
2296 0, /* 20 SIGCHLD */
2297 0, /* 21 SIGCONT */
2298 0, /* 22 SIGSTOP */
2299 0, /* 23 SIGTSTP */
2300 0, /* 24 SIGTTIN */
2301 0, /* 25 SIGTTOU */
2302 0, /* 26 */
2303 0, /* 27 */
2304 0 /* 28 SIGWINCH */
f2610a60
CL		 2305 };
2306
f2610a60
CL		 2307 static int initted = 0;
2308 if (!initted) {
2309 initted = 1;
2310 sig_code[16] = C$_SIGUSR1;
2311 sig_code[17] = C$_SIGUSR2;
fe1de8ce 2312 sig_code[20] = C$_SIGCHLD;
fe1de8ce
CB		 2313#if __CRTL_VER >= 70300000
2314 sig_code[28] = C$_SIGWINCH;
2315#endif
f2610a60 2316 }
f2610a60 2317
2e34cc90
CL		 2318 if (sig < _SIG_MIN) return 0;
2319 if (sig > _MY_SIG_MAX) return 0;
2320 return sig_code[sig];
2321}
2322
9c1171d1
JM		 2323unsigned int
2324Perl_sig_to_vmscondition(int sig)
2325{
2326#ifdef SS$_DEBUG
2327 if (vms_debug_on_exception != 0)
2328 lib$signal(SS$_DEBUG);
2329#endif
2330 return Perl_sig_to_vmscondition_int(sig);
2331}
2332
2333
c11536f5
CB		 2334#define sys$sigprc SYS$SIGPRC
2335#ifdef __cplusplus
2336extern "C" {
2337#endif
2338int sys$sigprc(unsigned int *pidadr,
2339 struct dsc$descriptor_s *prcname,
2340 unsigned int code);
2341#ifdef __cplusplus
2342}
2343#endif
2344
2e34cc90
CL		 2345int
2346Perl_my_kill(int pid, int sig)
2347{
2348 int iss;
2349 unsigned int code;
2e34cc90 2350
7a7fd8e0
JM		 2351 /* sig 0 means validate the PID */
2352 /*------------------------------*/
2353 if (sig == 0) {
2354 const unsigned long int jpicode = JPI$_PID;
2355 pid_t ret_pid;
2356 int status;
2357 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2358 if ($VMS_STATUS_SUCCESS(status))
2359 return 0;
2360 switch (status) {
2361 case SS$_NOSUCHNODE:
2362 case SS$_UNREACHABLE:
2363 case SS$_NONEXPR:
2364 errno = ESRCH;
2365 break;
2366 case SS$_NOPRIV:
2367 errno = EPERM;
2368 break;
2369 default:
2370 errno = EVMSERR;
2371 }
2372 vaxc$errno=status;
2373 return -1;
2374 }
2375
9c1171d1 2376 code = Perl_sig_to_vmscondition_int(sig);
2e34cc90 2377
7a7fd8e0
JM		 2378 if (!code) {
2379 SETERRNO(EINVAL, SS$_BADPARAM);
2380 return -1;
2381 }
2382
2383 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2384 * signals are to be sent to multiple processes.
2385 * pid = 0 - all processes in group except ones that the system exempts
2386 * pid = -1 - all processes except ones that the system exempts
2387 * pid = -n - all processes in group (abs(n)) except ...
2388 * For now, just report as not supported.
2389 */
2390
2391 if (pid <= 0) {
2392 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
f2610a60
CL		 2393 return -1;
2394 }
2395
2e34cc90 2396 iss = sys$sigprc((unsigned int *)&pid,0,code);
f2610a60
CL		 2397 if (iss&1) return 0;
2398
2399 switch (iss) {
2400 case SS$_NOPRIV:
2401 set_errno(EPERM); break;
2402 case SS$_NONEXPR:
2403 case SS$_NOSUCHNODE:
2404 case SS$_UNREACHABLE:
2405 set_errno(ESRCH); break;
2406 case SS$_INSFMEM:
2407 set_errno(ENOMEM); break;
2408 default:
ebd4d70b 2409 _ckvmssts_noperl(iss);
f2610a60
CL		 2410 set_errno(EVMSERR);
2411 }
2412 set_vaxc_errno(iss);
2413
2414 return -1;
2415}
2416#endif
2417
2fbb330f
JM		 2418/* Routine to convert a VMS status code to a UNIX status code.
2419** More tricky than it appears because of conflicting conventions with
2420** existing code.
2421**
2422** VMS status codes are a bit mask, with the least significant bit set for
2423** success.
2424**
2425** Special UNIX status of EVMSERR indicates that no translation is currently
2426** available, and programs should check the VMS status code.
2427**
2428** Programs compiled with _POSIX_EXIT have a special encoding that requires
2429** decoding.
2430*/
2431
2432#ifndef C_FACILITY_NO
2433#define C_FACILITY_NO 0x350000
2434#endif
2435#ifndef DCL_IVVERB
2436#define DCL_IVVERB 0x38090
2437#endif
2438
7a7fd8e0 2439int Perl_vms_status_to_unix(int vms_status, int child_flag)
2fbb330f
JM		 2440{
2441int facility;
2442int fac_sp;
2443int msg_no;
2444int msg_status;
2445int unix_status;
2446
2447 /* Assume the best or the worst */
2448 if (vms_status & STS$M_SUCCESS)
2449 unix_status = 0;
2450 else
2451 unix_status = EVMSERR;
2452
2453 msg_status = vms_status & ~STS$M_CONTROL;
2454
2455 facility = vms_status & STS$M_FAC_NO;
2456 fac_sp = vms_status & STS$M_FAC_SP;
2457 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2458
0968cdad 2459 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2fbb330f
JM		 2460 switch(msg_no) {
2461 case SS$_NORMAL:
2462 unix_status = 0;
2463 break;
2464 case SS$_ACCVIO:
2465 unix_status = EFAULT;
2466 break;
7a7fd8e0
JM		 2467 case SS$_DEVOFFLINE:
2468 unix_status = EBUSY;
2469 break;
2470 case SS$_CLEARED:
2471 unix_status = ENOTCONN;
2472 break;
2473 case SS$_IVCHAN:
2fbb330f
JM		 2474 case SS$_IVLOGNAM:
2475 case SS$_BADPARAM:
2476 case SS$_IVLOGTAB:
2477 case SS$_NOLOGNAM:
2478 case SS$_NOLOGTAB:
2479 case SS$_INVFILFOROP:
2480 case SS$_INVARG:
2481 case SS$_NOSUCHID:
2482 case SS$_IVIDENT:
2483 unix_status = EINVAL;
2484 break;
7a7fd8e0
JM		 2485 case SS$_UNSUPPORTED:
2486 unix_status = ENOTSUP;
2487 break;
2fbb330f
JM		 2488 case SS$_FILACCERR:
2489 case SS$_NOGRPPRV:
2490 case SS$_NOSYSPRV:
2491 unix_status = EACCES;
2492 break;
2493 case SS$_DEVICEFULL:
2494 unix_status = ENOSPC;
2495 break;
2496 case SS$_NOSUCHDEV:
2497 unix_status = ENODEV;
2498 break;
2499 case SS$_NOSUCHFILE:
2500 case SS$_NOSUCHOBJECT:
2501 unix_status = ENOENT;
2502 break;
fb38d079
JM		 2503 case SS$_ABORT: /* Fatal case */
2504 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2505 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2fbb330f
JM		 2506 unix_status = EINTR;
2507 break;
2508 case SS$_BUFFEROVF:
2509 unix_status = E2BIG;
2510 break;
2511 case SS$_INSFMEM:
2512 unix_status = ENOMEM;
2513 break;
2514 case SS$_NOPRIV:
2515 unix_status = EPERM;
2516 break;
2517 case SS$_NOSUCHNODE:
2518 case SS$_UNREACHABLE:
2519 unix_status = ESRCH;
2520 break;
2521 case SS$_NONEXPR:
2522 unix_status = ECHILD;
2523 break;
2524 default:
2525 if ((facility == 0) && (msg_no < 8)) {
2526 /* These are not real VMS status codes so assume that they are
2527 ** already UNIX status codes
2528 */
2529 unix_status = msg_no;
2530 break;
2531 }
2532 }
2533 }
2534 else {
2535 /* Translate a POSIX exit code to a UNIX exit code */
2536 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
7a7fd8e0 2537 unix_status = (msg_no & 0x07F8) >> 3;
2fbb330f
JM		 2538 }
2539 else {
7a7fd8e0
JM		 2540
2541 /* Documented traditional behavior for handling VMS child exits */
2542 /*--------------------------------------------------------------*/
2543 if (child_flag != 0) {
2544
2545 /* Success / Informational return 0 */
2546 /*----------------------------------*/
2547 if (msg_no & STS$K_SUCCESS)
2548 return 0;
2549
2550 /* Warning returns 1 */
2551 /*-------------------*/
2552 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2553 return 1;
2554
2555 /* Everything else pass through the severity bits */
2556 /*------------------------------------------------*/
2557 return (msg_no & STS$M_SEVERITY);
2558 }
2559
2560 /* Normal VMS status to ERRNO mapping attempt */
2561 /*--------------------------------------------*/
2fbb330f
JM		 2562 switch(msg_status) {
2563 /* case RMS$_EOF: */ /* End of File */
2564 case RMS$_FNF: /* File Not Found */
2565 case RMS$_DNF: /* Dir Not Found */
2566 unix_status = ENOENT;
2567 break;
2568 case RMS$_RNF: /* Record Not Found */
2569 unix_status = ESRCH;
2570 break;
2571 case RMS$_DIR:
2572 unix_status = ENOTDIR;
2573 break;
2574 case RMS$_DEV:
2575 unix_status = ENODEV;
2576 break;
7a7fd8e0
JM		 2577 case RMS$_IFI:
2578 case RMS$_FAC:
2579 case RMS$_ISI:
2580 unix_status = EBADF;
2581 break;
2582 case RMS$_FEX:
2583 unix_status = EEXIST;
2584 break;
2fbb330f
JM		 2585 case RMS$_SYN:
2586 case RMS$_FNM:
2587 case LIB$_INVSTRDES:
2588 case LIB$_INVARG:
2589 case LIB$_NOSUCHSYM:
2590 case LIB$_INVSYMNAM:
2591 case DCL_IVVERB:
2592 unix_status = EINVAL;
2593 break;
2594 case CLI$_BUFOVF:
2595 case RMS$_RTB:
2596 case CLI$_TKNOVF:
2597 case CLI$_RSLOVF:
2598 unix_status = E2BIG;
2599 break;
2600 case RMS$_PRV: /* No privilege */
2601 case RMS$_ACC: /* ACP file access failed */
2602 case RMS$_WLK: /* Device write locked */
2603 unix_status = EACCES;
2604 break;
ed1b9de0
JM		 2605 case RMS$_MKD: /* Failed to mark for delete */
2606 unix_status = EPERM;
2607 break;
2fbb330f
JM		 2608 /* case RMS$_NMF: */ /* No more files */
2609 }
2610 }
2611 }
2612
2613 return unix_status;
2614}
2615
7a7fd8e0
JM		 2616/* Try to guess at what VMS error status should go with a UNIX errno
2617 * value. This is hard to do as there could be many possible VMS
2618 * error statuses that caused the errno value to be set.
2619 */
2620
2621int Perl_unix_status_to_vms(int unix_status)
2622{
2623int test_unix_status;
2624
2625 /* Trivial cases first */
2626 /*---------------------*/
2627 if (unix_status == EVMSERR)
2628 return vaxc$errno;
2629
2630 /* Is vaxc$errno sane? */
2631 /*---------------------*/
2632 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2633 if (test_unix_status == unix_status)
2634 return vaxc$errno;
2635
2636 /* If way out of range, must be VMS code already */
2637 /*-----------------------------------------------*/
2638 if (unix_status > EVMSERR)
2639 return unix_status;
2640
2641 /* If out of range, punt */
2642 /*-----------------------*/
2643 if (unix_status > __ERRNO_MAX)
2644 return SS$_ABORT;
2645
2646
2647 /* Ok, now we have to do it the hard way. */
2648 /*----------------------------------------*/
2649 switch(unix_status) {
2650 case 0: return SS$_NORMAL;
2651 case EPERM: return SS$_NOPRIV;
2652 case ENOENT: return SS$_NOSUCHOBJECT;
2653 case ESRCH: return SS$_UNREACHABLE;
2654 case EINTR: return SS$_ABORT;
2655 /* case EIO: */
2656 /* case ENXIO: */
2657 case E2BIG: return SS$_BUFFEROVF;
2658 /* case ENOEXEC */
2659 case EBADF: return RMS$_IFI;
2660 case ECHILD: return SS$_NONEXPR;
2661 /* case EAGAIN */
2662 case ENOMEM: return SS$_INSFMEM;
2663 case EACCES: return SS$_FILACCERR;
2664 case EFAULT: return SS$_ACCVIO;
2665 /* case ENOTBLK */
0968cdad 2666 case EBUSY: return SS$_DEVOFFLINE;
7a7fd8e0
JM		 2667 case EEXIST: return RMS$_FEX;
2668 /* case EXDEV */
2669 case ENODEV: return SS$_NOSUCHDEV;
2670 case ENOTDIR: return RMS$_DIR;
2671 /* case EISDIR */
2672 case EINVAL: return SS$_INVARG;
2673 /* case ENFILE */
2674 /* case EMFILE */
2675 /* case ENOTTY */
2676 /* case ETXTBSY */
2677 /* case EFBIG */
2678 case ENOSPC: return SS$_DEVICEFULL;
2679 case ESPIPE: return LIB$_INVARG;
2680 /* case EROFS: */
2681 /* case EMLINK: */
2682 /* case EPIPE: */
2683 /* case EDOM */
2684 case ERANGE: return LIB$_INVARG;
2685 /* case EWOULDBLOCK */
2686 /* case EINPROGRESS */
2687 /* case EALREADY */
2688 /* case ENOTSOCK */
2689 /* case EDESTADDRREQ */
2690 /* case EMSGSIZE */
2691 /* case EPROTOTYPE */
2692 /* case ENOPROTOOPT */
2693 /* case EPROTONOSUPPORT */
2694 /* case ESOCKTNOSUPPORT */
2695 /* case EOPNOTSUPP */
2696 /* case EPFNOSUPPORT */
2697 /* case EAFNOSUPPORT */
2698 /* case EADDRINUSE */
2699 /* case EADDRNOTAVAIL */
2700 /* case ENETDOWN */
2701 /* case ENETUNREACH */
2702 /* case ENETRESET */
2703 /* case ECONNABORTED */
2704 /* case ECONNRESET */
2705 /* case ENOBUFS */
2706 /* case EISCONN */
2707 case ENOTCONN: return SS$_CLEARED;
2708 /* case ESHUTDOWN */
2709 /* case ETOOMANYREFS */
2710 /* case ETIMEDOUT */
2711 /* case ECONNREFUSED */
2712 /* case ELOOP */
2713 /* case ENAMETOOLONG */
2714 /* case EHOSTDOWN */
2715 /* case EHOSTUNREACH */
2716 /* case ENOTEMPTY */
2717 /* case EPROCLIM */
2718 /* case EUSERS */
2719 /* case EDQUOT */
2720 /* case ENOMSG */
2721 /* case EIDRM */
2722 /* case EALIGN */
2723 /* case ESTALE */
2724 /* case EREMOTE */
2725 /* case ENOLCK */
2726 /* case ENOSYS */
2727 /* case EFTYPE */
2728 /* case ECANCELED */
2729 /* case EFAIL */
2730 /* case EINPROG */
2731 case ENOTSUP:
2732 return SS$_UNSUPPORTED;
2733 /* case EDEADLK */
2734 /* case ENWAIT */
2735 /* case EILSEQ */
2736 /* case EBADCAT */
2737 /* case EBADMSG */
2738 /* case EABANDONED */
2739 default:
2740 return SS$_ABORT; /* punt */
2741 }
7a7fd8e0 2742}
2fbb330f
JM		 2743
2744
22d4bb9c 2745/* default piping mailbox size */
df17c887
CB		 2746#ifdef __VAX
2747# define PERL_BUFSIZ 512
2748#else
2749# define PERL_BUFSIZ 8192
2750#endif
22d4bb9c 2751
674d6c38 2752
a0d0e21e 2753static void
8a646e0b 2754create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
a0d0e21e 2755{
22d4bb9c
CB		 2756 unsigned long int mbxbufsiz;
2757 static unsigned long int syssize = 0;
2758 unsigned long int dviitm = DVI$_DEVNAM;
22d4bb9c 2759 char csize[LNM$C_NAMLENGTH+1];
f7ddb74a
JM		 2760 int sts;
2761
22d4bb9c
CB		 2762 if (!syssize) {
2763 unsigned long syiitm = SYI$_MAXBUF;
a0d0e21e 2764 /*
22d4bb9c
CB		 2765 * Get the SYSGEN parameter MAXBUF
2766 *
2767 * If the logical 'PERL_MBX_SIZE' is defined
2768 * use the value of the logical instead of PERL_BUFSIZ, but
2769 * keep the size between 128 and MAXBUF.
2770 *
a0d0e21e 2771 */
ebd4d70b 2772 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
22d4bb9c
CB		 2773 }
2774
2775 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2776 mbxbufsiz = atoi(csize);
2777 } else {
2778 mbxbufsiz = PERL_BUFSIZ;
a0d0e21e 2779 }
22d4bb9c
CB		 2780 if (mbxbufsiz < 128) mbxbufsiz = 128;
2781 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2782
ebd4d70b 2783 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
a0d0e21e 2784
ebd4d70b
JM		 2785 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2786 _ckvmssts_noperl(sts);
a0d0e21e
LW		 2787 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2788
2789} /* end of create_mbx() */
2790
22d4bb9c 2791
a0d0e21e 2792/*{{{ my_popen and my_pclose*/
22d4bb9c
CB		 2793
2794typedef struct _iosb IOSB;
2795typedef struct _iosb* pIOSB;
2796typedef struct _pipe Pipe;
2797typedef struct _pipe* pPipe;
2798typedef struct pipe_details Info;
2799typedef struct pipe_details* pInfo;
2800typedef struct _srqp RQE;
2801typedef struct _srqp* pRQE;
2802typedef struct _tochildbuf CBuf;
2803typedef struct _tochildbuf* pCBuf;
2804
2805struct _iosb {
2806 unsigned short status;
2807 unsigned short count;
2808 unsigned long dvispec;
2809};
2810
2811#pragma member_alignment save
2812#pragma nomember_alignment quadword
2813struct _srqp { /* VMS self-relative queue entry */
2814 unsigned long qptr[2];
2815};
2816#pragma member_alignment restore
2817static RQE RQE_ZERO = {0,0};
2818
2819struct _tochildbuf {
2820 RQE q;
2821 int eof;
2822 unsigned short size;
2823 char *buf;
2824};
2825
2826struct _pipe {
2827 RQE free;
2828 RQE wait;
2829 int fd_out;
2830 unsigned short chan_in;
2831 unsigned short chan_out;
2832 char *buf;
2833 unsigned int bufsize;
2834 IOSB iosb;
2835 IOSB iosb2;
2836 int *pipe_done;
2837 int retry;
2838 int type;
2839 int shut_on_empty;
2840 int need_wake;
2841 pPipe *home;
2842 pInfo info;
2843 pCBuf curr;
2844 pCBuf curr2;
fd8cd3a3
DS		 2845#if defined(PERL_IMPLICIT_CONTEXT)
2846 void *thx; /* Either a thread or an interpreter */
2847 /* pointer, depending on how we're built */
2848#endif
22d4bb9c
CB		 2849};
2850
2851
a0d0e21e
LW		 2852struct pipe_details
2853{
22d4bb9c 2854 pInfo next;
ff7adb52
CL		 2855 PerlIO *fp; /* file pointer to pipe mailbox */
2856 int useFILE; /* using stdio, not perlio */
748a9306
LW		 2857 int pid; /* PID of subprocess */
2858 int mode; /* == 'r' if pipe open for reading */
2859 int done; /* subprocess has completed */
ff7adb52 2860 int waiting; /* waiting for completion/closure */
22d4bb9c
CB		 2861 int closing; /* my_pclose is closing this pipe */
2862 unsigned long completion; /* termination status of subprocess */
2863 pPipe in; /* pipe in to sub */
2864 pPipe out; /* pipe out of sub */
2865 pPipe err; /* pipe of sub's sys$error */
2866 int in_done; /* true when in pipe finished */
2867 int out_done;
2868 int err_done;
cd1191f1
CB		 2869 unsigned short xchan; /* channel to debug xterm */
2870 unsigned short xchan_valid; /* channel is assigned */
a0d0e21e
LW		 2871};
2872
748a9306
LW		 2873struct exit_control_block
2874{
2875 struct exit_control_block *flink;
f7c699a0 2876 unsigned long int (*exit_routine)(void);
748a9306
LW		 2877 unsigned long int arg_count;
2878 unsigned long int *status_address;
2879 unsigned long int exit_status;
2880};
2881
d85f548a
JH		 2882typedef struct _closed_pipes Xpipe;
2883typedef struct _closed_pipes* pXpipe;
2884
2885struct _closed_pipes {
2886 int pid; /* PID of subprocess */
2887 unsigned long completion; /* termination status of subprocess */
2888};
2889#define NKEEPCLOSED 50
2890static Xpipe closed_list[NKEEPCLOSED];
2891static int closed_index = 0;
2892static int closed_num = 0;
2893
22d4bb9c
CB		 2894#define RETRY_DELAY "0 ::0.20"
2895#define MAX_RETRY 50
a0d0e21e 2896
22d4bb9c
CB		 2897static int pipe_ef = 0; /* first call to safe_popen inits these*/
2898static unsigned long mypid;
2899static unsigned long delaytime[2];
2900
2901static pInfo open_pipes = NULL;
2902static $DESCRIPTOR(nl_desc, "NL:");
3eeba6fb 2903
ff7adb52
CL		 2904#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2905
2906
3eeba6fb 2907
748a9306 2908static unsigned long int
f7c699a0 2909pipe_exit_routine(void)
748a9306 2910{
22d4bb9c 2911 pInfo info;
1e422769 2912 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
4e0c9737 2913 int sts, did_stuff, j;
ff7adb52 2914
5ce486e0
CB		 2915 /*
2916 * Flush any pending i/o, but since we are in process run-down, be
2917 * careful about referencing PerlIO structures that may already have
2918 * been deallocated. We may not even have an interpreter anymore.
ff7adb52
CL		 2919 */
2920 info = open_pipes;
2921 while (info) {
2922 if (info->fp) {
ebd4d70b
JM		 2923#if defined(PERL_IMPLICIT_CONTEXT)
2924 /* We need to use the Perl context of the thread that created */
2925 /* the pipe. */
2926 pTHX;
2927 if (info->err)
2928 aTHX = info->err->thx;
2929 else if (info->out)
2930 aTHX = info->out->thx;
2931 else if (info->in)
2932 aTHX = info->in->thx;
2933#endif
5ce486e0
CB		 2934 if (!info->useFILE
2935#if defined(USE_ITHREADS)
2936 && my_perl
2937#endif
a24c654f
CB		 2938#ifdef USE_PERLIO
2939 && PL_perlio_fd_refcnt
2940#endif
2941 )
5ce486e0 2942 PerlIO_flush(info->fp);
ff7adb52
CL		 2943 else
2944 fflush((FILE *)info->fp);
2945 }
2946 info = info->next;
2947 }
3eeba6fb
CB		 2948
2949 /*
ff7adb52 2950 next we try sending an EOF...ignore if doesn't work, make sure we
3eeba6fb
CB		 2951 don't hang
2952 */
2953 did_stuff = 0;
2954 info = open_pipes;
748a9306 2955
3eeba6fb 2956 while (info) {
d4c83939 2957 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 2958 if (info->in && !info->in->shut_on_empty) {
d4c83939 2959 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
ebd4d70b 2960 0, 0, 0, 0, 0, 0));
ff7adb52 2961 info->waiting = 1;
22d4bb9c 2962 did_stuff = 1;
748a9306 2963 }
d4c83939 2964 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2965 info = info->next;
2966 }
ff7adb52
CL		 2967
2968 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2969
2970 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2971 int nwait = 0;
2972
2973 info = open_pipes;
2974 while (info) {
d4c83939 2975 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 2976 if (info->waiting && info->done)
2977 info->waiting = 0;
2978 nwait += info->waiting;
d4c83939 2979 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 2980 info = info->next;
2981 }
2982 if (!nwait) break;
2983 sleep(1);
2984 }
3eeba6fb
CB		 2985
2986 did_stuff = 0;
2987 info = open_pipes;
2988 while (info) {
d4c83939 2989 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 2990 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2991 sts = sys$forcex(&info->pid,0,&abort);
d4c83939 2992 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3eeba6fb
CB		 2993 did_stuff = 1;
2994 }
d4c83939 2995 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 2996 info = info->next;
2997 }
ff7adb52
CL		 2998
2999 /* again, wait for effect */
3000
3001 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3002 int nwait = 0;
3003
3004 info = open_pipes;
3005 while (info) {
d4c83939 3006 _ckvmssts_noperl(sys$setast(0));
ff7adb52
CL		 3007 if (info->waiting && info->done)
3008 info->waiting = 0;
3009 nwait += info->waiting;
d4c83939 3010 _ckvmssts_noperl(sys$setast(1));
ff7adb52
CL		 3011 info = info->next;
3012 }
3013 if (!nwait) break;
3014 sleep(1);
3015 }
3eeba6fb
CB		 3016
3017 info = open_pipes;
3018 while (info) {
d4c83939 3019 _ckvmssts_noperl(sys$setast(0));
3eeba6fb
CB		 3020 if (!info->done) { /* We tried to be nice . . . */
3021 sts = sys$delprc(&info->pid,0);
d4c83939 3022 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2f1dcba4 3023 info->done = 1; /* sys$delprc is as done as we're going to get. */
3eeba6fb 3024 }
d4c83939 3025 _ckvmssts_noperl(sys$setast(1));
3eeba6fb
CB		 3026 info = info->next;
3027 }
3028
3029 while(open_pipes) {
ebd4d70b
JM		 3030
3031#if defined(PERL_IMPLICIT_CONTEXT)
3032 /* We need to use the Perl context of the thread that created */
3033 /* the pipe. */
3034 pTHX;
36b6faa8
CB		 3035 if (open_pipes->err)
3036 aTHX = open_pipes->err->thx;
3037 else if (open_pipes->out)
3038 aTHX = open_pipes->out->thx;
3039 else if (open_pipes->in)
3040 aTHX = open_pipes->in->thx;
ebd4d70b 3041#endif
1e422769 3042 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3043 else if (!(sts & 1)) retsts = sts;
748a9306
LW		 3044 }
3045 return retsts;
3046}
3047
3048static struct exit_control_block pipe_exitblock =
3049 {(struct exit_control_block *) 0,
3050 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3051
22d4bb9c
CB		 3052static void pipe_mbxtofd_ast(pPipe p);
3053static void pipe_tochild1_ast(pPipe p);
3054static void pipe_tochild2_ast(pPipe p);
748a9306 3055
a0d0e21e 3056static void
22d4bb9c 3057popen_completion_ast(pInfo info)
a0d0e21e 3058{
22d4bb9c
CB		 3059 pInfo i = open_pipes;
3060 int iss;
d85f548a
JH		 3061
3062 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3063 closed_list[closed_index].pid = info->pid;
3064 closed_list[closed_index].completion = info->completion;
3065 closed_index++;
3066 if (closed_index == NKEEPCLOSED)
3067 closed_index = 0;
3068 closed_num++;
22d4bb9c
CB		 3069
3070 while (i) {
3071 if (i == info) break;
3072 i = i->next;
3073 }
3074 if (!i) return; /* unlinked, probably freed too */
3075
22d4bb9c
CB		 3076 info->done = TRUE;
3077
3078/*
3079 Writing to subprocess ...
3080 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3081
3082 chan_out may be waiting for "done" flag, or hung waiting
3083 for i/o completion to child...cancel the i/o. This will
3084 put it into "snarf mode" (done but no EOF yet) that discards
3085 input.
3086
3087 Output from subprocess (stdout, stderr) needs to be flushed and
3088 shut down. We try sending an EOF, but if the mbx is full the pipe
3089 routine should still catch the "shut_on_empty" flag, telling it to
3090 use immediate-style reads so that "mbx empty" -> EOF.
3091
3092
3093*/
3094 if (info->in && !info->in_done) { /* only for mode=w */
3095 if (info->in->shut_on_empty && info->in->need_wake) {
3096 info->in->need_wake = FALSE;
fd8cd3a3 3097 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
22d4bb9c 3098 } else {
fd8cd3a3 3099 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
22d4bb9c
CB		 3100 }
3101 }
3102
3103 if (info->out && !info->out_done) { /* were we also piping output? */
3104 info->out->shut_on_empty = TRUE;
3105 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3106 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3107 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3108 }
3109
3110 if (info->err && !info->err_done) { /* we were piping stderr */
3111 info->err->shut_on_empty = TRUE;
3112 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3113 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
fd8cd3a3 3114 _ckvmssts_noperl(iss);
a0d0e21e 3115 }
fd8cd3a3 3116 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3117
a0d0e21e
LW		 3118}
3119
2fbb330f 3120static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
218fdd94 3121static void vms_execfree(struct dsc$descriptor_s *vmscmd);
22d4bb9c
CB		 3122static void pipe_infromchild_ast(pPipe p);
3123
3124/*
3125 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3126 inside an AST routine without worrying about reentrancy and which Perl
3127 memory allocator is being used.
3128
3129 We read data and queue up the buffers, then spit them out one at a
3130 time to the output mailbox when the output mailbox is ready for one.
3131
3132*/
3133#define INITIAL_TOCHILDQUEUE 2
3134
3135static pPipe
fd8cd3a3 3136pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3137{
22d4bb9c
CB		 3138 pPipe p;
3139 pCBuf b;
3140 char mbx1[64], mbx2[64];
3141 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3142 DSC$K_CLASS_S, mbx1},
3143 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3144 DSC$K_CLASS_S, mbx2};
3145 unsigned int dviitm = DVI$_DEVBUFSIZ;
3146 int j, n;
3147
d4c83939 3148 n = sizeof(Pipe);
ebd4d70b 3149 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3150
8a646e0b
JM		 3151 create_mbx(&p->chan_in , &d_mbx1);
3152 create_mbx(&p->chan_out, &d_mbx2);
ebd4d70b 3153 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
22d4bb9c
CB		 3154
3155 p->buf = 0;
3156 p->shut_on_empty = FALSE;
3157 p->need_wake = FALSE;
3158 p->type = 0;
3159 p->retry = 0;
3160 p->iosb.status = SS$_NORMAL;
3161 p->iosb2.status = SS$_NORMAL;
3162 p->free = RQE_ZERO;
3163 p->wait = RQE_ZERO;
3164 p->curr = 0;
3165 p->curr2 = 0;
3166 p->info = 0;
fd8cd3a3
DS		 3167#ifdef PERL_IMPLICIT_CONTEXT
3168 p->thx = aTHX;
3169#endif
22d4bb9c
CB		 3170
3171 n = sizeof(CBuf) + p->bufsize;
3172
3173 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
ebd4d70b 3174 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c 3175 b->buf = (char *) b + sizeof(CBuf);
ebd4d70b 3176 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3177 }
3178
3179 pipe_tochild2_ast(p);
3180 pipe_tochild1_ast(p);
3181 strcpy(wmbx, mbx1);
3182 strcpy(rmbx, mbx2);
3183 return p;
3184}
3185
3186/* reads the MBX Perl is writing, and queues */
3187
3188static void
3189pipe_tochild1_ast(pPipe p)
3190{
22d4bb9c
CB		 3191 pCBuf b = p->curr;
3192 int iss = p->iosb.status;
3193 int eof = (iss == SS$_ENDOFFILE);
f7ddb74a 3194 int sts;
fd8cd3a3
DS		 3195#ifdef PERL_IMPLICIT_CONTEXT
3196 pTHX = p->thx;
3197#endif
22d4bb9c
CB		 3198
3199 if (p->retry) {
3200 if (eof) {
3201 p->shut_on_empty = TRUE;
3202 b->eof = TRUE;
ebd4d70b 3203 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c 3204 } else {
ebd4d70b 3205 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3206 }
3207
3208 b->eof = eof;
3209 b->size = p->iosb.count;
ebd4d70b 3210 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
22d4bb9c
CB		 3211 if (p->need_wake) {
3212 p->need_wake = FALSE;
ebd4d70b 3213 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
22d4bb9c
CB		 3214 }
3215 } else {
3216 p->retry = 1; /* initial call */
3217 }
3218
3219 if (eof) { /* flush the free queue, return when done */
3220 int n = sizeof(CBuf) + p->bufsize;
3221 while (1) {
3222 iss = lib$remqti(&p->free, &b);
3223 if (iss == LIB$_QUEWASEMP) return;
ebd4d70b
JM		 3224 _ckvmssts_noperl(iss);
3225 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c
CB		 3226 }
3227 }
3228
3229 iss = lib$remqti(&p->free, &b);
3230 if (iss == LIB$_QUEWASEMP) {
3231 int n = sizeof(CBuf) + p->bufsize;
ebd4d70b 3232 _ckvmssts_noperl(lib$get_vm(&n, &b));
22d4bb9c
CB		 3233 b->buf = (char *) b + sizeof(CBuf);
3234 } else {
ebd4d70b 3235 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3236 }
3237
3238 p->curr = b;
3239 iss = sys$qio(0,p->chan_in,
3240 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3241 &p->iosb,
3242 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3243 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
ebd4d70b 3244 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3245}
3246
3247
3248/* writes queued buffers to output, waits for each to complete before
3249 doing the next */
3250
3251static void
3252pipe_tochild2_ast(pPipe p)
3253{
22d4bb9c
CB		 3254 pCBuf b = p->curr2;
3255 int iss = p->iosb2.status;
3256 int n = sizeof(CBuf) + p->bufsize;
3257 int done = (p->info && p->info->done) ||
3258 iss == SS$_CANCEL || iss == SS$_ABORT;
fd8cd3a3
DS		 3259#if defined(PERL_IMPLICIT_CONTEXT)
3260 pTHX = p->thx;
3261#endif
22d4bb9c
CB		 3262
3263 do {
3264 if (p->type) { /* type=1 has old buffer, dispose */
3265 if (p->shut_on_empty) {
ebd4d70b 3266 _ckvmssts_noperl(lib$free_vm(&n, &b));
22d4bb9c 3267 } else {
ebd4d70b 3268 _ckvmssts_noperl(lib$insqhi(b, &p->free));
22d4bb9c
CB		 3269 }
3270 p->type = 0;
3271 }
3272
3273 iss = lib$remqti(&p->wait, &b);
3274 if (iss == LIB$_QUEWASEMP) {
3275 if (p->shut_on_empty) {
3276 if (done) {
ebd4d70b 3277 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c 3278 *p->pipe_done = TRUE;
ebd4d70b 3279 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c 3280 } else {
ebd4d70b 3281 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3282 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3283 }
3284 return;
3285 }
3286 p->need_wake = TRUE;
3287 return;
3288 }
ebd4d70b 3289 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3290 p->type = 1;
3291 } while (done);
3292
3293
3294 p->curr2 = b;
3295 if (b->eof) {
ebd4d70b 3296 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
22d4bb9c
CB		 3297 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3298 } else {
ebd4d70b 3299 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
22d4bb9c
CB		 3300 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3301 }
3302
3303 return;
3304
3305}
3306
3307
3308static pPipe
fd8cd3a3 3309pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
22d4bb9c 3310{
22d4bb9c
CB		 3311 pPipe p;
3312 char mbx1[64], mbx2[64];
3313 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3314 DSC$K_CLASS_S, mbx1},
3315 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3316 DSC$K_CLASS_S, mbx2};
3317 unsigned int dviitm = DVI$_DEVBUFSIZ;
3318
d4c83939 3319 int n = sizeof(Pipe);
ebd4d70b 3320 _ckvmssts_noperl(lib$get_vm(&n, &p));
8a646e0b
JM		 3321 create_mbx(&p->chan_in , &d_mbx1);
3322 create_mbx(&p->chan_out, &d_mbx2);
22d4bb9c 3323
ebd4d70b 3324 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3325 n = p->bufsize * sizeof(char);
ebd4d70b 3326 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3327 p->shut_on_empty = FALSE;
3328 p->info = 0;
3329 p->type = 0;
3330 p->iosb.status = SS$_NORMAL;
fd8cd3a3
DS		 3331#if defined(PERL_IMPLICIT_CONTEXT)
3332 p->thx = aTHX;
3333#endif
22d4bb9c
CB		 3334 pipe_infromchild_ast(p);
3335
3336 strcpy(wmbx, mbx1);
3337 strcpy(rmbx, mbx2);
3338 return p;
3339}
3340
3341static void
3342pipe_infromchild_ast(pPipe p)
3343{
22d4bb9c
CB		 3344 int iss = p->iosb.status;
3345 int eof = (iss == SS$_ENDOFFILE);
3346 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3347 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
fd8cd3a3
DS		 3348#if defined(PERL_IMPLICIT_CONTEXT)
3349 pTHX = p->thx;
3350#endif
22d4bb9c
CB		 3351
3352 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
ebd4d70b 3353 _ckvmssts_noperl(sys$dassgn(p->chan_out));
22d4bb9c
CB		 3354 p->chan_out = 0;
3355 }
3356
3357 /* read completed:
3358 input shutdown if EOF from self (done or shut_on_empty)
3359 output shutdown if closing flag set (my_pclose)
3360 send data/eof from child or eof from self
3361 otherwise, re-read (snarf of data from child)
3362 */
3363
3364 if (p->type == 1) {
3365 p->type = 0;
3366 if (myeof && p->chan_in) { /* input shutdown */
ebd4d70b 3367 _ckvmssts_noperl(sys$dassgn(p->chan_in));
22d4bb9c
CB		 3368 p->chan_in = 0;
3369 }
3370
3371 if (p->chan_out) {
3372 if (myeof || kideof) { /* pass EOF to parent */
ebd4d70b
JM		 3373 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3374 pipe_infromchild_ast, p,
3375 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 3376 return;
3377 } else if (eof) { /* eat EOF --- fall through to read*/
3378
3379 } else { /* transmit data */
ebd4d70b
JM		 3380 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3381 pipe_infromchild_ast,p,
3382 p->buf, p->iosb.count, 0, 0, 0, 0));
22d4bb9c
CB		 3383 return;
3384 }
3385 }
3386 }
3387
3388 /* everything shut? flag as done */
3389
3390 if (!p->chan_in && !p->chan_out) {
3391 *p->pipe_done = TRUE;
ebd4d70b 3392 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3393 return;
3394 }
3395
3396 /* write completed (or read, if snarfing from child)
3397 if still have input active,
3398 queue read...immediate mode if shut_on_empty so we get EOF if empty
3399 otherwise,
3400 check if Perl reading, generate EOFs as needed
3401 */
3402
3403 if (p->type == 0) {
3404 p->type = 1;
3405 if (p->chan_in) {
3406 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3407 pipe_infromchild_ast,p,
3408 p->buf, p->bufsize, 0, 0, 0, 0);
3409 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
ebd4d70b 3410 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3411 } else { /* send EOFs for extra reads */
3412 p->iosb.status = SS$_ENDOFFILE;
3413 p->iosb.dvispec = 0;
ebd4d70b
JM		 3414 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3415 0, 0, 0,
3416 pipe_infromchild_ast, p, 0, 0, 0, 0));
22d4bb9c
CB		 3417 }
3418 }
3419}
3420
3421static pPipe
fd8cd3a3 3422pipe_mbxtofd_setup(pTHX_ int fd, char *out)
22d4bb9c 3423{
22d4bb9c
CB		 3424 pPipe p;
3425 char mbx[64];
3426 unsigned long dviitm = DVI$_DEVBUFSIZ;
3427 struct stat s;
3428 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3429 DSC$K_CLASS_S, mbx};
a480973c 3430 int n = sizeof(Pipe);
22d4bb9c
CB		 3431
3432 /* things like terminals and mbx's don't need this filter */
3433 if (fd && fstat(fd,&s) == 0) {
4e0c9737 3434 unsigned long devchar;
cfcfe586
JM		 3435 char device[65];
3436 unsigned short dev_len;
3437 struct dsc$descriptor_s d_dev;
3438 char * cptr;
3439 struct item_list_3 items[3];
3440 int status;
3441 unsigned short dvi_iosb[4];
3442
3443 cptr = getname(fd, out, 1);
ebd4d70b 3444 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
cfcfe586
JM		 3445 d_dev.dsc$a_pointer = out;
3446 d_dev.dsc$w_length = strlen(out);
3447 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3448 d_dev.dsc$b_class = DSC$K_CLASS_S;
3449
3450 items[0].len = 4;
3451 items[0].code = DVI$_DEVCHAR;
3452 items[0].bufadr = &devchar;
3453 items[0].retadr = NULL;
3454 items[1].len = 64;
3455 items[1].code = DVI$_FULLDEVNAM;
3456 items[1].bufadr = device;
3457 items[1].retadr = &dev_len;
3458 items[2].len = 0;
3459 items[2].code = 0;
3460
3461 status = sys$getdviw
3462 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
ebd4d70b 3463 _ckvmssts_noperl(status);
cfcfe586
JM		 3464 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3465 device[dev_len] = 0;
3466
3467 if (!(devchar & DEV$M_DIR)) {
3468 strcpy(out, device);
3469 return 0;
3470 }
3471 }
22d4bb9c
CB		 3472 }
3473
ebd4d70b 3474 _ckvmssts_noperl(lib$get_vm(&n, &p));
22d4bb9c 3475 p->fd_out = dup(fd);
8a646e0b 3476 create_mbx(&p->chan_in, &d_mbx);
ebd4d70b 3477 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
d4c83939 3478 n = (p->bufsize+1) * sizeof(char);
ebd4d70b 3479 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
22d4bb9c
CB		 3480 p->shut_on_empty = FALSE;
3481 p->retry = 0;
3482 p->info = 0;
3483 strcpy(out, mbx);
3484
ebd4d70b
JM		 3485 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3486 pipe_mbxtofd_ast, p,
3487 p->buf, p->bufsize, 0, 0, 0, 0));
22d4bb9c
CB		 3488
3489 return p;
3490}
3491
3492static void
3493pipe_mbxtofd_ast(pPipe p)
3494{
22d4bb9c
CB		 3495 int iss = p->iosb.status;
3496 int done = p->info->done;
3497 int iss2;
3498 int eof = (iss == SS$_ENDOFFILE);
3499 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3500 int err = !(iss&1) && !eof;
fd8cd3a3
DS		 3501#if defined(PERL_IMPLICIT_CONTEXT)
3502 pTHX = p->thx;
3503#endif
22d4bb9c
CB		 3504
3505 if (done && myeof) { /* end piping */
3506 close(p->fd_out);
3507 sys$dassgn(p->chan_in);
3508 *p->pipe_done = TRUE;
ebd4d70b 3509 _ckvmssts_noperl(sys$setef(pipe_ef));
22d4bb9c
CB		 3510 return;
3511 }
3512
3513 if (!err && !eof) { /* good data to send to file */
3514 p->buf[p->iosb.count] = '\n';
3515 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3516 if (iss2 < 0) {
3517 p->retry++;
3518 if (p->retry < MAX_RETRY) {
ebd4d70b 3519 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
22d4bb9c
CB		 3520 return;
3521 }
3522 }
3523 p->retry = 0;
3524 } else if (err) {
ebd4d70b 3525 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3526 }
3527
3528
3529 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3530 pipe_mbxtofd_ast, p,
3531 p->buf, p->bufsize, 0, 0, 0, 0);
3532 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
ebd4d70b 3533 _ckvmssts_noperl(iss);
22d4bb9c
CB		 3534}
3535
3536
3537typedef struct _pipeloc PLOC;
3538typedef struct _pipeloc* pPLOC;
3539
3540struct _pipeloc {
3541 pPLOC next;
3542 char dir[NAM$C_MAXRSS+1];
3543};
3544static pPLOC head_PLOC = 0;
3545
5c0ae288 3546void
fd8cd3a3 3547free_pipelocs(pTHX_ void *head)
5c0ae288
CL		 3548{
3549 pPLOC p, pnext;
ff7adb52 3550 pPLOC *pHead = (pPLOC *)head;
5c0ae288 3551
ff7adb52 3552 p = *pHead;
5c0ae288
CL		 3553 while (p) {
3554 pnext = p->next;
e0ef6b43 3555 PerlMem_free(p);
5c0ae288
CL		 3556 p = pnext;
3557 }
ff7adb52 3558 *pHead = 0;
5c0ae288 3559}
22d4bb9c
CB		 3560
3561static void
fd8cd3a3 3562store_pipelocs(pTHX)
22d4bb9c
CB		 3563{
3564 int i;
3565 pPLOC p;
ff7adb52 3566 AV *av = 0;
22d4bb9c 3567 SV *dirsv;
22d4bb9c
CB		 3568 char *dir, *x;
3569 char *unixdir;
3570 char temp[NAM$C_MAXRSS+1];
3571 STRLEN n_a;
3572
ff7adb52 3573 if (head_PLOC)
218fdd94 3574 free_pipelocs(aTHX_ &head_PLOC);
ff7adb52 3575
22d4bb9c
CB		 3576/* the . directory from @INC comes last */
3577
e0ef6b43 3578 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3579 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3580 p->next = head_PLOC;
3581 head_PLOC = p;
3582 strcpy(p->dir,"./");
3583
3584/* get the directory from $^X */
3585
c11536f5 3586 unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 3587 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c5375c28 3588
218fdd94
CL		 3589#ifdef PERL_IMPLICIT_CONTEXT
3590 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3591#else
22d4bb9c 3592 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
218fdd94 3593#endif
a35dcc95 3594 my_strlcpy(temp, PL_origargv[0], sizeof(temp));
22d4bb9c 3595 x = strrchr(temp,']');
2497a41f
JM		 3596 if (x == NULL) {
3597 x = strrchr(temp,'>');
3598 if (x == NULL) {
3599 /* It could be a UNIX path */
3600 x = strrchr(temp,'/');
3601 }
3602 }
3603 if (x)
3604 x[1] = '\0';
3605 else {
3606 /* Got a bare name, so use default directory */
3607 temp[0] = '.';
3608 temp[1] = '\0';
3609 }
22d4bb9c 3610
4e205ed6 3611 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
e0ef6b43 3612 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3613 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3614 p->next = head_PLOC;
3615 head_PLOC = p;
a35dcc95 3616 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
c5375c28 3617 }
22d4bb9c
CB		 3618 }
3619
3620/* reverse order of @INC entries, skip "." since entered above */
3621
218fdd94
CL		 3622#ifdef PERL_IMPLICIT_CONTEXT
3623 if (aTHX)
3624#endif
ff7adb52
CL		 3625 if (PL_incgv) av = GvAVn(PL_incgv);
3626
3627 for (i = 0; av && i <= AvFILL(av); i++) {
22d4bb9c
CB		 3628 dirsv = *av_fetch(av,i,TRUE);
3629
3630 if (SvROK(dirsv)) continue;
3631 dir = SvPVx(dirsv,n_a);
3632 if (strcmp(dir,".") == 0) continue;
4e205ed6 3633 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
22d4bb9c
CB		 3634 continue;
3635
e0ef6b43 3636 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
22d4bb9c
CB		 3637 p->next = head_PLOC;
3638 head_PLOC = p;
a35dcc95 3639 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3640 }
3641
3642/* most likely spot (ARCHLIB) put first in the list */
3643
3644#ifdef ARCHLIB_EXP
4e205ed6 3645 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
e0ef6b43 3646 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
ebd4d70b 3647 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
22d4bb9c
CB		 3648 p->next = head_PLOC;
3649 head_PLOC = p;
a35dcc95 3650 my_strlcpy(p->dir, unixdir, sizeof(p->dir));
22d4bb9c
CB		 3651 }
3652#endif
c5375c28 3653 PerlMem_free(unixdir);
22d4bb9c
CB		 3654}
3655
a1887106
JM		 3656static I32
3657Perl_cando_by_name_int
3658 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3659#if !defined(PERL_IMPLICIT_CONTEXT)
3660#define cando_by_name_int Perl_cando_by_name_int
3661#else
3662#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3663#endif
22d4bb9c
CB		 3664
3665static char *
fd8cd3a3 3666find_vmspipe(pTHX)
22d4bb9c
CB		 3667{
3668 static int vmspipe_file_status = 0;
3669 static char vmspipe_file[NAM$C_MAXRSS+1];
3670
3671 /* already found? Check and use ... need read+execute permission */
3672
3673 if (vmspipe_file_status == 1) {
a1887106
JM		 3674 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3675 && cando_by_name_int
3676 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3677 return vmspipe_file;
3678 }
3679 vmspipe_file_status = 0;
3680 }
3681
3682 /* scan through stored @INC, $^X */
3683
3684 if (vmspipe_file_status == 0) {
3685 char file[NAM$C_MAXRSS+1];
3686 pPLOC p = head_PLOC;
3687
3688 while (p) {
2f4077ca 3689 char * exp_res;
4d743a9b 3690 int dirlen;
a35dcc95
CB		 3691 dirlen = my_strlcpy(file, p->dir, sizeof(file));
3692 my_strlcat(file, "vmspipe.com", sizeof(file));
22d4bb9c
CB		 3693 p = p->next;
3694
6fb6c614 3695 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
2f4077ca 3696 if (!exp_res) continue;
22d4bb9c 3697
a1887106
JM		 3698 if (cando_by_name_int
3699 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3700 && cando_by_name_int
3701 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
22d4bb9c
CB		 3702 vmspipe_file_status = 1;
3703 return vmspipe_file;
3704 }
3705 }
3706 vmspipe_file_status = -1; /* failed, use tempfiles */
3707 }
3708
3709 return 0;
3710}
3711
3712static FILE *
fd8cd3a3 3713vmspipe_tempfile(pTHX)
22d4bb9c
CB		 3714{
3715 char file[NAM$C_MAXRSS+1];
3716 FILE *fp;
3717 static int index = 0;
2497a41f
JM		 3718 Stat_t s0, s1;
3719 int cmp_result;
22d4bb9c
CB		 3720
3721 /* create a tempfile */
3722
3723 /* we can't go from W, shr=get to R, shr=get without
3724 an intermediate vulnerable state, so don't bother trying...
3725
3726 and lib$spawn doesn't shr=put, so have to close the write
3727
3728 So... match up the creation date/time and the FID to
3729 make sure we're dealing with the same file
3730
3731 */
3732
3733 index++;
2497a41f
JM		 3734 if (!decc_filename_unix_only) {
3735 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3736 fp = fopen(file,"w");
3737 if (!fp) {
22d4bb9c
CB		 3738 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3739 fp = fopen(file,"w");
3740 if (!fp) {
3741 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3742 fp = fopen(file,"w");
2497a41f
JM		 3743 }
3744 }
3745 }
3746 else {
3747 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3748 fp = fopen(file,"w");
3749 if (!fp) {
3750 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3751 fp = fopen(file,"w");
3752 if (!fp) {
3753 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3754 fp = fopen(file,"w");
3755 }
3756 }
22d4bb9c
CB		 3757 }
3758 if (!fp) return 0; /* we're hosed */
3759
f9ecfa39 3760 fprintf(fp,"$! 'f$verify(0)'\n");
22d4bb9c
CB		 3761 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3762 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3763 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3764 fprintf(fp,"$ perl_on = \"set noon\"\n");
3765 fprintf(fp,"$ perl_exit = \"exit\"\n");
3766 fprintf(fp,"$ perl_del = \"delete\"\n");
3767 fprintf(fp,"$ pif = \"if\"\n");
3768 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2d5e9e5d
JH		 3769 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3770 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
0e06870b 3771 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
48b5a746
CL		 3772 fprintf(fp,"$! --- build command line to get max possible length\n");
3773 fprintf(fp,"$c=perl_popen_cmd0\n");
3774 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3775 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3776 fprintf(fp,"$x=perl_popen_cmd3\n");
3777 fprintf(fp,"$c=c+x\n");
22d4bb9c 3778 fprintf(fp,"$ perl_on\n");
f9ecfa39 3779 fprintf(fp,"$ 'c'\n");
22d4bb9c 3780 fprintf(fp,"$ perl_status = $STATUS\n");
0e06870b 3781 fprintf(fp,"$ perl_del 'perl_cfile'\n");
22d4bb9c
CB		 3782 fprintf(fp,"$ perl_exit 'perl_status'\n");
3783 fsync(fileno(fp));
3784
3785 fgetname(fp, file, 1);
312ac60b 3786 fstat(fileno(fp), &s0.crtl_stat);
22d4bb9c
CB		 3787 fclose(fp);
3788
2497a41f 3789 if (decc_filename_unix_only)
0e5ce2c7 3790 int_tounixspec(file, file, NULL);
22d4bb9c
CB		 3791 fp = fopen(file,"r","shr=get");
3792 if (!fp) return 0;
312ac60b 3793 fstat(fileno(fp), &s1.crtl_stat);
2497a41f 3794
682e4b71 3795 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
2497a41f 3796 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
22d4bb9c
CB		 3797 fclose(fp);
3798 return 0;
3799 }
3800
3801 return fp;
3802}
3803
3804
cd1191f1
CB		 3805static int vms_is_syscommand_xterm(void)
3806{
3807 const static struct dsc$descriptor_s syscommand_dsc =
3808 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3809
3810 const static struct dsc$descriptor_s decwdisplay_dsc =
3811 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3812
3813 struct item_list_3 items[2];
3814 unsigned short dvi_iosb[4];
3815 unsigned long devchar;
3816 unsigned long devclass;
3817 int status;
3818
3819 /* Very simple check to guess if sys$command is a decterm? */
3820 /* First see if the DECW$DISPLAY: device exists */
3821 items[0].len = 4;
3822 items[0].code = DVI$_DEVCHAR;
3823 items[0].bufadr = &devchar;
3824 items[0].retadr = NULL;
3825 items[1].len = 0;
3826 items[1].code = 0;
3827
3828 status = sys$getdviw
3829 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3830
3831 if ($VMS_STATUS_SUCCESS(status)) {
3832 status = dvi_iosb[0];
3833 }
3834
3835 if (!$VMS_STATUS_SUCCESS(status)) {
3836 SETERRNO(EVMSERR, status);
3837 return -1;
3838 }
3839
3840 /* If it does, then for now assume that we are on a workstation */
3841 /* Now verify that SYS$COMMAND is a terminal */
3842 /* for creating the debugger DECTerm */
3843
3844 items[0].len = 4;
3845 items[0].code = DVI$_DEVCLASS;
3846 items[0].bufadr = &devclass;
3847 items[0].retadr = NULL;
3848 items[1].len = 0;
3849 items[1].code = 0;
3850
3851 status = sys$getdviw
3852 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3853
3854 if ($VMS_STATUS_SUCCESS(status)) {
3855 status = dvi_iosb[0];
3856 }
3857
3858 if (!$VMS_STATUS_SUCCESS(status)) {
3859 SETERRNO(EVMSERR, status);
3860 return -1;
3861 }
3862 else {
3863 if (devclass == DC$_TERM) {
3864 return 0;
3865 }
3866 }
3867 return -1;
3868}
3869
3870/* If we are on a DECTerm, we can pretend to fork xterms when requested */
3871static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3872{
3873 int status;
3874 int ret_stat;
3875 char * ret_char;
3876 char device_name[65];
3877 unsigned short device_name_len;
3878 struct dsc$descriptor_s customization_dsc;
3879 struct dsc$descriptor_s device_name_dsc;
3880 const char * cptr;
cd1191f1
CB		 3881 char customization[200];
3882 char title[40];
3883 pInfo info = NULL;
3884 char mbx1[64];
3885 unsigned short p_chan;
3886 int n;
3887 unsigned short iosb[4];
cd1191f1
CB		 3888 const char * cust_str =
3889 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3890 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3891 DSC$K_CLASS_S, mbx1};
3892
8cb5d3d5
JM		 3893 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3894 /*---------------------------------------*/
d30c1055 3895 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
8cb5d3d5
JM		 3896
3897
3898 /* Make sure that this is from the Perl debugger */
cd1191f1
CB		 3899 ret_char = strstr(cmd," xterm ");
3900 if (ret_char == NULL)
3901 return NULL;
3902 cptr = ret_char + 7;
3903 ret_char = strstr(cmd,"tty");
3904 if (ret_char == NULL)
3905 return NULL;
3906 ret_char = strstr(cmd,"sleep");
3907 if (ret_char == NULL)
3908 return NULL;
3909
8cb5d3d5
JM		 3910 if (decw_term_port == 0) {
3911 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3912 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3913 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3914
d30c1055 3915 status = lib$find_image_symbol
8cb5d3d5
JM		 3916 (&filename1_dsc,
3917 &decw_term_port_dsc,
3918 (void *)&decw_term_port,
3919 NULL,
3920 0);
3921
3922 /* Try again with the other image name */
3923 if (!$VMS_STATUS_SUCCESS(status)) {
3924
d30c1055 3925 status = lib$find_image_symbol
8cb5d3d5
JM		 3926 (&filename2_dsc,
3927 &decw_term_port_dsc,
3928 (void *)&decw_term_port,
3929 NULL,
3930 0);
3931
3932 }
3933
3934 }
3935
3936
3937 /* No decw$term_port, give it up */
3938 if (!$VMS_STATUS_SUCCESS(status))
3939 return NULL;
3940
cd1191f1
CB		 3941 /* Are we on a workstation? */
3942 /* to do: capture the rows / columns and pass their properties */
3943 ret_stat = vms_is_syscommand_xterm();
3944 if (ret_stat < 0)
3945 return NULL;
3946
3947 /* Make the title: */
3948 ret_char = strstr(cptr,"-title");
3949 if (ret_char != NULL) {
3950 while ((*cptr != 0) && (*cptr != '\"')) {
3951 cptr++;
3952 }
3953 if (*cptr == '\"')
3954 cptr++;
3955 n = 0;
3956 while ((*cptr != 0) && (*cptr != '\"')) {
3957 title[n] = *cptr;
3958 n++;
3959 if (n == 39) {
07bee079 3960 title[39] = 0;
cd1191f1
CB		 3961 break;
3962 }
3963 cptr++;
3964 }
3965 title[n] = 0;
3966 }
3967 else {
3968 /* Default title */
3969 strcpy(title,"Perl Debug DECTerm");
3970 }
3971 sprintf(customization, cust_str, title);
3972
3973 customization_dsc.dsc$a_pointer = customization;
3974 customization_dsc.dsc$w_length = strlen(customization);
3975 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3976 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3977
3978 device_name_dsc.dsc$a_pointer = device_name;
3979 device_name_dsc.dsc$w_length = sizeof device_name -1;
3980 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3981 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3982
3983 device_name_len = 0;
3984
3985 /* Try to create the window */
8cb5d3d5 3986 status = (*decw_term_port)
cd1191f1
CB		 3987 (NULL,
3988 NULL,
3989 &customization_dsc,
3990 &device_name_dsc,
3991 &device_name_len,
3992 NULL,
3993 NULL,
3994 NULL);
3995 if (!$VMS_STATUS_SUCCESS(status)) {
3996 SETERRNO(EVMSERR, status);
3997 return NULL;
3998 }
3999
4000 device_name[device_name_len] = '\0';
4001
4002 /* Need to set this up to look like a pipe for cleanup */
4003 n = sizeof(Info);
4004 status = lib$get_vm(&n, &info);
4005 if (!$VMS_STATUS_SUCCESS(status)) {
4006 SETERRNO(ENOMEM, status);
4007 return NULL;
4008 }
4009
4010 info->mode = *mode;
4011 info->done = FALSE;
4012 info->completion = 0;
4013 info->closing = FALSE;
4014 info->in = 0;
4015 info->out = 0;
4016 info->err = 0;
4e205ed6 4017 info->fp = NULL;
cd1191f1
CB		 4018 info->useFILE = 0;
4019 info->waiting = 0;
4020 info->in_done = TRUE;
4021 info->out_done = TRUE;
4022 info->err_done = TRUE;
4023
4024 /* Assign a channel on this so that it will persist, and not login */
4025 /* We stash this channel in the info structure for reference. */
4026 /* The created xterm self destructs when the last channel is removed */
4027 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4028 /* So leave this assigned. */
4029 device_name_dsc.dsc$w_length = device_name_len;
4030 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4031 if (!$VMS_STATUS_SUCCESS(status)) {
4032 SETERRNO(EVMSERR, status);
4033 return NULL;
4034 }
4035 info->xchan_valid = 1;
4036
4037 /* Now create a mailbox to be read by the application */
4038
8a646e0b 4039 create_mbx(&p_chan, &d_mbx1);
cd1191f1
CB		 4040
4041 /* write the name of the created terminal to the mailbox */
4042 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4043 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4044
4045 if (!$VMS_STATUS_SUCCESS(status)) {
4046 SETERRNO(EVMSERR, status);
4047 return NULL;
4048 }
4049
4050 info->fp = PerlIO_open(mbx1, mode);
4051
4052 /* Done with this channel */
4053 sys$dassgn(p_chan);
4054
4055 /* If any errors, then clean up */
4056 if (!info->fp) {
4057 n = sizeof(Info);
ebd4d70b 4058 _ckvmssts_noperl(lib$free_vm(&n, &info));
cd1191f1
CB		 4059 return NULL;
4060 }
4061
4062 /* All done */
4063 return info->fp;
4064}
22d4bb9c 4065
ebd4d70b
JM		 4066static I32 my_pclose_pinfo(pTHX_ pInfo info);
4067
8fde5078 4068static PerlIO *
2fbb330f 4069safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
a0d0e21e 4070{
748a9306 4071 static int handler_set_up = FALSE;
ebd4d70b 4072 PerlIO * ret_fp;
55f2b99c 4073 unsigned long int sts, flags = CLI$M_NOWAIT;
f9ecfa39
PP		 4074 /* The use of a GLOBAL table (as was done previously) rendered
4075 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4076 * environment. Hence we've switched to LOCAL symbol table.
4077 */
4078 unsigned int table = LIB$K_CLI_LOCAL_SYM;
d4c83939 4079 int j, wait = 0, n;
ff7adb52 4080 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
cfcfe586 4081 char *in, *out, *err, mbx[512];
22d4bb9c
CB		 4082 FILE *tpipe = 0;
4083 char tfilebuf[NAM$C_MAXRSS+1];
d4c83939 4084 pInfo info = NULL;
48b5a746 4085 char cmd_sym_name[20];
22d4bb9c
CB		 4086 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4087 DSC$K_CLASS_S, symbol};
22d4bb9c 4088 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
a0d0e21e 4089 DSC$K_CLASS_S, 0};
48b5a746
CL		 4090 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4091 DSC$K_CLASS_S, cmd_sym_name};
218fdd94 4092 struct dsc$descriptor_s *vmscmd;
22d4bb9c 4093 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
0e06870b 4094 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
22d4bb9c 4095 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
cd1191f1 4096
cd1191f1
CB		 4097 /* Check here for Xterm create request. This means looking for
4098 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4099 * is possible to create an xterm.
4100 */
4101 if (*in_mode == 'r') {
4102 PerlIO * xterm_fd;
4103
4d9538c1
JM		 4104#if defined(PERL_IMPLICIT_CONTEXT)
4105 /* Can not fork an xterm with a NULL context */
4106 /* This probably could never happen */
4107 xterm_fd = NULL;
4108 if (aTHX != NULL)
4109#endif
cd1191f1 4110 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4e205ed6 4111 if (xterm_fd != NULL)
cd1191f1
CB		 4112 return xterm_fd;
4113 }
cd1191f1 4114
afd8f436
JH		 4115 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4116
22d4bb9c
CB		 4117 /* once-per-program initialization...
4118 note that the SETAST calls and the dual test of pipe_ef
4119 makes sure that only the FIRST thread through here does
4120 the initialization...all other threads wait until it's
4121 done.
4122
4123 Yeah, uglier than a pthread call, it's got all the stuff inline
4124 rather than in a separate routine.
4125 */
4126
4127 if (!pipe_ef) {
ebd4d70b 4128 _ckvmssts_noperl(sys$setast(0));
22d4bb9c
CB		 4129 if (!pipe_ef) {
4130 unsigned long int pidcode = JPI$_PID;
4131 $DESCRIPTOR(d_delay, RETRY_DELAY);
ebd4d70b
JM		 4132 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4133 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4134 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
22d4bb9c
CB		 4135 }
4136 if (!handler_set_up) {
ebd4d70b 4137 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
22d4bb9c
CB		 4138 handler_set_up = TRUE;
4139 }
ebd4d70b 4140 _ckvmssts_noperl(sys$setast(1));
22d4bb9c
CB		 4141 }
4142
4143 /* see if we can find a VMSPIPE.COM */
4144
4145 tfilebuf[0] = '@';
fd8cd3a3 4146 vmspipe = find_vmspipe(aTHX);
22d4bb9c 4147 if (vmspipe) {
a35dcc95 4148 vmspipedsc.dsc$w_length = my_strlcpy(tfilebuf+1, vmspipe, sizeof(tfilebuf)-1) + 1;
22d4bb9c 4149 } else { /* uh, oh...we're in tempfile hell */
fd8cd3a3 4150 tpipe = vmspipe_tempfile(aTHX);
22d4bb9c
CB		 4151 if (!tpipe) { /* a fish popular in Boston */
4152 if (ckWARN(WARN_PIPE)) {
f98bc0c6 4153 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
22d4bb9c 4154 }
4e205ed6 4155 return NULL;
22d4bb9c
CB		 4156 }
4157 fgetname(tpipe,tfilebuf+1,1);
a35dcc95 4158 vmspipedsc.dsc$w_length = strlen(tfilebuf);
22d4bb9c
CB		 4159 }
4160 vmspipedsc.dsc$a_pointer = tfilebuf;
a0d0e21e 4161
218fdd94 4162 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
a2669cfc
JH		 4163 if (!(sts & 1)) {
4164 switch (sts) {
4165 case RMS$_FNF: case RMS$_DNF:
4166 set_errno(ENOENT); break;
4167 case RMS$_DIR:
4168 set_errno(ENOTDIR); break;
4169 case RMS$_DEV:
4170 set_errno(ENODEV); break;
4171 case RMS$_PRV:
4172 set_errno(EACCES); break;
4173 case RMS$_SYN:
4174 set_errno(EINVAL); break;
4175 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4176 set_errno(E2BIG); break;
4177 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 4178 _ckvmssts_noperl(sts); /* fall through */
a2669cfc
JH		 4179 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4180 set_errno(EVMSERR);
4181 }
4182 set_vaxc_errno(sts);
cd1191f1 4183 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
f98bc0c6 4184 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
a2669cfc 4185 }
ff7adb52 4186 *psts = sts;
4e205ed6 4187 return NULL;
a2669cfc 4188 }
d4c83939 4189 n = sizeof(Info);
ebd4d70b 4190 _ckvmssts_noperl(lib$get_vm(&n, &info));
22d4bb9c 4191
a35dcc95 4192 my_strlcpy(mode, in_mode, sizeof(mode));
22d4bb9c
CB		 4193 info->mode = *mode;
4194 info->done = FALSE;
4195 info->completion = 0;
4196 info->closing = FALSE;
4197 info->in = 0;
4198 info->out = 0;
4199 info->err = 0;
4e205ed6 4200 info->fp = NULL;
ff7adb52
CL		 4201 info->useFILE = 0;
4202 info->waiting = 0;
22d4bb9c
CB		 4203 info->in_done = TRUE;
4204 info->out_done = TRUE;
4205 info->err_done = TRUE;
cd1191f1
CB		 4206 info->xchan = 0;
4207 info->xchan_valid = 0;
cfcfe586 4208
c11536f5 4209 in = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4210 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4211 out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4212 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 4213 err = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 4214 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cfcfe586 4215
0e06870b 4216 in[0] = out[0] = err[0] = '\0';
22d4bb9c 4217
ff7adb52
CL		 4218 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4219 info->useFILE = 1;
4220 strcpy(p,p+1);
4221 }
4222 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4223 wait = 1;
4224 strcpy(p,p+1);
4225 }
4226
22d4bb9c 4227 if (*mode == 'r') { /* piping from subroutine */
22d4bb9c 4228
fd8cd3a3 4229 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
22d4bb9c
CB		 4230 if (info->out) {
4231 info->out->pipe_done = &info->out_done;
4232 info->out_done = FALSE;
4233 info->out->info = info;
4234 }
ff7adb52 4235 if (!info->useFILE) {
cd1191f1 4236 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4237 } else {
4238 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
0db50132 4239 vmssetuserlnm("SYS$INPUT", mbx);
ff7adb52
CL		 4240 }
4241
22d4bb9c
CB		 4242 if (!info->fp && info->out) {
4243 sys$cancel(info->out->chan_out);
4244
4245 while (!info->out_done) {
4246 int done;
ebd4d70b 4247 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4248 done = info->out_done;
ebd4d70b
JM		 4249 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4250 _ckvmssts_noperl(sys$setast(1));
4251 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
0e06870b 4252 }
22d4bb9c 4253
d4c83939
CB		 4254 if (info->out->buf) {
4255 n = info->out->bufsize * sizeof(char);
ebd4d70b 4256 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
d4c83939
CB		 4257 }
4258 n = sizeof(Pipe);
ebd4d70b 4259 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
d4c83939 4260 n = sizeof(Info);
ebd4d70b 4261 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4262 *psts = RMS$_FNF;
4e205ed6 4263 return NULL;
0e06870b 4264 }
22d4bb9c 4265
fd8cd3a3 4266 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
22d4bb9c
CB		 4267 if (info->err) {
4268 info->err->pipe_done = &info->err_done;
4269 info->err_done = FALSE;
4270 info->err->info = info;
4271 }
a0d0e21e 4272
ff7adb52
CL		 4273 } else if (*mode == 'w') { /* piping to subroutine */
4274
4275 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4276 if (info->out) {
4277 info->out->pipe_done = &info->out_done;
4278 info->out_done = FALSE;
4279 info->out->info = info;
4280 }
4281
4282 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4283 if (info->err) {
4284 info->err->pipe_done = &info->err_done;
4285 info->err_done = FALSE;
4286 info->err->info = info;
4287 }
a0d0e21e 4288
fd8cd3a3 4289 info->in = pipe_tochild_setup(aTHX_ in,mbx);
ff7adb52 4290 if (!info->useFILE) {
a480973c 4291 info->fp = PerlIO_open(mbx, mode);
ff7adb52
CL		 4292 } else {
4293 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
0db50132 4294 vmssetuserlnm("SYS$OUTPUT", mbx);
ff7adb52
CL		 4295 }
4296
22d4bb9c
CB		 4297 if (info->in) {
4298 info->in->pipe_done = &info->in_done;
4299 info->in_done = FALSE;
4300 info->in->info = info;
4301 }
a0d0e21e 4302
22d4bb9c
CB		 4303 /* error cleanup */
4304 if (!info->fp && info->in) {
4305 info->done = TRUE;
ebd4d70b
JM		 4306 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4307 0, 0, 0, 0, 0, 0, 0, 0));
22d4bb9c
CB		 4308
4309 while (!info->in_done) {
4310 int done;
ebd4d70b 4311 _ckvmssts_noperl(sys$setast(0));
22d4bb9c 4312 done = info->in_done;
ebd4d70b
JM		 4313 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4314 _ckvmssts_noperl(sys$setast(1));
4315 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
22d4bb9c 4316 }
a0d0e21e 4317
d4c83939
CB		 4318 if (info->in->buf) {
4319 n = info->in->bufsize * sizeof(char);
ebd4d70b 4320 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
d4c83939
CB		 4321 }
4322 n = sizeof(Pipe);
ebd4d70b 4323 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
d4c83939 4324 n = sizeof(Info);
ebd4d70b 4325 _ckvmssts_noperl(lib$free_vm(&n, &info));
ff7adb52 4326 *psts = RMS$_FNF;
4e205ed6 4327 return NULL;
22d4bb9c 4328 }
a0d0e21e 4329
22d4bb9c 4330
ff7adb52 4331 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
fd8cd3a3 4332 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
22d4bb9c
CB		 4333 if (info->out) {
4334 info->out->pipe_done = &info->out_done;
4335 info->out_done = FALSE;
4336 info->out->info = info;
4337 }
0e06870b 4338
fd8cd3a3 4339 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
0e06870b
CB		 4340 if (info->err) {
4341 info->err->pipe_done = &info->err_done;
4342 info->err_done = FALSE;
4343 info->err->info = info;
4344 }
748a9306 4345 }
22d4bb9c 4346
a35dcc95 4347 d_symbol.dsc$w_length = my_strlcpy(symbol, in, sizeof(symbol));
ebd4d70b 4348 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
22d4bb9c 4349
a35dcc95 4350 d_symbol.dsc$w_length = my_strlcpy(symbol, err, sizeof(symbol));
ebd4d70b 4351 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
22d4bb9c 4352
a35dcc95 4353 d_symbol.dsc$w_length = my_strlcpy(symbol, out, sizeof(symbol));
ebd4d70b 4354 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
22d4bb9c 4355
cfcfe586
JM		 4356 /* Done with the names for the pipes */
4357 PerlMem_free(err);
4358 PerlMem_free(out);
4359 PerlMem_free(in);
4360
218fdd94 4361 p = vmscmd->dsc$a_pointer;
22d4bb9c
CB		 4362 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4363 if (*p == '$') p++; /* remove leading $ */
4364 while (*p == ' ' || *p == '\t') p++;
48b5a746
CL		 4365
4366 for (j = 0; j < 4; j++) {
4367 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4369
a35dcc95 4370 d_symbol.dsc$w_length = my_strlcpy(symbol, p, sizeof(symbol));
ebd4d70b 4371 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
22d4bb9c 4372
48b5a746
CL		 4373 if (strlen(p) > MAX_DCL_SYMBOL) {
4374 p += MAX_DCL_SYMBOL;
4375 } else {
4376 p += strlen(p);
4377 }
4378 }
ebd4d70b 4379 _ckvmssts_noperl(sys$setast(0));
a0d0e21e
LW		 4380 info->next=open_pipes; /* prepend to list */
4381 open_pipes=info;
ebd4d70b 4382 _ckvmssts_noperl(sys$setast(1));
55f2b99c
CB		 4383 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4384 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4385 * have SYS$COMMAND if we need it.
4386 */
ebd4d70b 4387 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
22d4bb9c
CB		 4388 0, &info->pid, &info->completion,
4389 0, popen_completion_ast,info,0,0,0));
4390
4391 /* if we were using a tempfile, close it now */
4392
4393 if (tpipe) fclose(tpipe);
4394
ff7adb52 4395 /* once the subprocess is spawned, it has copied the symbols and
22d4bb9c
CB		 4396 we can get rid of ours */
4397
48b5a746
CL		 4398 for (j = 0; j < 4; j++) {
4399 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4400 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
ebd4d70b 4401 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
48b5a746 4402 }
ebd4d70b
JM		 4403 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4404 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4405 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
218fdd94 4406 vms_execfree(vmscmd);
a0d0e21e 4407
218fdd94
CL		 4408#ifdef PERL_IMPLICIT_CONTEXT
4409 if (aTHX)
4410#endif
6b88bc9c 4411 PL_forkprocess = info->pid;
218fdd94 4412
ebd4d70b 4413 ret_fp = info->fp;
ff7adb52 4414 if (wait) {
ebd4d70b 4415 dSAVEDERRNO;
ff7adb52
CL		 4416 int done = 0;
4417 while (!done) {
ebd4d70b 4418 _ckvmssts_noperl(sys$setast(0));
ff7adb52 4419 done = info->done;
ebd4d70b
JM		 4420 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4421 _ckvmssts_noperl(sys$setast(1));
4422 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
ff7adb52
CL		 4423 }
4424 *psts = info->completion;
2fbb330f
JM		 4425/* Caller thinks it is open and tries to close it. */
4426/* This causes some problems, as it changes the error status */
4427/* my_pclose(info->fp); */
ebd4d70b
JM		 4428
4429 /* If we did not have a file pointer open, then we have to */
4430 /* clean up here or eventually we will run out of something */
4431 SAVE_ERRNO;
4432 if (info->fp == NULL) {
4433 my_pclose_pinfo(aTHX_ info);
4434 }
4435 RESTORE_ERRNO;
4436
ff7adb52 4437 } else {
eed5d6a1 4438 *psts = info->pid;
ff7adb52 4439 }
ebd4d70b 4440 return ret_fp;
1e422769 4441} /* end of safe_popen */
4442
4443
a15cef0c
CB		 4444/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4445PerlIO *
2fbb330f 4446Perl_my_popen(pTHX_ const char *cmd, const char *mode)
1e422769 4447{
ff7adb52 4448 int sts;
1e422769 4449 TAINT_ENV();
4450 TAINT_PROPER("popen");
45bc9206 4451 PERL_FLUSHALL_FOR_CHILD;
ff7adb52 4452 return safe_popen(aTHX_ cmd,mode,&sts);
a0d0e21e 4453}
1e422769 4454
a0d0e21e
LW		 4455/*}}}*/
4456
ebd4d70b
JM		 4457
4458/* Routine to close and cleanup a pipe info structure */
4459
4460static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4461
748a9306 4462 unsigned long int retsts;
4e0c9737 4463 int done, n;
ebd4d70b 4464 pInfo next, last;
748a9306 4465
bbce6d69 4466 /* If we were writing to a subprocess, insure that someone reading from
4467 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
22d4bb9c
CB		 4468 * produce an EOF record in the mailbox.
4469 *
4470 * well, at least sometimes it *does*, so we have to watch out for
4471 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4472 */
ff7adb52 4473 if (info->fp) {
5ce486e0
CB		 4474 if (!info->useFILE
4475#if defined(USE_ITHREADS)
4476 && my_perl
4477#endif
a24c654f
CB		 4478#ifdef USE_PERLIO
4479 && PL_perlio_fd_refcnt
4480#endif
4481 )
5ce486e0 4482 PerlIO_flush(info->fp);
ff7adb52
CL		 4483 else
4484 fflush((FILE *)info->fp);
4485 }
22d4bb9c 4486
b08af3f0 4487 _ckvmssts(sys$setast(0));
22d4bb9c
CB		 4488 info->closing = TRUE;
4489 done = info->done && info->in_done && info->out_done && info->err_done;
4490 /* hanging on write to Perl's input? cancel it */
4491 if (info->mode == 'r' && info->out && !info->out_done) {
4492 if (info->out->chan_out) {
4493 _ckvmssts(sys$cancel(info->out->chan_out));
4494 if (!info->out->chan_in) { /* EOF generation, need AST */
4495 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4496 }
4497 }
4498 }
4499 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4500 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4501 0, 0, 0, 0, 0, 0));
b08af3f0 4502 _ckvmssts(sys$setast(1));
ff7adb52 4503 if (info->fp) {
5ce486e0
CB		 4504 if (!info->useFILE
4505#if defined(USE_ITHREADS)
4506 && my_perl
4507#endif
a24c654f
CB		 4508#ifdef USE_PERLIO
4509 && PL_perlio_fd_refcnt
4510#endif
4511 )
d4c83939 4512 PerlIO_close(info->fp);
ff7adb52
CL		 4513 else
4514 fclose((FILE *)info->fp);
4515 }
22d4bb9c
CB		 4516 /*
4517 we have to wait until subprocess completes, but ALSO wait until all
4518 the i/o completes...otherwise we'll be freeing the "info" structure
4519 that the i/o ASTs could still be using...
4520 */
4521
4522 while (!done) {
4523 _ckvmssts(sys$setast(0));
4524 done = info->done && info->in_done && info->out_done && info->err_done;
4525 if (!done) _ckvmssts(sys$clref(pipe_ef));
4526 _ckvmssts(sys$setast(1));
4527 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4528 }
4529 retsts = info->completion;
a0d0e21e 4530
a0d0e21e 4531 /* remove from list of open pipes */
b08af3f0 4532 _ckvmssts(sys$setast(0));
ebd4d70b
JM		 4533 last = NULL;
4534 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4535 if (next == info)
4536 break;
4537 }
4538
4539 if (last)
4540 last->next = info->next;
4541 else
4542 open_pipes = info->next;
b08af3f0 4543 _ckvmssts(sys$setast(1));
22d4bb9c
CB		 4544
4545 /* free buffers and structures */
4546
4547 if (info->in) {
d4c83939
CB		 4548 if (info->in->buf) {
4549 n = info->in->bufsize * sizeof(char);
4550 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4551 }
4552 n = sizeof(Pipe);
4553 _ckvmssts(lib$free_vm(&n, &info->in));
22d4bb9c
CB		 4554 }
4555 if (info->out) {
d4c83939
CB		 4556 if (info->out->buf) {
4557 n = info->out->bufsize * sizeof(char);
4558 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4559 }
4560 n = sizeof(Pipe);
4561 _ckvmssts(lib$free_vm(&n, &info->out));
22d4bb9c
CB		 4562 }
4563 if (info->err) {
d4c83939
CB		 4564 if (info->err->buf) {
4565 n = info->err->bufsize * sizeof(char);
4566 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4567 }
4568 n = sizeof(Pipe);
4569 _ckvmssts(lib$free_vm(&n, &info->err));
22d4bb9c 4570 }
d4c83939
CB		 4571 n = sizeof(Info);
4572 _ckvmssts(lib$free_vm(&n, &info));
a0d0e21e
LW		 4573
4574 return retsts;
ebd4d70b
JM		 4575}
4576
4577
4578/*{{{ I32 my_pclose(PerlIO *fp)*/
4579I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4580{
4581 pInfo info, last = NULL;
4582 I32 ret_status;
4583
4584 /* Fixme - need ast and mutex protection here */
4585 for (info = open_pipes; info != NULL; last = info, info = info->next)
4586 if (info->fp == fp) break;
4587
4588 if (info == NULL) { /* no such pipe open */
4589 set_errno(ECHILD); /* quoth POSIX */
4590 set_vaxc_errno(SS$_NONEXPR);
4591 return -1;
4592 }
4593
4594 ret_status = my_pclose_pinfo(aTHX_ info);
4595
4596 return ret_status;
748a9306 4597
a0d0e21e
LW		 4598} /* end of my_pclose() */
4599
119586db 4600#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4601 /* Roll our own prototype because we want this regardless of whether
4602 * _VMS_WAIT is defined.
4603 */
c11536f5
CB		 4604
4605#ifdef __cplusplus
4606extern "C" {
4607#endif
aeb5cf3c 4608 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
c11536f5
CB		 4609#ifdef __cplusplus
4610}
4611#endif
4612
aeb5cf3c
CB		 4613#endif
4614/* sort-of waitpid; special handling of pipe clean-up for subprocesses
4615 created with popen(); otherwise partially emulate waitpid() unless
4616 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4617 Also check processes not considered by the CRTL waitpid().
4618 */
4fdae800 4619/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4620Pid_t
fd8cd3a3 4621Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
a0d0e21e 4622{
22d4bb9c
CB		 4623 pInfo info;
4624 int done;
aeb5cf3c 4625 int sts;
d85f548a 4626 int j;
aeb5cf3c
CB		 4627
4628 if (statusp) *statusp = 0;
a0d0e21e
LW		 4629
4630 for (info = open_pipes; info != NULL; info = info->next)
4631 if (info->pid == pid) break;
4632
4633 if (info != NULL) { /* we know about this child */
748a9306 4634 while (!info->done) {
22d4bb9c
CB		 4635 _ckvmssts(sys$setast(0));
4636 done = info->done;
4637 if (!done) _ckvmssts(sys$clref(pipe_ef));
4638 _ckvmssts(sys$setast(1));
4639 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
a0d0e21e
LW		 4640 }
4641
aeb5cf3c 4642 if (statusp) *statusp = info->completion;
a0d0e21e 4643 return pid;
d85f548a
JH		 4644 }
4645
4646 /* child that already terminated? */
aeb5cf3c 4647
d85f548a
JH		 4648 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4649 if (closed_list[j].pid == pid) {
4650 if (statusp) *statusp = closed_list[j].completion;
4651 return pid;
4652 }
a0d0e21e 4653 }
d85f548a
JH		 4654
4655 /* fall through if this child is not one of our own pipe children */
aeb5cf3c 4656
119586db 4657#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
aeb5cf3c
CB		 4658
4659 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4660 * in 7.2 did we get a version that fills in the VMS completion
4661 * status as Perl has always tried to do.
4662 */
4663
4664 sts = __vms_waitpid( pid, statusp, flags );
4665
4666 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4667 return sts;
4668
4669 /* If the real waitpid tells us the child does not exist, we
4670 * fall through here to implement waiting for a child that
4671 * was created by some means other than exec() (say, spawned
4672 * from DCL) or to wait for a process that is not a subprocess
4673 * of the current process.
4674 */
4675
119586db 4676#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
aeb5cf3c 4677
21bc9d50 4678 {
a0d0e21e 4679 $DESCRIPTOR(intdsc,"0 00:00:01");
aeb5cf3c
CB		 4680 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4681 unsigned long int pidcode = JPI$_PID, mypid;
4682 unsigned long int interval[2];
aeb5cf3c 4683 unsigned int jpi_iosb[2];
d85f548a 4684 struct itmlst_3 jpilist[2] = {
aeb5cf3c 4685 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
aeb5cf3c
CB		 4686 { 0, 0, 0, 0}
4687 };
aeb5cf3c
CB		 4688
4689 if (pid <= 0) {
4690 /* Sorry folks, we don't presently implement rooting around for
4691 the first child we can find, and we definitely don't want to
4692 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4693 */
4694 set_errno(ENOTSUP);
4695 return -1;
4696 }
4697
d85f548a
JH		 4698 /* Get the owner of the child so I can warn if it's not mine. If the
4699 * process doesn't exist or I don't have the privs to look at it,
4700 * I can go home early.
aeb5cf3c
CB		 4701 */
4702 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4703 if (sts & 1) sts = jpi_iosb[0];
4704 if (!(sts & 1)) {
4705 switch (sts) {
4706 case SS$_NONEXPR:
4707 set_errno(ECHILD);
4708 break;
4709 case SS$_NOPRIV:
4710 set_errno(EACCES);
4711 break;
4712 default:
4713 _ckvmssts(sts);
4714 }
4715 set_vaxc_errno(sts);
4716 return -1;
4717 }
a0d0e21e 4718
3eeba6fb 4719 if (ckWARN(WARN_EXEC)) {
aeb5cf3c
CB		 4720 /* remind folks they are asking for non-standard waitpid behavior */
4721 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
748a9306 4722 if (ownerpid != mypid)
f98bc0c6 4723 Perl_warner(aTHX_ packWARN(WARN_EXEC),
aeb5cf3c
CB		 4724 "waitpid: process %x is not a child of process %x",
4725 pid,mypid);
748a9306 4726 }
a0d0e21e 4727
d85f548a
JH		 4728 /* simply check on it once a second until it's not there anymore. */
4729
4730 _ckvmssts(sys$bintim(&intdsc,interval));
4731 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
aeb5cf3c
CB		 4732 _ckvmssts(sys$schdwk(0,0,interval,0));
4733 _ckvmssts(sys$hiber());
d85f548a
JH		 4734 }
4735 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
aeb5cf3c
CB		 4736
4737 _ckvmssts(sts);
a0d0e21e 4738 return pid;
21bc9d50 4739 }
a0d0e21e 4740} /* end of waitpid() */
a0d0e21e
LW		 4741/*}}}*/
4742/*}}}*/
4743/*}}}*/
4744
4745/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4746char *
4747my_gconvert(double val, int ndig, int trail, char *buf)
4748{
4749 static char __gcvtbuf[DBL_DIG+1];
4750 char *loc;
4751
4752 loc = buf ? buf : __gcvtbuf;
71be2cbc 4753
a0d0e21e
LW		 4754 if (val) {
4755 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4756 return gcvt(val,ndig,loc);
4757 }
4758 else {
4759 loc[0] = '0'; loc[1] = '\0';
4760 return loc;
4761 }
4762
4763}
4764/*}}}*/
4765
988c775c 4766#if defined(__VAX) || !defined(NAML$C_MAXRSS)
a480973c
JM		 4767static int rms_free_search_context(struct FAB * fab)
4768{
4769struct NAM * nam;
4770
4771 nam = fab->fab$l_nam;
4772 nam->nam$b_nop |= NAM$M_SYNCHK;
4773 nam->nam$l_rlf = NULL;
4774 fab->fab$b_dns = 0;
4775 return sys$parse(fab, NULL, NULL);
4776}
4777
4778#define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4d743a9b 4779#define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
a480973c
JM		 4780#define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4781#define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4782#define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4783#define rms_nam_esll(nam) nam.nam$b_esl
4784#define rms_nam_esl(nam) nam.nam$b_esl
4785#define rms_nam_name(nam) nam.nam$l_name
4786#define rms_nam_namel(nam) nam.nam$l_name
4787#define rms_nam_type(nam) nam.nam$l_type
4788#define rms_nam_typel(nam) nam.nam$l_type
4789#define rms_nam_ver(nam) nam.nam$l_ver
4790#define rms_nam_verl(nam) nam.nam$l_ver
4791#define rms_nam_rsll(nam) nam.nam$b_rsl
4792#define rms_nam_rsl(nam) nam.nam$b_rsl
4793#define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4794#define rms_set_fna(fab, nam, name, size) \
a1887106 4795 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
a480973c
JM		 4796#define rms_get_fna(fab, nam) fab.fab$l_fna
4797#define rms_set_dna(fab, nam, name, size) \
a1887106
JM		 4798 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4799#define rms_nam_dns(fab, nam) fab.fab$b_dns
d584a1c6 4800#define rms_set_esa(nam, name, size) \
a1887106 4801 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
a480973c 4802#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4803 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
a480973c 4804#define rms_set_rsa(nam, name, size) \
a1887106 4805 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
a480973c 4806#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106
JM		 4807 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4808#define rms_nam_name_type_l_size(nam) \
4809 (nam.nam$b_name + nam.nam$b_type)
a480973c
JM		 4810#else
4811static int rms_free_search_context(struct FAB * fab)
4812{
4813struct NAML * nam;
4814
4815 nam = fab->fab$l_naml;
4816 nam->naml$b_nop |= NAM$M_SYNCHK;
4817 nam->naml$l_rlf = NULL;
4818 nam->naml$l_long_defname_size = 0;
988c775c 4819
a480973c
JM		 4820 fab->fab$b_dns = 0;
4821 return sys$parse(fab, NULL, NULL);
4822}
4823
4824#define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4d743a9b 4825#define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
a480973c
JM		 4826#define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4827#define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4828#define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4829#define rms_nam_esll(nam) nam.naml$l_long_expand_size
4830#define rms_nam_esl(nam) nam.naml$b_esl
4831#define rms_nam_name(nam) nam.naml$l_name
4832#define rms_nam_namel(nam) nam.naml$l_long_name
4833#define rms_nam_type(nam) nam.naml$l_type
4834#define rms_nam_typel(nam) nam.naml$l_long_type
4835#define rms_nam_ver(nam) nam.naml$l_ver
4836#define rms_nam_verl(nam) nam.naml$l_long_ver
4837#define rms_nam_rsll(nam) nam.naml$l_long_result_size
4838#define rms_nam_rsl(nam) nam.naml$b_rsl
4839#define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4840#define rms_set_fna(fab, nam, name, size) \
a1887106 4841 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
a480973c 4842 nam.naml$l_long_filename_size = size; \
a1887106 4843 nam.naml$l_long_filename = name;}
a480973c
JM		 4844#define rms_get_fna(fab, nam) nam.naml$l_long_filename
4845#define rms_set_dna(fab, nam, name, size) \
a1887106 4846 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
a480973c 4847 nam.naml$l_long_defname_size = size; \
a1887106 4848 nam.naml$l_long_defname = name; }
a480973c 4849#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
d584a1c6 4850#define rms_set_esa(nam, name, size) \
a1887106 4851 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
a480973c 4852 nam.naml$l_long_expand_alloc = size; \
a1887106 4853 nam.naml$l_long_expand = name; }
a480973c 4854#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
a1887106 4855 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
a480973c 4856 nam.naml$l_long_expand = l_name; \
a1887106 4857 nam.naml$l_long_expand_alloc = l_size; }
a480973c 4858#define rms_set_rsa(nam, name, size) \
a1887106 4859 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
a480973c 4860 nam.naml$l_long_result = name; \
a1887106 4861 nam.naml$l_long_result_alloc = size; }
a480973c 4862#define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
a1887106 4863 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
a480973c 4864 nam.naml$l_long_result = l_name; \
a1887106
JM		 4865 nam.naml$l_long_result_alloc = l_size; }
4866#define rms_nam_name_type_l_size(nam) \
4867 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
a480973c
JM		 4868#endif
4869
4fdf8f88 4870
e0e5e8d6
JM		 4871/* rms_erase
4872 * The CRTL for 8.3 and later can create symbolic links in any mode,
4fdf8f88 4873 * however in 8.3 the unlink/remove/delete routines will only properly handle
e0e5e8d6 4874 * them if one of the PCP modes is active.
e0e5e8d6
JM		 4875 */
4876static int rms_erase(const char * vmsname)
4877{
4878 int status;
4879 struct FAB myfab = cc$rms_fab;
4880 rms_setup_nam(mynam);
4881
4882 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4883 rms_bind_fab_nam(myfab, mynam);
4fdf8f88 4884
e0e5e8d6
JM		 4885#ifdef NAML$M_OPEN_SPECIAL
4886 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4887#endif
4888
d30c1055 4889 status = sys$erase(&myfab, 0, 0);
e0e5e8d6
JM		 4890
4891 return status;
4892}
4893
bbce6d69 4894
4fdf8f88
JM		 4895static int
4896vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4897 const struct dsc$descriptor_s * vms_dst_dsc,
4898 unsigned long flags)
4899{
4900 /* VMS and UNIX handle file permissions differently and the
4901 * the same ACL trick may be needed for renaming files,
4902 * especially if they are directories.
4903 */
4904
4905 /* todo: get kill_file and rename to share common code */
4906 /* I can not find online documentation for $change_acl
4907 * it appears to be replaced by $set_security some time ago */
4908
4909const unsigned int access_mode = 0;
4910$DESCRIPTOR(obj_file_dsc,"FILE");
4911char *vmsname;
4912char *rslt;
4e0c9737 4913unsigned long int jpicode = JPI$_UIC;
4fdf8f88
JM		 4914int aclsts, fndsts, rnsts = -1;
4915unsigned int ctx = 0;
4916struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4917struct dsc$descriptor_s * clean_dsc;
4918
4919struct myacedef {
4920 unsigned char myace$b_length;
4921 unsigned char myace$b_type;
4922 unsigned short int myace$w_flags;
4923 unsigned long int myace$l_access;
4924 unsigned long int myace$l_ident;
4925} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4926 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4927 0},
4928 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4929
4930struct item_list_3
4931 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4932 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4933 {0,0,0,0}},
4934 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4935 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4936 {0,0,0,0}};
4937
4938
4939 /* Expand the input spec using RMS, since we do not want to put
4940 * ACLs on the target of a symbolic link */
c11536f5 4941 vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
4fdf8f88
JM		 4942 if (vmsname == NULL)
4943 return SS$_INSFMEM;
4944
6fb6c614 4945 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
4fdf8f88 4946 vmsname,
6fb6c614 4947 PERL_RMSEXPAND_M_SYMLINK);
4fdf8f88
JM		 4948 if (rslt == NULL) {
4949 PerlMem_free(vmsname);
4950 return SS$_INSFMEM;
4951 }
4952
4953 /* So we get our own UIC to use as a rights identifier,
4954 * and the insert an ACE at the head of the ACL which allows us
4955 * to delete the file.
4956 */
ebd4d70b 4957 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4fdf8f88
JM		 4958
4959 fildsc.dsc$w_length = strlen(vmsname);
4960 fildsc.dsc$a_pointer = vmsname;
4961 ctx = 0;
4962 newace.myace$l_ident = oldace.myace$l_ident;
4963 rnsts = SS$_ABORT;
4964
4965 /* Grab any existing ACEs with this identifier in case we fail */
4966 clean_dsc = &fildsc;
4967 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4968 &fildsc,
4969 NULL,
4970 OSS$M_WLOCK,
4971 findlst,
4972 &ctx,
4973 &access_mode);
4974
4975 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4976 /* Add the new ACE . . . */
4977
4978 /* if the sys$get_security succeeded, then ctx is valid, and the
4979 * object/file descriptors will be ignored. But otherwise they
4980 * are needed
4981 */
4982 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4983 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4984 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4985 set_errno(EVMSERR);
4986 set_vaxc_errno(aclsts);
4987 PerlMem_free(vmsname);
4988 return aclsts;
4989 }
4990
4991 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4992 NULL, NULL,
4993 &flags,
4994 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4995
4996 if ($VMS_STATUS_SUCCESS(rnsts)) {
4997 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4998 }
4999
5000 /* Put things back the way they were. */
5001 ctx = 0;
5002 aclsts = sys$get_security(&obj_file_dsc,
5003 clean_dsc,
5004 NULL,
5005 OSS$M_WLOCK,
5006 findlst,
5007 &ctx,
5008 &access_mode);
5009
5010 if ($VMS_STATUS_SUCCESS(aclsts)) {
5011 int sec_flags;
5012
5013 sec_flags = 0;
5014 if (!$VMS_STATUS_SUCCESS(fndsts))
5015 sec_flags = OSS$M_RELCTX;
5016
5017 /* Get rid of the new ACE */
5018 aclsts = sys$set_security(NULL, NULL, NULL,
5019 sec_flags, dellst, &ctx, &access_mode);
5020
5021 /* If there was an old ACE, put it back */
5022 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5023 addlst[0].bufadr = &oldace;
5024 aclsts = sys$set_security(NULL, NULL, NULL,
5025 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5026 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5027 set_errno(EVMSERR);
5028 set_vaxc_errno(aclsts);
5029 rnsts = aclsts;
5030 }
5031 } else {
5032 int aclsts2;
5033
5034 /* Try to clear the lock on the ACL list */
5035 aclsts2 = sys$set_security(NULL, NULL, NULL,
5036 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5037
5038 /* Rename errors are most important */
5039 if (!$VMS_STATUS_SUCCESS(rnsts))
5040 aclsts = rnsts;
5041 set_errno(EVMSERR);
5042 set_vaxc_errno(aclsts);
5043 rnsts = aclsts;
5044 }
5045 }
5046 else {
5047 if (aclsts != SS$_ACLEMPTY)
5048 rnsts = aclsts;
5049 }
5050 }
5051 else
5052 rnsts = fndsts;
5053
5054 PerlMem_free(vmsname);
5055 return rnsts;
5056}
5057
5058
5059/*{{{int rename(const char *, const char * */
5060/* Not exactly what X/Open says to do, but doing it absolutely right
5061 * and efficiently would require a lot more work. This should be close
5062 * enough to pass all but the most strict X/Open compliance test.
5063 */
5064int
5065Perl_rename(pTHX_ const char *src, const char * dst)
5066{
5067int retval;
5068int pre_delete = 0;
5069int src_sts;
5070int dst_sts;
5071Stat_t src_st;
5072Stat_t dst_st;
5073
5074 /* Validate the source file */
46c05374 5075 src_sts = flex_lstat(src, &src_st);
4fdf8f88
JM		 5076 if (src_sts != 0) {
5077
5078 /* No source file or other problem */
5079 return src_sts;
5080 }
b94a8c49
JM		 5081 if (src_st.st_devnam[0] == 0) {
5082 /* This may be possible so fail if it is seen. */
5083 errno = EIO;
5084 return -1;
5085 }
4fdf8f88 5086
46c05374 5087 dst_sts = flex_lstat(dst, &dst_st);
4fdf8f88
JM		 5088 if (dst_sts == 0) {
5089
5090 if (dst_st.st_dev != src_st.st_dev) {
5091 /* Must be on the same device */
5092 errno = EXDEV;
5093 return -1;
5094 }
5095
5096 /* VMS_INO_T_COMPARE is true if the inodes are different
5097 * to match the output of memcmp
5098 */
5099
5100 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5101 /* That was easy, the files are the same! */
5102 return 0;
5103 }
5104
5105 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5106 /* If source is a directory, so must be dest */
5107 errno = EISDIR;
5108 return -1;
5109 }
5110
5111 }
5112
5113
5114 if ((dst_sts == 0) &&
5115 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5116
5117 /* We have issues here if vms_unlink_all_versions is set
5118 * If the destination exists, and is not a directory, then
5119 * we must delete in advance.
5120 *
5121 * If the src is a directory, then we must always pre-delete
5122 * the destination.
5123 *
5124 * If we successfully delete the dst in advance, and the rename fails
5125 * X/Open requires that errno be EIO.
5126 *
5127 */
5128
5129 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5130 int d_sts;
46c05374 5131 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
b94a8c49
JM		 5132 S_ISDIR(dst_st.st_mode));
5133
5134 /* Need to delete all versions ? */
5135 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5136 int i = 0;
5137
5138 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
46c05374 5139 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
b94a8c49
JM		 5140 if (d_sts != 0)
5141 break;
5142 i++;
5143
5144 /* Make sure that we do not loop forever */
5145 if (i > 32767) {
5146 errno = EIO;
5147 d_sts = -1;
5148 break;
5149 }
5150 }
5151 }
5152
4fdf8f88
JM		 5153 if (d_sts != 0)
5154 return d_sts;
5155
5156 /* We killed the destination, so only errno now is EIO */
5157 pre_delete = 1;
5158 }
5159 }
5160
5161 /* Originally the idea was to call the CRTL rename() and only
5162 * try the lib$rename_file if it failed.
5163 * It turns out that there are too many variants in what the
5164 * the CRTL rename might do, so only use lib$rename_file
5165 */
5166 retval = -1;
5167
5168 {
5169 /* Is the source and dest both in VMS format */
5170 /* if the source is a directory, then need to fileify */
94ae10c0 5171 /* and dest must be a directory or non-existent. */
4fdf8f88 5172
4fdf8f88
JM		 5173 char * vms_dst;
5174 int sts;
5175 char * ret_str;
5176 unsigned long flags;
5177 struct dsc$descriptor_s old_file_dsc;
5178 struct dsc$descriptor_s new_file_dsc;
5179
5180 /* We need to modify the src and dst depending
5181 * on if one or more of them are directories.
5182 */
5183
c11536f5 5184 vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5185 if (vms_dst == NULL)
ebd4d70b 5186 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88
JM		 5187
5188 if (S_ISDIR(src_st.st_mode)) {
5189 char * ret_str;
5190 char * vms_dir_file;
5191
c11536f5 5192 vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
4fdf8f88 5193 if (vms_dir_file == NULL)
ebd4d70b 5194 _ckvmssts_noperl(SS$_INSFMEM);
4fdf8f88 5195
29475144 5196 /* If the dest is a directory, we must remove it */
4fdf8f88
JM		 5197 if (dst_sts == 0) {
5198 int d_sts;
46c05374 5199 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
4fdf8f88 5200 if (d_sts != 0) {
4fdf8f88
JM		 5201 PerlMem_free(vms_dst);
5202 errno = EIO;
29475144 5203 return d_sts;
4fdf8f88
JM		 5204 }
5205
5206 pre_delete = 1;
5207 }
5208
5209 /* The dest must be a VMS file specification */
df278665 5210 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5211 if (ret_str == NULL) {
4fdf8f88
JM		 5212 PerlMem_free(vms_dst);
5213 errno = EIO;
5214 return -1;
5215 }
5216
5217 /* The source must be a file specification */
4fdf8f88
JM		 5218 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5219 if (ret_str == NULL) {
4fdf8f88
JM		 5220 PerlMem_free(vms_dst);
5221 PerlMem_free(vms_dir_file);
5222 errno = EIO;
5223 return -1;
5224 }
5225 PerlMem_free(vms_dst);
5226 vms_dst = vms_dir_file;
5227
5228 } else {
5229 /* File to file or file to new dir */
5230
5231 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5232 /* VMS pathify a dir target */
4846f1d7 5233 ret_str = int_tovmspath(dst, vms_dst, NULL);
4fdf8f88 5234 if (ret_str == NULL) {
4fdf8f88
JM		 5235 PerlMem_free(vms_dst);
5236 errno = EIO;
5237 return -1;
5238 }
5239 } else {
b94a8c49
JM		 5240 char * v_spec, * r_spec, * d_spec, * n_spec;
5241 char * e_spec, * vs_spec;
5242 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
4fdf8f88
JM		 5243
5244 /* fileify a target VMS file specification */
df278665 5245 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
4fdf8f88 5246 if (ret_str == NULL) {
4fdf8f88
JM		 5247 PerlMem_free(vms_dst);
5248 errno = EIO;
5249 return -1;
5250 }
b94a8c49
JM		 5251
5252 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5253 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5254 &e_len, &vs_spec, &vs_len);
5255 if (sts == 0) {
5256 if (e_len == 0) {
5257 /* Get rid of the version */
5258 if (vs_len != 0) {
5259 *vs_spec = '\0';
5260 }
5261 /* Need to specify a '.' so that the extension */
5262 /* is not inherited */
5263 strcat(vms_dst,".");
5264 }
5265 }
4fdf8f88
JM		 5266 }
5267 }
5268
b94a8c49
JM		 5269 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5270 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
4fdf8f88
JM		 5271 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5272 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5273
5274 new_file_dsc.dsc$a_pointer = vms_dst;
5275 new_file_dsc.dsc$w_length = strlen(vms_dst);
5276 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5277 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5278
5279 flags = 0;
5280#if !defined(__VAX) && defined(NAML$C_MAXRSS)
449de3c2 5281 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
4fdf8f88
JM		 5282#endif
5283
5284 sts = lib$rename_file(&old_file_dsc,
5285 &new_file_dsc,
5286 NULL, NULL,
5287 &flags,
5288 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5289 if (!$VMS_STATUS_SUCCESS(sts)) {
5290
5291 /* We could have failed because VMS style permissions do not
5292 * permit renames that UNIX will allow. Just like the hack
5293 * in for kill_file.
5294 */
5295 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5296 }
5297
4fdf8f88
JM		 5298 PerlMem_free(vms_dst);
5299 if (!$VMS_STATUS_SUCCESS(sts)) {
5300 errno = EIO;
5301 return -1;
5302 }
5303 retval = 0;
5304 }
5305
5306 if (vms_unlink_all_versions) {
5307 /* Now get rid of any previous versions of the source file that
5308 * might still exist
5309 */
b94a8c49
JM		 5310 int i = 0;
5311 dSAVEDERRNO;
5312 SAVE_ERRNO;
46c05374 5313 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5314 S_ISDIR(src_st.st_mode));
5315 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
46c05374 5316 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
b94a8c49
JM		 5317 S_ISDIR(src_st.st_mode));
5318 if (src_sts != 0)
5319 break;
5320 i++;
5321
5322 /* Make sure that we do not loop forever */
5323 if (i > 32767) {
5324 src_sts = -1;
5325 break;
5326 }
5327 }
5328 RESTORE_ERRNO;
4fdf8f88
JM		 5329 }
5330
5331 /* We deleted the destination, so must force the error to be EIO */
5332 if ((retval != 0) && (pre_delete != 0))
5333 errno = EIO;
5334
5335 return retval;
5336}
5337/*}}}*/
5338
5339
bbce6d69 5340/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5341/* Shortcut for common case of simple calls to $PARSE and $SEARCH
5342 * to expand file specification. Allows for a single default file
5343 * specification and a simple mask of options. If outbuf is non-NULL,
5344 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5345 * the resultant file specification is placed. If outbuf is NULL, the
5346 * resultant file specification is placed into a static buffer.
5347 * The third argument, if non-NULL, is taken to be a default file
5348 * specification string. The fourth argument is unused at present.
5349 * rmesexpand() returns the address of the resultant string if
5350 * successful, and NULL on error.
e886094b
JM		 5351 *
5352 * New functionality for previously unused opts value:
5353 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
a1887106
JM		 5354 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5355 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
e0e5e8d6 5356 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
bbce6d69 5357 */
360732b5 5358static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
96e4d5b1 5359
bbce6d69 5360static char *
6fb6c614
JM		 5361int_rmsexpand
5362 (const char *filespec,
360732b5 5363 char *outbuf,
360732b5
JM		 5364 const char *defspec,
5365 unsigned opts,
5366 int * fs_utf8,
5367 int * dfs_utf8)
bbce6d69 5368{
6fb6c614
JM		 5369 char * ret_spec;
5370 const char * in_spec;
5371 char * spec_buf;
5372 const char * def_spec;
5373 char * vmsfspec, *vmsdefspec;
5374 char * esa;
7566800d 5375 char * esal = NULL;
18a3d61e
JM		 5376 char * outbufl;
5377 struct FAB myfab = cc$rms_fab;
a480973c 5378 rms_setup_nam(mynam);
18a3d61e
JM		 5379 STRLEN speclen;
5380 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5381 int sts;
5382
360732b5
JM		 5383 /* temp hack until UTF8 is actually implemented */
5384 if (fs_utf8 != NULL)
5385 *fs_utf8 = 0;
5386
18a3d61e
JM		 5387 if (!filespec || !*filespec) {
5388 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5389 return NULL;
5390 }
18a3d61e
JM		 5391
5392 vmsfspec = NULL;
6fb6c614 5393 vmsdefspec = NULL;
18a3d61e 5394 outbufl = NULL;
a1887106 5395
6fb6c614 5396 in_spec = filespec;
a1887106
JM		 5397 isunix = 0;
5398 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
6fb6c614
JM		 5399 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5400 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5401
5402 /* If this is a UNIX file spec, convert it to VMS */
5403 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5404 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5405 &e_len, &vs_spec, &vs_len);
5406 if (sts != 0) {
5407 isunix = 1;
5408 char * ret_spec;
5409
c11536f5 5410 vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5411 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5412 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5413 if (ret_spec == NULL) {
5414 PerlMem_free(vmsfspec);
5415 return NULL;
5416 }
5417 in_spec = (const char *)vmsfspec;
18a3d61e 5418
6fb6c614
JM		 5419 /* Unless we are forcing to VMS format, a UNIX input means
5420 * UNIX output, and that requires long names to be used
5421 */
5422 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
b1a8dcd7 5423#if !defined(__VAX) && defined(NAML$C_MAXRSS)
6fb6c614 5424 opts |= PERL_RMSEXPAND_M_LONG;
778e045f
CB		 5425#else
5426 NOOP;
b1a8dcd7 5427#endif
6fb6c614
JM		 5428 else
5429 isunix = 0;
a1887106 5430 }
18a3d61e 5431
6fb6c614
JM		 5432 }
5433
5434 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
a480973c 5435 rms_bind_fab_nam(myfab, mynam);
18a3d61e 5436
6fb6c614
JM		 5437 /* Process the default file specification if present */
5438 def_spec = defspec;
18a3d61e
JM		 5439 if (defspec && *defspec) {
5440 int t_isunix;
5441 t_isunix = is_unix_filespec(defspec);
5442 if (t_isunix) {
c11536f5 5443 vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
6fb6c614
JM		 5444 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5445 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5446
5447 if (ret_spec == NULL) {
5448 /* Clean up and bail */
5449 PerlMem_free(vmsdefspec);
5450 if (vmsfspec != NULL)
5451 PerlMem_free(vmsfspec);
5452 return NULL;
5453 }
5454 def_spec = (const char *)vmsdefspec;
18a3d61e 5455 }
6fb6c614
JM		 5456 rms_set_dna(myfab, mynam,
5457 (char *)def_spec, strlen(def_spec)); /* cast ok */
18a3d61e
JM		 5458 }
5459
6fb6c614 5460 /* Now we need the expansion buffers */
c11536f5 5461 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 5462 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5463#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 5464 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5465 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5466#endif
a1887106 5467 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
18a3d61e 5468
d584a1c6
JM		 5469 /* If a NAML block is used RMS always writes to the long and short
5470 * addresses unless you suppress the short name.
5471 */
a480973c 5472#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 5473 outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 5474 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5475#endif
d584a1c6 5476 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
18a3d61e 5477
f7ddb74a
JM		 5478#ifdef NAM$M_NO_SHORT_UPCASE
5479 if (decc_efs_case_preserve)
a480973c 5480 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 5481#endif
18a3d61e 5482
e0e5e8d6
JM		 5483 /* We may not want to follow symbolic links */
5484#ifdef NAML$M_OPEN_SPECIAL
5485 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5486 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5487#endif
5488
18a3d61e
JM		 5489 /* First attempt to parse as an existing file */
5490 retsts = sys$parse(&myfab,0,0);
5491 if (!(retsts & STS$K_SUCCESS)) {
5492
5493 /* Could not find the file, try as syntax only if error is not fatal */
a480973c 5494 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
6fb6c614
JM		 5495 if (retsts == RMS$_DNF ||
5496 retsts == RMS$_DIR ||
5497 retsts == RMS$_DEV ||
5498 retsts == RMS$_PRV) {
18a3d61e 5499 retsts = sys$parse(&myfab,0,0);
6fb6c614 5500 if (retsts & STS$K_SUCCESS) goto int_expanded;
18a3d61e
JM		 5501 }
5502
5503 /* Still could not parse the file specification */
5504 /*----------------------------------------------*/
a480973c 5505 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5506 if (vmsdefspec != NULL)
5507 PerlMem_free(vmsdefspec);
18a3d61e 5508 if (vmsfspec != NULL)
c5375c28
JM		 5509 PerlMem_free(vmsfspec);
5510 if (outbufl != NULL)
5511 PerlMem_free(outbufl);
5512 PerlMem_free(esa);
7566800d
CB		 5513 if (esal != NULL)
5514 PerlMem_free(esal);
18a3d61e
JM		 5515 set_vaxc_errno(retsts);
5516 if (retsts == RMS$_PRV) set_errno(EACCES);
5517 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5518 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5519 else set_errno(EVMSERR);
5520 return NULL;
5521 }
5522 retsts = sys$search(&myfab,0,0);
5523 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
a480973c 5524 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5525 if (vmsdefspec != NULL)
5526 PerlMem_free(vmsdefspec);
18a3d61e 5527 if (vmsfspec != NULL)
c5375c28
JM		 5528 PerlMem_free(vmsfspec);
5529 if (outbufl != NULL)
5530 PerlMem_free(outbufl);
5531 PerlMem_free(esa);
7566800d
CB		 5532 if (esal != NULL)
5533 PerlMem_free(esal);
18a3d61e
JM		 5534 set_vaxc_errno(retsts);
5535 if (retsts == RMS$_PRV) set_errno(EACCES);
5536 else set_errno(EVMSERR);
5537 return NULL;
5538 }
5539
5540 /* If the input filespec contained any lowercase characters,
5541 * downcase the result for compatibility with Unix-minded code. */
6fb6c614 5542int_expanded:
18a3d61e 5543 if (!decc_efs_case_preserve) {
6fb6c614 5544 char * tbuf;
c5375c28
JM		 5545 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5546 if (islower(*tbuf)) { haslower = 1; break; }
18a3d61e
JM		 5547 }
5548
5549 /* Is a long or a short name expected */
5550 /*------------------------------------*/
6fb6c614 5551 spec_buf = NULL;
778e045f 5552#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5553 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5554 if (rms_nam_rsll(mynam)) {
6fb6c614 5555 spec_buf = outbufl;
a480973c 5556 speclen = rms_nam_rsll(mynam);
18a3d61e
JM		 5557 }
5558 else {
6fb6c614 5559 spec_buf = esal; /* Not esa */
a480973c 5560 speclen = rms_nam_esll(mynam);
18a3d61e
JM		 5561 }
5562 }
5563 else {
778e045f 5564#endif
a480973c 5565 if (rms_nam_rsl(mynam)) {
6fb6c614 5566 spec_buf = outbuf;
a480973c 5567 speclen = rms_nam_rsl(mynam);
18a3d61e
JM		 5568 }
5569 else {
6fb6c614 5570 spec_buf = esa; /* Not esal */
a480973c 5571 speclen = rms_nam_esl(mynam);
18a3d61e 5572 }
778e045f 5573#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5574 }
778e045f 5575#endif
6fb6c614 5576 spec_buf[speclen] = '\0';
4d743a9b 5577
18a3d61e
JM		 5578 /* Trim off null fields added by $PARSE
5579 * If type > 1 char, must have been specified in original or default spec
5580 * (not true for version; $SEARCH may have added version of existing file).
5581 */
a480973c 5582 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
18a3d61e 5583 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5584 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5585 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
18a3d61e
JM		 5586 }
5587 else {
a480973c
JM		 5588 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5589 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
18a3d61e
JM		 5590 }
5591 if (trimver || trimtype) {
5592 if (defspec && *defspec) {
5593 char *defesal = NULL;
d584a1c6 5594 char *defesa = NULL;
c11536f5 5595 defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
d584a1c6 5596 if (defesa != NULL) {
6fb6c614 5597 struct FAB deffab = cc$rms_fab;
d584a1c6 5598#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 5599 defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5600 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 5601#endif
a480973c 5602 rms_setup_nam(defnam);
18a3d61e 5603
a480973c
JM		 5604 rms_bind_fab_nam(deffab, defnam);
5605
5606 /* Cast ok */
5607 rms_set_fna
5608 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5609
d584a1c6
JM		 5610 /* RMS needs the esa/esal as a work area if wildcards are involved */
5611 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
a480973c 5612
4d743a9b 5613 rms_clear_nam_nop(defnam);
a480973c 5614 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
18a3d61e
JM		 5615#ifdef NAM$M_NO_SHORT_UPCASE
5616 if (decc_efs_case_preserve)
a480973c 5617 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
18a3d61e 5618#endif
e0e5e8d6
JM		 5619#ifdef NAML$M_OPEN_SPECIAL
5620 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5621 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5622#endif
18a3d61e
JM		 5623 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5624 if (trimver) {
a480973c 5625 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
18a3d61e
JM		 5626 }
5627 if (trimtype) {
a480973c 5628 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
18a3d61e
JM		 5629 }
5630 }
d584a1c6
JM		 5631 if (defesal != NULL)
5632 PerlMem_free(defesal);
5633 PerlMem_free(defesa);
6fb6c614
JM		 5634 } else {
5635 _ckvmssts_noperl(SS$_INSFMEM);
18a3d61e
JM		 5636 }
5637 }
5638 if (trimver) {
5639 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c 5640 if (*(rms_nam_verl(mynam)) != '\"')
6fb6c614 5641 speclen = rms_nam_verl(mynam) - spec_buf;
18a3d61e
JM		 5642 }
5643 else {
a480973c 5644 if (*(rms_nam_ver(mynam)) != '\"')
6fb6c614 5645 speclen = rms_nam_ver(mynam) - spec_buf;
18a3d61e
JM		 5646 }
5647 }
5648 if (trimtype) {
5649 /* If we didn't already trim version, copy down */
5650 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
6fb6c614 5651 if (speclen > rms_nam_verl(mynam) - spec_buf)
18a3d61e 5652 memmove
a480973c
JM		 5653 (rms_nam_typel(mynam),
5654 rms_nam_verl(mynam),
6fb6c614 5655 speclen - (rms_nam_verl(mynam) - spec_buf));
a480973c 5656 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
18a3d61e
JM		 5657 }
5658 else {
6fb6c614 5659 if (speclen > rms_nam_ver(mynam) - spec_buf)
18a3d61e 5660 memmove
a480973c
JM		 5661 (rms_nam_type(mynam),
5662 rms_nam_ver(mynam),
6fb6c614 5663 speclen - (rms_nam_ver(mynam) - spec_buf));
a480973c 5664 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
18a3d61e
JM		 5665 }
5666 }
5667 }
5668
5669 /* Done with these copies of the input files */
5670 /*-------------------------------------------*/
5671 if (vmsfspec != NULL)
c5375c28 5672 PerlMem_free(vmsfspec);
6fb6c614
JM		 5673 if (vmsdefspec != NULL)
5674 PerlMem_free(vmsdefspec);
18a3d61e
JM		 5675
5676 /* If we just had a directory spec on input, $PARSE "helpfully"
5677 * adds an empty name and type for us */
d584a1c6 5678#if !defined(__VAX) && defined(NAML$C_MAXRSS)
18a3d61e 5679 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
a480973c
JM		 5680 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5681 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5682 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5683 speclen = rms_nam_namel(mynam) - spec_buf;
18a3d61e 5684 }
d584a1c6
JM		 5685 else
5686#endif
5687 {
a480973c
JM		 5688 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5689 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5690 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
6fb6c614 5691 speclen = rms_nam_name(mynam) - spec_buf;
18a3d61e
JM		 5692 }
5693
5694 /* Posix format specifications must have matching quotes */
4d743a9b 5695 if (speclen < (VMS_MAXRSS - 1)) {
6fb6c614
JM		 5696 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5697 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5698 spec_buf[speclen] = '\"';
4d743a9b
JM		 5699 speclen++;
5700 }
18a3d61e
JM		 5701 }
5702 }
6fb6c614
JM		 5703 spec_buf[speclen] = '\0';
5704 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
18a3d61e
JM		 5705
5706 /* Have we been working with an expanded, but not resultant, spec? */
5707 /* Also, convert back to Unix syntax if necessary. */
d584a1c6
JM		 5708 {
5709 int rsl;
18a3d61e 5710
d584a1c6
JM		 5711#if !defined(__VAX) && defined(NAML$C_MAXRSS)
5712 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5713 rsl = rms_nam_rsll(mynam);
5714 } else
5715#endif
5716 {
5717 rsl = rms_nam_rsl(mynam);
5718 }
5719 if (!rsl) {
6fb6c614
JM		 5720 /* rsl is not present, it means that spec_buf is either */
5721 /* esa or esal, and needs to be copied to outbuf */
5722 /* convert to Unix if desired */
d584a1c6 5723 if (isunix) {
6fb6c614
JM		 5724 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5725 } else {
5726 /* VMS file specs are not in UTF-8 */
5727 if (fs_utf8 != NULL)
5728 *fs_utf8 = 0;
a35dcc95 5729 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5730 ret_spec = outbuf;
18a3d61e
JM		 5731 }
5732 }
6fb6c614
JM		 5733 else {
5734 /* Now spec_buf is either outbuf or outbufl */
5735 /* We need the result into outbuf */
5736 if (isunix) {
5737 /* If we need this in UNIX, then we need another buffer */
5738 /* to keep things in order */
5739 char * src;
5740 char * new_src = NULL;
5741 if (spec_buf == outbuf) {
c11536f5 5742 new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 5743 my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
6fb6c614
JM		 5744 } else {
5745 src = spec_buf;
5746 }
5747 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5748 if (new_src) {
5749 PerlMem_free(new_src);
5750 }
5751 } else {
5752 /* VMS file specs are not in UTF-8 */
5753 if (fs_utf8 != NULL)
5754 *fs_utf8 = 0;
5755
5756 /* Copy the buffer if needed */
5757 if (outbuf != spec_buf)
a35dcc95 5758 my_strlcpy(outbuf, spec_buf, VMS_MAXRSS);
6fb6c614 5759 ret_spec = outbuf;
d584a1c6 5760 }
18a3d61e 5761 }
18a3d61e 5762 }
6fb6c614
JM		 5763
5764 /* Need to clean up the search context */
a480973c
JM		 5765 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5766 sts = rms_free_search_context(&myfab); /* Free search context */
6fb6c614
JM		 5767
5768 /* Clean up the extra buffers */
7566800d 5769 if (esal != NULL)
6fb6c614
JM		 5770 PerlMem_free(esal);
5771 PerlMem_free(esa);
c5375c28
JM		 5772 if (outbufl != NULL)
5773 PerlMem_free(outbufl);
6fb6c614
JM		 5774
5775 /* Return the result */
5776 return ret_spec;
5777}
5778
5779/* Common simple case - Expand an already VMS spec */
5780static char *
5781int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5782 opts |= PERL_RMSEXPAND_M_VMS_IN;
5783 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5784}
5785
5786/* Common simple case - Expand to a VMS spec */
5787static char *
5788int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5789 opts |= PERL_RMSEXPAND_M_VMS;
5790 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5791}
5792
5793
5794/* Entry point used by perl routines */
5795static char *
5796mp_do_rmsexpand
5797 (pTHX_ const char *filespec,
5798 char *outbuf,
5799 int ts,
5800 const char *defspec,
5801 unsigned opts,
5802 int * fs_utf8,
5803 int * dfs_utf8)
5804{
5805 static char __rmsexpand_retbuf[VMS_MAXRSS];
5806 char * expanded, *ret_spec, *ret_buf;
5807
5808 expanded = NULL;
5809 ret_buf = outbuf;
5810 if (ret_buf == NULL) {
5811 if (ts) {
5812 Newx(expanded, VMS_MAXRSS, char);
5813 if (expanded == NULL)
5814 _ckvmssts(SS$_INSFMEM);
5815 ret_buf = expanded;
5816 } else {
5817 ret_buf = __rmsexpand_retbuf;
5818 }
5819 }
5820
5821
5822 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5823 opts, fs_utf8, dfs_utf8);
5824
5825 if (ret_spec == NULL) {
5826 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5827 if (expanded)
5828 Safefree(expanded);
5829 }
5830
5831 return ret_spec;
bbce6d69 5832}
5833/*}}}*/
5834/* External entry points */
2fbb330f 5835char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5 5836{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
2fbb330f 5837char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
360732b5
JM		 5838{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5839char *Perl_rmsexpand_utf8
5840 (pTHX_ const char *spec, char *buf, const char *def,
5841 unsigned opt, int * fs_utf8, int * dfs_utf8)
5842{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5843char *Perl_rmsexpand_utf8_ts
5844 (pTHX_ const char *spec, char *buf, const char *def,
5845 unsigned opt, int * fs_utf8, int * dfs_utf8)
5846{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
bbce6d69 5847
5848
a0d0e21e
LW		 5849/*
5850** The following routines are provided to make life easier when
5851** converting among VMS-style and Unix-style directory specifications.
5852** All will take input specifications in either VMS or Unix syntax. On
5853** failure, all return NULL. If successful, the routines listed below
748a9306 5854** return a pointer to a buffer containing the appropriately
a0d0e21e
LW		 5855** reformatted spec (and, therefore, subsequent calls to that routine
5856** will clobber the result), while the routines of the same names with
5857** a _ts suffix appended will return a pointer to a mallocd string
5858** containing the appropriately reformatted spec.
5859** In all cases, only explicit syntax is altered; no check is made that
5860** the resulting string is valid or that the directory in question
5861** actually exists.
5862**
5863** fileify_dirspec() - convert a directory spec into the name of the
5864** directory file (i.e. what you can stat() to see if it's a dir).
5865** The style (VMS or Unix) of the result is the same as the style
5866** of the parameter passed in.
5867** pathify_dirspec() - convert a directory spec into a path (i.e.
5868** what you prepend to a filename to indicate what directory it's in).
5869** The style (VMS or Unix) of the result is the same as the style
5870** of the parameter passed in.
5871** tounixpath() - convert a directory spec into a Unix-style path.
5872** tovmspath() - convert a directory spec into a VMS-style path.
5873** tounixspec() - convert any file spec into a Unix-style file spec.
5874** tovmsspec() - convert any file spec into a VMS-style spec.
360732b5 5875** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
e518068a 5876**
bd3fa61c 5877** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
01b8edb6 5878** Permission is given to distribute this code as part of the Perl
5879** standard distribution under the terms of the GNU General Public
5880** License or the Perl Artistic License. Copies of each may be
5881** found in the Perl standard distribution.
a0d0e21e
LW		 5882 */
5883
a979ce91
JM		 5884/*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5885static char *
5886int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
a0d0e21e 5887{
4e0c9737 5888 unsigned long int dirlen, retlen, hasfilename = 0;
a979ce91 5889 char *cp1, *cp2, *lastdir;
a480973c 5890 char *trndir, *vmsdir;
2d9f3838 5891 unsigned short int trnlnm_iter_count;
f7ddb74a 5892 int sts;
360732b5
JM		 5893 if (utf8_fl != NULL)
5894 *utf8_fl = 0;
a0d0e21e 5895
c07a80fd 5896 if (!dir || !*dir) {
5897 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5898 }
a0d0e21e 5899 dirlen = strlen(dir);
a2a90019 5900 while (dirlen && dir[dirlen-1] == '/') --dirlen;
61bb5906 5901 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
f7ddb74a
JM		 5902 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5903 dir = "/sys$disk";
5904 dirlen = 9;
5905 }
5906 else
5907 dirlen = 1;
61bb5906 5908 }
a480973c
JM		 5909 if (dirlen > (VMS_MAXRSS - 1)) {
5910 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5911 return NULL;
c07a80fd 5912 }
c11536f5 5913 trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5914 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 5915 if (!strpbrk(dir+1,"/]>:") &&
5916 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
e518068a 5917 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2d9f3838 5918 trnlnm_iter_count = 0;
b8486b9d 5919 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
2d9f3838
CB		 5920 trnlnm_iter_count++;
5921 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5922 }
b8ffc8df 5923 dirlen = strlen(trndir);
e518068a 5924 }
01b8edb6 5925 else {
a35dcc95 5926 memcpy(trndir, dir, dirlen);
01b8edb6 5927 trndir[dirlen] = '\0';
01b8edb6 5928 }
b8ffc8df
RGS		 5929
5930 /* At this point we are done with *dir and use *trndir which is a
5931 * copy that can be modified. *dir must not be modified.
5932 */
5933
c07a80fd 5934 /* If we were handed a rooted logical name or spec, treat it like a
5935 * simple directory, so that
5936 * $ Define myroot dev:[dir.]
5937 * ... do_fileify_dirspec("myroot",buf,1) ...
5938 * does something useful.
5939 */
b8ffc8df
RGS		 5940 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5941 trndir[--dirlen] = '\0';
5942 trndir[dirlen-1] = ']';
c07a80fd 5943 }
b8ffc8df
RGS		 5944 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5945 trndir[--dirlen] = '\0';
5946 trndir[dirlen-1] = '>';
46112e17 5947 }
e518068a 5948
b8ffc8df 5949 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
b7ae7a0d 5950 /* If we've got an explicit filename, we can just shuffle the string. */
5951 if (*(cp1+1)) hasfilename = 1;
5952 /* Similarly, we can just back up a level if we've got multiple levels
5953 of explicit directories in a VMS spec which ends with directories. */
5954 else {
b8ffc8df 5955 for (cp2 = cp1; cp2 > trndir; cp2--) {
f7ddb74a
JM		 5956 if (*cp2 == '.') {
5957 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
657054d4 5958/* fix-me, can not scan EFS file specs backward like this */
f7ddb74a
JM		 5959 *cp2 = *cp1; *cp1 = '\0';
5960 hasfilename = 1;
5961 break;
5962 }
b7ae7a0d 5963 }
5964 if (*cp2 == '[' || *cp2 == '<') break;
5965 }
5966 }
5967 }
5968
c11536f5 5969 vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
ebd4d70b 5970 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c 5971 cp1 = strpbrk(trndir,"]:>");
a979ce91
JM		 5972 if (hasfilename || !cp1) { /* filename present or not VMS */
5973
b8ffc8df 5974 if (trndir[0] == '.') {
a480973c 5975 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
c5375c28
JM		 5976 PerlMem_free(trndir);
5977 PerlMem_free(vmsdir);
a979ce91 5978 return int_fileify_dirspec("[]", buf, NULL);
a480973c 5979 }
b8ffc8df 5980 else if (trndir[1] == '.' &&
a480973c 5981 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
c5375c28
JM		 5982 PerlMem_free(trndir);
5983 PerlMem_free(vmsdir);
a979ce91 5984 return int_fileify_dirspec("[-]", buf, NULL);
a480973c 5985 }
748a9306 5986 }
b8ffc8df 5987 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
a0d0e21e 5988 dirlen -= 1; /* to last element */
b8ffc8df 5989 lastdir = strrchr(trndir,'/');
a0d0e21e 5990 }
b8ffc8df 5991 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
01b8edb6 5992 /* If we have "/." or "/..", VMSify it and let the VMS code
5993 * below expand it, rather than repeating the code to handle
5994 * relative components of a filespec here */
4633a7c4
LW		 5995 do {
5996 if (*(cp1+2) == '.') cp1++;
5997 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
a480973c 5998 char * ret_chr;
df278665 5999 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
c5375c28
JM		 6000 PerlMem_free(trndir);
6001 PerlMem_free(vmsdir);
a480973c
JM		 6002 return NULL;
6003 }
fc1ce8cc 6004 if (strchr(vmsdir,'/') != NULL) {
df278665 6005 /* If int_tovmsspec() returned it, it must have VMS syntax
fc1ce8cc
CB		 6006 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6007 * the time to check this here only so we avoid a recursion
6008 * loop; otherwise, gigo.
6009 */
c5375c28
JM		 6010 PerlMem_free(trndir);
6011 PerlMem_free(vmsdir);
a480973c
JM		 6012 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6013 return NULL;
fc1ce8cc 6014 }
a979ce91 6015 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6016 PerlMem_free(trndir);
6017 PerlMem_free(vmsdir);
a480973c
JM		 6018 return NULL;
6019 }
0e5ce2c7 6020 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6021 PerlMem_free(trndir);
6022 PerlMem_free(vmsdir);
a480973c 6023 return ret_chr;
4633a7c4
LW		 6024 }
6025 cp1++;
6026 } while ((cp1 = strstr(cp1,"/.")) != NULL);
b8ffc8df 6027 lastdir = strrchr(trndir,'/');
748a9306 6028 }
b8ffc8df 6029 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
a480973c 6030 char * ret_chr;
61bb5906
CB		 6031 /* Ditto for specs that end in an MFD -- let the VMS code
6032 * figure out whether it's a real device or a rooted logical. */
f7ddb74a
JM		 6033
6034 /* This should not happen any more. Allowing the fake /000000
6035 * in a UNIX pathname causes all sorts of problems when trying
6036 * to run in UNIX emulation. So the VMS to UNIX conversions
6037 * now remove the fake /000000 directories.
6038 */
6039
b8ffc8df 6040 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
df278665 6041 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
c5375c28
JM		 6042 PerlMem_free(trndir);
6043 PerlMem_free(vmsdir);
a480973c
JM		 6044 return NULL;
6045 }
a979ce91 6046 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
c5375c28
JM		 6047 PerlMem_free(trndir);
6048 PerlMem_free(vmsdir);
a480973c
JM		 6049 return NULL;
6050 }
0e5ce2c7 6051 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
c5375c28
JM		 6052 PerlMem_free(trndir);
6053 PerlMem_free(vmsdir);
a480973c 6054 return ret_chr;
61bb5906 6055 }
a0d0e21e 6056 else {
f7ddb74a 6057
b8ffc8df
RGS		 6058 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6059 !(lastdir = cp1 = strrchr(trndir,']')) &&
6060 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
f7ddb74a 6061
a979ce91
JM		 6062 cp2 = strrchr(cp1,'.');
6063 if (cp2) {
6064 int e_len, vs_len = 0;
6065 int is_dir = 0;
6066 char * cp3;
6067 cp3 = strchr(cp2,';');
6068 e_len = strlen(cp2);
6069 if (cp3) {
6070 vs_len = strlen(cp3);
6071 e_len = e_len - vs_len;
6072 }
6073 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6074 if (!is_dir) {
6075 if (!decc_efs_charset) {
6076 /* If this is not EFS, then not a directory */
6077 PerlMem_free(trndir);
6078 PerlMem_free(vmsdir);
6079 set_errno(ENOTDIR);
6080 set_vaxc_errno(RMS$_DIR);
6081 return NULL;
6082 }
6083 } else {
6084 /* Ok, here we have an issue, technically if a .dir shows */
6085 /* from inside a directory, then we should treat it as */
6086 /* xxx^.dir.dir. But we do not have that context at this */
6087 /* point unless this is totally restructured, so we remove */
6088 /* The .dir for now, and fix this better later */
6089 dirlen = cp2 - trndir;
6090 }
37769287
CB		 6091 if (decc_efs_charset && !strchr(trndir,'/')) {
6092 /* Dots are allowed in dir names, so escape them if input not in Unix syntax. */
a9fac63d
CB		 6093 char *cp4 = is_dir ? (cp2 - 1) : cp2;
6094
6095 for (; cp4 > cp1; cp4--) {
6096 if (*cp4 == '.') {
6097 if ((cp4 - 1 > trndir) && (*(cp4 - 1) != '^')) {
6098 memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1);
6099 *cp4 = '^';
6100 dirlen++;
6101 }
6102 }
6103 }
6104 }
a0d0e21e 6105 }
a979ce91 6106
748a9306 6107 }
f7ddb74a
JM		 6108
6109 retlen = dirlen + 6;
a979ce91
JM		 6110 memcpy(buf, trndir, dirlen);
6111 buf[dirlen] = '\0';
f7ddb74a 6112
a0d0e21e
LW		 6113 /* We've picked up everything up to the directory file name.
6114 Now just add the type and version, and we're set. */
839e16da
CB		 6115 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
6116 strcat(buf,".dir;1");
6117 else
6118 strcat(buf,".DIR;1");
c5375c28
JM		 6119 PerlMem_free(trndir);
6120 PerlMem_free(vmsdir);
a979ce91 6121 return buf;
a0d0e21e
LW		 6122 }
6123 else { /* VMS-style directory spec */
a480973c 6124
d584a1c6
JM		 6125 char *esa, *esal, term, *cp;
6126 char *my_esa;
6127 int my_esa_len;
4e0c9737 6128 unsigned long int cmplen, haslower = 0;
a0d0e21e 6129 struct FAB dirfab = cc$rms_fab;
a480973c
JM		 6130 rms_setup_nam(savnam);
6131 rms_setup_nam(dirnam);
6132
c11536f5 6133 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 6134 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 6135 esal = NULL;
6136#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 6137 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6138 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 6139#endif
a480973c
JM		 6140 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6141 rms_bind_fab_nam(dirfab, dirnam);
6142 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
d584a1c6 6143 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
f7ddb74a
JM		 6144#ifdef NAM$M_NO_SHORT_UPCASE
6145 if (decc_efs_case_preserve)
a480973c 6146 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6147#endif
01b8edb6 6148
b8ffc8df 6149 for (cp = trndir; *cp; cp++)
01b8edb6 6150 if (islower(*cp)) { haslower = 1; break; }
a480973c 6151 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
a979ce91
JM		 6152 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6153 (dirfab.fab$l_sts == RMS$_DNF) ||
6154 (dirfab.fab$l_sts == RMS$_PRV)) {
6155 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6156 sts = sys$parse(&dirfab);
e518068a 6157 }
6158 if (!sts) {
c5375c28 6159 PerlMem_free(esa);
d584a1c6
JM		 6160 if (esal != NULL)
6161 PerlMem_free(esal);
c5375c28
JM		 6162 PerlMem_free(trndir);
6163 PerlMem_free(vmsdir);
748a9306
LW		 6164 set_errno(EVMSERR);
6165 set_vaxc_errno(dirfab.fab$l_sts);
a0d0e21e
LW		 6166 return NULL;
6167 }
e518068a 6168 }
6169 else {
6170 savnam = dirnam;
a480973c
JM		 6171 /* Does the file really exist? */
6172 if (sys$search(&dirfab)& STS$K_SUCCESS) {
e518068a 6173 /* Yes; fake the fnb bits so we'll check type below */
a979ce91 6174 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
e518068a 6175 }
752635ea
CB		 6176 else { /* No; just work with potential name */
6177 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6178 else {
2623a4a6
JM		 6179 int fab_sts;
6180 fab_sts = dirfab.fab$l_sts;
6181 sts = rms_free_search_context(&dirfab);
c5375c28 6182 PerlMem_free(esa);
d584a1c6
JM		 6183 if (esal != NULL)
6184 PerlMem_free(esal);
c5375c28
JM		 6185 PerlMem_free(trndir);
6186 PerlMem_free(vmsdir);
2623a4a6 6187 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
e518068a 6188 return NULL;
6189 }
e518068a 6190 }
a0d0e21e 6191 }
d584a1c6
JM		 6192
6193 /* Make sure we are using the right buffer */
778e045f 6194#if !defined(__VAX) && defined(NAML$C_MAXRSS)
d584a1c6
JM		 6195 if (esal != NULL) {
6196 my_esa = esal;
6197 my_esa_len = rms_nam_esll(dirnam);
6198 } else {
778e045f 6199#endif
d584a1c6
JM		 6200 my_esa = esa;
6201 my_esa_len = rms_nam_esl(dirnam);
778e045f 6202#if !defined(__VAX) && defined(NAML$C_MAXRSS)
d584a1c6 6203 }
778e045f 6204#endif
d584a1c6 6205 my_esa[my_esa_len] = '\0';
a480973c 6206 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
d584a1c6
JM		 6207 cp1 = strchr(my_esa,']');
6208 if (!cp1) cp1 = strchr(my_esa,'>');
748a9306 6209 if (cp1) { /* Should always be true */
d584a1c6
JM		 6210 my_esa_len -= cp1 - my_esa - 1;
6211 memmove(my_esa, cp1 + 1, my_esa_len);
748a9306
LW		 6212 }
6213 }
a480973c 6214 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
a0d0e21e 6215 /* Yep; check version while we're at it, if it's there. */
a480973c
JM		 6216 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6217 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
a0d0e21e 6218 /* Something other than .DIR[;1]. Bzzt. */
a480973c 6219 sts = rms_free_search_context(&dirfab);
c5375c28 6220 PerlMem_free(esa);
d584a1c6
JM		 6221 if (esal != NULL)
6222 PerlMem_free(esal);
c5375c28
JM		 6223 PerlMem_free(trndir);
6224 PerlMem_free(vmsdir);
748a9306
LW		 6225 set_errno(ENOTDIR);
6226 set_vaxc_errno(RMS$_DIR);
a0d0e21e
LW		 6227 return NULL;
6228 }
748a9306 6229 }
ae6d78fe 6230
a480973c 6231 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
748a9306 6232 /* They provided at least the name; we added the type, if necessary, */
a35dcc95 6233 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a480973c 6234 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6235 PerlMem_free(trndir);
6236 PerlMem_free(esa);
d584a1c6
JM		 6237 if (esal != NULL)
6238 PerlMem_free(esal);
c5375c28 6239 PerlMem_free(vmsdir);
a979ce91 6240 return buf;
748a9306 6241 }
c07a80fd 6242 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6243 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6244 *cp1 = '\0';
d584a1c6 6245 my_esa_len -= 9;
c07a80fd 6246 }
d584a1c6 6247 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
752635ea 6248 if (cp1 == NULL) { /* should never happen */
a480973c 6249 sts = rms_free_search_context(&dirfab);
c5375c28
JM		 6250 PerlMem_free(trndir);
6251 PerlMem_free(esa);
d584a1c6
JM		 6252 if (esal != NULL)
6253 PerlMem_free(esal);
c5375c28 6254 PerlMem_free(vmsdir);
752635ea
CB		 6255 return NULL;
6256 }
748a9306
LW		 6257 term = *cp1;
6258 *cp1 = '\0';
d584a1c6
JM		 6259 retlen = strlen(my_esa);
6260 cp1 = strrchr(my_esa,'.');
f7ddb74a 6261 /* ODS-5 directory specifications can have extra "." in them. */
657054d4 6262 /* Fix-me, can not scan EFS file specifications backwards */
f7ddb74a 6263 while (cp1 != NULL) {
d584a1c6 6264 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6265 break;
6266 else {
6267 cp1--;
d584a1c6 6268 while ((cp1 > my_esa) && (*cp1 != '.'))
f7ddb74a
JM		 6269 cp1--;
6270 }
d584a1c6 6271 if (cp1 == my_esa)
f7ddb74a
JM		 6272 cp1 = NULL;
6273 }
6274
6275 if ((cp1) != NULL) {
748a9306
LW		 6276 /* There's more than one directory in the path. Just roll back. */
6277 *cp1 = term;
a35dcc95 6278 my_strlcpy(buf, my_esa, VMS_MAXRSS);
a0d0e21e
LW		 6279 }
6280 else {
a480973c 6281 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
748a9306 6282 /* Go back and expand rooted logical name */
a480973c 6283 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
f7ddb74a
JM		 6284#ifdef NAM$M_NO_SHORT_UPCASE
6285 if (decc_efs_case_preserve)
a480973c 6286 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
f7ddb74a 6287#endif
a480973c
JM		 6288 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6289 sts = rms_free_search_context(&dirfab);
c5375c28 6290 PerlMem_free(esa);
d584a1c6
JM		 6291 if (esal != NULL)
6292 PerlMem_free(esal);
c5375c28
JM		 6293 PerlMem_free(trndir);
6294 PerlMem_free(vmsdir);
748a9306
LW		 6295 set_errno(EVMSERR);
6296 set_vaxc_errno(dirfab.fab$l_sts);
6297 return NULL;
6298 }
d584a1c6
JM		 6299
6300 /* This changes the length of the string of course */
6301 if (esal != NULL) {
6302 my_esa_len = rms_nam_esll(dirnam);
6303 } else {
6304 my_esa_len = rms_nam_esl(dirnam);
6305 }
6306
6307 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
d584a1c6
JM		 6308 cp1 = strstr(my_esa,"][");
6309 if (!cp1) cp1 = strstr(my_esa,"]<");
6310 dirlen = cp1 - my_esa;
a979ce91 6311 memcpy(buf, my_esa, dirlen);
748a9306 6312 if (!strncmp(cp1+2,"000000]",7)) {
a979ce91 6313 buf[dirlen-1] = '\0';
657054d4 6314 /* fix-me Not full ODS-5, just extra dots in directories for now */
a979ce91
JM		 6315 cp1 = buf + dirlen - 1;
6316 while (cp1 > buf)
f7ddb74a
JM		 6317 {
6318 if (*cp1 == '[')
6319 break;
6320 if (*cp1 == '.') {
6321 if (*(cp1-1) != '^')
6322 break;
6323 }
6324 cp1--;
6325 }
4633a7c4
LW		 6326 if (*cp1 == '.') *cp1 = ']';
6327 else {
a979ce91 6328 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6329 memmove(cp1+1,"000000]",7);
4633a7c4 6330 }
748a9306
LW		 6331 }
6332 else {
a979ce91
JM		 6333 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6334 buf[retlen] = '\0';
748a9306 6335 /* Convert last '.' to ']' */
a979ce91 6336 cp1 = buf+retlen-1;
f7ddb74a
JM		 6337 while (*cp != '[') {
6338 cp1--;
6339 if (*cp1 == '.') {
6340 /* Do not trip on extra dots in ODS-5 directories */
a979ce91 6341 if ((cp1 == buf) || (*(cp1-1) != '^'))
f7ddb74a
JM		 6342 break;
6343 }
6344 }
4633a7c4
LW		 6345 if (*cp1 == '.') *cp1 = ']';
6346 else {
a979ce91 6347 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
18a3d61e 6348 memmove(cp1+1,"000000]",7);
4633a7c4 6349 }
748a9306 6350 }
a0d0e21e 6351 }
748a9306 6352 else { /* This is a top-level dir. Add the MFD to the path. */
d584a1c6 6353 cp1 = my_esa;
a979ce91 6354 cp2 = buf;
bbdb6c9a 6355 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
a0d0e21e
LW		 6356 strcpy(cp2,":[000000]");
6357 cp1 += 2;
6358 strcpy(cp2+9,cp1);
6359 }
748a9306 6360 }
a480973c 6361 sts = rms_free_search_context(&dirfab);
748a9306 6362 /* We've set up the string up through the filename. Add the
a0d0e21e 6363 type and version, and we're done. */
a979ce91 6364 strcat(buf,".DIR;1");
01b8edb6 6365
6366 /* $PARSE may have upcased filespec, so convert output to lower
6367 * case if input contained any lowercase characters. */
a979ce91 6368 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
c5375c28
JM		 6369 PerlMem_free(trndir);
6370 PerlMem_free(esa);
d584a1c6
JM		 6371 if (esal != NULL)
6372 PerlMem_free(esal);
c5375c28 6373 PerlMem_free(vmsdir);
a979ce91 6374 return buf;
a0d0e21e 6375 }
a979ce91
JM		 6376} /* end of int_fileify_dirspec() */
6377
6378
6379/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6380static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6381{
6382 static char __fileify_retbuf[VMS_MAXRSS];
6383 char * fileified, *ret_spec, *ret_buf;
6384
6385 fileified = NULL;
6386 ret_buf = buf;
6387 if (ret_buf == NULL) {
6388 if (ts) {
6389 Newx(fileified, VMS_MAXRSS, char);
6390 if (fileified == NULL)
6391 _ckvmssts(SS$_INSFMEM);
6392 ret_buf = fileified;
6393 } else {
6394 ret_buf = __fileify_retbuf;
6395 }
6396 }
6397
6398 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6399
6400 if (ret_spec == NULL) {
6401 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6402 if (fileified)
6403 Safefree(fileified);
6404 }
6405
6406 return ret_spec;
a0d0e21e
LW		 6407} /* end of do_fileify_dirspec() */
6408/*}}}*/
a979ce91 6409
a0d0e21e 6410/* External entry points */
b8ffc8df 6411char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6412{ return do_fileify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6413char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6414{ return do_fileify_dirspec(dir,buf,1,NULL); }
6415char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6416{ return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6417char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6418{ return do_fileify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e 6419
1fe570cc
JM		 6420static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6421 char * v_spec, int v_len, char * r_spec, int r_len,
6422 char * d_spec, int d_len, char * n_spec, int n_len,
6423 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6424
6425 /* VMS specification - Try to do this the simple way */
6426 if ((v_len + r_len > 0) || (d_len > 0)) {
6427 int is_dir;
6428
6429 /* No name or extension component, already a directory */
6430 if ((n_len + e_len + vs_len) == 0) {
6431 strcpy(buf, dir);
6432 return buf;
6433 }
6434
6435 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6436 /* This results from catfile() being used instead of catdir() */
6437 /* So even though it should not work, we need to allow it */
6438
6439 /* If this is .DIR;1 then do a simple conversion */
6440 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6441 if (is_dir || (e_len == 0) && (d_len > 0)) {
6442 int len;
6443 len = v_len + r_len + d_len - 1;
6444 char dclose = d_spec[d_len - 1];
a35dcc95 6445 memcpy(buf, dir, len);
1fe570cc
JM		 6446 buf[len] = '.';
6447 len++;
a35dcc95 6448 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6449 len += n_len;
6450 buf[len] = dclose;
6451 buf[len + 1] = '\0';
6452 return buf;
6453 }
6454
6455#ifdef HAS_SYMLINK
6456 else if (d_len > 0) {
6457 /* In the olden days, a directory needed to have a .DIR */
6458 /* extension to be a valid directory, but now it could */
6459 /* be a symbolic link */
6460 int len;
6461 len = v_len + r_len + d_len - 1;
6462 char dclose = d_spec[d_len - 1];
a35dcc95 6463 memcpy(buf, dir, len);
1fe570cc
JM		 6464 buf[len] = '.';
6465 len++;
a35dcc95 6466 memcpy(&buf[len], n_spec, n_len);
1fe570cc
JM		 6467 len += n_len;
6468 if (e_len > 0) {
6469 if (decc_efs_charset) {
6470 buf[len] = '^';
6471 len++;
a35dcc95 6472 memcpy(&buf[len], e_spec, e_len);
1fe570cc
JM		 6473 len += e_len;
6474 } else {
6475 set_vaxc_errno(RMS$_DIR);
6476 set_errno(ENOTDIR);
6477 return NULL;
6478 }
6479 }
6480 buf[len] = dclose;
6481 buf[len + 1] = '\0';
6482 return buf;
6483 }
6484#else
6485 else {
6486 set_vaxc_errno(RMS$_DIR);
6487 set_errno(ENOTDIR);
6488 return NULL;
6489 }
6490#endif
6491 }
6492 set_vaxc_errno(RMS$_DIR);
6493 set_errno(ENOTDIR);
6494 return NULL;
6495}
6496
6497
6498/* Internal routine to make sure or convert a directory to be in a */
6499/* path specification. No utf8 flag because it is not changed or used */
6500static char *int_pathify_dirspec(const char *dir, char *buf)
a0d0e21e 6501{
1fe570cc
JM		 6502 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6503 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6504 char * exp_spec, *ret_spec;
6505 char * trndir;
2d9f3838 6506 unsigned short int trnlnm_iter_count;
baf3cf9c 6507 STRLEN trnlen;
1fe570cc
JM		 6508 int need_to_lower;
6509
6510 if (vms_debug_fileify) {
6511 if (dir == NULL)
6512 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6513 else
6514 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6515 }
6516
6517 /* We may need to lower case the result if we translated */
6518 /* a logical name or got the current working directory */
6519 need_to_lower = 0;
a0d0e21e 6520
c07a80fd 6521 if (!dir || !*dir) {
1fe570cc
JM		 6522 set_errno(EINVAL);
6523 set_vaxc_errno(SS$_BADPARAM);
6524 return NULL;
c07a80fd 6525 }
6526
c11536f5 6527 trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6528 if (trndir == NULL)
6529 _ckvmssts_noperl(SS$_INSFMEM);
c07a80fd 6530
1fe570cc
JM		 6531 /* If no directory specified use the current default */
6532 if (*dir)
a35dcc95 6533 my_strlcpy(trndir, dir, VMS_MAXRSS);
1fe570cc
JM		 6534 else {
6535 getcwd(trndir, VMS_MAXRSS - 1);
6536 need_to_lower = 1;
6537 }
6538
6539 /* now deal with bare names that could be logical names */
2d9f3838 6540 trnlnm_iter_count = 0;
93948341 6541 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1fe570cc
JM		 6542 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6543 trnlnm_iter_count++;
6544 need_to_lower = 1;
6545 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6546 break;
6547 trnlen = strlen(trndir);
6548
6549 /* Trap simple rooted lnms, and return lnm:[000000] */
6550 if (!strcmp(trndir+trnlen-2,".]")) {
a35dcc95 6551 my_strlcpy(buf, dir, VMS_MAXRSS);
1fe570cc
JM		 6552 strcat(buf, ":[000000]");
6553 PerlMem_free(trndir);
6554
6555 if (vms_debug_fileify) {
6556 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6557 }
6558 return buf;
6559 }
c07a80fd 6560 }
748a9306 6561
1fe570cc 6562 /* At this point we do not work with *dir, but the copy in *trndir */
b8ffc8df 6563
1fe570cc
JM		 6564 if (need_to_lower && !decc_efs_case_preserve) {
6565 /* Legacy mode, lower case the returned value */
6566 __mystrtolower(trndir);
6567 }
f7ddb74a 6568
1fe570cc
JM		 6569
6570 /* Some special cases, '..', '.' */
6571 sts = 0;
6572 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6573 /* Force UNIX filespec */
6574 sts = 1;
6575
6576 } else {
6577 /* Is this Unix or VMS format? */
6578 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6579 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6580 &e_len, &vs_spec, &vs_len);
6581 if (sts == 0) {
6582
6583 /* Just a filename? */
6584 if ((v_len + r_len + d_len) == 0) {
6585
6586 /* Now we have a problem, this could be Unix or VMS */
6587 /* We have to guess. .DIR usually means VMS */
6588
6589 /* In UNIX report mode, the .DIR extension is removed */
6590 /* if one shows up, it is for a non-directory or a directory */
6591 /* in EFS charset mode */
6592
6593 /* So if we are in Unix report mode, assume that this */
6594 /* is a relative Unix directory specification */
6595
6596 sts = 1;
6597 if (!decc_filename_unix_report && decc_efs_charset) {
6598 int is_dir;
6599 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6600
6601 if (is_dir) {
6602 /* Traditional mode, assume .DIR is directory */
6603 buf[0] = '[';
6604 buf[1] = '.';
a35dcc95 6605 memcpy(&buf[2], n_spec, n_len);
1fe570cc
JM		 6606 buf[n_len + 2] = ']';
6607 buf[n_len + 3] = '\0';
6608 PerlMem_free(trndir);
6609 if (vms_debug_fileify) {
6610 fprintf(stderr,
6611 "int_pathify_dirspec: buf = %s\n",
6612 buf);
6613 }
6614 return buf;
6615 }
6616 }
6617 }
a0d0e21e 6618 }
a0d0e21e 6619 }
1fe570cc
JM		 6620 if (sts == 0) {
6621 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6622 v_spec, v_len, r_spec, r_len,
6623 d_spec, d_len, n_spec, n_len,
6624 e_spec, e_len, vs_spec, vs_len);
a0d0e21e 6625
1fe570cc
JM		 6626 if (ret_spec != NULL) {
6627 PerlMem_free(trndir);
6628 if (vms_debug_fileify) {
6629 fprintf(stderr,
6630 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6631 }
6632 return ret_spec;
b7ae7a0d 6633 }
1fe570cc
JM		 6634
6635 /* Simple way did not work, which means that a logical name */
6636 /* was present for the directory specification. */
6637 /* Need to use an rmsexpand variant to decode it completely */
c11536f5 6638 exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
1fe570cc
JM		 6639 if (exp_spec == NULL)
6640 _ckvmssts_noperl(SS$_INSFMEM);
6641
6642 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6643 if (ret_spec != NULL) {
6644 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6645 &r_spec, &r_len, &d_spec, &d_len,
6646 &n_spec, &n_len, &e_spec,
6647 &e_len, &vs_spec, &vs_len);
6648 if (sts == 0) {
6649 ret_spec = int_pathify_dirspec_simple(
6650 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6651 d_spec, d_len, n_spec, n_len,
6652 e_spec, e_len, vs_spec, vs_len);
6653
6654 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6655 /* Legacy mode, lower case the returned value */
6656 __mystrtolower(ret_spec);
6657 }
6658 } else {
6659 set_vaxc_errno(RMS$_DIR);
6660 set_errno(ENOTDIR);
6661 ret_spec = NULL;
6662 }
b7ae7a0d 6663 }
1fe570cc
JM		 6664 PerlMem_free(exp_spec);
6665 PerlMem_free(trndir);
6666 if (vms_debug_fileify) {
6667 if (ret_spec == NULL)
6668 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6669 else
6670 fprintf(stderr,
6671 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6672 }
6673 return ret_spec;
a480973c 6674
1fe570cc 6675 } else {
bd1901c6
CB		 6676 /* Unix specification, Could be trivial conversion, */
6677 /* but have to deal with trailing '.dir' or extra '.' */
1fe570cc 6678
bd1901c6
CB		 6679 char * lastdot;
6680 char * lastslash;
6681 int is_dir;
6682 STRLEN dir_len = strlen(trndir);
1fe570cc 6683
bd1901c6
CB		 6684 lastslash = strrchr(trndir, '/');
6685 if (lastslash == NULL)
6686 lastslash = trndir;
6687 else
6688 lastslash++;
6689
6690 lastdot = NULL;
6691
6692 /* '..' or '.' are valid directory components */
6693 is_dir = 0;
6694 if (lastslash[0] == '.') {
6695 if (lastslash[1] == '\0') {
6696 is_dir = 1;
6697 } else if (lastslash[1] == '.') {
6698 if (lastslash[2] == '\0') {
6699 is_dir = 1;
6700 } else {
6701 /* And finally allow '...' */
6702 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
1fe570cc 6703 is_dir = 1;
1fe570cc
JM		 6704 }
6705 }
6706 }
bd1901c6 6707 }
01b8edb6 6708
bd1901c6
CB		 6709 if (!is_dir) {
6710 lastdot = strrchr(lastslash, '.');
6711 }
6712 if (lastdot != NULL) {
6713 STRLEN e_len;
6714 /* '.dir' is discarded, and any other '.' is invalid */
6715 e_len = strlen(lastdot);
1fe570cc 6716
bd1901c6 6717 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
1fe570cc 6718
bd1901c6
CB		 6719 if (is_dir) {
6720 dir_len = dir_len - 4;
1fe570cc 6721 }
e518068a 6722 }
1fe570cc 6723
a35dcc95 6724 my_strlcpy(buf, trndir, VMS_MAXRSS);
1fe570cc
JM		 6725 if (buf[dir_len - 1] != '/') {
6726 buf[dir_len] = '/';
6727 buf[dir_len + 1] = '\0';
a0d0e21e 6728 }
1fe570cc
JM		 6729
6730 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6731 if (!decc_efs_charset) {
6732 int dir_start = 0;
6733 char * str = buf;
6734 if (str[0] == '.') {
6735 char * dots = str;
6736 int cnt = 1;
6737 while ((dots[cnt] == '.') && (cnt < 3))
6738 cnt++;
6739 if (cnt <= 3) {
6740 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6741 dir_start = 1;
6742 str += cnt;
6743 }
6744 }
6745 }
6746 for (; *str; ++str) {
6747 while (*str == '/') {
6748 dir_start = 1;
6749 *str++;
6750 }
6751 if (dir_start) {
6752
6753 /* Have to skip up to three dots which could be */
6754 /* directories, 3 dots being a VMS extension for Perl */
6755 char * dots = str;
6756 int cnt = 0;
6757 while ((dots[cnt] == '.') && (cnt < 3)) {
6758 cnt++;
6759 }
6760 if (dots[cnt] == '\0')
6761 break;
6762 if ((cnt > 1) && (dots[cnt] != '/')) {
6763 dir_start = 0;
6764 } else {
6765 str += cnt;
6766 }
6767
6768 /* too many dots? */
6769 if ((cnt == 0) || (cnt > 3)) {
6770 dir_start = 0;
6771 }
6772 }
6773 if (!dir_start && (*str == '.')) {
6774 *str = '_';
6775 }
6776 }
e518068a 6777 }
1fe570cc
JM		 6778 PerlMem_free(trndir);
6779 ret_spec = buf;
6780 if (vms_debug_fileify) {
6781 if (ret_spec == NULL)
6782 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6783 else
6784 fprintf(stderr,
6785 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
a0d0e21e 6786 }
1fe570cc
JM		 6787 return ret_spec;
6788 }
6789}
d584a1c6 6790
1fe570cc
JM		 6791/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6792static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6793{
6794 static char __pathify_retbuf[VMS_MAXRSS];
6795 char * pathified, *ret_spec, *ret_buf;
6796
6797 pathified = NULL;
6798 ret_buf = buf;
6799 if (ret_buf == NULL) {
6800 if (ts) {
6801 Newx(pathified, VMS_MAXRSS, char);
6802 if (pathified == NULL)
6803 _ckvmssts(SS$_INSFMEM);
6804 ret_buf = pathified;
6805 } else {
6806 ret_buf = __pathify_retbuf;
6807 }
6808 }
d584a1c6 6809
1fe570cc
JM		 6810 ret_spec = int_pathify_dirspec(dir, ret_buf);
6811
6812 if (ret_spec == NULL) {
6813 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6814 if (pathified)
6815 Safefree(pathified);
a0d0e21e
LW		 6816 }
6817
1fe570cc
JM		 6818 return ret_spec;
6819
a0d0e21e 6820} /* end of do_pathify_dirspec() */
1fe570cc
JM		 6821
6822
a0d0e21e 6823/* External entry points */
b8ffc8df 6824char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
360732b5 6825{ return do_pathify_dirspec(dir,buf,0,NULL); }
b8ffc8df 6826char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
360732b5
JM		 6827{ return do_pathify_dirspec(dir,buf,1,NULL); }
6828char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6829{ return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6830char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6831{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
a0d0e21e 6832
0e5ce2c7
JM		 6833/* Internal tounixspec routine that does not use a thread context */
6834/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6835static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
a0d0e21e 6836{
0e5ce2c7 6837 char *dirend, *cp1, *cp3, *tmp;
b8ffc8df 6838 const char *cp2;
4e0c9737 6839 int dirlen;
2d9f3838 6840 unsigned short int trnlnm_iter_count;
f7ddb74a 6841 int cmp_rslt;
360732b5
JM		 6842 if (utf8_fl != NULL)
6843 *utf8_fl = 0;
a0d0e21e 6844
0e5ce2c7
JM		 6845 if (vms_debug_fileify) {
6846 if (spec == NULL)
6847 fprintf(stderr, "int_tounixspec: spec = NULL\n");
6848 else
6849 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6850 }
6851
6852
6853 if (spec == NULL) {
6854 set_errno(EINVAL);
6855 set_vaxc_errno(SS$_BADPARAM);
6856 return NULL;
6857 }
6858 if (strlen(spec) > (VMS_MAXRSS-1)) {
6859 set_errno(E2BIG);
6860 set_vaxc_errno(SS$_BUFFEROVF);
6861 return NULL;
e518068a 6862 }
f7ddb74a 6863
2497a41f
JM		 6864 /* New VMS specific format needs translation
6865 * glob passes filenames with trailing '\n' and expects this preserved.
6866 */
6867 if (decc_posix_compliant_pathnames) {
6868 if (strncmp(spec, "\"^UP^", 5) == 0) {
6869 char * uspec;
6870 char *tunix;
6871 int tunix_len;
6872 int nl_flag;
6873
c11536f5 6874 tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6875 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 6876 tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
2497a41f
JM		 6877 nl_flag = 0;
6878 if (tunix[tunix_len - 1] == '\n') {
6879 tunix[tunix_len - 1] = '\"';
6880 tunix[tunix_len] = '\0';
6881 tunix_len--;
6882 nl_flag = 1;
6883 }
6884 uspec = decc$translate_vms(tunix);
367e4b85 6885 PerlMem_free(tunix);
2497a41f 6886 if ((int)uspec > 0) {
a35dcc95 6887 my_strlcpy(rslt, uspec, VMS_MAXRSS);
2497a41f
JM		 6888 if (nl_flag) {
6889 strcat(rslt,"\n");
6890 }
6891 else {
6892 /* If we can not translate it, makemaker wants as-is */
a35dcc95 6893 my_strlcpy(rslt, spec, VMS_MAXRSS);
2497a41f
JM		 6894 }
6895 return rslt;
6896 }
6897 }
6898 }
6899
f7ddb74a
JM		 6900 cmp_rslt = 0; /* Presume VMS */
6901 cp1 = strchr(spec, '/');
6902 if (cp1 == NULL)
6903 cmp_rslt = 0;
6904
6905 /* Look for EFS ^/ */
6906 if (decc_efs_charset) {
6907 while (cp1 != NULL) {
6908 cp2 = cp1 - 1;
6909 if (*cp2 != '^') {
6910 /* Found illegal VMS, assume UNIX */
6911 cmp_rslt = 1;
6912 break;
6913 }
6914 cp1++;
6915 cp1 = strchr(cp1, '/');
6916 }
6917 }
6918
6919 /* Look for "." and ".." */
6920 if (decc_filename_unix_report) {
6921 if (spec[0] == '.') {
6922 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6923 cmp_rslt = 1;
6924 }
6925 else {
6926 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6927 cmp_rslt = 1;
6928 }
6929 }
6930 }
6931 }
6932 /* This is already UNIX or at least nothing VMS understands */
6933 if (cmp_rslt) {
a35dcc95 6934 my_strlcpy(rslt, spec, VMS_MAXRSS);
0e5ce2c7
JM		 6935 if (vms_debug_fileify) {
6936 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6937 }
a0d0e21e
LW		 6938 return rslt;
6939 }
6940
6941 cp1 = rslt;
6942 cp2 = spec;
6943 dirend = strrchr(spec,']');
6944 if (dirend == NULL) dirend = strrchr(spec,'>');
6945 if (dirend == NULL) dirend = strchr(spec,':');
6946 if (dirend == NULL) {
6947 strcpy(rslt,spec);
0e5ce2c7
JM		 6948 if (vms_debug_fileify) {
6949 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
6950 }
a0d0e21e
LW		 6951 return rslt;
6952 }
f7ddb74a
JM		 6953
6954 /* Special case 1 - sys$posix_root = / */
f7ddb74a
JM		 6955 if (!decc_disable_posix_root) {
6956 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6957 *cp1 = '/';
6958 cp1++;
6959 cp2 = cp2 + 15;
6960 }
6961 }
f7ddb74a
JM		 6962
6963 /* Special case 2 - Convert NLA0: to /dev/null */
f7ddb74a 6964 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
f7ddb74a
JM		 6965 if (cmp_rslt == 0) {
6966 strcpy(rslt, "/dev/null");
6967 cp1 = cp1 + 9;
6968 cp2 = cp2 + 5;
6969 if (spec[6] != '\0') {
07bee079 6970 cp1[9] = '/';
f7ddb74a
JM		 6971 cp1++;
6972 cp2++;
6973 }
6974 }
6975
6976 /* Also handle special case "SYS$SCRATCH:" */
f7ddb74a 6977 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
c11536f5 6978 tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 6979 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f7ddb74a
JM		 6980 if (cmp_rslt == 0) {
6981 int islnm;
6982
b8486b9d 6983 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
f7ddb74a
JM		 6984 if (!islnm) {
6985 strcpy(rslt, "/tmp");
6986 cp1 = cp1 + 4;
6987 cp2 = cp2 + 12;
6988 if (spec[12] != '\0') {
07bee079 6989 cp1[4] = '/';
f7ddb74a
JM		 6990 cp1++;
6991 cp2++;
6992 }
6993 }
6994 }
6995
a5f75d66 6996 if (*cp2 != '[' && *cp2 != '<') {
a0d0e21e
LW		 6997 *(cp1++) = '/';
6998 }
6999 else { /* the VMS spec begins with directories */
7000 cp2++;
a5f75d66 7001 if (*cp2 == ']' || *cp2 == '>') {
f86702cc 7002 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
367e4b85 7003 PerlMem_free(tmp);
a5f75d66
AD		 7004 return rslt;
7005 }
f7ddb74a 7006 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2f4077ca 7007 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
367e4b85 7008 PerlMem_free(tmp);
0e5ce2c7
JM		 7009 if (vms_debug_fileify) {
7010 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7011 }
a0d0e21e
LW		 7012 return NULL;
7013 }
2d9f3838 7014 trnlnm_iter_count = 0;
a0d0e21e
LW		 7015 do {
7016 cp3 = tmp;
7017 while (*cp3 != ':' && *cp3) cp3++;
7018 *(cp3++) = '\0';
7019 if (strchr(cp3,']') != NULL) break;
2d9f3838
CB		 7020 trnlnm_iter_count++;
7021 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
f675dbe5 7022 } while (vmstrnenv(tmp,tmp,0,fildev,0));
0e5ce2c7 7023 cp1 = rslt;
f86702cc 7024 cp3 = tmp;
7025 *(cp1++) = '/';
7026 while (*cp3) {
7027 *(cp1++) = *(cp3++);
0e5ce2c7 7028 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
367e4b85 7029 PerlMem_free(tmp);
0e5ce2c7
JM		 7030 set_errno(ENAMETOOLONG);
7031 set_vaxc_errno(SS$_BUFFEROVF);
7032 if (vms_debug_fileify) {
7033 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7034 }
2f4077ca
JM		 7035 return NULL; /* No room */
7036 }
a0d0e21e 7037 }
f86702cc 7038 *(cp1++) = '/';
7039 }
f7ddb74a
JM		 7040 if ((*cp2 == '^')) {
7041 /* EFS file escape, pass the next character as is */
38a44b82 7042 /* Fix me: HEX encoding for Unicode not implemented */
f7ddb74a
JM		 7043 cp2++;
7044 }
f86702cc 7045 else if ( *cp2 == '.') {
7046 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7047 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7048 cp2 += 3;
7049 }
7050 else cp2++;
a0d0e21e 7051 }
a0d0e21e 7052 }
367e4b85 7053 PerlMem_free(tmp);
a0d0e21e 7054 for (; cp2 <= dirend; cp2++) {
f7ddb74a
JM		 7055 if ((*cp2 == '^')) {
7056 /* EFS file escape, pass the next character as is */
38a44b82 7057 /* Fix me: HEX encoding for Unicode not implemented */
42cd432e
CB		 7058 *(cp1++) = *(++cp2);
7059 /* An escaped dot stays as is -- don't convert to slash */
7060 if (*cp2 == '.') cp2++;
f7ddb74a 7061 }
a0d0e21e
LW		 7062 if (*cp2 == ':') {
7063 *(cp1++) = '/';
5ad5b34c 7064 if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
a0d0e21e 7065 }
f86702cc 7066 else if (*cp2 == ']' || *cp2 == '>') {
7067 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7068 }
f7ddb74a 7069 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
a0d0e21e 7070 *(cp1++) = '/';
e518068a 7071 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7072 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7073 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7074 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7075 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7076 }
f86702cc 7077 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7078 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7079 cp2 += 2;
7080 }
a0d0e21e
LW		 7081 }
7082 else if (*cp2 == '-') {
7083 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7084 while (*cp2 == '-') {
7085 cp2++;
7086 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7087 }
7088 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
0e5ce2c7 7089 /* filespecs like */
01b8edb6 7090 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
0e5ce2c7
JM		 7091 if (vms_debug_fileify) {
7092 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7093 }
a0d0e21e
LW		 7094 return NULL;
7095 }
a0d0e21e
LW		 7096 }
7097 else *(cp1++) = *cp2;
7098 }
7099 else *(cp1++) = *cp2;
7100 }
0e5ce2c7 7101 /* Translate the rest of the filename. */
42cd432e 7102 while (*cp2) {
0e5ce2c7
JM		 7103 int dot_seen;
7104 dot_seen = 0;
7105 switch(*cp2) {
7106 /* Fixme - for compatibility with the CRTL we should be removing */
7107 /* spaces from the file specifications, but this may show that */
7108 /* some tests that were appearing to pass are not really passing */
7109 case '%':
7110 cp2++;
7111 *(cp1++) = '?';
7112 break;
7113 case '^':
7114 /* Fix me hex expansions not implemented */
7115 cp2++; /* '^.' --> '.' and other. */
7116 if (*cp2) {
7117 if (*cp2 == '_') {
7118 cp2++;
7119 *(cp1++) = ' ';
7120 } else {
7121 *(cp1++) = *(cp2++);
7122 }
7123 }
7124 break;
7125 case ';':
7126 if (decc_filename_unix_no_version) {
7127 /* Easy, drop the version */
7128 while (*cp2)
7129 cp2++;
7130 break;
7131 } else {
7132 /* Punt - passing the version as a dot will probably */
7133 /* break perl in weird ways, but so did passing */
7134 /* through the ; as a version. Follow the CRTL and */
7135 /* hope for the best. */
7136 cp2++;
7137 *(cp1++) = '.';
7138 }
7139 break;
7140 case '.':
7141 if (dot_seen) {
7142 /* We will need to fix this properly later */
7143 /* As Perl may be installed on an ODS-5 volume, but not */
7144 /* have the EFS_CHARSET enabled, it still may encounter */
7145 /* filenames with extra dots in them, and a precedent got */
7146 /* set which allowed them to work, that we will uphold here */
7147 /* If extra dots are present in a name and no ^ is on them */
7148 /* VMS assumes that the first one is the extension delimiter */
7149 /* the rest have an implied ^. */
7150
7151 /* this is also a conflict as the . is also a version */
7152 /* delimiter in VMS, */
7153
7154 *(cp1++) = *(cp2++);
7155 break;
7156 }
7157 dot_seen = 1;
7158 /* This is an extension */
7159 if (decc_readdir_dropdotnotype) {
7160 cp2++;
7161 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7162 /* Drop the dot for the extension */
7163 break;
7164 } else {
7165 *(cp1++) = '.';
7166 }
7167 break;
7168 }
7169 default:
7170 *(cp1++) = *(cp2++);
7171 }
42cd432e 7172 }
a0d0e21e
LW		 7173 *cp1 = '\0';
7174
f7ddb74a
JM		 7175 /* This still leaves /000000/ when working with a
7176 * VMS device root or concealed root.
7177 */
7178 {
7179 int ulen;
7180 char * zeros;
7181
7182 ulen = strlen(rslt);
7183
7184 /* Get rid of "000000/ in rooted filespecs */
7185 if (ulen > 7) {
7186 zeros = strstr(rslt, "/000000/");
7187 if (zeros != NULL) {
7188 int mlen;
7189 mlen = ulen - (zeros - rslt) - 7;
7190 memmove(zeros, &zeros[7], mlen);
7191 ulen = ulen - 7;
7192 rslt[ulen] = '\0';
7193 }
7194 }
7195 }
7196
0e5ce2c7
JM		 7197 if (vms_debug_fileify) {
7198 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7199 }
a0d0e21e
LW		 7200 return rslt;
7201
0e5ce2c7
JM		 7202} /* end of int_tounixspec() */
7203
7204
7205/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7206static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7207{
7208 static char __tounixspec_retbuf[VMS_MAXRSS];
7209 char * unixspec, *ret_spec, *ret_buf;
7210
7211 unixspec = NULL;
7212 ret_buf = buf;
7213 if (ret_buf == NULL) {
7214 if (ts) {
7215 Newx(unixspec, VMS_MAXRSS, char);
7216 if (unixspec == NULL)
7217 _ckvmssts(SS$_INSFMEM);
7218 ret_buf = unixspec;
7219 } else {
7220 ret_buf = __tounixspec_retbuf;
7221 }
7222 }
7223
7224 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7225
7226 if (ret_spec == NULL) {
7227 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7228 if (unixspec)
7229 Safefree(unixspec);
7230 }
7231
7232 return ret_spec;
7233
a0d0e21e
LW		 7234} /* end of do_tounixspec() */
7235/*}}}*/
7236/* External entry points */
360732b5
JM		 7237char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7238 { return do_tounixspec(spec,buf,0, NULL); }
7239char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7240 { return do_tounixspec(spec,buf,1, NULL); }
7241char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7242 { return do_tounixspec(spec,buf,0, utf8_fl); }
7243char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7244 { return do_tounixspec(spec,buf,1, utf8_fl); }
a0d0e21e 7245
360732b5 7246#if __CRTL_VER >= 70200000 && !defined(__VAX)
2497a41f 7247
360732b5
JM		 7248/*
7249 This procedure is used to identify if a path is based in either
7250 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7251 it returns the OpenVMS format directory for it.
7252
7253 It is expecting specifications of only '/' or '/xxxx/'
7254
7255 If a posix root does not exist, or 'xxxx' is not a directory
7256 in the posix root, it returns a failure.
7257
7258 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7259
7260 It is used only internally by posix_to_vmsspec_hardway().
7261 */
7262
7263static int posix_root_to_vms
7264 (char *vmspath, int vmspath_len,
7265 const char *unixpath,
d584a1c6
JM		 7266 const int * utf8_fl)
7267{
2497a41f
JM		 7268int sts;
7269struct FAB myfab = cc$rms_fab;
d584a1c6 7270rms_setup_nam(mynam);
2497a41f 7271struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
d584a1c6
JM		 7272struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7273char * esa, * esal, * rsa, * rsal;
2497a41f
JM		 7274int dir_flag;
7275int unixlen;
7276
360732b5 7277 dir_flag = 0;
d584a1c6 7278 vmspath[0] = '\0';
360732b5
JM		 7279 unixlen = strlen(unixpath);
7280 if (unixlen == 0) {
360732b5
JM		 7281 return RMS$_FNF;
7282 }
7283
7284#if __CRTL_VER >= 80200000
2497a41f 7285 /* If not a posix spec already, convert it */
360732b5
JM		 7286 if (decc_posix_compliant_pathnames) {
7287 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7288 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7289 }
7290 else {
7291 /* This is already a VMS specification, no conversion */
7292 unixlen--;
a35dcc95 7293 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
360732b5 7294 }
2497a41f 7295 }
360732b5
JM		 7296 else
7297#endif
7298 {
7299 int path_len;
7300 int i,j;
7301
7302 /* Check to see if this is under the POSIX root */
7303 if (decc_disable_posix_root) {
7304 return RMS$_FNF;
7305 }
7306
7307 /* Skip leading / */
7308 if (unixpath[0] == '/') {
7309 unixpath++;
7310 unixlen--;
7311 }
7312
7313
7314 strcpy(vmspath,"SYS$POSIX_ROOT:");
7315
7316 /* If this is only the / , or blank, then... */
7317 if (unixpath[0] == '\0') {
7318 /* by definition, this is the answer */
7319 return SS$_NORMAL;
7320 }
7321
7322 /* Need to look up a directory */
7323 vmspath[15] = '[';
7324 vmspath[16] = '\0';
7325
7326 /* Copy and add '^' escape characters as needed */
7327 j = 16;
7328 i = 0;
7329 while (unixpath[i] != 0) {
7330 int k;
7331
7332 j += copy_expand_unix_filename_escape
7333 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7334 i += k;
7335 }
7336
7337 path_len = strlen(vmspath);
7338 if (vmspath[path_len - 1] == '/')
7339 path_len--;
7340 vmspath[path_len] = ']';
7341 path_len++;
7342 vmspath[path_len] = '\0';
7343
2497a41f
JM		 7344 }
7345 vmspath[vmspath_len] = 0;
7346 if (unixpath[unixlen - 1] == '/')
7347 dir_flag = 1;
c11536f5 7348 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7349 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7350 esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
c5375c28 7351 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7352 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
d584a1c6 7353 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 7354 rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
d584a1c6
JM		 7355 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7356 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7357 rms_bind_fab_nam(myfab, mynam);
7358 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7359 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
2497a41f
JM		 7360 if (decc_efs_case_preserve)
7361 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
ea0c9945 7362#ifdef NAML$M_OPEN_SPECIAL
2497a41f 7363 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
ea0c9945 7364#endif
2497a41f
JM		 7365
7366 /* Set up the remaining naml fields */
7367 sts = sys$parse(&myfab);
7368
7369 /* It failed! Try again as a UNIX filespec */
7370 if (!(sts & 1)) {
d584a1c6 7371 PerlMem_free(esal);
367e4b85 7372 PerlMem_free(esa);
d584a1c6
JM		 7373 PerlMem_free(rsal);
7374 PerlMem_free(rsa);
2497a41f
JM		 7375 return sts;
7376 }
7377
7378 /* get the Device ID and the FID */
7379 sts = sys$search(&myfab);
d584a1c6
JM		 7380
7381 /* These are no longer needed */
7382 PerlMem_free(esa);
7383 PerlMem_free(rsal);
7384 PerlMem_free(rsa);
7385
2497a41f
JM		 7386 /* on any failure, returned the POSIX ^UP^ filespec */
7387 if (!(sts & 1)) {
d584a1c6 7388 PerlMem_free(esal);
2497a41f
JM		 7389 return sts;
7390 }
7391 specdsc.dsc$a_pointer = vmspath;
7392 specdsc.dsc$w_length = vmspath_len;
7393
7394 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7395 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7396 sts = lib$fid_to_name
7397 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7398
7399 /* on any failure, returned the POSIX ^UP^ filespec */
7400 if (!(sts & 1)) {
7401 /* This can happen if user does not have permission to read directories */
7402 if (strncmp(unixpath,"\"^UP^",5) != 0)
7403 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7404 else
a35dcc95 7405 my_strlcpy(vmspath, unixpath, vmspath_len + 1);
2497a41f
JM		 7406 }
7407 else {
7408 vmspath[specdsc.dsc$w_length] = 0;
7409
7410 /* Are we expecting a directory? */
7411 if (dir_flag != 0) {
7412 int i;
7413 char *eptr;
7414
7415 eptr = NULL;
7416
7417 i = specdsc.dsc$w_length - 1;
7418 while (i > 0) {
7419 int zercnt;
7420 zercnt = 0;
7421 /* Version must be '1' */
7422 if (vmspath[i--] != '1')
7423 break;
7424 /* Version delimiter is one of ".;" */
7425 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7426 break;
7427 i--;
7428 if (vmspath[i--] != 'R')
7429 break;
7430 if (vmspath[i--] != 'I')
7431 break;
7432 if (vmspath[i--] != 'D')
7433 break;
7434 if (vmspath[i--] != '.')
7435 break;
7436 eptr = &vmspath[i+1];
7437 while (i > 0) {
7438 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7439 if (vmspath[i-1] != '^') {
7440 if (zercnt != 6) {
7441 *eptr = vmspath[i];
7442 eptr[1] = '\0';
7443 vmspath[i] = '.';
7444 break;
7445 }
7446 else {
7447 /* Get rid of 6 imaginary zero directory filename */
7448 vmspath[i+1] = '\0';
7449 }
7450 }
7451 }
7452 if (vmspath[i] == '0')
7453 zercnt++;
7454 else
7455 zercnt = 10;
7456 i--;
7457 }
7458 break;
7459 }
7460 }
7461 }
d584a1c6 7462 PerlMem_free(esal);
2497a41f
JM		 7463 return sts;
7464}
7465
360732b5
JM		 7466/* /dev/mumble needs to be handled special.
7467 /dev/null becomes NLA0:, And there is the potential for other stuff
7468 like /dev/tty which may need to be mapped to something.
7469*/
7470
7471static int
7472slash_dev_special_to_vms
7473 (const char * unixptr,
7474 char * vmspath,
7475 int vmspath_len)
7476{
7477char * nextslash;
7478int len;
7479int cmp;
360732b5
JM		 7480
7481 unixptr += 4;
7482 nextslash = strchr(unixptr, '/');
7483 len = strlen(unixptr);
7484 if (nextslash != NULL)
7485 len = nextslash - unixptr;
7486 cmp = strncmp("null", unixptr, 5);
7487 if (cmp == 0) {
7488 if (vmspath_len >= 6) {
7489 strcpy(vmspath, "_NLA0:");
7490 return SS$_NORMAL;
7491 }
7492 }
c5193628 7493 return 0;
360732b5
JM		 7494}
7495
7496
7497/* The built in routines do not understand perl's special needs, so
7498 doing a manual conversion from UNIX to VMS
7499
7500 If the utf8_fl is not null and points to a non-zero value, then
7501 treat 8 bit characters as UTF-8.
7502
7503 The sequence starting with '$(' and ending with ')' will be passed
7504 through with out interpretation instead of being escaped.
7505
7506 */
2497a41f 7507static int posix_to_vmsspec_hardway
360732b5
JM		 7508 (char *vmspath, int vmspath_len,
7509 const char *unixpath,
7510 int dir_flag,
7511 int * utf8_fl) {
2497a41f
JM		 7512
7513char *esa;
7514const char *unixptr;
360732b5 7515const char *unixend;
2497a41f
JM		 7516char *vmsptr;
7517const char *lastslash;
7518const char *lastdot;
7519int unixlen;
7520int vmslen;
7521int dir_start;
7522int dir_dot;
7523int quoted;
360732b5
JM		 7524char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7525int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
2497a41f 7526
360732b5
JM		 7527 if (utf8_fl != NULL)
7528 *utf8_fl = 0;
2497a41f
JM		 7529
7530 unixptr = unixpath;
7531 dir_dot = 0;
7532
7533 /* Ignore leading "/" characters */
7534 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7535 unixptr++;
7536 }
7537 unixlen = strlen(unixptr);
7538
7539 /* Do nothing with blank paths */
7540 if (unixlen == 0) {
7541 vmspath[0] = '\0';
7542 return SS$_NORMAL;
7543 }
7544
360732b5
JM		 7545 quoted = 0;
7546 /* This could have a "^UP^ on the front */
7547 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7548 quoted = 1;
7549 unixptr+= 5;
7550 unixlen-= 5;
7551 }
7552
2497a41f
JM		 7553 lastslash = strrchr(unixptr,'/');
7554 lastdot = strrchr(unixptr,'.');
360732b5
JM		 7555 unixend = strrchr(unixptr,'\"');
7556 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7557 unixend = unixptr + unixlen;
7558 }
2497a41f
JM		 7559
7560 /* last dot is last dot or past end of string */
7561 if (lastdot == NULL)
7562 lastdot = unixptr + unixlen;
7563
7564 /* if no directories, set last slash to beginning of string */
7565 if (lastslash == NULL) {
7566 lastslash = unixptr;
7567 }
7568 else {
7569 /* Watch out for trailing "." after last slash, still a directory */
7570 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7571 lastslash = unixptr + unixlen;
7572 }
7573
94ae10c0 7574 /* Watch out for trailing ".." after last slash, still a directory */
2497a41f
JM		 7575 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7576 lastslash = unixptr + unixlen;
7577 }
7578
7579 /* dots in directories are aways escaped */
7580 if (lastdot < lastslash)
7581 lastdot = unixptr + unixlen;
7582 }
7583
7584 /* if (unixptr < lastslash) then we are in a directory */
7585
7586 dir_start = 0;
2497a41f
JM		 7587
7588 vmsptr = vmspath;
7589 vmslen = 0;
7590
2497a41f
JM		 7591 /* Start with the UNIX path */
7592 if (*unixptr != '/') {
7593 /* relative paths */
360732b5
JM		 7594
7595 /* If allowing logical names on relative pathnames, then handle here */
7596 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7597 !decc_posix_compliant_pathnames) {
7598 char * nextslash;
7599 int seg_len;
7600 char * trn;
7601 int islnm;
7602
7603 /* Find the next slash */
7604 nextslash = strchr(unixptr,'/');
7605
c11536f5 7606 esa = (char *)PerlMem_malloc(vmspath_len);
360732b5
JM		 7607 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7608
c11536f5 7609 trn = (char *)PerlMem_malloc(VMS_MAXRSS);
360732b5
JM		 7610 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7611
7612 if (nextslash != NULL) {
7613
7614 seg_len = nextslash - unixptr;
a35dcc95 7615 memcpy(esa, unixptr, seg_len);
360732b5
JM		 7616 esa[seg_len] = 0;
7617 }
7618 else {
a35dcc95 7619 seg_len = my_strlcpy(esa, unixptr, sizeof(esa));
360732b5
JM		 7620 }
7621 /* trnlnm(section) */
7622 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7623
7624 if (islnm) {
7625 /* Now fix up the directory */
7626
7627 /* Split up the path to find the components */
7628 sts = vms_split_path
7629 (trn,
7630 &v_spec,
7631 &v_len,
7632 &r_spec,
7633 &r_len,
7634 &d_spec,
7635 &d_len,
7636 &n_spec,
7637 &n_len,
7638 &e_spec,
7639 &e_len,
7640 &vs_spec,
7641 &vs_len);
7642
7643 while (sts == 0) {
360732b5
JM		 7644 int cmp;
7645
7646 /* A logical name must be a directory or the full
7647 specification. It is only a full specification if
7648 it is the only component */
7649 if ((unixptr[seg_len] == '\0') ||
7650 (unixptr[seg_len+1] == '\0')) {
7651
7652 /* Is a directory being required? */
7653 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7654 /* Not a logical name */
7655 break;
7656 }
7657
7658
7659 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7660 /* This must be a directory */
7661 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
a35dcc95 7662 vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1);
360732b5
JM		 7663 vmsptr[vmslen] = ':';
7664 vmslen++;
7665 vmsptr[vmslen] = '\0';
7666 return SS$_NORMAL;
7667 }
7668 }
7669
7670 }
7671
7672
7673 /* must be dev/directory - ignore version */
7674 if ((n_len + e_len) != 0)
7675 break;
7676
7677 /* transfer the volume */
7678 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
a35dcc95 7679 memcpy(vmsptr, v_spec, v_len);
360732b5
JM		 7680 vmsptr += v_len;
7681 vmsptr[0] = '\0';
7682 vmslen += v_len;
7683 }
7684
7685 /* unroot the rooted directory */
7686 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7687 r_spec[0] = '[';
7688 r_spec[r_len - 1] = ']';
7689
7690 /* This should not be there, but nothing is perfect */
7691 if (r_len > 9) {
7692 cmp = strcmp(&r_spec[1], "000000.");
7693 if (cmp == 0) {
7694 r_spec += 7;
7695 r_spec[7] = '[';
7696 r_len -= 7;
7697 if (r_len == 2)
7698 r_len = 0;
7699 }
7700 }
7701 if (r_len > 0) {
a35dcc95 7702 memcpy(vmsptr, r_spec, r_len);
360732b5
JM		 7703 vmsptr += r_len;
7704 vmslen += r_len;
7705 vmsptr[0] = '\0';
7706 }
7707 }
7708 /* Bring over the directory. */
7709 if ((d_len > 0) &&
7710 ((d_len + vmslen) < vmspath_len)) {
7711 d_spec[0] = '[';
7712 d_spec[d_len - 1] = ']';
7713 if (d_len > 9) {
7714 cmp = strcmp(&d_spec[1], "000000.");
7715 if (cmp == 0) {
7716 d_spec += 7;
7717 d_spec[7] = '[';
7718 d_len -= 7;
7719 if (d_len == 2)
7720 d_len = 0;
7721 }
7722 }
7723
7724 if (r_len > 0) {
7725 /* Remove the redundant root */
7726 if (r_len > 0) {
7727 /* remove the ][ */
7728 vmsptr--;
7729 vmslen--;
7730 d_spec++;
7731 d_len--;
7732 }
a35dcc95 7733 memcpy(vmsptr, d_spec, d_len);
360732b5
JM		 7734 vmsptr += d_len;
7735 vmslen += d_len;
7736 vmsptr[0] = '\0';
7737 }
7738 }
7739 break;
7740 }
7741 }
7742
7743 PerlMem_free(esa);
7744 PerlMem_free(trn);
7745 }
7746
2497a41f
JM		 7747 if (lastslash > unixptr) {
7748 int dotdir_seen;
7749
7750 /* skip leading ./ */
7751 dotdir_seen = 0;
7752 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7753 dotdir_seen = 1;
7754 unixptr++;
7755 unixptr++;
7756 }
7757
7758 /* Are we still in a directory? */
7759 if (unixptr <= lastslash) {
7760 *vmsptr++ = '[';
7761 vmslen = 1;
7762 dir_start = 1;
7763
7764 /* if not backing up, then it is relative forward. */
7765 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 7766 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
2497a41f
JM		 7767 *vmsptr++ = '.';
7768 vmslen++;
7769 dir_dot = 1;
360732b5 7770 }
2497a41f
JM		 7771 }
7772 else {
7773 if (dotdir_seen) {
7774 /* Perl wants an empty directory here to tell the difference
94ae10c0 7775 * between a DCL command and a filename
2497a41f
JM		 7776 */
7777 *vmsptr++ = '[';
7778 *vmsptr++ = ']';
7779 vmslen = 2;
7780 }
7781 }
7782 }
7783 else {
7784 /* Handle two special files . and .. */
7785 if (unixptr[0] == '.') {
360732b5 7786 if (&unixptr[1] == unixend) {
2497a41f
JM		 7787 *vmsptr++ = '[';
7788 *vmsptr++ = ']';
7789 vmslen += 2;
7790 *vmsptr++ = '\0';
7791 return SS$_NORMAL;
7792 }
360732b5 7793 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
2497a41f
JM		 7794 *vmsptr++ = '[';
7795 *vmsptr++ = '-';
7796 *vmsptr++ = ']';
7797 vmslen += 3;
7798 *vmsptr++ = '\0';
7799 return SS$_NORMAL;
7800 }
7801 }
7802 }
7803 }
7804 else { /* Absolute PATH handling */
7805 int sts;
7806 char * nextslash;
7807 int seg_len;
7808 /* Need to find out where root is */
7809
7810 /* In theory, this procedure should never get an absolute POSIX pathname
7811 * that can not be found on the POSIX root.
7812 * In practice, that can not be relied on, and things will show up
7813 * here that are a VMS device name or concealed logical name instead.
7814 * So to make things work, this procedure must be tolerant.
7815 */
c11536f5 7816 esa = (char *)PerlMem_malloc(vmspath_len);
c5375c28 7817 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2497a41f
JM		 7818
7819 sts = SS$_NORMAL;
7820 nextslash = strchr(&unixptr[1],'/');
7821 seg_len = 0;
7822 if (nextslash != NULL) {
db4c2905 7823 int cmp;
2497a41f 7824 seg_len = nextslash - &unixptr[1];
db4c2905 7825 my_strlcpy(vmspath, unixptr, seg_len + 2);
360732b5
JM		 7826 cmp = 1;
7827 if (seg_len == 3) {
7828 cmp = strncmp(vmspath, "dev", 4);
7829 if (cmp == 0) {
7830 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
07bee079 7831 if (sts == SS$_NORMAL)
360732b5
JM		 7832 return SS$_NORMAL;
7833 }
7834 }
7835 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
2497a41f
JM		 7836 }
7837
360732b5 7838 if ($VMS_STATUS_SUCCESS(sts)) {
2497a41f
JM		 7839 /* This is verified to be a real path */
7840
360732b5
JM		 7841 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7842 if ($VMS_STATUS_SUCCESS(sts)) {
a35dcc95 7843 vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1);
360732b5
JM		 7844 vmsptr = vmspath + vmslen;
7845 unixptr++;
7846 if (unixptr < lastslash) {
7847 char * rptr;
7848 vmsptr--;
7849 *vmsptr++ = '.';
7850 dir_start = 1;
7851 dir_dot = 1;
7852 if (vmslen > 7) {
7853 int cmp;
7854 rptr = vmsptr - 7;
7855 cmp = strcmp(rptr,"000000.");
7856 if (cmp == 0) {
7857 vmslen -= 7;
7858 vmsptr -= 7;
7859 vmsptr[1] = '\0';
7860 } /* removing 6 zeros */
7861 } /* vmslen < 7, no 6 zeros possible */
7862 } /* Not in a directory */
7863 } /* Posix root found */
7864 else {
7865 /* No posix root, fall back to default directory */
7866 strcpy(vmspath, "SYS$DISK:[");
7867 vmsptr = &vmspath[10];
7868 vmslen = 10;
7869 if (unixptr > lastslash) {
7870 *vmsptr = ']';
7871 vmsptr++;
7872 vmslen++;
7873 }
7874 else {
7875 dir_start = 1;
7876 }
7877 }
2497a41f
JM		 7878 } /* end of verified real path handling */
7879 else {
7880 int add_6zero;
7881 int islnm;
7882
7883 /* Ok, we have a device or a concealed root that is not in POSIX
7884 * or we have garbage. Make the best of it.
7885 */
7886
7887 /* Posix to VMS destroyed this, so copy it again */
db4c2905
CB		 7888 my_strlcpy(vmspath, &unixptr[1], seg_len + 1);
7889 vmslen = strlen(vmspath); /* We know we're truncating. */
2497a41f
JM		 7890 vmsptr = &vmsptr[vmslen];
7891 islnm = 0;
7892
7893 /* Now do we need to add the fake 6 zero directory to it? */
7894 add_6zero = 1;
7895 if ((*lastslash == '/') && (nextslash < lastslash)) {
7896 /* No there is another directory */
7897 add_6zero = 0;
7898 }
7899 else {
7900 int trnend;
360732b5 7901 int cmp;
2497a41f
JM		 7902
7903 /* now we have foo:bar or foo:[000000]bar to decide from */
7ded3206 7904 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
360732b5
JM		 7905
7906 if (!islnm && !decc_posix_compliant_pathnames) {
7907
7908 cmp = strncmp("bin", vmspath, 4);
7909 if (cmp == 0) {
7910 /* bin => SYS$SYSTEM: */
7911 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7912 }
7913 else {
7914 /* tmp => SYS$SCRATCH: */
7915 cmp = strncmp("tmp", vmspath, 4);
7916 if (cmp == 0) {
7917 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7918 }
7919 }
7920 }
7921
7ded3206 7922 trnend = islnm ? islnm - 1 : 0;
2497a41f
JM		 7923
7924 /* if this was a logical name, ']' or '>' must be present */
7925 /* if not a logical name, then assume a device and hope. */
7926 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7927
7928 /* if log name and trailing '.' then rooted - treat as device */
7929 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7930
7931 /* Fix me, if not a logical name, a device lookup should be
7932 * done to see if the device is file structured. If the device
7933 * is not file structured, the 6 zeros should not be put on.
7934 *
7935 * As it is, perl is occasionally looking for dev:[000000]tty.
7936 * which looks a little strange.
360732b5
JM		 7937 *
7938 * Not that easy to detect as "/dev" may be file structured with
7939 * special device files.
2497a41f
JM		 7940 */
7941
30e68285 7942 if (!islnm && (add_6zero == 0) && (*nextslash == '/') &&
360732b5 7943 (&nextslash[1] == unixend)) {
2497a41f
JM		 7944 /* No real directory present */
7945 add_6zero = 1;
7946 }
7947 }
7948
7949 /* Put the device delimiter on */
7950 *vmsptr++ = ':';
7951 vmslen++;
7952 unixptr = nextslash;
7953 unixptr++;
7954
7955 /* Start directory if needed */
7956 if (!islnm || add_6zero) {
7957 *vmsptr++ = '[';
7958 vmslen++;
7959 dir_start = 1;
7960 }
7961
7962 /* add fake 000000] if needed */
7963 if (add_6zero) {
7964 *vmsptr++ = '0';
7965 *vmsptr++ = '0';
7966 *vmsptr++ = '0';
7967 *vmsptr++ = '0';
7968 *vmsptr++ = '0';
7969 *vmsptr++ = '0';
7970 *vmsptr++ = ']';
7971 vmslen += 7;
7972 dir_start = 0;
7973 }
7974
7975 } /* non-POSIX translation */
367e4b85 7976 PerlMem_free(esa);
2497a41f
JM		 7977 } /* End of relative/absolute path handling */
7978
360732b5 7979 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
2497a41f 7980 int dash_flag;
360732b5
JM		 7981 int in_cnt;
7982 int out_cnt;
2497a41f
JM		 7983
7984 dash_flag = 0;
7985
7986 if (dir_start != 0) {
7987
7988 /* First characters in a directory are handled special */
7989 while ((*unixptr == '/') ||
7990 ((*unixptr == '.') &&
360732b5
JM		 7991 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7992 (&unixptr[1]==unixend)))) {
2497a41f
JM		 7993 int loop_flag;
7994
7995 loop_flag = 0;
7996
7997 /* Skip redundant / in specification */
7998 while ((*unixptr == '/') && (dir_start != 0)) {
7999 loop_flag = 1;
8000 unixptr++;
8001 if (unixptr == lastslash)
8002 break;
8003 }
8004 if (unixptr == lastslash)
8005 break;
8006
8007 /* Skip redundant ./ characters */
8008 while ((*unixptr == '.') &&
360732b5 8009 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
2497a41f
JM		 8010 loop_flag = 1;
8011 unixptr++;
8012 if (unixptr == lastslash)
8013 break;
8014 if (*unixptr == '/')
8015 unixptr++;
8016 }
8017 if (unixptr == lastslash)
8018 break;
8019
8020 /* Skip redundant ../ characters */
8021 while ((*unixptr == '.') && (unixptr[1] == '.') &&
360732b5 8022 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
2497a41f
JM		 8023 /* Set the backing up flag */
8024 loop_flag = 1;
8025 dir_dot = 0;
8026 dash_flag = 1;
8027 *vmsptr++ = '-';
8028 vmslen++;
8029 unixptr++; /* first . */
8030 unixptr++; /* second . */
8031 if (unixptr == lastslash)
8032 break;
8033 if (*unixptr == '/') /* The slash */
8034 unixptr++;
8035 }
8036 if (unixptr == lastslash)
8037 break;
8038
8039 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8040 /* Not needed when VMS is pretending to be UNIX. */
8041
8042 /* Is this loop stuck because of too many dots? */
8043 if (loop_flag == 0) {
8044 /* Exit the loop and pass the rest through */
8045 break;
8046 }
8047 }
8048
8049 /* Are we done with directories yet? */
8050 if (unixptr >= lastslash) {
8051
8052 /* Watch out for trailing dots */
8053 if (dir_dot != 0) {
8054 vmslen --;
8055 vmsptr--;
8056 }
8057 *vmsptr++ = ']';
8058 vmslen++;
8059 dash_flag = 0;
8060 dir_start = 0;
8061 if (*unixptr == '/')
8062 unixptr++;
8063 }
8064 else {
8065 /* Have we stopped backing up? */
8066 if (dash_flag) {
8067 *vmsptr++ = '.';
8068 vmslen++;
8069 dash_flag = 0;
8070 /* dir_start continues to be = 1 */
8071 }
8072 if (*unixptr == '-') {
8073 *vmsptr++ = '^';
8074 *vmsptr++ = *unixptr++;
8075 vmslen += 2;
8076 dir_start = 0;
8077
8078 /* Now are we done with directories yet? */
8079 if (unixptr >= lastslash) {
8080
8081 /* Watch out for trailing dots */
8082 if (dir_dot != 0) {
8083 vmslen --;
8084 vmsptr--;
8085 }
8086
8087 *vmsptr++ = ']';
8088 vmslen++;
8089 dash_flag = 0;
8090 dir_start = 0;
8091 }
8092 }
8093 }
8094 }
8095
8096 /* All done? */
360732b5 8097 if (unixptr >= unixend)
2497a41f
JM		 8098 break;
8099
8100 /* Normal characters - More EFS work probably needed */
8101 dir_start = 0;
8102 dir_dot = 0;
8103
8104 switch(*unixptr) {
8105 case '/':
8106 /* remove multiple / */
8107 while (unixptr[1] == '/') {
8108 unixptr++;
8109 }
8110 if (unixptr == lastslash) {
8111 /* Watch out for trailing dots */
8112 if (dir_dot != 0) {
8113 vmslen --;
8114 vmsptr--;
8115 }
8116 *vmsptr++ = ']';
8117 }
8118 else {
8119 dir_start = 1;
8120 *vmsptr++ = '.';
8121 dir_dot = 1;
8122
8123 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8124 /* Not needed when VMS is pretending to be UNIX. */
8125
8126 }
8127 dash_flag = 0;
360732b5 8128 if (unixptr != unixend)
2497a41f
JM		 8129 unixptr++;
8130 vmslen++;
8131 break;
2497a41f 8132 case '.':
360732b5
JM		 8133 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8134 (&unixptr[1] == unixend)) {
2497a41f
JM		 8135 *vmsptr++ = '^';
8136 *vmsptr++ = '.';
8137 vmslen += 2;
8138 unixptr++;
8139
8140 /* trailing dot ==> '^..' on VMS */
360732b5 8141 if (unixptr == unixend) {
2497a41f
JM		 8142 *vmsptr++ = '.';
8143 vmslen++;
360732b5 8144 unixptr++;
2497a41f 8145 }
2497a41f
JM		 8146 break;
8147 }
360732b5 8148
2497a41f 8149 *vmsptr++ = *unixptr++;
360732b5
JM		 8150 vmslen ++;
8151 break;
8152 case '"':
8153 if (quoted && (&unixptr[1] == unixend)) {
8154 unixptr++;
8155 break;
8156 }
8157 in_cnt = copy_expand_unix_filename_escape
8158 (vmsptr, unixptr, &out_cnt, utf8_fl);
8159 vmsptr += out_cnt;
8160 unixptr += in_cnt;
2497a41f
JM		 8161 break;
8162 case '~':
8163 case ';':
8164 case '\\':
360732b5
JM		 8165 case '?':
8166 case ' ':
2497a41f 8167 default:
360732b5
JM		 8168 in_cnt = copy_expand_unix_filename_escape
8169 (vmsptr, unixptr, &out_cnt, utf8_fl);
8170 vmsptr += out_cnt;
8171 unixptr += in_cnt;
2497a41f
JM		 8172 break;
8173 }
8174 }
8175
8176 /* Make sure directory is closed */
8177 if (unixptr == lastslash) {
8178 char *vmsptr2;
8179 vmsptr2 = vmsptr - 1;
8180
8181 if (*vmsptr2 != ']') {
8182 *vmsptr2--;
8183
8184 /* directories do not end in a dot bracket */
8185 if (*vmsptr2 == '.') {
8186 vmsptr2--;
8187
8188 /* ^. is allowed */
8189 if (*vmsptr2 != '^') {
8190 vmsptr--; /* back up over the dot */
8191 }
8192 }
8193 *vmsptr++ = ']';
8194 }
8195 }
8196 else {
8197 char *vmsptr2;
8198 /* Add a trailing dot if a file with no extension */
8199 vmsptr2 = vmsptr - 1;
360732b5
JM		 8200 if ((vmslen > 1) &&
8201 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
30e68285 8202 (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) {
2497a41f
JM		 8203 *vmsptr++ = '.';
8204 vmslen++;
8205 }
8206 }
8207
8208 *vmsptr = '\0';
8209 return SS$_NORMAL;
8210}
8211#endif
8212
360732b5
JM		 8213 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8214static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8215{
8216char * result;
8217int utf8_flag;
8218
8219 /* If a UTF8 flag is being passed, honor it */
8220 utf8_flag = 0;
8221 if (utf8_fl != NULL) {
8222 utf8_flag = *utf8_fl;
8223 *utf8_fl = 0;
8224 }
8225
8226 if (utf8_flag) {
8227 /* If there is a possibility of UTF8, then if any UTF8 characters
8228 are present, then they must be converted to VTF-7
8229 */
8230 result = strcpy(rslt, path); /* FIX-ME */
8231 }
8232 else
8233 result = strcpy(rslt, path);
8234
8235 return result;
8236}
8237
8238
df278665 8239
360732b5 8240/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
df278665
JM		 8241static char *int_tovmsspec
8242 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8243 char *dirend;
f7ddb74a 8244 char *lastdot;
eb578fdb 8245 char *cp1;
b8ffc8df 8246 const char *cp2;
e518068a 8247 unsigned long int infront = 0, hasdir = 1;
f7ddb74a
JM		 8248 int rslt_len;
8249 int no_type_seen;
360732b5
JM		 8250 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8251 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e 8252
df278665
JM		 8253 if (vms_debug_fileify) {
8254 if (path == NULL)
8255 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8256 else
8257 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8258 }
8259
8260 if (path == NULL) {
8261 /* If we fail, we should be setting errno */
8262 set_errno(EINVAL);
8263 set_vaxc_errno(SS$_BADPARAM);
8264 return NULL;
8265 }
4d743a9b 8266 rslt_len = VMS_MAXRSS-1;
360732b5
JM		 8267
8268 /* '.' and '..' are "[]" and "[-]" for a quick check */
8269 if (path[0] == '.') {
8270 if (path[1] == '\0') {
8271 strcpy(rslt,"[]");
8272 if (utf8_flag != NULL)
8273 *utf8_flag = 0;
8274 return rslt;
8275 }
8276 else {
8277 if (path[1] == '.' && path[2] == '\0') {
8278 strcpy(rslt,"[-]");
8279 if (utf8_flag != NULL)
8280 *utf8_flag = 0;
8281 return rslt;
8282 }
8283 }
a0d0e21e 8284 }
f7ddb74a 8285
2497a41f
JM		 8286 /* Posix specifications are now a native VMS format */
8287 /*--------------------------------------------------*/
8288#if __CRTL_VER >= 80200000 && !defined(__VAX)
8289 if (decc_posix_compliant_pathnames) {
8290 if (strncmp(path,"\"^UP^",5) == 0) {
360732b5 8291 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
2497a41f
JM		 8292 return rslt;
8293 }
8294 }
8295#endif
8296
360732b5
JM		 8297 /* This is really the only way to see if this is already in VMS format */
8298 sts = vms_split_path
8299 (path,
8300 &v_spec,
8301 &v_len,
8302 &r_spec,
8303 &r_len,
8304 &d_spec,
8305 &d_len,
8306 &n_spec,
8307 &n_len,
8308 &e_spec,
8309 &e_len,
8310 &vs_spec,
8311 &vs_len);
8312 if (sts == 0) {
8313 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8314 replacement, because the above parse just took care of most of
8315 what is needed to do vmspath when the specification is already
8316 in VMS format.
8317
8318 And if it is not already, it is easier to do the conversion as
8319 part of this routine than to call this routine and then work on
8320 the result.
8321 */
2497a41f 8322
360732b5
JM		 8323 /* If VMS punctuation was found, it is already VMS format */
8324 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8325 if (utf8_flag != NULL)
8326 *utf8_flag = 0;
a35dcc95 8327 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8328 if (vms_debug_fileify) {
8329 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8330 }
360732b5
JM		 8331 return rslt;
8332 }
8333 /* Now, what to do with trailing "." cases where there is no
8334 extension? If this is a UNIX specification, and EFS characters
8335 are enabled, then the trailing "." should be converted to a "^.".
8336 But if this was already a VMS specification, then it should be
8337 left alone.
2497a41f 8338
360732b5
JM		 8339 So in the case of ambiguity, leave the specification alone.
8340 */
2497a41f 8341
2497a41f 8342
360732b5
JM		 8343 /* If there is a possibility of UTF8, then if any UTF8 characters
8344 are present, then they must be converted to VTF-7
8345 */
8346 if (utf8_flag != NULL)
8347 *utf8_flag = 0;
a35dcc95 8348 my_strlcpy(rslt, path, VMS_MAXRSS);
df278665
JM		 8349 if (vms_debug_fileify) {
8350 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8351 }
2497a41f
JM		 8352 return rslt;
8353 }
8354
360732b5
JM		 8355 dirend = strrchr(path,'/');
8356
8357 if (dirend == NULL) {
8358 /* If we get here with no UNIX directory delimiters, then this is
b3efb248
CB		 8359 * not a complete file specification, such as a Unix glob
8360 * specification, shell macro, make macro, or even a valid VMS
8361 * filespec but with unescaped extended characters. The safest
8362 * thing in all these cases is to pass it through as-is.
360732b5 8363 */
b3efb248
CB		 8364 my_strlcpy(rslt, path, VMS_MAXRSS);
8365 if (vms_debug_fileify) {
8366 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
df278665 8367 }
b3efb248 8368 return rslt;
360732b5 8369 }
e645f6f8 8370 else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
748a9306
LW		 8371 if (!*(dirend+2)) dirend +=2;
8372 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
360732b5
JM		 8373 if (decc_efs_charset == 0) {
8374 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8375 }
748a9306 8376 }
f7ddb74a 8377
a0d0e21e
LW		 8378 cp1 = rslt;
8379 cp2 = path;
f7ddb74a 8380 lastdot = strrchr(cp2,'.');
a0d0e21e 8381 if (*cp2 == '/') {
a480973c 8382 char *trndev;
e518068a 8383 int islnm, rooted;
8384 STRLEN trnend;
8385
b7ae7a0d 8386 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
61bb5906 8387 if (!*(cp2+1)) {
f7ddb74a
JM		 8388 if (decc_disable_posix_root) {
8389 strcpy(rslt,"sys$disk:[000000]");
8390 }
8391 else {
8392 strcpy(rslt,"sys$posix_root:[000000]");
8393 }
360732b5
JM		 8394 if (utf8_flag != NULL)
8395 *utf8_flag = 0;
df278665
JM		 8396 if (vms_debug_fileify) {
8397 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8398 }
61bb5906
CB		 8399 return rslt;
8400 }
a0d0e21e 8401 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
e518068a 8402 *cp1 = '\0';
c11536f5 8403 trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 8404 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
b8486b9d 8405 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8406
8407 /* DECC special handling */
8408 if (!islnm) {
8409 if (strcmp(rslt,"bin") == 0) {
8410 strcpy(rslt,"sys$system");
8411 cp1 = rslt + 10;
8412 *cp1 = 0;
b8486b9d 8413 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8414 }
8415 else if (strcmp(rslt,"tmp") == 0) {
8416 strcpy(rslt,"sys$scratch");
8417 cp1 = rslt + 11;
8418 *cp1 = 0;
b8486b9d 8419 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8420 }
8421 else if (!decc_disable_posix_root) {
8422 strcpy(rslt, "sys$posix_root");
b8486b9d 8423 cp1 = rslt + 14;
f7ddb74a
JM		 8424 *cp1 = 0;
8425 cp2 = path;
8426 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
b8486b9d 8427 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8428 }
8429 else if (strcmp(rslt,"dev") == 0) {
8430 if (strncmp(cp2,"/null", 5) == 0) {
8431 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8432 strcpy(rslt,"NLA0");
8433 cp1 = rslt + 4;
8434 *cp1 = 0;
8435 cp2 = cp2 + 5;
b8486b9d 8436 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
f7ddb74a
JM		 8437 }
8438 }
8439 }
8440 }
8441
e518068a 8442 trnend = islnm ? strlen(trndev) - 1 : 0;
8443 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8444 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8445 /* If the first element of the path is a logical name, determine
8446 * whether it has to be translated so we can add more directories. */
8447 if (!islnm || rooted) {
8448 *(cp1++) = ':';
8449 *(cp1++) = '[';
8450 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8451 else cp2++;
8452 }
8453 else {
8454 if (cp2 != dirend) {
a35dcc95 8455 my_strlcpy(rslt, trndev, VMS_MAXRSS);
e518068a 8456 cp1 = rslt + trnend;
755b3d5d
JM		 8457 if (*cp2 != 0) {
8458 *(cp1++) = '.';
8459 cp2++;
8460 }
e518068a 8461 }
8462 else {
f7ddb74a
JM		 8463 if (decc_disable_posix_root) {
8464 *(cp1++) = ':';
8465 hasdir = 0;
8466 }
e518068a 8467 }
8468 }
367e4b85 8469 PerlMem_free(trndev);
748a9306 8470 }
a0d0e21e
LW		 8471 else {
8472 *(cp1++) = '[';
748a9306
LW		 8473 if (*cp2 == '.') {
8474 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8475 cp2 += 2; /* skip over "./" - it's redundant */
8476 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8477 }
8478 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8479 *(cp1++) = '-'; /* "../" --> "-" */
8480 cp2 += 3;
8481 }
f86702cc 8482 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8483 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8484 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8485 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8486 cp2 += 4;
8487 }
f7ddb74a
JM		 8488 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8489 /* Escape the extra dots in EFS file specifications */
8490 *(cp1++) = '^';
8491 }
748a9306
LW		 8492 if (cp2 > dirend) cp2 = dirend;
8493 }
8494 else *(cp1++) = '.';
8495 }
8496 for (; cp2 < dirend; cp2++) {
8497 if (*cp2 == '/') {
01b8edb6 8498 if (*(cp2-1) == '/') continue;
748a9306
LW		 8499 if (*(cp1-1) != '.') *(cp1++) = '.';
8500 infront = 0;
8501 }
8502 else if (!infront && *cp2 == '.') {
01b8edb6 8503 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8504 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
fd7385b9
CB		 8505 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8506 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
748a9306 8507 else if (*(cp1-2) == '[') *(cp1-1) = '-';
4ab1eb56
CB		 8508 else {
8509 *(cp1++) = '-';
748a9306
LW		 8510 }
8511 cp2 += 2;
01b8edb6 8512 if (cp2 == dirend) break;
748a9306 8513 }
f86702cc 8514 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8515 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8516 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8517 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8518 if (!*(cp2+3)) {
8519 *(cp1++) = '.'; /* Simulate trailing '/' */
8520 cp2 += 2; /* for loop will incr this to == dirend */
8521 }
8522 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8523 }
f7ddb74a
JM		 8524 else {
8525 if (decc_efs_charset == 0)
8526 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8527 else {
8528 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8529 *(cp1++) = '.';
8530 }
8531 }
748a9306
LW		 8532 }
8533 else {
e518068a 8534 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
f7ddb74a
JM		 8535 if (*cp2 == '.') {
8536 if (decc_efs_charset == 0)
8537 *(cp1++) = '_';
8538 else {
8539 *(cp1++) = '^';
8540 *(cp1++) = '.';
8541 }
8542 }
748a9306
LW		 8543 else *(cp1++) = *cp2;
8544 infront = 1;
8545 }
a0d0e21e 8546 }
748a9306 8547 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
e518068a 8548 if (hasdir) *(cp1++) = ']';
748a9306 8549 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
f7ddb74a
JM		 8550 /* fixme for ODS5 */
8551 no_type_seen = 0;
8552 if (cp2 > lastdot)
8553 no_type_seen = 1;
8554 while (*cp2) {
8555 switch(*cp2) {
8556 case '?':
360732b5
JM		 8557 if (decc_efs_charset == 0)
8558 *(cp1++) = '%';
8559 else
8560 *(cp1++) = '?';
f7ddb74a
JM		 8561 cp2++;
8562 case ' ':
8563 *(cp1)++ = '^';
8564 *(cp1)++ = '_';
8565 cp2++;
8566 break;
8567 case '.':
8568 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8569 decc_readdir_dropdotnotype) {
8570 *(cp1)++ = '^';
8571 *(cp1)++ = '.';
8572 cp2++;
8573
8574 /* trailing dot ==> '^..' on VMS */
8575 if (*cp2 == '\0') {
8576 *(cp1++) = '.';
8577 no_type_seen = 0;
8578 }
8579 }
8580 else {
8581 *(cp1++) = *(cp2++);
8582 no_type_seen = 0;
8583 }
8584 break;
360732b5
JM		 8585 case '$':
8586 /* This could be a macro to be passed through */
8587 *(cp1++) = *(cp2++);
8588 if (*cp2 == '(') {
8589 const char * save_cp2;
8590 char * save_cp1;
8591 int is_macro;
8592
8593 /* paranoid check */
8594 save_cp2 = cp2;
8595 save_cp1 = cp1;
8596 is_macro = 0;
8597
8598 /* Test through */
8599 *(cp1++) = *(cp2++);
8600 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8601 *(cp1++) = *(cp2++);
8602 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8603 *(cp1++) = *(cp2++);
8604 }
8605 if (*cp2 == ')') {
8606 *(cp1++) = *(cp2++);
8607 is_macro = 1;
8608 }
8609 }
8610 if (is_macro == 0) {
8611 /* Not really a macro - never mind */
8612 cp2 = save_cp2;
8613 cp1 = save_cp1;
8614 }
8615 }
8616 break;
f7ddb74a
JM		 8617 case '\"':
8618 case '~':
8619 case '`':
8620 case '!':
8621 case '#':
8622 case '%':
8623 case '^':
adc11f0b
CB		 8624 /* Don't escape again if following character is
8625 * already something we escape.
8626 */
8627 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8628 *(cp1++) = *(cp2++);
8629 break;
8630 }
8631 /* But otherwise fall through and escape it. */
f7ddb74a
JM		 8632 case '&':
8633 case '(':
8634 case ')':
8635 case '=':
8636 case '+':
8637 case '\'':
8638 case '@':
8639 case '[':
8640 case ']':
8641 case '{':
8642 case '}':
8643 case ':':
8644 case '\\':
8645 case '|':
8646 case '<':
8647 case '>':
8648 *(cp1++) = '^';
8649 *(cp1++) = *(cp2++);
8650 break;
8651 case ';':
8652 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
657054d4 8653 * which is wrong. UNIX notation should be ".dir." unless
f7ddb74a
JM		 8654 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8655 * changing this behavior could break more things at this time.
2497a41f
JM		 8656 * efs character set effectively does not allow "." to be a version
8657 * delimiter as a further complication about changing this.
f7ddb74a
JM		 8658 */
8659 if (decc_filename_unix_report != 0) {
8660 *(cp1++) = '^';
8661 }
8662 *(cp1++) = *(cp2++);
8663 break;
8664 default:
8665 *(cp1++) = *(cp2++);
8666 }
8667 }
8668 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8669 char *lcp1;
8670 lcp1 = cp1;
8671 lcp1--;
8672 /* Fix me for "^]", but that requires making sure that you do
8673 * not back up past the start of the filename
8674 */
8675 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8676 *cp1++ = '.';
8677 }
a0d0e21e
LW		 8678 *cp1 = '\0';
8679
360732b5
JM		 8680 if (utf8_flag != NULL)
8681 *utf8_flag = 0;
df278665
JM		 8682 if (vms_debug_fileify) {
8683 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8684 }
a0d0e21e
LW		 8685 return rslt;
8686
df278665
JM		 8687} /* end of int_tovmsspec() */
8688
8689
8690/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8691static char *mp_do_tovmsspec
8692 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8693 static char __tovmsspec_retbuf[VMS_MAXRSS];
8694 char * vmsspec, *ret_spec, *ret_buf;
8695
8696 vmsspec = NULL;
8697 ret_buf = buf;
8698 if (ret_buf == NULL) {
8699 if (ts) {
8700 Newx(vmsspec, VMS_MAXRSS, char);
8701 if (vmsspec == NULL)
8702 _ckvmssts(SS$_INSFMEM);
8703 ret_buf = vmsspec;
8704 } else {
8705 ret_buf = __tovmsspec_retbuf;
8706 }
8707 }
8708
8709 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8710
8711 if (ret_spec == NULL) {
8712 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8713 if (vmsspec)
8714 Safefree(vmsspec);
8715 }
8716
8717 return ret_spec;
8718
8719} /* end of mp_do_tovmsspec() */
a0d0e21e
LW		 8720/*}}}*/
8721/* External entry points */
360732b5
JM		 8722char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8723 { return do_tovmsspec(path,buf,0,NULL); }
8724char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8725 { return do_tovmsspec(path,buf,1,NULL); }
8726char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8727 { return do_tovmsspec(path,buf,0,utf8_fl); }
8728char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8729 { return do_tovmsspec(path,buf,1,utf8_fl); }
8730
4846f1d7 8731/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
94ae10c0 8732/* Internal routine for use with out an explicit context present */
4846f1d7
JM		 8733static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8734
8735 char * ret_spec, *pathified;
8736
8737 if (path == NULL)
8738 return NULL;
8739
c11536f5 8740 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
4846f1d7
JM		 8741 if (pathified == NULL)
8742 _ckvmssts_noperl(SS$_INSFMEM);
8743
8744 ret_spec = int_pathify_dirspec(path, pathified);
8745
8746 if (ret_spec == NULL) {
8747 PerlMem_free(pathified);
8748 return NULL;
8749 }
8750
8751 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8752
8753 PerlMem_free(pathified);
8754 return ret_spec;
8755
8756}
8757
360732b5
JM		 8758/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8759static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8760 static char __tovmspath_retbuf[VMS_MAXRSS];
a0d0e21e 8761 int vmslen;
a480973c 8762 char *pathified, *vmsified, *cp;
a0d0e21e 8763
748a9306 8764 if (path == NULL) return NULL;
c11536f5 8765 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 8766 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 8767 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 8768 PerlMem_free(pathified);
a480973c
JM		 8769 return NULL;
8770 }
c5375c28
JM		 8771
8772 vmsified = NULL;
8773 if (buf == NULL)
8774 Newx(vmsified, VMS_MAXRSS, char);
360732b5 8775 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
c5375c28
JM		 8776 PerlMem_free(pathified);
8777 if (vmsified) Safefree(vmsified);
a480973c
JM		 8778 return NULL;
8779 }
c5375c28 8780 PerlMem_free(pathified);
a480973c 8781 if (buf) {
a480973c
JM		 8782 return buf;
8783 }
a0d0e21e
LW		 8784 else if (ts) {
8785 vmslen = strlen(vmsified);
a02a5408 8786 Newx(cp,vmslen+1,char);
a0d0e21e
LW		 8787 memcpy(cp,vmsified,vmslen);
8788 cp[vmslen] = '\0';
a480973c 8789 Safefree(vmsified);
a0d0e21e
LW		 8790 return cp;
8791 }
8792 else {
a35dcc95 8793 my_strlcpy(__tovmspath_retbuf, vmsified, sizeof(__tovmspath_retbuf));
a480973c 8794 Safefree(vmsified);
a0d0e21e
LW		 8795 return __tovmspath_retbuf;
8796 }
8797
8798} /* end of do_tovmspath() */
8799/*}}}*/
8800/* External entry points */
360732b5
JM		 8801char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8802 { return do_tovmspath(path,buf,0, NULL); }
8803char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8804 { return do_tovmspath(path,buf,1, NULL); }
8805char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8806 { return do_tovmspath(path,buf,0,utf8_fl); }
8807char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8808 { return do_tovmspath(path,buf,1,utf8_fl); }
8809
8810
8811/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8812static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
a480973c 8813 static char __tounixpath_retbuf[VMS_MAXRSS];
a0d0e21e 8814 int unixlen;
a480973c 8815 char *pathified, *unixified, *cp;
a0d0e21e 8816
748a9306 8817 if (path == NULL) return NULL;
c11536f5 8818 pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 8819 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
1fe570cc 8820 if (int_pathify_dirspec(path, pathified) == NULL) {
c5375c28 8821 PerlMem_free(pathified);
a480973c
JM		 8822 return NULL;
8823 }
c5375c28
JM		 8824
8825 unixified = NULL;
8826 if (buf == NULL) {
8827 Newx(unixified, VMS_MAXRSS, char);
8828 }
360732b5 8829 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
c5375c28
JM		 8830 PerlMem_free(pathified);
8831 if (unixified) Safefree(unixified);
a480973c
JM		 8832 return NULL;
8833 }
c5375c28 8834 PerlMem_free(pathified);
a480973c 8835 if (buf) {
a480973c
JM		 8836 return buf;
8837 }
a0d0e21e
LW		 8838 else if (ts) {
8839 unixlen = strlen(unixified);
a02a5408 8840 Newx(cp,unixlen+1,char);
a0d0e21e
LW		 8841 memcpy(cp,unixified,unixlen);
8842 cp[unixlen] = '\0';
a480973c 8843 Safefree(unixified);
a0d0e21e
LW		 8844 return cp;
8845 }
8846 else {
a35dcc95 8847 my_strlcpy(__tounixpath_retbuf, unixified, sizeof(__tounixpath_retbuf));
a480973c 8848 Safefree(unixified);
a0d0e21e
LW		 8849 return __tounixpath_retbuf;
8850 }
8851
8852} /* end of do_tounixpath() */
8853/*}}}*/
8854/* External entry points */
360732b5
JM		 8855char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8856 { return do_tounixpath(path,buf,0,NULL); }
8857char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8858 { return do_tounixpath(path,buf,1,NULL); }
8859char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8860 { return do_tounixpath(path,buf,0,utf8_fl); }
8861char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8862 { return do_tounixpath(path,buf,1,utf8_fl); }
a0d0e21e
LW		 8863
8864/*
cbb8049c 8865 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8866 *
8867 *****************************************************************************
8868 * *
cbb8049c 8869 * Copyright (C) 1989-1994, 2007 by *
a0d0e21e
LW		 8870 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8871 * *
cbb8049c
MP		 8872 * Permission is hereby granted for the reproduction of this software *
8873 * on condition that this copyright notice is included in source *
8874 * distributions of the software. The code may be modified and *
8875 * distributed under the same terms as Perl itself. *
a0d0e21e
LW		 8876 * *
8877 * 27-Aug-1994 Modified for inclusion in perl5 *
cbb8049c 8878 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
a0d0e21e
LW		 8879 *****************************************************************************
8880 */
8881
8882/*
8883 * getredirection() is intended to aid in porting C programs
8884 * to VMS (Vax-11 C). The native VMS environment does not support
8885 * '>' and '<' I/O redirection, or command line wild card expansion,
8886 * or a command line pipe mechanism using the '|' AND background
8887 * command execution '&'. All of these capabilities are provided to any
8888 * C program which calls this procedure as the first thing in the
8889 * main program.
8890 * The piping mechanism will probably work with almost any 'filter' type
8891 * of program. With suitable modification, it may useful for other
8892 * portability problems as well.
8893 *
cbb8049c 8894 * Author: Mark Pizzolato (mark AT infocomm DOT com)
a0d0e21e
LW		 8895 */
8896struct list_item
8897 {
8898 struct list_item *next;
8899 char *value;
8900 };
8901
8902static void add_item(struct list_item **head,
8903 struct list_item **tail,
8904 char *value,
8905 int *count);
8906
4b19af01
CB		 8907static void mp_expand_wild_cards(pTHX_ char *item,
8908 struct list_item **head,
8909 struct list_item **tail,
8910 int *count);
a0d0e21e 8911
8df869cb 8912static int background_process(pTHX_ int argc, char **argv);
a0d0e21e 8913
fd8cd3a3 8914static void pipe_and_fork(pTHX_ char **cmargv);
a0d0e21e
LW		 8915
8916/*{{{ void getredirection(int *ac, char ***av)*/
84902520 8917static void
4b19af01 8918mp_getredirection(pTHX_ int *ac, char ***av)
a0d0e21e
LW		 8919/*
8920 * Process vms redirection arg's. Exit if any error is seen.
8921 * If getredirection() processes an argument, it is erased
8922 * from the vector. getredirection() returns a new argc and argv value.
8923 * In the event that a background command is requested (by a trailing "&"),
8924 * this routine creates a background subprocess, and simply exits the program.
8925 *
8926 * Warning: do not try to simplify the code for vms. The code
8927 * presupposes that getredirection() is called before any data is
8928 * read from stdin or written to stdout.
8929 *
8930 * Normal usage is as follows:
8931 *
8932 * main(argc, argv)
8933 * int argc;
8934 * char *argv[];
8935 * {
8936 * getredirection(&argc, &argv);
8937 * }
8938 */
8939{
8940 int argc = *ac; /* Argument Count */
8941 char **argv = *av; /* Argument Vector */
8942 char *ap; /* Argument pointer */
8943 int j; /* argv[] index */
8944 int item_count = 0; /* Count of Items in List */
8945 struct list_item *list_head = 0; /* First Item in List */
8946 struct list_item *list_tail; /* Last Item in List */
8947 char *in = NULL; /* Input File Name */
8948 char *out = NULL; /* Output File Name */
8949 char *outmode = "w"; /* Mode to Open Output File */
8950 char *err = NULL; /* Error File Name */
8951 char *errmode = "w"; /* Mode to Open Error File */
8952 int cmargc = 0; /* Piped Command Arg Count */
8953 char **cmargv = NULL;/* Piped Command Arg Vector */
a0d0e21e
LW		 8954
8955 /*
8956 * First handle the case where the last thing on the line ends with
8957 * a '&'. This indicates the desire for the command to be run in a
8958 * subprocess, so we satisfy that desire.
8959 */
8960 ap = argv[argc-1];
8961 if (0 == strcmp("&", ap))
8c3eed29 8962 exit(background_process(aTHX_ --argc, argv));
e518068a 8963 if (*ap && '&' == ap[strlen(ap)-1])
a0d0e21e
LW		 8964 {
8965 ap[strlen(ap)-1] = '\0';
8c3eed29 8966 exit(background_process(aTHX_ argc, argv));
a0d0e21e
LW		 8967 }
8968 /*
8969 * Now we handle the general redirection cases that involve '>', '>>',
8970 * '<', and pipes '|'.
8971 */
8972 for (j = 0; j < argc; ++j)
8973 {
8974 if (0 == strcmp("<", argv[j]))
8975 {
8976 if (j+1 >= argc)
8977 {
fd71b04b 8978 fprintf(stderr,"No input file after < on command line");
748a9306 8979 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8980 }
8981 in = argv[++j];
8982 continue;
8983 }
8984 if ('<' == *(ap = argv[j]))
8985 {
8986 in = 1 + ap;
8987 continue;
8988 }
8989 if (0 == strcmp(">", ap))
8990 {
8991 if (j+1 >= argc)
8992 {
fd71b04b 8993 fprintf(stderr,"No output file after > on command line");
748a9306 8994 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 8995 }
8996 out = argv[++j];
8997 continue;
8998 }
8999 if ('>' == *ap)
9000 {
9001 if ('>' == ap[1])
9002 {
9003 outmode = "a";
9004 if ('\0' == ap[2])
9005 out = argv[++j];
9006 else
9007 out = 2 + ap;
9008 }
9009 else
9010 out = 1 + ap;
9011 if (j >= argc)
9012 {
fd71b04b 9013 fprintf(stderr,"No output file after > or >> on command line");
748a9306 9014 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9015 }
9016 continue;
9017 }
9018 if (('2' == *ap) && ('>' == ap[1]))
9019 {
9020 if ('>' == ap[2])
9021 {
9022 errmode = "a";
9023 if ('\0' == ap[3])
9024 err = argv[++j];
9025 else
9026 err = 3 + ap;
9027 }
9028 else
9029 if ('\0' == ap[2])
9030 err = argv[++j];
9031 else
748a9306 9032 err = 2 + ap;
a0d0e21e
LW		 9033 if (j >= argc)
9034 {
fd71b04b 9035 fprintf(stderr,"No output file after 2> or 2>> on command line");
748a9306 9036 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9037 }
9038 continue;
9039 }
9040 if (0 == strcmp("|", argv[j]))
9041 {
9042 if (j+1 >= argc)
9043 {
fd71b04b 9044 fprintf(stderr,"No command into which to pipe on command line");
748a9306 9045 exit(LIB$_WRONUMARG);
a0d0e21e
LW		 9046 }
9047 cmargc = argc-(j+1);
9048 cmargv = &argv[j+1];
9049 argc = j;
9050 continue;
9051 }
9052 if ('|' == *(ap = argv[j]))
9053 {
9054 ++argv[j];
9055 cmargc = argc-j;
9056 cmargv = &argv[j];
9057 argc = j;
9058 continue;
9059 }
9060 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9061 }
9062 /*
9063 * Allocate and fill in the new argument vector, Some Unix's terminate
9064 * the list with an extra null pointer.
9065 */
e0ef6b43 9066 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
c5375c28 9067 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9068 *av = argv;
9069 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9070 argv[j] = list_head->value;
9071 *ac = item_count;
9072 if (cmargv != NULL)
9073 {
9074 if (out != NULL)
9075 {
fd71b04b 9076 fprintf(stderr,"'|' and '>' may not both be specified on command line");
748a9306 9077 exit(LIB$_INVARGORD);
a0d0e21e 9078 }
fd8cd3a3 9079 pipe_and_fork(aTHX_ cmargv);
a0d0e21e
LW		 9080 }
9081
9082 /* Check for input from a pipe (mailbox) */
9083
a5f75d66 9084 if (in == NULL && 1 == isapipe(0))
a0d0e21e
LW		 9085 {
9086 char mbxname[L_tmpnam];
9087 long int bufsize;
9088 long int dvi_item = DVI$_DEVBUFSIZ;
9089 $DESCRIPTOR(mbxnam, "");
9090 $DESCRIPTOR(mbxdevnam, "");
9091
9092 /* Input from a pipe, reopen it in binary mode to disable */
9093 /* carriage control processing. */
9094
bf8d1304 9095 fgetname(stdin, mbxname, 1);
a0d0e21e
LW		 9096 mbxnam.dsc$a_pointer = mbxname;
9097 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9098 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9099 mbxdevnam.dsc$a_pointer = mbxname;
9100 mbxdevnam.dsc$w_length = sizeof(mbxname);
9101 dvi_item = DVI$_DEVNAM;
9102 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9103 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
748a9306
LW		 9104 set_errno(0);
9105 set_vaxc_errno(1);
a0d0e21e
LW		 9106 freopen(mbxname, "rb", stdin);
9107 if (errno != 0)
9108 {
fd71b04b 9109 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
748a9306 9110 exit(vaxc$errno);
a0d0e21e
LW		 9111 }
9112 }
9113 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9114 {
fd71b04b 9115 fprintf(stderr,"Can't open input file %s as stdin",in);
748a9306 9116 exit(vaxc$errno);
a0d0e21e
LW		 9117 }
9118 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9119 {
fd71b04b 9120 fprintf(stderr,"Can't open output file %s as stdout",out);
748a9306 9121 exit(vaxc$errno);
a0d0e21e 9122 }
0db50132 9123 if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
0e06870b 9124
748a9306 9125 if (err != NULL) {
71d7ec5d 9126 if (strcmp(err,"&1") == 0) {
a15cef0c 9127 dup2(fileno(stdout), fileno(stderr));
0db50132 9128 vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
71d7ec5d 9129 } else {
748a9306
LW		 9130 FILE *tmperr;
9131 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9132 {
fd71b04b 9133 fprintf(stderr,"Can't open error file %s as stderr",err);
748a9306
LW		 9134 exit(vaxc$errno);
9135 }
9136 fclose(tmperr);
a15cef0c 9137 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
748a9306
LW		 9138 {
9139 exit(vaxc$errno);
9140 }
0db50132 9141 vmssetuserlnm("SYS$ERROR", err);
a0d0e21e 9142 }
71d7ec5d 9143 }
a0d0e21e 9144#ifdef ARGPROC_DEBUG
740ce14c 9145 PerlIO_printf(Perl_debug_log, "Arglist:\n");
a0d0e21e 9146 for (j = 0; j < *ac; ++j)
740ce14c 9147 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
a0d0e21e 9148#endif
b7ae7a0d 9149 /* Clear errors we may have hit expanding wildcards, so they don't
9150 show up in Perl's $! later */
9151 set_errno(0); set_vaxc_errno(1);
a0d0e21e
LW		 9152} /* end of getredirection() */
9153/*}}}*/
9154
9155static void add_item(struct list_item **head,
9156 struct list_item **tail,
9157 char *value,
9158 int *count)
9159{
9160 if (*head == 0)
9161 {
e0ef6b43 9162 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9163 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9164 *tail = *head;
9165 }
9166 else {
e0ef6b43 9167 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
c5375c28 9168 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e
LW		 9169 *tail = (*tail)->next;
9170 }
9171 (*tail)->value = value;
9172 ++(*count);
9173}
9174
4b19af01 9175static void mp_expand_wild_cards(pTHX_ char *item,
a0d0e21e
LW		 9176 struct list_item **head,
9177 struct list_item **tail,
9178 int *count)
9179{
9180int expcount = 0;
748a9306 9181unsigned long int context = 0;
a0d0e21e 9182int isunix = 0;
773da73d 9183int item_len = 0;
a0d0e21e
LW		 9184char *had_version;
9185char *had_device;
9186int had_directory;
f675dbe5 9187char *devdir,*cp;
a480973c 9188char *vmsspec;
a0d0e21e 9189$DESCRIPTOR(filespec, "");
748a9306 9190$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
a0d0e21e 9191$DESCRIPTOR(resultspec, "");
a480973c
JM		 9192unsigned long int lff_flags = 0;
9193int sts;
dca5a913 9194int rms_sts;
a480973c
JM		 9195
9196#ifdef VMS_LONGNAME_SUPPORT
9197 lff_flags = LIB$M_FIL_LONG_NAMES;
9198#endif
a0d0e21e 9199
f675dbe5
CB		 9200 for (cp = item; *cp; cp++) {
9201 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9202 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9203 }
9204 if (!*cp || isspace(*cp))
a0d0e21e
LW		 9205 {
9206 add_item(head, tail, item, count);
9207 return;
9208 }
773da73d
JH		 9209 else
9210 {
9211 /* "double quoted" wild card expressions pass as is */
9212 /* From DCL that means using e.g.: */
9213 /* perl program """perl.*""" */
9214 item_len = strlen(item);
9215 if ( '"' == *item && '"' == item[item_len-1] )
9216 {
9217 item++;
9218 item[item_len-2] = '\0';
9219 add_item(head, tail, item, count);
9220 return;
9221 }
9222 }
a0d0e21e
LW		 9223 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9224 resultspec.dsc$b_class = DSC$K_CLASS_D;
9225 resultspec.dsc$a_pointer = NULL;
c11536f5 9226 vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
c5375c28 9227 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
748a9306 9228 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
df278665 9229 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
a0d0e21e
LW		 9230 if (!isunix || !filespec.dsc$a_pointer)
9231 filespec.dsc$a_pointer = item;
9232 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9233 /*
9234 * Only return version specs, if the caller specified a version
9235 */
9236 had_version = strchr(item, ';');
9237 /*
94ae10c0 9238 * Only return device and directory specs, if the caller specified either.
a0d0e21e
LW		 9239 */
9240 had_device = strchr(item, ':');
9241 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9242
a480973c
JM		 9243 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9244 (&filespec, &resultspec, &context,
dca5a913 9245 &defaultspec, 0, &rms_sts, &lff_flags)))
a0d0e21e
LW		 9246 {
9247 char *string;
9248 char *c;
9249
c11536f5 9250 string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
c5375c28 9251 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
db4c2905 9252 my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
a0d0e21e 9253 if (NULL == had_version)
f7ddb74a 9254 *(strrchr(string, ';')) = '\0';
a0d0e21e
LW		 9255 if ((!had_directory) && (had_device == NULL))
9256 {
9257 if (NULL == (devdir = strrchr(string, ']')))
9258 devdir = strrchr(string, '>');
db4c2905 9259 my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1);
a0d0e21e
LW		 9260 }
9261 /*
9262 * Be consistent with what the C RTL has already done to the rest of
9263 * the argv items and lowercase all of these names.
9264 */
f7ddb74a
JM		 9265 if (!decc_efs_case_preserve) {
9266 for (c = string; *c; ++c)
a0d0e21e
LW		 9267 if (isupper(*c))
9268 *c = tolower(*c);
f7ddb74a 9269 }
f86702cc 9270 if (isunix) trim_unixpath(string,item,1);
a0d0e21e
LW		 9271 add_item(head, tail, string, count);
9272 ++expcount;
a480973c 9273 }
367e4b85 9274 PerlMem_free(vmsspec);
c07a80fd 9275 if (sts != RMS$_NMF)
9276 {
9277 set_vaxc_errno(sts);
9278 switch (sts)
9279 {
f282b18d 9280 case RMS$_FNF: case RMS$_DNF:
c07a80fd 9281 set_errno(ENOENT); break;
f282b18d
CB		 9282 case RMS$_DIR:
9283 set_errno(ENOTDIR); break;
c07a80fd 9284 case RMS$_DEV:
9285 set_errno(ENODEV); break;
f282b18d 9286 case RMS$_FNM: case RMS$_SYN:
c07a80fd 9287 set_errno(EINVAL); break;
9288 case RMS$_PRV:
9289 set_errno(EACCES); break;
9290 default:
b7ae7a0d 9291 _ckvmssts_noperl(sts);
c07a80fd 9292 }
9293 }
a0d0e21e
LW		 9294 if (expcount == 0)
9295 add_item(head, tail, item, count);
b7ae7a0d 9296 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9297 _ckvmssts_noperl(lib$find_file_end(&context));
a0d0e21e
LW		 9298}
9299
9300static int child_st[2];/* Event Flag set when child process completes */
9301
748a9306 9302static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
a0d0e21e 9303
f7c699a0 9304static unsigned long int exit_handler(void)
a0d0e21e
LW		 9305{
9306short iosb[4];
9307
9308 if (0 == child_st[0])
9309 {
9310#ifdef ARGPROC_DEBUG
740ce14c 9311 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
a0d0e21e
LW		 9312#endif
9313 fflush(stdout); /* Have to flush pipe for binary data to */
9314 /* terminate properly -- <tp@mccall.com> */
9315 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9316 sys$dassgn(child_chan);
9317 fclose(stdout);
9318 sys$synch(0, child_st);
9319 }
9320 return(1);
9321}
9322
9323static void sig_child(int chan)
9324{
9325#ifdef ARGPROC_DEBUG
740ce14c 9326 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
a0d0e21e
LW		 9327#endif
9328 if (child_st[0] == 0)
9329 child_st[0] = 1;
9330}
9331
748a9306 9332static struct exit_control_block exit_block =
a0d0e21e
LW		 9333 {
9334 0,
9335 exit_handler,
9336 1,
9337 &exit_block.exit_status,
9338 0
9339 };
9340
ff7adb52
CL		 9341static void
9342pipe_and_fork(pTHX_ char **cmargv)
a0d0e21e 9343{
ff7adb52 9344 PerlIO *fp;
218fdd94 9345 struct dsc$descriptor_s *vmscmd;
ff7adb52
CL		 9346 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9347 int sts, j, l, ismcr, quote, tquote = 0;
9348
218fdd94
CL		 9349 sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9350 vms_execfree(vmscmd);
ff7adb52
CL		 9351
9352 j = l = 0;
9353 p = subcmd;
9354 q = cmargv[0];
9355 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9356 && toupper(*(q+2)) == 'R' && !*(q+3);
9357
9358 while (q && l < MAX_DCL_LINE_LENGTH) {
9359 if (!*q) {
9360 if (j > 0 && quote) {
9361 *p++ = '"';
9362 l++;
9363 }
9364 q = cmargv[++j];
9365 if (q) {
9366 if (ismcr && j > 1) quote = 1;
9367 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9368 *p++ = ' ';
9369 l++;
9370 if (quote || tquote) {
9371 *p++ = '"';
9372 l++;
9373 }
988c775c 9374 }
ff7adb52
CL		 9375 } else {
9376 if ((quote||tquote) && *q == '"') {
9377 *p++ = '"';
9378 l++;
988c775c 9379 }
ff7adb52
CL		 9380 *p++ = *q++;
9381 l++;
9382 }
9383 }
9384 *p = '\0';
a0d0e21e 9385
218fdd94 9386 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4e205ed6 9387 if (fp == NULL) {
ff7adb52 9388 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
988c775c 9389 }
a0d0e21e
LW		 9390}
9391
8df869cb 9392static int background_process(pTHX_ int argc, char **argv)
a0d0e21e 9393{
a480973c 9394char command[MAX_DCL_SYMBOL + 1] = "$";
a0d0e21e
LW		 9395$DESCRIPTOR(value, "");
9396static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9397static $DESCRIPTOR(null, "NLA0:");
9398static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9399char pidstring[80];
9400$DESCRIPTOR(pidstr, "");
9401int pid;
748a9306 9402unsigned long int flags = 17, one = 1, retsts;
a480973c 9403int len;
a0d0e21e 9404
a35dcc95 9405 len = my_strlcat(command, argv[0], sizeof(command));
a480973c 9406 while (--argc && (len < MAX_DCL_SYMBOL))
a0d0e21e 9407 {
a35dcc95
CB		 9408 my_strlcat(command, " \"", sizeof(command));
9409 my_strlcat(command, *(++argv), sizeof(command));
9410 len = my_strlcat(command, "\"", sizeof(command));
a0d0e21e
LW		 9411 }
9412 value.dsc$a_pointer = command;
9413 value.dsc$w_length = strlen(value.dsc$a_pointer);
b7ae7a0d 9414 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
748a9306
LW		 9415 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9416 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
b7ae7a0d 9417 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
748a9306
LW		 9418 }
9419 else {
b7ae7a0d 9420 _ckvmssts_noperl(retsts);
748a9306 9421 }
a0d0e21e 9422#ifdef ARGPROC_DEBUG
740ce14c 9423 PerlIO_printf(Perl_debug_log, "%s\n", command);
a0d0e21e
LW		 9424#endif
9425 sprintf(pidstring, "%08X", pid);
740ce14c 9426 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
a0d0e21e
LW		 9427 pidstr.dsc$a_pointer = pidstring;
9428 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9429 lib$set_symbol(&pidsymbol, &pidstr);
9430 return(SS$_NORMAL);
9431}
9432/*}}}*/
9433/***** End of code taken from Mark Pizzolato's argproc.c package *****/
9434
84902520
TB		 9435
9436/* OS-specific initialization at image activation (not thread startup) */
61bb5906
CB		 9437/* Older VAXC header files lack these constants */
9438#ifndef JPI$_RIGHTS_SIZE
9439# define JPI$_RIGHTS_SIZE 817
9440#endif
9441#ifndef KGB$M_SUBSYSTEM
9442# define KGB$M_SUBSYSTEM 0x8
9443#endif
a480973c 9444
e0ef6b43
CB		 9445/* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9446
84902520
TB		 9447/*{{{void vms_image_init(int *, char ***)*/
9448void
9449vms_image_init(int *argcp, char ***argvp)
9450{
b53f3677 9451 int status;
f675dbe5
CB		 9452 char eqv[LNM$C_NAMLENGTH+1] = "";
9453 unsigned int len, tabct = 8, tabidx = 0;
9454 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
61bb5906
CB		 9455 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9456 unsigned short int dummy, rlen;
f675dbe5 9457 struct dsc$descriptor_s **tabvec;
fd8cd3a3
DS		 9458#if defined(PERL_IMPLICIT_CONTEXT)
9459 pTHX = NULL;
9460#endif
61bb5906
CB		 9461 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9462 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9463 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9464 { 0, 0, 0, 0} };
84902520 9465
2e34cc90 9466#ifdef KILL_BY_SIGPRC
f7ddb74a 9467 Perl_csighandler_init();
2e34cc90
CL		 9468#endif
9469
778e045f 9470#if __CRTL_VER >= 70300000 && !defined(__VAX)
b53f3677
JM		 9471 /* This was moved from the pre-image init handler because on threaded */
9472 /* Perl it was always returning 0 for the default value. */
98c7875d 9473 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
b53f3677
JM		 9474 if (status > 0) {
9475 int s;
9476 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9477 if (s > 0) {
9478 int initial;
9479 initial = decc$feature_get_value(s, 4);
98c7875d
CB		 9480 if (initial > 0) {
9481 /* initial is: 0 if nothing has set the feature */
9482 /* -1 if initialized to default */
9483 /* 1 if set by logical name */
9484 /* 2 if set by decc$feature_set_value */
b53f3677
JM		 9485 decc_disable_posix_root = decc$feature_get_value(s, 1);
9486
9487 /* If the value is not valid, force the feature off */
9488 if (decc_disable_posix_root < 0) {
9489 decc$feature_set_value(s, 1, 1);
9490 decc_disable_posix_root = 1;
9491 }
9492 }
9493 else {
98c7875d 9494 /* Nothing has asked for it explicitly, so use our own default. */
b53f3677
JM		 9495 decc_disable_posix_root = 1;
9496 decc$feature_set_value(s, 1, 1);
9497 }
9498 }
9499 }
778e045f 9500#endif
b53f3677 9501
fd8cd3a3
DS		 9502 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9503 _ckvmssts_noperl(iosb[0]);
61bb5906
CB		 9504 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9505 if (iprv[i]) { /* Running image installed with privs? */
fd8cd3a3 9506 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
f675dbe5 9507 will_taint = TRUE;
84902520
TB		 9508 break;
9509 }
9510 }
61bb5906 9511 /* Rights identifiers might trigger tainting as well. */
f675dbe5 9512 if (!will_taint && (rlen || rsz)) {
61bb5906
CB		 9513 while (rlen < rsz) {
9514 /* We didn't get all the identifiers on the first pass. Allocate a
9515 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9516 * were needed to hold all identifiers at time of last call; we'll
9517 * allocate that many unsigned long ints), and go back and get 'em.
22d4bb9c
CB		 9518 * If it gave us less than it wanted to despite ample buffer space,
9519 * something's broken. Is your system missing a system identifier?
61bb5906 9520 */
22d4bb9c
CB		 9521 if (rsz <= jpilist[1].buflen) {
9522 /* Perl_croak accvios when used this early in startup. */
9523 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9524 rsz, (unsigned long) jpilist[1].buflen,
9525 "Check your rights database for corruption.\n");
9526 exit(SS$_ABORT);
9527 }
e0ef6b43
CB		 9528 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9529 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
c5375c28 9530 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
61bb5906 9531 jpilist[1].buflen = rsz * sizeof(unsigned long int);
fd8cd3a3
DS		 9532 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9533 _ckvmssts_noperl(iosb[0]);
61bb5906 9534 }
c11536f5 9535 mask = (unsigned long int *)jpilist[1].bufadr;
61bb5906
CB		 9536 /* Check attribute flags for each identifier (2nd longword); protected
9537 * subsystem identifiers trigger tainting.
9538 */
9539 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9540 if (mask[i] & KGB$M_SUBSYSTEM) {
f675dbe5 9541 will_taint = TRUE;
61bb5906
CB		 9542 break;
9543 }
9544 }
367e4b85 9545 if (mask != rlst) PerlMem_free(mask);
61bb5906 9546 }
f7ddb74a
JM		 9547
9548 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9549 * logical, some versions of the CRTL will add a phanthom /000000/
9550 * directory. This needs to be removed.
9551 */
9552 if (decc_filename_unix_report) {
9553 char * zeros;
9554 int ulen;
9555 ulen = strlen(argvp[0][0]);
9556 if (ulen > 7) {
9557 zeros = strstr(argvp[0][0], "/000000/");
9558 if (zeros != NULL) {
9559 int mlen;
9560 mlen = ulen - (zeros - argvp[0][0]) - 7;
9561 memmove(zeros, &zeros[7], mlen);
9562 ulen = ulen - 7;
9563 argvp[0][0][ulen] = '\0';
9564 }
9565 }
9566 /* It also may have a trailing dot that needs to be removed otherwise
9567 * it will be converted to VMS mode incorrectly.
9568 */
9569 ulen--;
9570 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9571 argvp[0][0][ulen] = '\0';
9572 }
9573
61bb5906 9574 /* We need to use this hack to tell Perl it should run with tainting,
6b88bc9c 9575 * since its tainting flag may be part of the PL_curinterp struct, which
61bb5906
CB		 9576 * hasn't been allocated when vms_image_init() is called.
9577 */
f675dbe5 9578 if (will_taint) {
ec618cdf
CB		 9579 char **newargv, **oldargv;
9580 oldargv = *argvp;
e0ef6b43 9581 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
c5375c28 9582 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf 9583 newargv[0] = oldargv[0];
c11536f5 9584 newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
c5375c28 9585 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ec618cdf
CB		 9586 strcpy(newargv[1], "-T");
9587 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9588 (*argcp)++;
9589 newargv[*argcp] = NULL;
61bb5906
CB		 9590 /* We orphan the old argv, since we don't know where it's come from,
9591 * so we don't know how to free it.
9592 */
ec618cdf 9593 *argvp = newargv;
61bb5906 9594 }
f675dbe5
CB		 9595 else { /* Did user explicitly request tainting? */
9596 int i;
9597 char *cp, **av = *argvp;
9598 for (i = 1; i < *argcp; i++) {
9599 if (*av[i] != '-') break;
9600 for (cp = av[i]+1; *cp; cp++) {
9601 if (*cp == 'T') { will_taint = 1; break; }
9602 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9603 strchr("DFIiMmx",*cp)) break;
9604 }
9605 if (will_taint) break;
9606 }
9607 }
9608
9609 for (tabidx = 0;
9610 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9611 tabidx++) {
c5375c28
JM		 9612 if (!tabidx) {
9613 tabvec = (struct dsc$descriptor_s **)
9614 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9615 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9616 }
f675dbe5
CB		 9617 else if (tabidx >= tabct) {
9618 tabct += 8;
e0ef6b43 9619 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
c5375c28 9620 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5 9621 }
e0ef6b43 9622 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
c5375c28 9623 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
f675dbe5
CB		 9624 tabvec[tabidx]->dsc$w_length = 0;
9625 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9626 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9627 tabvec[tabidx]->dsc$a_pointer = NULL;
fd8cd3a3 9628 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
f675dbe5
CB		 9629 }
9630 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9631
84902520 9632 getredirection(argcp,argvp);
3bc25146
CB		 9633#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9634 {
9635# include <reentrancy.h>
f7ddb74a 9636 decc$set_reentrancy(C$C_MULTITHREAD);
3bc25146
CB		 9637 }
9638#endif
84902520
TB		 9639 return;
9640}
9641/*}}}*/
9642
9643
a0d0e21e
LW		 9644/* trim_unixpath()
9645 * Trim Unix-style prefix off filespec, so it looks like what a shell
9646 * glob expansion would return (i.e. from specified prefix on, not
9647 * full path). Note that returned filespec is Unix-style, regardless
9648 * of whether input filespec was VMS-style or Unix-style.
9649 *
a3e9d8c9 9650 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
f86702cc 9651 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9652 * vector of options; at present, only bit 0 is used, and if set tells
9653 * trim unixpath to try the current default directory as a prefix when
9654 * presented with a possibly ambiguous ... wildcard.
a3e9d8c9 9655 *
9656 * Returns !=0 on success, with trimmed filespec replacing contents of
9657 * fspec, and 0 on failure, with contents of fpsec unchanged.
a0d0e21e 9658 */
f86702cc 9659/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
a0d0e21e 9660int
2fbb330f 9661Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
a0d0e21e 9662{
c11536f5 9663 char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
eb578fdb 9664 int tmplen, reslen = 0, dirs = 0;
a0d0e21e 9665
a3e9d8c9 9666 if (!wildspec || !fspec) return 0;
ebd4d70b 9667
c11536f5 9668 unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9669 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9670 tplate = unixwild;
a3e9d8c9 9671 if (strpbrk(wildspec,"]>:") != NULL) {
0e5ce2c7 9672 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
367e4b85 9673 PerlMem_free(unixwild);
a480973c
JM		 9674 return 0;
9675 }
a3e9d8c9 9676 }
2fbb330f 9677 else {
a35dcc95 9678 my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
2fbb330f 9679 }
c11536f5 9680 unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9681 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a0d0e21e 9682 if (strpbrk(fspec,"]>:") != NULL) {
0e5ce2c7 9683 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
367e4b85
JM		 9684 PerlMem_free(unixwild);
9685 PerlMem_free(unixified);
a480973c
JM		 9686 return 0;
9687 }
a0d0e21e 9688 else base = unixified;
a3e9d8c9 9689 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9690 * check to see that final result fits into (isn't longer than) fspec */
9691 reslen = strlen(fspec);
a0d0e21e
LW		 9692 }
9693 else base = fspec;
a3e9d8c9 9694
9695 /* No prefix or absolute path on wildcard, so nothing to remove */
c11536f5 9696 if (!*tplate || *tplate == '/') {
367e4b85 9697 PerlMem_free(unixwild);
a480973c 9698 if (base == fspec) {
367e4b85 9699 PerlMem_free(unixified);
a480973c
JM		 9700 return 1;
9701 }
a3e9d8c9 9702 tmplen = strlen(unixified);
a480973c 9703 if (tmplen > reslen) {
367e4b85 9704 PerlMem_free(unixified);
a480973c
JM		 9705 return 0; /* not enough space */
9706 }
a3e9d8c9 9707 /* Copy unixified resultant, including trailing NUL */
9708 memmove(fspec,unixified,tmplen+1);
367e4b85 9709 PerlMem_free(unixified);
a3e9d8c9 9710 return 1;
9711 }
a0d0e21e 9712
f86702cc 9713 for (end = base; *end; end++) ; /* Find end of resultant filespec */
c11536f5
CB		 9714 if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
9715 for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
f86702cc 9716 for (cp1 = end ;cp1 >= base; cp1--)
9717 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9718 { cp1++; break; }
9719 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
367e4b85
JM		 9720 PerlMem_free(unixified);
9721 PerlMem_free(unixwild);
a3e9d8c9 9722 return 1;
9723 }
f86702cc 9724 else {
a480973c 9725 char *tpl, *lcres;
f86702cc 9726 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9727 int ells = 1, totells, segdirs, match;
a480973c 9728 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
f86702cc 9729 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9730
9731 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9732 totells = ells;
9733 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
c11536f5 9734 tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9735 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9736 if (ellipsis == tplate && opts & 1) {
f86702cc 9737 /* Template begins with an ellipsis. Since we can't tell how many
9738 * directory names at the front of the resultant to keep for an
9739 * arbitrary starting point, we arbitrarily choose the current
9740 * default directory as a starting point. If it's there as a prefix,
9741 * clip it off. If not, fall through and act as if the leading
9742 * ellipsis weren't there (i.e. return shortest possible path that
9743 * could match template).
9744 */
a480973c 9745 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
367e4b85
JM		 9746 PerlMem_free(tpl);
9747 PerlMem_free(unixified);
9748 PerlMem_free(unixwild);
a480973c
JM		 9749 return 0;
9750 }
f7ddb74a
JM		 9751 if (!decc_efs_case_preserve) {
9752 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9753 if (_tolower(*cp1) != _tolower(*cp2)) break;
9754 }
f86702cc 9755 segdirs = dirs - totells; /* Min # of dirs we must have left */
9756 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9757 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
18a3d61e 9758 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9759 PerlMem_free(tpl);
9760 PerlMem_free(unixified);
9761 PerlMem_free(unixwild);
f86702cc 9762 return 1;
a3e9d8c9 9763 }
a3e9d8c9 9764 }
f86702cc 9765 /* First off, back up over constant elements at end of path */
9766 if (dirs) {
9767 for (front = end ; front >= base; front--)
9768 if (*front == '/' && !dirs--) { front++; break; }
a3e9d8c9 9769 }
c11536f5 9770 lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 9771 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 9772 for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
a480973c
JM		 9773 cp1++,cp2++) {
9774 if (!decc_efs_case_preserve) {
9775 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9776 }
9777 else {
9778 *cp2 = *cp1;
9779 }
9780 }
9781 if (cp1 != '\0') {
367e4b85
JM		 9782 PerlMem_free(tpl);
9783 PerlMem_free(unixified);
9784 PerlMem_free(unixwild);
c5375c28 9785 PerlMem_free(lcres);
a480973c 9786 return 0; /* Path too long. */
f7ddb74a 9787 }
f86702cc 9788 lcend = cp2;
9789 *cp2 = '\0'; /* Pick up with memcpy later */
9790 lcfront = lcres + (front - base);
9791 /* Now skip over each ellipsis and try to match the path in front of it. */
9792 while (ells--) {
c11536f5 9793 for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
f86702cc 9794 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9795 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
c11536f5 9796 if (cp1 < tplate) break; /* template started with an ellipsis */
f86702cc 9797 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9798 ellipsis = cp1; continue;
9799 }
a480973c 9800 wilddsc.dsc$a_pointer = tpl;
f86702cc 9801 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9802 nextell = cp1;
9803 for (segdirs = 0, cp2 = tpl;
a480973c 9804 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
f86702cc 9805 cp1++, cp2++) {
9806 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
f7ddb74a
JM		 9807 else {
9808 if (!decc_efs_case_preserve) {
9809 *cp2 = _tolower(*cp1); /* else lowercase for match */
9810 }
9811 else {
9812 *cp2 = *cp1; /* else preserve case for match */
9813 }
9814 }
f86702cc 9815 if (*cp2 == '/') segdirs++;
9816 }
a480973c 9817 if (cp1 != ellipsis - 1) {
367e4b85
JM		 9818 PerlMem_free(tpl);
9819 PerlMem_free(unixified);
9820 PerlMem_free(unixwild);
9821 PerlMem_free(lcres);
a480973c
JM		 9822 return 0; /* Path too long */
9823 }
f86702cc 9824 /* Back up at least as many dirs as in template before matching */
9825 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9826 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9827 for (match = 0; cp1 > lcres;) {
9828 resdsc.dsc$a_pointer = cp1;
9829 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9830 match++;
9831 if (match == 1) lcfront = cp1;
9832 }
9833 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9834 }
a480973c 9835 if (!match) {
367e4b85
JM		 9836 PerlMem_free(tpl);
9837 PerlMem_free(unixified);
9838 PerlMem_free(unixwild);
9839 PerlMem_free(lcres);
a480973c
JM		 9840 return 0; /* Can't find prefix ??? */
9841 }
f86702cc 9842 if (match > 1 && opts & 1) {
9843 /* This ... wildcard could cover more than one set of dirs (i.e.
9844 * a set of similar dir names is repeated). If the template
9845 * contains more than 1 ..., upstream elements could resolve the
9846 * ambiguity, but it's not worth a full backtracking setup here.
9847 * As a quick heuristic, clip off the current default directory
9848 * if it's present to find the trimmed spec, else use the
9849 * shortest string that this ... could cover.
9850 */
9851 char def[NAM$C_MAXRSS+1], *st;
9852
a480973c 9853 if (getcwd(def, sizeof def,0) == NULL) {
827f156d
JM		 9854 PerlMem_free(unixified);
9855 PerlMem_free(unixwild);
9856 PerlMem_free(lcres);
9857 PerlMem_free(tpl);
a480973c
JM		 9858 return 0;
9859 }
f7ddb74a
JM		 9860 if (!decc_efs_case_preserve) {
9861 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9862 if (_tolower(*cp1) != _tolower(*cp2)) break;
9863 }
f86702cc 9864 segdirs = dirs - totells; /* Min # of dirs we must have left */
9865 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9866 if (*cp1 == '\0' && *cp2 == '/') {
18a3d61e 9867 memmove(fspec,cp2+1,end - cp2);
367e4b85
JM		 9868 PerlMem_free(tpl);
9869 PerlMem_free(unixified);
9870 PerlMem_free(unixwild);
9871 PerlMem_free(lcres);
f86702cc 9872 return 1;
9873 }
9874 /* Nope -- stick with lcfront from above and keep going. */
9875 }
9876 }
18a3d61e 9877 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
367e4b85
JM		 9878 PerlMem_free(tpl);
9879 PerlMem_free(unixified);
9880 PerlMem_free(unixwild);
9881 PerlMem_free(lcres);
a3e9d8c9 9882 return 1;
a0d0e21e 9883 }
a0d0e21e
LW		 9884
9885} /* end of trim_unixpath() */
9886/*}}}*/
9887
a0d0e21e
LW		 9888
9889/*
9890 * VMS readdir() routines.
9891 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
a0d0e21e 9892 *
bd3fa61c 9893 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
a0d0e21e
LW		 9894 * Minor modifications to original routines.
9895 */
9896
a9852f7c
CB		 9897/* readdir may have been redefined by reentr.h, so make sure we get
9898 * the local version for what we do here.
9899 */
9900#ifdef readdir
9901# undef readdir
9902#endif
9903#if !defined(PERL_IMPLICIT_CONTEXT)
9904# define readdir Perl_readdir
9905#else
9906# define readdir(a) Perl_readdir(aTHX_ a)
9907#endif
9908
a0d0e21e
LW		 9909 /* Number of elements in vms_versions array */
9910#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9911
9912/*
9913 * Open a directory, return a handle for later use.
9914 */
9915/*{{{ DIR *opendir(char*name) */
ddcbaa1c 9916DIR *
b8ffc8df 9917Perl_opendir(pTHX_ const char *name)
a0d0e21e 9918{
ddcbaa1c 9919 DIR *dd;
657054d4 9920 char *dir;
61bb5906 9921 Stat_t sb;
657054d4
JM		 9922
9923 Newx(dir, VMS_MAXRSS, char);
4846f1d7 9924 if (int_tovmspath(name, dir, NULL) == NULL) {
657054d4 9925 Safefree(dir);
61bb5906 9926 return NULL;
a0d0e21e 9927 }
ada67d10
CB		 9928 /* Check access before stat; otherwise stat does not
9929 * accurately report whether it's a directory.
9930 */
a1887106 9931 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
fac786e7 9932 /* cando_by_name has already set errno */
657054d4 9933 Safefree(dir);
ada67d10
CB		 9934 return NULL;
9935 }
61bb5906
CB		 9936 if (flex_stat(dir,&sb) == -1) return NULL;
9937 if (!S_ISDIR(sb.st_mode)) {
657054d4 9938 Safefree(dir);
61bb5906
CB		 9939 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9940 return NULL;
9941 }
61bb5906 9942 /* Get memory for the handle, and the pattern. */
ddcbaa1c 9943 Newx(dd,1,DIR);
a02a5408 9944 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
a0d0e21e
LW		 9945
9946 /* Fill in the fields; mainly playing with the descriptor. */
f7ddb74a 9947 sprintf(dd->pattern, "%s*.*",dir);
657054d4 9948 Safefree(dir);
a0d0e21e
LW		 9949 dd->context = 0;
9950 dd->count = 0;
657054d4 9951 dd->flags = 0;
a096370a
CB		 9952 /* By saying we always want the result of readdir() in unix format, we
9953 * are really saying we want all the escapes removed. Otherwise the caller,
9954 * having no way to know whether it's already in VMS format, might send it
9955 * through tovmsspec again, thus double escaping.
9956 */
9957 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
a0d0e21e
LW		 9958 dd->pat.dsc$a_pointer = dd->pattern;
9959 dd->pat.dsc$w_length = strlen(dd->pattern);
9960 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9961 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3bc25146 9962#if defined(USE_ITHREADS)
a02a5408 9963 Newx(dd->mutex,1,perl_mutex);
a9852f7c
CB		 9964 MUTEX_INIT( (perl_mutex *) dd->mutex );
9965#else
9966 dd->mutex = NULL;
9967#endif
a0d0e21e
LW		 9968
9969 return dd;
9970} /* end of opendir() */
9971/*}}}*/
9972
9973/*
9974 * Set the flag to indicate we want versions or not.
9975 */
9976/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9977void
ddcbaa1c 9978vmsreaddirversions(DIR *dd, int flag)
a0d0e21e 9979{
657054d4
JM		 9980 if (flag)
9981 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9982 else
9983 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
a0d0e21e
LW		 9984}
9985/*}}}*/
9986
9987/*
9988 * Free up an opened directory.
9989 */
9990/*{{{ void closedir(DIR *dd)*/
9991void
ddcbaa1c 9992Perl_closedir(DIR *dd)
a0d0e21e 9993{
f7ddb74a
JM		 9994 int sts;
9995
9996 sts = lib$find_file_end(&dd->context);
a0d0e21e 9997 Safefree(dd->pattern);
3bc25146 9998#if defined(USE_ITHREADS)
a9852f7c
CB		 9999 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10000 Safefree(dd->mutex);
10001#endif
f7ddb74a 10002 Safefree(dd);
a0d0e21e
LW		 10003}
10004/*}}}*/
10005
10006/*
10007 * Collect all the version numbers for the current file.
10008 */
10009static void
ddcbaa1c 10010collectversions(pTHX_ DIR *dd)
a0d0e21e
LW		 10011{
10012 struct dsc$descriptor_s pat;
10013 struct dsc$descriptor_s res;
ddcbaa1c 10014 struct dirent *e;
657054d4 10015 char *p, *text, *buff;
a0d0e21e
LW		 10016 int i;
10017 unsigned long context, tmpsts;
10018
10019 /* Convenient shorthand. */
10020 e = &dd->entry;
10021
10022 /* Add the version wildcard, ignoring the "*.*" put on before */
10023 i = strlen(dd->pattern);
a02a5408 10024 Newx(text,i + e->d_namlen + 3,char);
a35dcc95 10025 my_strlcpy(text, dd->pattern, i + 1);
f7ddb74a 10026 sprintf(&text[i - 3], "%s;*", e->d_name);
a0d0e21e
LW		 10027
10028 /* Set up the pattern descriptor. */
10029 pat.dsc$a_pointer = text;
10030 pat.dsc$w_length = i + e->d_namlen - 1;
10031 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10032 pat.dsc$b_class = DSC$K_CLASS_S;
10033
10034 /* Set up result descriptor. */
657054d4 10035 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10036 res.dsc$a_pointer = buff;
657054d4 10037 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10038 res.dsc$b_dtype = DSC$K_DTYPE_T;
10039 res.dsc$b_class = DSC$K_CLASS_S;
10040
10041 /* Read files, collecting versions. */
10042 for (context = 0, e->vms_verscount = 0;
10043 e->vms_verscount < VERSIZE(e);
10044 e->vms_verscount++) {
657054d4
JM		 10045 unsigned long rsts;
10046 unsigned long flags = 0;
10047
10048#ifdef VMS_LONGNAME_SUPPORT
988c775c 10049 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10050#endif
10051 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
a0d0e21e 10052 if (tmpsts == RMS$_NMF || context == 0) break;
748a9306 10053 _ckvmssts(tmpsts);
657054d4 10054 buff[VMS_MAXRSS - 1] = '\0';
748a9306 10055 if ((p = strchr(buff, ';')))
a0d0e21e
LW		 10056 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10057 else
10058 e->vms_versions[e->vms_verscount] = -1;
10059 }
10060
748a9306 10061 _ckvmssts(lib$find_file_end(&context));
a0d0e21e 10062 Safefree(text);
657054d4 10063 Safefree(buff);
a0d0e21e
LW		 10064
10065} /* end of collectversions() */
10066
10067/*
10068 * Read the next entry from the directory.
10069 */
10070/*{{{ struct dirent *readdir(DIR *dd)*/
ddcbaa1c
CB		 10071struct dirent *
10072Perl_readdir(pTHX_ DIR *dd)
a0d0e21e
LW		 10073{
10074 struct dsc$descriptor_s res;
657054d4 10075 char *p, *buff;
a0d0e21e 10076 unsigned long int tmpsts;
657054d4
JM		 10077 unsigned long rsts;
10078 unsigned long flags = 0;
dca5a913 10079 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
657054d4 10080 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
a0d0e21e
LW		 10081
10082 /* Set up result descriptor, and get next file. */
657054d4 10083 Newx(buff, VMS_MAXRSS, char);
a0d0e21e 10084 res.dsc$a_pointer = buff;
657054d4 10085 res.dsc$w_length = VMS_MAXRSS - 1;
a0d0e21e
LW		 10086 res.dsc$b_dtype = DSC$K_DTYPE_T;
10087 res.dsc$b_class = DSC$K_CLASS_S;
657054d4
JM		 10088
10089#ifdef VMS_LONGNAME_SUPPORT
988c775c 10090 flags = LIB$M_FIL_LONG_NAMES;
657054d4
JM		 10091#endif
10092
10093 tmpsts = lib$find_file
10094 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
4633a7c4
LW		 10095 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10096 if (!(tmpsts & 1)) {
10097 set_vaxc_errno(tmpsts);
10098 switch (tmpsts) {
10099 case RMS$_PRV:
c07a80fd 10100 set_errno(EACCES); break;
4633a7c4 10101 case RMS$_DEV:
c07a80fd 10102 set_errno(ENODEV); break;
4633a7c4 10103 case RMS$_DIR:
f282b18d
CB		 10104 set_errno(ENOTDIR); break;
10105 case RMS$_FNF: case RMS$_DNF:
c07a80fd 10106 set_errno(ENOENT); break;
4633a7c4
LW		 10107 default:
10108 set_errno(EVMSERR);
10109 }
657054d4 10110 Safefree(buff);
4633a7c4
LW		 10111 return NULL;
10112 }
10113 dd->count++;
a0d0e21e 10114 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
c43a0d1c
CB		 10115 buff[res.dsc$w_length] = '\0';
10116 p = buff + res.dsc$w_length;
10117 while (--p >= buff) if (!isspace(*p)) break;
10118 *p = '\0';
f7ddb74a 10119 if (!decc_efs_case_preserve) {
f7ddb74a 10120 for (p = buff; *p; p++) *p = _tolower(*p);
f7ddb74a 10121 }
a0d0e21e
LW		 10122
10123 /* Skip any directory component and just copy the name. */
657054d4 10124 sts = vms_split_path
360732b5 10125 (buff,
657054d4
JM		 10126 &v_spec,
10127 &v_len,
10128 &r_spec,
10129 &r_len,
10130 &d_spec,
10131 &d_len,
10132 &n_spec,
10133 &n_len,
10134 &e_spec,
10135 &e_len,
10136 &vs_spec,
10137 &vs_len);
10138
0dddfaca
JM		 10139 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10140
10141 /* In Unix report mode, remove the ".dir;1" from the name */
10142 /* if it is a real directory. */
10143 if (decc_filename_unix_report || decc_efs_charset) {
f785e3a1
JM		 10144 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10145 Stat_t statbuf;
10146 int ret_sts;
10147
10148 ret_sts = flex_lstat(buff, &statbuf);
10149 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10150 e_len = 0;
10151 e_spec[0] = 0;
0dddfaca
JM		 10152 }
10153 }
10154 }
10155
10156 /* Drop NULL extensions on UNIX file specification */
10157 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10158 e_len = 0;
10159 e_spec[0] = '\0';
10160 }
dca5a913
JM		 10161 }
10162
a35dcc95 10163 memcpy(dd->entry.d_name, n_spec, n_len + e_len);
657054d4
JM		 10164 dd->entry.d_name[n_len + e_len] = '\0';
10165 dd->entry.d_namlen = strlen(dd->entry.d_name);
a0d0e21e 10166
657054d4
JM		 10167 /* Convert the filename to UNIX format if needed */
10168 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10169
10170 /* Translate the encoded characters. */
38a44b82 10171 /* Fixme: Unicode handling could result in embedded 0 characters */
657054d4
JM		 10172 if (strchr(dd->entry.d_name, '^') != NULL) {
10173 char new_name[256];
10174 char * q;
657054d4
JM		 10175 p = dd->entry.d_name;
10176 q = new_name;
10177 while (*p != 0) {
f617045b
CB		 10178 int inchars_read, outchars_added;
10179 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10180 p += inchars_read;
10181 q += outchars_added;
dca5a913 10182 /* fix-me */
f617045b 10183 /* if outchars_added > 1, then this is a wide file specification */
dca5a913 10184 /* Wide file specifications need to be passed in Perl */
38a44b82 10185 /* counted strings apparently with a Unicode flag */
657054d4
JM		 10186 }
10187 *q = 0;
a35dcc95 10188 dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name));
657054d4 10189 }
657054d4 10190 }
a0d0e21e 10191
a0d0e21e 10192 dd->entry.vms_verscount = 0;
657054d4
JM		 10193 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10194 Safefree(buff);
a0d0e21e
LW		 10195 return &dd->entry;
10196
10197} /* end of readdir() */
10198/*}}}*/
10199
10200/*
a9852f7c
CB		 10201 * Read the next entry from the directory -- thread-safe version.
10202 */
10203/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10204int
ddcbaa1c 10205Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
a9852f7c
CB		 10206{
10207 int retval;
10208
10209 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10210
7ded3206 10211 entry = readdir(dd);
a9852f7c
CB		 10212 *result = entry;
10213 retval = ( *result == NULL ? errno : 0 );
10214
10215 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10216
10217 return retval;
10218
10219} /* end of readdir_r() */
10220/*}}}*/
10221
10222/*
a0d0e21e
LW		 10223 * Return something that can be used in a seekdir later.
10224 */
10225/*{{{ long telldir(DIR *dd)*/
10226long
ddcbaa1c 10227Perl_telldir(DIR *dd)
a0d0e21e
LW		 10228{
10229 return dd->count;
10230}
10231/*}}}*/
10232
10233/*
10234 * Return to a spot where we used to be. Brute force.
10235 */
10236/*{{{ void seekdir(DIR *dd,long count)*/
10237void
ddcbaa1c 10238Perl_seekdir(pTHX_ DIR *dd, long count)
a0d0e21e 10239{
657054d4 10240 int old_flags;
a0d0e21e
LW		 10241
10242 /* If we haven't done anything yet... */
10243 if (dd->count == 0)
10244 return;
10245
10246 /* Remember some state, and clear it. */
657054d4
JM		 10247 old_flags = dd->flags;
10248 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
748a9306 10249 _ckvmssts(lib$find_file_end(&dd->context));
a0d0e21e
LW		 10250 dd->context = 0;
10251
10252 /* The increment is in readdir(). */
10253 for (dd->count = 0; dd->count < count; )
f7ddb74a 10254 readdir(dd);
a0d0e21e 10255
657054d4 10256 dd->flags = old_flags;
a0d0e21e
LW		 10257
10258} /* end of seekdir() */
10259/*}}}*/
10260
10261/* VMS subprocess management
10262 *
10263 * my_vfork() - just a vfork(), after setting a flag to record that
10264 * the current script is trying a Unix-style fork/exec.
10265 *
10266 * vms_do_aexec() and vms_do_exec() are called in response to the
10267 * perl 'exec' function. If this follows a vfork call, then they
a6d05634 10268 * call out the regular perl routines in doio.c which do an
a0d0e21e
LW		 10269 * execvp (for those who really want to try this under VMS).
10270 * Otherwise, they do exactly what the perl docs say exec should
10271 * do - terminate the current script and invoke a new command
10272 * (See below for notes on command syntax.)
10273 *
10274 * do_aspawn() and do_spawn() implement the VMS side of the perl
10275 * 'system' function.
10276 *
10277 * Note on command arguments to perl 'exec' and 'system': When handled
10278 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
eed5d6a1
CB		 10279 * are concatenated to form a DCL command string. If the first non-numeric
10280 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
a6d05634 10281 * the command string is handed off to DCL directly. Otherwise,
a0d0e21e
LW		 10282 * the first token of the command is taken as the filespec of an image
10283 * to run. The filespec is expanded using a default type of '.EXE' and
3eeba6fb 10284 * the process defaults for device, directory, etc., and if found, the resultant
a0d0e21e 10285 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3eeba6fb 10286 * the command string as parameters. This is perhaps a bit complicated,
a0d0e21e
LW		 10287 * but I hope it will form a happy medium between what VMS folks expect
10288 * from lib$spawn and what Unix folks expect from exec.
10289 */
10290
10291static int vfork_called;
10292
f7c699a0 10293/*{{{int my_vfork(void)*/
a0d0e21e 10294int
f7c699a0 10295my_vfork(void)
a0d0e21e 10296{
748a9306 10297 vfork_called++;
a0d0e21e
LW		 10298 return vfork();
10299}
10300/*}}}*/
10301
4633a7c4 10302
a0d0e21e 10303static void
218fdd94
CL		 10304vms_execfree(struct dsc$descriptor_s *vmscmd)
10305{
10306 if (vmscmd) {
10307 if (vmscmd->dsc$a_pointer) {
c5375c28 10308 PerlMem_free(vmscmd->dsc$a_pointer);
218fdd94 10309 }
c5375c28 10310 PerlMem_free(vmscmd);
4633a7c4
LW		 10311 }
10312}
10313
10314static char *
fd8cd3a3 10315setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
a0d0e21e 10316{
4e205ed6 10317 char *junk, *tmps = NULL;
eb578fdb 10318 size_t cmdlen = 0;
a0d0e21e 10319 size_t rlen;
eb578fdb 10320 SV **idx;
2d8e6c8d 10321 STRLEN n_a;
a0d0e21e
LW		 10322
10323 idx = mark;
4633a7c4
LW		 10324 if (really) {
10325 tmps = SvPV(really,rlen);
10326 if (*tmps) {
10327 cmdlen += rlen + 1;
10328 idx++;
10329 }
a0d0e21e
LW		 10330 }
10331
10332 for (idx++; idx <= sp; idx++) {
10333 if (*idx) {
10334 junk = SvPVx(*idx,rlen);
10335 cmdlen += rlen ? rlen + 1 : 0;
10336 }
10337 }
c5375c28 10338 Newx(PL_Cmd, cmdlen+1, char);
a0d0e21e 10339
4633a7c4 10340 if (tmps && *tmps) {
a35dcc95 10341 my_strlcpy(PL_Cmd, tmps, cmdlen + 1);
a0d0e21e
LW		 10342 mark++;
10343 }
6b88bc9c 10344 else *PL_Cmd = '\0';
a0d0e21e
LW		 10345 while (++mark <= sp) {
10346 if (*mark) {
3eeba6fb
CB		 10347 char *s = SvPVx(*mark,n_a);
10348 if (!*s) continue;
a35dcc95
CB		 10349 if (*PL_Cmd) my_strlcat(PL_Cmd, " ", cmdlen+1);
10350 my_strlcat(PL_Cmd, s, cmdlen+1);
a0d0e21e
LW		 10351 }
10352 }
6b88bc9c 10353 return PL_Cmd;
a0d0e21e
LW		 10354
10355} /* end of setup_argstr() */
10356
4633a7c4 10357
a0d0e21e 10358static unsigned long int
2fbb330f 10359setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
218fdd94 10360 struct dsc$descriptor_s **pvmscmd)
a0d0e21e 10361{
e919cd19
JM		 10362 char * vmsspec;
10363 char * resspec;
e886094b
JM		 10364 char image_name[NAM$C_MAXRSS+1];
10365 char image_argv[NAM$C_MAXRSS+1];
a0d0e21e 10366 $DESCRIPTOR(defdsc,".EXE");
8012a33e 10367 $DESCRIPTOR(defdsc2,".");
e919cd19 10368 struct dsc$descriptor_s resdsc;
218fdd94 10369 struct dsc$descriptor_s *vmscmd;
a0d0e21e 10370 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3eeba6fb 10371 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
eb578fdb 10372 char *s, *rest, *cp, *wordbreak;
2fbb330f
JM		 10373 char * cmd;
10374 int cmdlen;
eb578fdb 10375 int isdcl;
a0d0e21e 10376
426fe37a 10377 vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
ebd4d70b 10378 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2fbb330f 10379
e919cd19 10380 /* vmsspec is a DCL command buffer, not just a filename */
c11536f5 10381 vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
e919cd19
JM		 10382 if (vmsspec == NULL)
10383 _ckvmssts_noperl(SS$_INSFMEM);
10384
c11536f5 10385 resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
e919cd19
JM		 10386 if (resspec == NULL)
10387 _ckvmssts_noperl(SS$_INSFMEM);
10388
2fbb330f
JM		 10389 /* Make a copy for modification */
10390 cmdlen = strlen(incmd);
c11536f5 10391 cmd = (char *)PerlMem_malloc(cmdlen+1);
ebd4d70b 10392 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a35dcc95 10393 my_strlcpy(cmd, incmd, cmdlen + 1);
e886094b
JM		 10394 image_name[0] = 0;
10395 image_argv[0] = 0;
2fbb330f 10396
e919cd19
JM		 10397 resdsc.dsc$a_pointer = resspec;
10398 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10399 resdsc.dsc$b_class = DSC$K_CLASS_S;
10400 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10401
218fdd94
CL		 10402 vmscmd->dsc$a_pointer = NULL;
10403 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10404 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10405 vmscmd->dsc$w_length = 0;
10406 if (pvmscmd) *pvmscmd = vmscmd;
10407
ff7adb52
CL		 10408 if (suggest_quote) *suggest_quote = 0;
10409
2fbb330f 10410 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
c5375c28 10411 PerlMem_free(cmd);
e919cd19
JM		 10412 PerlMem_free(vmsspec);
10413 PerlMem_free(resspec);
a2669cfc 10414 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2fbb330f
JM		 10415 }
10416
a0d0e21e 10417 s = cmd;
2fbb330f 10418
a0d0e21e 10419 while (*s && isspace(*s)) s++;
aa779de1
CB		 10420
10421 if (*s == '@' || *s == '$') {
10422 vmsspec[0] = *s; rest = s + 1;
10423 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10424 }
10425 else { cp = vmsspec; rest = s; }
22831cc5
CB		 10426
10427 /* If the first word is quoted, then we need to unquote it and
10428 * escape spaces within it. We'll expand into the resspec buffer,
10429 * then copy back into the cmd buffer, expanding the latter if
10430 * necessary.
10431 */
10432 if (*rest == '"') {
10433 char *cp2;
10434 char *r = rest;
10435 bool in_quote = 0;
10436 int clen = cmdlen;
10437 int soff = s - cmd;
10438
10439 for (cp2 = resspec;
10440 *rest && cp2 - resspec < (VMS_MAXRSS - 1);
10441 rest++) {
10442
10443 if (*rest == ' ') { /* Escape ' ' to '^_'. */
10444 *cp2 = '^';
10445 *(++cp2) = '_';
10446 cp2++;
10447 clen++;
10448 }
10449 else if (*rest == '"') {
10450 clen--;
10451 if (in_quote) { /* Must be closing quote. */
10452 rest++;
10453 break;
10454 }
10455 in_quote = 1;
10456 }
10457 else {
10458 *cp2 = *rest;
10459 cp2++;
10460 }
10461 }
10462 *cp2 = '\0';
10463
10464 /* Expand the command buffer if necessary. */
10465 if (clen > cmdlen) {
223c162b 10466 cmd = (char *)PerlMem_realloc(cmd, clen);
22831cc5
CB		 10467 if (cmd == NULL)
10468 _ckvmssts_noperl(SS$_INSFMEM);
10469 /* Where we are may have changed, so recompute offsets */
10470 r = cmd + (r - s - soff);
10471 rest = cmd + (rest - s - soff);
10472 s = cmd + soff;
10473 }
10474
10475 /* Shift the non-verb portion of the command (if any) up or
10476 * down as necessary.
10477 */
10478 if (*rest)
10479 memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
10480
10481 /* Copy the unquoted and escaped command verb into place. */
10482 memcpy(r, resspec, cp2 - resspec);
10483 cmd[clen] = '\0';
10484 cmdlen = clen;
10485 rest = r; /* Rewind for subsequent operations. */
10486 }
10487
aa779de1
CB		 10488 if (*rest == '.' || *rest == '/') {
10489 char *cp2;
10490 for (cp2 = resspec;
e919cd19 10491 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
aa779de1
CB		 10492 rest++, cp2++) *cp2 = *rest;
10493 *cp2 = '\0';
df278665 10494 if (int_tovmsspec(resspec, cp, 0, NULL)) {
aa779de1 10495 s = vmsspec;
cfbf46cd
JM		 10496
10497 /* When a UNIX spec with no file type is translated to VMS, */
10498 /* A trailing '.' is appended under ODS-5 rules. */
10499 /* Here we do not want that trailing "." as it prevents */
10500 /* Looking for a implied ".exe" type. */
10501 if (decc_efs_charset) {
10502 int i;
10503 i = strlen(vmsspec);
10504 if (vmsspec[i-1] == '.') {
10505 vmsspec[i-1] = '\0';
10506 }
10507 }
10508
aa779de1
CB		 10509 if (*rest) {
10510 for (cp2 = vmsspec + strlen(vmsspec);
e919cd19 10511 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
aa779de1
CB		 10512 rest++, cp2++) *cp2 = *rest;
10513 *cp2 = '\0';
a0d0e21e
LW		 10514 }
10515 }
10516 }
aa779de1
CB		 10517 /* Intuit whether verb (first word of cmd) is a DCL command:
10518 * - if first nonspace char is '@', it's a DCL indirection
10519 * otherwise
10520 * - if verb contains a filespec separator, it's not a DCL command
10521 * - if it doesn't, caller tells us whether to default to a DCL
10522 * command, or to a local image unless told it's DCL (by leading '$')
10523 */
ff7adb52
CL		 10524 if (*s == '@') {
10525 isdcl = 1;
10526 if (suggest_quote) *suggest_quote = 1;
10527 } else {
eb578fdb 10528 char *filespec = strpbrk(s,":<[.;");
aa779de1
CB		 10529 rest = wordbreak = strpbrk(s," \"\t/");
10530 if (!wordbreak) wordbreak = s + strlen(s);
10531 if (*s == '$') check_img = 0;
10532 if (filespec && (filespec < wordbreak)) isdcl = 0;
10533 else isdcl = !check_img;
10534 }
10535
3eeba6fb 10536 if (!isdcl) {
dca5a913 10537 int rsts;
aa779de1
CB		 10538 imgdsc.dsc$a_pointer = s;
10539 imgdsc.dsc$w_length = wordbreak - s;
dca5a913 10540 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8012a33e 10541 if (!(retsts&1)) {
ebd4d70b 10542 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10543 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f 10544 if (!(retsts & 1) && *s == '$') {
ebd4d70b 10545 _ckvmssts_noperl(lib$find_file_end(&cxt));
2497a41f 10546 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
dca5a913 10547 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
2497a41f 10548 if (!(retsts&1)) {
ebd4d70b 10549 _ckvmssts_noperl(lib$find_file_end(&cxt));
dca5a913 10550 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
2497a41f
JM		 10551 }
10552 }
aa779de1 10553 }
ebd4d70b 10554 _ckvmssts_noperl(lib$find_file_end(&cxt));
8012a33e 10555
aa779de1 10556 if (retsts & 1) {
8012a33e 10557 FILE *fp;
a0d0e21e
LW		 10558 s = resspec;
10559 while (*s && !isspace(*s)) s++;
10560 *s = '\0';
8012a33e
CB		 10561
10562 /* check that it's really not DCL with no file extension */
e886094b 10563 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8012a33e 10564 if (fp) {
2497a41f
JM		 10565 char b[256] = {0,0,0,0};
10566 read(fileno(fp), b, 256);
8012a33e 10567 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
2497a41f 10568 if (isdcl) {
e886094b
JM		 10569 int shebang_len;
10570
2497a41f 10571 /* Check for script */
e886094b
JM		 10572 shebang_len = 0;
10573 if ((b[0] == '#') && (b[1] == '!'))
10574 shebang_len = 2;
10575#ifdef ALTERNATE_SHEBANG
10576 else {
10577 shebang_len = strlen(ALTERNATE_SHEBANG);
10578 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10579 char * perlstr;
10580 perlstr = strstr("perl",b);
10581 if (perlstr == NULL)
10582 shebang_len = 0;
10583 }
10584 else
10585 shebang_len = 0;
10586 }
10587#endif
10588
10589 if (shebang_len > 0) {
10590 int i;
10591 int j;
10592 char tmpspec[NAM$C_MAXRSS + 1];
10593
10594 i = shebang_len;
10595 /* Image is following after white space */
10596 /*--------------------------------------*/
10597 while (isprint(b[i]) && isspace(b[i]))
10598 i++;
10599
10600 j = 0;
10601 while (isprint(b[i]) && !isspace(b[i])) {
10602 tmpspec[j++] = b[i++];
10603 if (j >= NAM$C_MAXRSS)
10604 break;
10605 }
10606 tmpspec[j] = '\0';
10607
10608 /* There may be some default parameters to the image */
10609 /*---------------------------------------------------*/
10610 j = 0;
10611 while (isprint(b[i])) {
10612 image_argv[j++] = b[i++];
10613 if (j >= NAM$C_MAXRSS)
10614 break;
10615 }
10616 while ((j > 0) && !isprint(image_argv[j-1]))
10617 j--;
10618 image_argv[j] = 0;
10619
2497a41f 10620 /* It will need to be converted to VMS format and validated */
e886094b
JM		 10621 if (tmpspec[0] != '\0') {
10622 char * iname;
10623
10624 /* Try to find the exact program requested to be run */
10625 /*---------------------------------------------------*/
6fb6c614
JM		 10626 iname = int_rmsexpand
10627 (tmpspec, image_name, ".exe",
360732b5 10628 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10629 if (iname != NULL) {
a1887106
JM		 10630 if (cando_by_name_int
10631 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10632 /* MCR prefix needed */
10633 isdcl = 0;
10634 }
10635 else {
10636 /* Try again with a null type */
10637 /*----------------------------*/
6fb6c614
JM		 10638 iname = int_rmsexpand
10639 (tmpspec, image_name, ".",
360732b5 10640 PERL_RMSEXPAND_M_VMS, NULL, NULL);
e886094b 10641 if (iname != NULL) {
a1887106
JM		 10642 if (cando_by_name_int
10643 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
e886094b
JM		 10644 /* MCR prefix needed */
10645 isdcl = 0;
10646 }
10647 }
10648 }
10649
10650 /* Did we find the image to run the script? */
10651 /*------------------------------------------*/
10652 if (isdcl) {
10653 char *tchr;
10654
10655 /* Assume DCL or foreign command exists */
10656 /*--------------------------------------*/
10657 tchr = strrchr(tmpspec, '/');
10658 if (tchr != NULL) {
10659 tchr++;
10660 }
10661 else {
10662 tchr = tmpspec;
10663 }
a35dcc95 10664 my_strlcpy(image_name, tchr, sizeof(image_name));
e886094b
JM		 10665 }
10666 }
10667 }
2497a41f
JM		 10668 }
10669 }
8012a33e
CB		 10670 fclose(fp);
10671 }
e919cd19
JM		 10672 if (check_img && isdcl) {
10673 PerlMem_free(cmd);
10674 PerlMem_free(resspec);
10675 PerlMem_free(vmsspec);
10676 return RMS$_FNF;
10677 }
8012a33e 10678
3eeba6fb 10679 if (cando_by_name(S_IXUSR,0,resspec)) {
c11536f5 10680 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
ebd4d70b 10681 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8012a33e 10682 if (!isdcl) {
a35dcc95 10683 my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
e886094b 10684 if (image_name[0] != 0) {
a35dcc95
CB		 10685 my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10686 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10687 }
10688 } else if (image_name[0] != 0) {
a35dcc95
CB		 10689 my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
10690 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
8012a33e 10691 } else {
a35dcc95 10692 my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
8012a33e 10693 }
e886094b
JM		 10694 if (suggest_quote) *suggest_quote = 1;
10695
10696 /* If there is an image name, use original command */
10697 if (image_name[0] == 0)
a35dcc95 10698 my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10699 else {
10700 rest = cmd;
10701 while (*rest && isspace(*rest)) rest++;
10702 }
10703
10704 if (image_argv[0] != 0) {
a35dcc95
CB		 10705 my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
10706 my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
e886094b
JM		 10707 }
10708 if (rest) {
10709 int rest_len;
10710 int vmscmd_len;
10711
10712 rest_len = strlen(rest);
10713 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10714 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
a35dcc95 10715 my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
e886094b
JM		 10716 else
10717 retsts = CLI$_BUFOVF;
10718 }
218fdd94 10719 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
c5375c28 10720 PerlMem_free(cmd);
e919cd19
JM		 10721 PerlMem_free(vmsspec);
10722 PerlMem_free(resspec);
218fdd94 10723 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
3eeba6fb 10724 }
c5375c28
JM		 10725 else
10726 retsts = RMS$_PRV;
a0d0e21e
LW		 10727 }
10728 }
3eeba6fb 10729 /* It's either a DCL command or we couldn't find a suitable image */
218fdd94 10730 vmscmd->dsc$w_length = strlen(cmd);
ff7adb52 10731
c11536f5 10732 vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
a35dcc95 10733 my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
c5375c28
JM		 10734
10735 PerlMem_free(cmd);
e919cd19
JM		 10736 PerlMem_free(resspec);
10737 PerlMem_free(vmsspec);
2fbb330f 10738
ff7adb52
CL		 10739 /* check if it's a symbol (for quoting purposes) */
10740 if (suggest_quote && !*suggest_quote) {
10741 int iss;
10742 char equiv[LNM$C_NAMLENGTH];
10743 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10744 eqvdsc.dsc$a_pointer = equiv;
10745
218fdd94 10746 iss = lib$get_symbol(vmscmd,&eqvdsc);
ff7adb52
CL		 10747 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10748 }
3eeba6fb
CB		 10749 if (!(retsts & 1)) {
10750 /* just hand off status values likely to be due to user error */
10751 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10752 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10753 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
ebd4d70b 10754 else { _ckvmssts_noperl(retsts); }
3eeba6fb 10755 }
a0d0e21e 10756
218fdd94 10757 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
a3e9d8c9 10758
a0d0e21e
LW		 10759} /* end of setup_cmddsc() */
10760
a3e9d8c9 10761
a0d0e21e
LW		 10762/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10763bool
fd8cd3a3 10764Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
a0d0e21e 10765{
c5375c28
JM		 10766bool exec_sts;
10767char * cmd;
10768
a0d0e21e
LW		 10769 if (sp > mark) {
10770 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10771 vfork_called--;
10772 if (vfork_called < 0) {
5c84aa53 10773 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10774 vfork_called = 0;
10775 }
10776 else return do_aexec(really,mark,sp);
a0d0e21e 10777 }
4633a7c4 10778 /* no vfork - act VMSish */
c5375c28
JM		 10779 cmd = setup_argstr(aTHX_ really,mark,sp);
10780 exec_sts = vms_do_exec(cmd);
10781 Safefree(cmd); /* Clean up from setup_argstr() */
10782 return exec_sts;
a0d0e21e
LW		 10783 }
10784
10785 return FALSE;
10786} /* end of vms_do_aexec() */
10787/*}}}*/
10788
10789/* {{{bool vms_do_exec(char *cmd) */
10790bool
2fbb330f 10791Perl_vms_do_exec(pTHX_ const char *cmd)
a0d0e21e 10792{
218fdd94 10793 struct dsc$descriptor_s *vmscmd;
a0d0e21e
LW		 10794
10795 if (vfork_called) { /* this follows a vfork - act Unixish */
748a9306
LW		 10796 vfork_called--;
10797 if (vfork_called < 0) {
5c84aa53 10798 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
748a9306
LW		 10799 vfork_called = 0;
10800 }
10801 else return do_exec(cmd);
a0d0e21e 10802 }
748a9306
LW		 10803
10804 { /* no vfork - act VMSish */
748a9306 10805 unsigned long int retsts;
a0d0e21e 10806
1e422769 10807 TAINT_ENV();
10808 TAINT_PROPER("exec");
218fdd94
CL		 10809 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10810 retsts = lib$do_command(vmscmd);
a0d0e21e 10811
09b7f37c 10812 switch (retsts) {
f282b18d 10813 case RMS$_FNF: case RMS$_DNF:
09b7f37c 10814 set_errno(ENOENT); break;
f282b18d 10815 case RMS$_DIR:
09b7f37c 10816 set_errno(ENOTDIR); break;
f282b18d
CB		 10817 case RMS$_DEV:
10818 set_errno(ENODEV); break;
09b7f37c
CB		 10819 case RMS$_PRV:
10820 set_errno(EACCES); break;
10821 case RMS$_SYN:
10822 set_errno(EINVAL); break;
a2669cfc 10823 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
09b7f37c
CB		 10824 set_errno(E2BIG); break;
10825 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 10826 _ckvmssts_noperl(retsts); /* fall through */
09b7f37c
CB		 10827 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10828 set_errno(EVMSERR);
10829 }
748a9306 10830 set_vaxc_errno(retsts);
3eeba6fb 10831 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10832 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
218fdd94 10833 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
3eeba6fb 10834 }
218fdd94 10835 vms_execfree(vmscmd);
a0d0e21e
LW		 10836 }
10837
10838 return FALSE;
10839
10840} /* end of vms_do_exec() */
10841/*}}}*/
10842
9ec7171b 10843int do_spawn2(pTHX_ const char *, int);
a0d0e21e 10844
9ec7171b
CB		 10845int
10846Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
a0d0e21e 10847{
c5375c28
JM		 10848unsigned long int sts;
10849char * cmd;
eed5d6a1 10850int flags = 0;
a0d0e21e 10851
c5375c28 10852 if (sp > mark) {
eed5d6a1
CB		 10853
10854 /* We'll copy the (undocumented?) Win32 behavior and allow a
10855 * numeric first argument. But the only value we'll support
10856 * through do_aspawn is a value of 1, which means spawn without
10857 * waiting for completion -- other values are ignored.
10858 */
9ec7171b 10859 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
eed5d6a1 10860 ++mark;
9ec7171b 10861 flags = SvIVx(*mark);
eed5d6a1
CB		 10862 }
10863
10864 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10865 flags = CLI$M_NOWAIT;
10866 else
10867 flags = 0;
10868
9ec7171b 10869 cmd = setup_argstr(aTHX_ really, mark, sp);
eed5d6a1 10870 sts = do_spawn2(aTHX_ cmd, flags);
c5375c28
JM		 10871 /* pp_sys will clean up cmd */
10872 return sts;
10873 }
a0d0e21e
LW		 10874 return SS$_ABORT;
10875} /* end of do_aspawn() */
10876/*}}}*/
10877
eed5d6a1 10878
9ec7171b
CB		 10879/* {{{int do_spawn(char* cmd) */
10880int
10881Perl_do_spawn(pTHX_ char* cmd)
a0d0e21e 10882{
7918f24d
NC		 10883 PERL_ARGS_ASSERT_DO_SPAWN;
10884
eed5d6a1
CB		 10885 return do_spawn2(aTHX_ cmd, 0);
10886}
10887/*}}}*/
10888
9ec7171b
CB		 10889/* {{{int do_spawn_nowait(char* cmd) */
10890int
10891Perl_do_spawn_nowait(pTHX_ char* cmd)
10892{
10893 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10894
10895 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10896}
10897/*}}}*/
10898
10899/* {{{int do_spawn2(char *cmd) */
10900int
eed5d6a1
CB		 10901do_spawn2(pTHX_ const char *cmd, int flags)
10902{
209030df 10903 unsigned long int sts, substs;
a0d0e21e 10904
c5375c28
JM		 10905 /* The caller of this routine expects to Safefree(PL_Cmd) */
10906 Newx(PL_Cmd,10,char);
10907
1e422769 10908 TAINT_ENV();
10909 TAINT_PROPER("spawn");
748a9306 10910 if (!cmd || !*cmd) {
eed5d6a1 10911 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
c8795d8b
JH		 10912 if (!(sts & 1)) {
10913 switch (sts) {
209030df
JH		 10914 case RMS$_FNF: case RMS$_DNF:
10915 set_errno(ENOENT); break;
10916 case RMS$_DIR:
10917 set_errno(ENOTDIR); break;
10918 case RMS$_DEV:
10919 set_errno(ENODEV); break;
10920 case RMS$_PRV:
10921 set_errno(EACCES); break;
10922 case RMS$_SYN:
10923 set_errno(EINVAL); break;
10924 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10925 set_errno(E2BIG); break;
10926 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
ebd4d70b 10927 _ckvmssts_noperl(sts); /* fall through */
209030df
JH		 10928 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10929 set_errno(EVMSERR);
c8795d8b
JH		 10930 }
10931 set_vaxc_errno(sts);
10932 if (ckWARN(WARN_EXEC)) {
f98bc0c6 10933 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
c8795d8b
JH		 10934 Strerror(errno));
10935 }
09b7f37c 10936 }
c8795d8b 10937 sts = substs;
48023aa8
CL		 10938 }
10939 else {
eed5d6a1 10940 char mode[3];
2fbb330f 10941 PerlIO * fp;
eed5d6a1
CB		 10942 if (flags & CLI$M_NOWAIT)
10943 strcpy(mode, "n");
10944 else
10945 strcpy(mode, "nW");
10946
10947 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
2fbb330f
JM		 10948 if (fp != NULL)
10949 my_pclose(fp);
eed5d6a1 10950 /* sts will be the pid in the nowait case */
48023aa8 10951 }
48023aa8 10952 return sts;
eed5d6a1 10953} /* end of do_spawn2() */
a0d0e21e
LW		 10954/*}}}*/
10955
bc10a425
CB		 10956
10957static unsigned int *sockflags, sockflagsize;
10958
10959/*
10960 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10961 * routines found in some versions of the CRTL can't deal with sockets.
10962 * We don't shim the other file open routines since a socket isn't
10963 * likely to be opened by a name.
10964 */
275feba9
CB		 10965/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10966FILE *my_fdopen(int fd, const char *mode)
bc10a425 10967{
f7ddb74a 10968 FILE *fp = fdopen(fd, mode);
bc10a425
CB		 10969
10970 if (fp) {
10971 unsigned int fdoff = fd / sizeof(unsigned int);
2497a41f 10972 Stat_t sbuf; /* native stat; we don't need flex_stat */
bc10a425
CB		 10973 if (!sockflagsize || fdoff > sockflagsize) {
10974 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
a02a5408 10975 else Newx (sockflags,fdoff+2,unsigned int);
bc10a425
CB		 10976 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10977 sockflagsize = fdoff + 2;
10978 }
312ac60b 10979 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
bc10a425
CB		 10980 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10981 }
10982 return fp;
10983
10984}
10985/*}}}*/
10986
10987
10988/*
10989 * Clear the corresponding bit when the (possibly) socket stream is closed.
10990 * There still a small hole: we miss an implicit close which might occur
10991 * via freopen(). >> Todo
10992 */
10993/*{{{ int my_fclose(FILE *fp)*/
10994int my_fclose(FILE *fp) {
10995 if (fp) {
10996 unsigned int fd = fileno(fp);
10997 unsigned int fdoff = fd / sizeof(unsigned int);
10998
e0951028 10999 if (sockflagsize && fdoff < sockflagsize)
bc10a425
CB		 11000 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11001 }
11002 return fclose(fp);
11003}
11004/*}}}*/
11005
11006
a0d0e21e
LW		 11007/*
11008 * A simple fwrite replacement which outputs itmsz*nitm chars without
11009 * introducing record boundaries every itmsz chars.
22d4bb9c
CB		 11010 * We are using fputs, which depends on a terminating null. We may
11011 * well be writing binary data, so we need to accommodate not only
11012 * data with nulls sprinkled in the middle but also data with no null
11013 * byte at the end.
a0d0e21e 11014 */
a15cef0c 11015/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
a0d0e21e 11016int
a15cef0c 11017my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
a0d0e21e 11018{
eb578fdb 11019 char *cp, *end, *cpd;
2e05a54c 11020 char *data;
eb578fdb
KW		 11021 unsigned int fd = fileno(dest);
11022 unsigned int fdoff = fd / sizeof(unsigned int);
22d4bb9c 11023 int retval;
bc10a425
CB		 11024 int bufsize = itmsz * nitm + 1;
11025
11026 if (fdoff < sockflagsize &&
11027 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11028 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11029 return nitm;
11030 }
22d4bb9c 11031
bc10a425 11032 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
22d4bb9c
CB		 11033 memcpy( data, src, itmsz*nitm );
11034 data[itmsz*nitm] = '\0';
a0d0e21e 11035
22d4bb9c
CB		 11036 end = data + itmsz * nitm;
11037 retval = (int) nitm; /* on success return # items written */
a0d0e21e 11038
22d4bb9c
CB		 11039 cpd = data;
11040 while (cpd <= end) {
11041 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11042 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
a0d0e21e 11043 if (cp < end)
22d4bb9c
CB		 11044 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11045 cpd = cp + 1;
a0d0e21e
LW		 11046 }
11047
bc10a425 11048 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
22d4bb9c 11049 return retval;
a0d0e21e
LW		 11050
11051} /* end of my_fwrite() */
11052/*}}}*/
11053
d27fe803
JH		 11054/*{{{ int my_flush(FILE *fp)*/
11055int
fd8cd3a3 11056Perl_my_flush(pTHX_ FILE *fp)
d27fe803
JH		 11057{
11058 int res;
93948341 11059 if ((res = fflush(fp)) == 0 && fp) {
d27fe803 11060#ifdef VMS_DO_SOCKETS
61bb5906 11061 Stat_t s;
ed1b9de0 11062 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
d27fe803
JH		 11063#endif
11064 res = fsync(fileno(fp));
11065 }
22d4bb9c
CB		 11066/*
11067 * If the flush succeeded but set end-of-file, we need to clear
11068 * the error because our caller may check ferror(). BTW, this
11069 * probably means we just flushed an empty file.
11070 */
11071 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11072
d27fe803
JH		 11073 return res;
11074}
11075/*}}}*/
11076
bf8d1304
JM		 11077/* fgetname() is not returning the correct file specifications when
11078 * decc_filename_unix_report mode is active. So we have to have it
11079 * aways return filenames in VMS mode and convert it ourselves.
11080 */
11081
11082/*{{{ char * my_fgetname(FILE *fp, buf)*/
11083char *
11084Perl_my_fgetname(FILE *fp, char * buf) {
11085 char * retname;
11086 char * vms_name;
11087
11088 retname = fgetname(fp, buf, 1);
11089
11090 /* If we are in VMS mode, then we are done */
11091 if (!decc_filename_unix_report || (retname == NULL)) {
11092 return retname;
11093 }
11094
11095 /* Convert this to Unix format */
c11536f5 11096 vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
a35dcc95 11097 my_strlcpy(vms_name, retname, VMS_MAXRSS);
bf8d1304
JM		 11098 retname = int_tounixspec(vms_name, buf, NULL);
11099 PerlMem_free(vms_name);
11100
11101 return retname;
11102}
11103/*}}}*/
11104
748a9306
LW		 11105/*
11106 * Here are replacements for the following Unix routines in the VMS environment:
11107 * getpwuid Get information for a particular UIC or UID
11108 * getpwnam Get information for a named user
11109 * getpwent Get information for each user in the rights database
11110 * setpwent Reset search to the start of the rights database
11111 * endpwent Finish searching for users in the rights database
11112 *
11113 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11114 * (defined in pwd.h), which contains the following fields:-
11115 * struct passwd {
11116 * char *pw_name; Username (in lower case)
11117 * char *pw_passwd; Hashed password
11118 * unsigned int pw_uid; UIC
11119 * unsigned int pw_gid; UIC group number
11120 * char *pw_unixdir; Default device/directory (VMS-style)
11121 * char *pw_gecos; Owner name
11122 * char *pw_dir; Default device/directory (Unix-style)
11123 * char *pw_shell; Default CLI name (eg. DCL)
11124 * };
11125 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11126 *
11127 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11128 * not the UIC member number (eg. what's returned by getuid()),
11129 * getpwuid() can accept either as input (if uid is specified, the caller's
11130 * UIC group is used), though it won't recognise gid=0.
11131 *
11132 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11133 * information about other users in your group or in other groups, respectively.
11134 * If the required privilege is not available, then these routines fill only
11135 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11136 * string).
11137 *
11138 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11139 */
11140
11141/* sizes of various UAF record fields */
11142#define UAI$S_USERNAME 12
11143#define UAI$S_IDENT 31
11144#define UAI$S_OWNER 31
11145#define UAI$S_DEFDEV 31
11146#define UAI$S_DEFDIR 63
11147#define UAI$S_DEFCLI 31
11148#define UAI$S_PWD 8
11149
11150#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11151 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11152 (uic).uic$v_group != UIC$K_WILD_GROUP)
11153
4633a7c4
LW		 11154static char __empty[]= "";
11155static struct passwd __passwd_empty=
748a9306
LW		 11156 {(char *) __empty, (char *) __empty, 0, 0,
11157 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11158static int contxt= 0;
11159static struct passwd __pwdcache;
11160static char __pw_namecache[UAI$S_IDENT+1];
11161
748a9306
LW		 11162/*
11163 * This routine does most of the work extracting the user information.
11164 */
fd8cd3a3 11165static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
a0d0e21e 11166{
748a9306
LW		 11167 static struct {
11168 unsigned char length;
11169 char pw_gecos[UAI$S_OWNER+1];
11170 } owner;
11171 static union uicdef uic;
11172 static struct {
11173 unsigned char length;
11174 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11175 } defdev;
11176 static struct {
11177 unsigned char length;
11178 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11179 } defdir;
11180 static struct {
11181 unsigned char length;
11182 char pw_shell[UAI$S_DEFCLI+1];
11183 } defcli;
11184 static char pw_passwd[UAI$S_PWD+1];
11185
11186 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11187 struct dsc$descriptor_s name_desc;
c07a80fd 11188 unsigned long int sts;
748a9306 11189
4633a7c4 11190 static struct itmlst_3 itmlst[]= {
748a9306
LW		 11191 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11192 {sizeof(uic), UAI$_UIC, &uic, &luic},
11193 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11194 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11195 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11196 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11197 {0, 0, NULL, NULL}};
11198
11199 name_desc.dsc$w_length= strlen(name);
11200 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11201 name_desc.dsc$b_class= DSC$K_CLASS_S;
f7ddb74a 11202 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
748a9306
LW		 11203
11204/* Note that sys$getuai returns many fields as counted strings. */
c07a80fd 11205 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11206 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11207 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11208 }
11209 else { _ckvmssts(sts); }
11210 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
748a9306
LW		 11211
11212 if ((int) owner.length < lowner) lowner= (int) owner.length;
11213 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11214 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11215 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11216 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11217 owner.pw_gecos[lowner]= '\0';
11218 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11219 defcli.pw_shell[ldefcli]= '\0';
11220 if (valid_uic(uic)) {
11221 pwd->pw_uid= uic.uic$l_uic;
11222 pwd->pw_gid= uic.uic$v_group;
11223 }
11224 else
5c84aa53 11225 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
748a9306
LW		 11226 pwd->pw_passwd= pw_passwd;
11227 pwd->pw_gecos= owner.pw_gecos;
11228 pwd->pw_dir= defdev.pw_dir;
360732b5 11229 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
748a9306
LW		 11230 pwd->pw_shell= defcli.pw_shell;
11231 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11232 int ldir;
11233 ldir= strlen(pwd->pw_unixdir) - 1;
11234 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11235 }
11236 else
a35dcc95 11237 my_strlcpy(pwd->pw_unixdir, pwd->pw_dir, sizeof(pwd->pw_unixdir));
f7ddb74a
JM		 11238 if (!decc_efs_case_preserve)
11239 __mystrtolower(pwd->pw_unixdir);
c07a80fd 11240 return 1;
a0d0e21e 11241}
748a9306
LW		 11242
11243/*
11244 * Get information for a named user.
11245*/
11246/*{{{struct passwd *getpwnam(char *name)*/
2fbb330f 11247struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
748a9306
LW		 11248{
11249 struct dsc$descriptor_s name_desc;
11250 union uicdef uic;
4e0c9737 11251 unsigned long int sts;
748a9306
LW		 11252
11253 __pwdcache = __passwd_empty;
fd8cd3a3 11254 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
748a9306
LW		 11255 /* We still may be able to determine pw_uid and pw_gid */
11256 name_desc.dsc$w_length= strlen(name);
11257 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11258 name_desc.dsc$b_class= DSC$K_CLASS_S;
11259 name_desc.dsc$a_pointer= (char *) name;
aa689395 11260 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
748a9306
LW		 11261 __pwdcache.pw_uid= uic.uic$l_uic;
11262 __pwdcache.pw_gid= uic.uic$v_group;
11263 }
c07a80fd 11264 else {
aa689395 11265 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11266 set_vaxc_errno(sts);
11267 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
c07a80fd 11268 return NULL;
11269 }
aa689395 11270 else { _ckvmssts(sts); }
c07a80fd 11271 }
748a9306 11272 }
a35dcc95 11273 my_strlcpy(__pw_namecache, name, sizeof(__pw_namecache));
748a9306
LW		 11274 __pwdcache.pw_name= __pw_namecache;
11275 return &__pwdcache;
11276} /* end of my_getpwnam() */
a0d0e21e
LW		 11277/*}}}*/
11278
748a9306
LW		 11279/*
11280 * Get information for a particular UIC or UID.
11281 * Called by my_getpwent with uid=-1 to list all users.
11282*/
11283/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
fd8cd3a3 11284struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
a0d0e21e 11285{
748a9306
LW		 11286 const $DESCRIPTOR(name_desc,__pw_namecache);
11287 unsigned short lname;
11288 union uicdef uic;
11289 unsigned long int status;
11290
11291 if (uid == (unsigned int) -1) {
11292 do {
11293 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11294 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
c07a80fd 11295 set_vaxc_errno(status);
11296 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
748a9306
LW		 11297 my_endpwent();
11298 return NULL;
11299 }
11300 else { _ckvmssts(status); }
11301 } while (!valid_uic (uic));
11302 }
11303 else {
11304 uic.uic$l_uic= uid;
c07a80fd 11305 if (!uic.uic$v_group)
76e3520e 11306 uic.uic$v_group= PerlProc_getgid();
748a9306
LW		 11307 if (valid_uic(uic))
11308 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11309 else status = SS$_IVIDENT;
c07a80fd 11310 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11311 status == RMS$_PRV) {
11312 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11313 return NULL;
11314 }
11315 else { _ckvmssts(status); }
748a9306
LW		 11316 }
11317 __pw_namecache[lname]= '\0';
01b8edb6 11318 __mystrtolower(__pw_namecache);
748a9306
LW		 11319
11320 __pwdcache = __passwd_empty;
11321 __pwdcache.pw_name = __pw_namecache;
11322
11323/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11324 The identifier's value is usually the UIC, but it doesn't have to be,
11325 so if we can, we let fillpasswd update this. */
11326 __pwdcache.pw_uid = uic.uic$l_uic;
11327 __pwdcache.pw_gid = uic.uic$v_group;
11328
fd8cd3a3 11329 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
748a9306 11330 return &__pwdcache;
a0d0e21e 11331
748a9306
LW		 11332} /* end of my_getpwuid() */
11333/*}}}*/
11334
11335/*
11336 * Get information for next user.
11337*/
11338/*{{{struct passwd *my_getpwent()*/
fd8cd3a3 11339struct passwd *Perl_my_getpwent(pTHX)
748a9306
LW		 11340{
11341 return (my_getpwuid((unsigned int) -1));
11342}
11343/*}}}*/
a0d0e21e 11344
748a9306
LW		 11345/*
11346 * Finish searching rights database for users.
11347*/
11348/*{{{void my_endpwent()*/
fd8cd3a3 11349void Perl_my_endpwent(pTHX)
748a9306
LW		 11350{
11351 if (contxt) {
11352 _ckvmssts(sys$finish_rdb(&contxt));
11353 contxt= 0;
11354 }
a0d0e21e
LW		 11355}
11356/*}}}*/
748a9306 11357
ff0cee69 11358/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11359 * my_utime(), and flex_stat(), all of which operate on UTC unless
11360 * VMSISH_TIMES is true.
11361 */
11362/* method used to handle UTC conversions:
11363 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
e518068a 11364 */
ff0cee69 11365static int gmtime_emulation_type;
11366/* number of secs to add to UTC POSIX-style time to get local time */
11367static long int utc_offset_secs;
e518068a 11368
ff0cee69 11369/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11370 * in vmsish.h. #undef them here so we can call the CRTL routines
11371 * directly.
e518068a 11372 */
11373#undef gmtime
ff0cee69 11374#undef localtime
11375#undef time
11376
61bb5906
CB		 11377
11378static time_t toutc_dst(time_t loc) {
11379 struct tm *rsltmp;
11380
f7c699a0 11381 if ((rsltmp = localtime(&loc)) == NULL) return -1u;
61bb5906
CB		 11382 loc -= utc_offset_secs;
11383 if (rsltmp->tm_isdst) loc -= 3600;
11384 return loc;
11385}
32da55ab 11386#define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11387 ((gmtime_emulation_type || my_time(NULL)), \
11388 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11389 ((secs) - utc_offset_secs))))
11390
11391static time_t toloc_dst(time_t utc) {
11392 struct tm *rsltmp;
11393
11394 utc += utc_offset_secs;
f7c699a0 11395 if ((rsltmp = localtime(&utc)) == NULL) return -1u;
61bb5906
CB		 11396 if (rsltmp->tm_isdst) utc += 3600;
11397 return utc;
11398}
32da55ab 11399#define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
61bb5906
CB		 11400 ((gmtime_emulation_type || my_time(NULL)), \
11401 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11402 ((secs) + utc_offset_secs))))
11403
ff0cee69 11404/* my_time(), my_localtime(), my_gmtime()
61bb5906 11405 * By default traffic in UTC time values, using CRTL gmtime() or
ff0cee69 11406 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
61bb5906
CB		 11407 * Note: We need to use these functions even when the CRTL has working
11408 * UTC support, since they also handle C<use vmsish qw(times);>
11409 *
ff0cee69 11410 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
bd3fa61c 11411 * Modified by Charles Bailey <bailey@newman.upenn.edu>
ff0cee69 11412 */
11413
11414/*{{{time_t my_time(time_t *timep)*/
fd8cd3a3 11415time_t Perl_my_time(pTHX_ time_t *timep)
e518068a 11416{
e518068a 11417 time_t when;
61bb5906 11418 struct tm *tm_p;
e518068a 11419
11420 if (gmtime_emulation_type == 0) {
61bb5906
CB		 11421 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11422 /* results of calls to gmtime() and localtime() */
11423 /* for same &base */
ff0cee69 11424
e518068a 11425 gmtime_emulation_type++;
ff0cee69 11426 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
f675dbe5 11427 char off[LNM$C_NAMLENGTH+1];;
ff0cee69 11428
e518068a 11429 gmtime_emulation_type++;
f675dbe5 11430 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
e518068a 11431 gmtime_emulation_type++;
22d4bb9c 11432 utc_offset_secs = 0;
5c84aa53 11433 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
ff0cee69 11434 }
11435 else { utc_offset_secs = atol(off); }
e518068a 11436 }
ff0cee69 11437 else { /* We've got a working gmtime() */
11438 struct tm gmt, local;
e518068a 11439
ff0cee69 11440 gmt = *tm_p;
11441 tm_p = localtime(&base);
11442 local = *tm_p;
11443 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11444 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11445 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11446 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11447 }
e518068a 11448 }
ff0cee69 11449
11450 when = time(NULL);
61bb5906 11451# ifdef VMSISH_TIME
61bb5906 11452 if (VMSISH_TIME) when = _toloc(when);
61bb5906 11453# endif
ff0cee69 11454 if (timep != NULL) *timep = when;
11455 return when;
11456
11457} /* end of my_time() */
11458/*}}}*/
11459
11460
11461/*{{{struct tm *my_gmtime(const time_t *timep)*/
11462struct tm *
fd8cd3a3 11463Perl_my_gmtime(pTHX_ const time_t *timep)
ff0cee69 11464{
ff0cee69 11465 time_t when;
61bb5906 11466 struct tm *rsltmp;
ff0cee69 11467
68dc0745 11468 if (timep == NULL) {
11469 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11470 return NULL;
11471 }
11472 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
ff0cee69 11473
11474 when = *timep;
11475# ifdef VMSISH_TIME
61bb5906
CB		 11476 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11477# endif
61bb5906 11478 return gmtime(&when);
e518068a 11479} /* end of my_gmtime() */
e518068a 11480/*}}}*/
11481
11482
ff0cee69 11483/*{{{struct tm *my_localtime(const time_t *timep)*/
11484struct tm *
fd8cd3a3 11485Perl_my_localtime(pTHX_ const time_t *timep)
ff0cee69 11486{
c11536f5 11487 time_t when;
ff0cee69 11488
68dc0745 11489 if (timep == NULL) {
11490 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11491 return NULL;
11492 }
11493 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
f7ddb74a 11494 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
ff0cee69 11495
11496 when = *timep;
11497# ifdef VMSISH_TIME
61bb5906 11498 if (VMSISH_TIME) when = _toutc(when);
ff0cee69 11499# endif
61bb5906 11500 /* CRTL localtime() wants UTC as input, does tz correction itself */
ff0cee69 11501 return localtime(&when);
ff0cee69 11502} /* end of my_localtime() */
11503/*}}}*/
11504
11505/* Reset definitions for later calls */
11506#define gmtime(t) my_gmtime(t)
11507#define localtime(t) my_localtime(t)
11508#define time(t) my_time(t)
11509
11510
941b3de1
CB		 11511/* my_utime - update modification/access time of a file
11512 *
11513 * VMS 7.3 and later implementation
11514 * Only the UTC translation is home-grown. The rest is handled by the
11515 * CRTL utime(), which will take into account the relevant feature
11516 * logicals and ODS-5 volume characteristics for true access times.
11517 *
11518 * pre VMS 7.3 implementation:
11519 * The calling sequence is identical to POSIX utime(), but under
11520 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11521 * not maintain access times. Restrictions differ from the POSIX
ff0cee69 11522 * definition in that the time can be changed as long as the
11523 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11524 * no separate checks are made to insure that the caller is the
11525 * owner of the file or has special privs enabled.
11526 * Code here is based on Joe Meadows' FILE utility.
941b3de1 11527 *
ff0cee69 11528 */
11529
11530/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11531 * to VMS epoch (01-JAN-1858 00:00:00.00)
11532 * in 100 ns intervals.
11533 */
11534static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11535
94a11853
CB		 11536/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11537int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
ff0cee69 11538{
941b3de1
CB		 11539#if __CRTL_VER >= 70300000
11540 struct utimbuf utc_utimes, *utc_utimesp;
11541
11542 if (utimes != NULL) {
11543 utc_utimes.actime = utimes->actime;
11544 utc_utimes.modtime = utimes->modtime;
11545# ifdef VMSISH_TIME
11546 /* If input was local; convert to UTC for sys svc */
11547 if (VMSISH_TIME) {
11548 utc_utimes.actime = _toutc(utimes->actime);
11549 utc_utimes.modtime = _toutc(utimes->modtime);
11550 }
11551# endif
11552 utc_utimesp = &utc_utimes;
11553 }
11554 else {
11555 utc_utimesp = NULL;
11556 }
11557
11558 return utime(file, utc_utimesp);
11559
11560#else /* __CRTL_VER < 70300000 */
11561
eb578fdb 11562 int i;
f7ddb74a 11563 int sts;
ff0cee69 11564 long int bintime[2], len = 2, lowbit, unixtime,
11565 secscale = 10000000; /* seconds --> 100 ns intervals */
11566 unsigned long int chan, iosb[2], retsts;
11567 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11568 struct FAB myfab = cc$rms_fab;
11569 struct NAM mynam = cc$rms_nam;
11570#if defined (__DECC) && defined (__VAX)
11571 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11572 * at least through VMS V6.1, which causes a type-conversion warning.
11573 */
11574# pragma message save
11575# pragma message disable cvtdiftypes
11576#endif
11577 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11578 struct fibdef myfib;
11579#if defined (__DECC) && defined (__VAX)
11580 /* This should be right after the declaration of myatr, but due
11581 * to a bug in VAX DEC C, this takes effect a statement early.
11582 */
11583# pragma message restore
11584#endif
f7ddb74a 11585 /* cast ok for read only parameter */
ff0cee69 11586 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11587 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11588 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
704c2eb3 11589
ff0cee69 11590 if (file == NULL || *file == '\0') {
941b3de1 11591 SETERRNO(ENOENT, LIB$_INVARG);
ff0cee69 11592 return -1;
11593 }
704c2eb3
JM		 11594
11595 /* Convert to VMS format ensuring that it will fit in 255 characters */
6fb6c614 11596 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
941b3de1
CB		 11597 SETERRNO(ENOENT, LIB$_INVARG);
11598 return -1;
11599 }
ff0cee69 11600 if (utimes != NULL) {
11601 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11602 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11603 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11604 * as input, we force the sign bit to be clear by shifting unixtime right
11605 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11606 */
11607 lowbit = (utimes->modtime & 1) ? secscale : 0;
11608 unixtime = (long int) utimes->modtime;
61bb5906
CB		 11609# ifdef VMSISH_TIME
11610 /* If input was UTC; convert to local for sys svc */
11611 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
ff0cee69 11612# endif
1a6334fb 11613 unixtime >>= 1; secscale <<= 1;
ff0cee69 11614 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11615 if (!(retsts & 1)) {
941b3de1 11616 SETERRNO(EVMSERR, retsts);
ff0cee69 11617 return -1;
11618 }
11619 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11620 if (!(retsts & 1)) {
941b3de1 11621 SETERRNO(EVMSERR, retsts);
ff0cee69 11622 return -1;
11623 }
11624 }
11625 else {
11626 /* Just get the current time in VMS format directly */
11627 retsts = sys$gettim(bintime);
11628 if (!(retsts & 1)) {
941b3de1 11629 SETERRNO(EVMSERR, retsts);
ff0cee69 11630 return -1;
11631 }
11632 }
11633
11634 myfab.fab$l_fna = vmsspec;
11635 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11636 myfab.fab$l_nam = &mynam;
11637 mynam.nam$l_esa = esa;
11638 mynam.nam$b_ess = (unsigned char) sizeof esa;
11639 mynam.nam$l_rsa = rsa;
11640 mynam.nam$b_rss = (unsigned char) sizeof rsa;
f7ddb74a
JM		 11641 if (decc_efs_case_preserve)
11642 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
ff0cee69 11643
11644 /* Look for the file to be affected, letting RMS parse the file
11645 * specification for us as well. I have set errno using only
11646 * values documented in the utime() man page for VMS POSIX.
11647 */
11648 retsts = sys$parse(&myfab,0,0);
11649 if (!(retsts & 1)) {
11650 set_vaxc_errno(retsts);
11651 if (retsts == RMS$_PRV) set_errno(EACCES);
11652 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11653 else set_errno(EVMSERR);
11654 return -1;
11655 }
11656 retsts = sys$search(&myfab,0,0);
11657 if (!(retsts & 1)) {
752635ea 11658 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11659 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11660 set_vaxc_errno(retsts);
11661 if (retsts == RMS$_PRV) set_errno(EACCES);
11662 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11663 else set_errno(EVMSERR);
11664 return -1;
11665 }
11666
11667 devdsc.dsc$w_length = mynam.nam$b_dev;
f7ddb74a 11668 /* cast ok for read only parameter */
ff0cee69 11669 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11670
11671 retsts = sys$assign(&devdsc,&chan,0,0);
11672 if (!(retsts & 1)) {
752635ea 11673 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11674 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11675 set_vaxc_errno(retsts);
11676 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11677 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11678 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11679 else set_errno(EVMSERR);
11680 return -1;
11681 }
11682
11683 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11684 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11685
11686 memset((void *) &myfib, 0, sizeof myfib);
22d4bb9c 11687#if defined(__DECC) || defined(__DECCXX)
ff0cee69 11688 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11689 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11690 /* This prevents the revision time of the file being reset to the current
11691 * time as a result of our IO$_MODIFY $QIO. */
11692 myfib.fib$l_acctl = FIB$M_NORECORD;
11693#else
11694 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11695 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11696 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11697#endif
11698 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
752635ea 11699 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
f7ddb74a 11700 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
ff0cee69 11701 _ckvmssts(sys$dassgn(chan));
11702 if (retsts & 1) retsts = iosb[0];
11703 if (!(retsts & 1)) {
11704 set_vaxc_errno(retsts);
11705 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11706 else set_errno(EVMSERR);
11707 return -1;
11708 }
11709
11710 return 0;
941b3de1
CB		 11711
11712#endif /* #if __CRTL_VER >= 70300000 */
11713
ff0cee69 11714} /* end of my_utime() */
11715/*}}}*/
11716
748a9306 11717/*
2497a41f 11718 * flex_stat, flex_lstat, flex_fstat
748a9306
LW		 11719 * basic stat, but gets it right when asked to stat
11720 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11721 */
11722
2497a41f 11723#ifndef _USE_STD_STAT
748a9306
LW		 11724/* encode_dev packs a VMS device name string into an integer to allow
11725 * simple comparisons. This can be used, for example, to check whether two
11726 * files are located on the same device, by comparing their encoded device
11727 * names. Even a string comparison would not do, because stat() reuses the
11728 * device name buffer for each call; so without encode_dev, it would be
11729 * necessary to save the buffer and use strcmp (this would mean a number of
11730 * changes to the standard Perl code, to say nothing of what a Perl script
11731 * would have to do.
11732 *
11733 * The device lock id, if it exists, should be unique (unless perhaps compared
11734 * with lock ids transferred from other nodes). We have a lock id if the disk is
11735 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11736 * device names. Thus we use the lock id in preference, and only if that isn't
11737 * available, do we try to pack the device name into an integer (flagged by
11738 * the sign bit (LOCKID_MASK) being set).
11739 *
e518068a 11740 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
748a9306
LW		 11741 * name and its encoded form, but it seems very unlikely that we will find
11742 * two files on different disks that share the same encoded device names,
11743 * and even more remote that they will share the same file id (if the test
11744 * is to check for the same file).
11745 *
11746 * A better method might be to use sys$device_scan on the first call, and to
11747 * search for the device, returning an index into the cached array.
cb9e088c 11748 * The number returned would be more intelligible.
748a9306
LW		 11749 * This is probably not worth it, and anyway would take quite a bit longer
11750 * on the first call.
11751 */
11752#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
fd8cd3a3 11753static mydev_t encode_dev (pTHX_ const char *dev)
748a9306
LW		 11754{
11755 int i;
11756 unsigned long int f;
aa689395 11757 mydev_t enc;
748a9306
LW		 11758 char c;
11759 const char *q;
11760
11761 if (!dev || !dev[0]) return 0;
11762
11763#if LOCKID_MASK
11764 {
11765 struct dsc$descriptor_s dev_desc;
cb9e088c 11766 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
748a9306
LW		 11767
11768 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11769 can try that first. */
11770 dev_desc.dsc$w_length = strlen (dev);
11771 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11772 dev_desc.dsc$b_class = DSC$K_CLASS_S;
f7ddb74a 11773 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
cb9e088c 11774 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
360732b5 11775 if (!$VMS_STATUS_SUCCESS(status)) {
cb9e088c
CB		 11776 switch (status) {
11777 case SS$_NOSUCHDEV:
11778 SETERRNO(ENODEV, status);
11779 return 0;
11780 default:
11781 _ckvmssts(status);
11782 }
11783 }
748a9306
LW		 11784 if (lockid) return (lockid & ~LOCKID_MASK);
11785 }
a0d0e21e 11786#endif
748a9306
LW		 11787
11788 /* Otherwise we try to encode the device name */
11789 enc = 0;
11790 f = 1;
11791 i = 0;
11792 for (q = dev + strlen(dev); q--; q >= dev) {
988c775c
JM		 11793 if (*q == ':')
11794 break;
748a9306
LW		 11795 if (isdigit (*q))
11796 c= (*q) - '0';
11797 else if (isalpha (toupper (*q)))
11798 c= toupper (*q) - 'A' + (char)10;
11799 else
11800 continue; /* Skip '$'s */
11801 i++;
11802 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11803 if (i>1) f *= 36;
11804 enc += f * (unsigned long int) c;
11805 }
11806 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11807
11808} /* end of encode_dev() */
cfcfe586
JM		 11809#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11810 device_no = encode_dev(aTHX_ devname)
11811#else
11812#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11813 device_no = new_dev_no
2497a41f 11814#endif
748a9306 11815
748a9306 11816static int
135577da 11817is_null_device(const char *name)
748a9306 11818{
2497a41f 11819 if (decc_bug_devnull != 0) {
682e4b71 11820 if (strncmp("/dev/null", name, 9) == 0)
2497a41f
JM		 11821 return 1;
11822 }
748a9306
LW		 11823 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11824 The underscore prefix, controller letter, and unit number are
11825 independently optional; for our purposes, the colon punctuation
11826 is not. The colon can be trailed by optional directory and/or
11827 filename, but two consecutive colons indicates a nodename rather
11828 than a device. [pr] */
11829 if (*name == '_') ++name;
11830 if (tolower(*name++) != 'n') return 0;
11831 if (tolower(*name++) != 'l') return 0;
11832 if (tolower(*name) == 'a') ++name;
11833 if (*name == '0') ++name;
11834 return (*name++ == ':') && (*name != ':');
11835}
11836
312ac60b
JM		 11837static int
11838Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
c07a80fd 11839
46c05374
CB		 11840#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11841
a1887106
JM		 11842static I32
11843Perl_cando_by_name_int
11844 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
748a9306 11845{
e538e23f
CB		 11846 char usrname[L_cuserid];
11847 struct dsc$descriptor_s usrdsc =
748a9306 11848 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
e538e23f 11849 char *vmsname = NULL, *fileified = NULL;
597c27e2 11850 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
2d9f3838 11851 unsigned short int retlen, trnlnm_iter_count;
748a9306
LW		 11852 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11853 union prvdef curprv;
597c27e2
CB		 11854 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11855 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11856 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
ada67d10
CB		 11857 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11858 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11859 {0,0,0,0}};
11860 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
748a9306 11861 {0,0,0,0}};
ada67d10 11862 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
858aded6 11863 Stat_t st;
6151c65c 11864 static int profile_context = -1;
748a9306
LW		 11865
11866 if (!fname || !*fname) return FALSE;
a1887106 11867
e538e23f 11868 /* Make sure we expand logical names, since sys$check_access doesn't */
c11536f5 11869 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11870 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f 11871 if (!strpbrk(fname,"/]>:")) {
a35dcc95 11872 my_strlcpy(fileified, fname, VMS_MAXRSS);
a1887106 11873 trnlnm_iter_count = 0;
e538e23f 11874 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
2d9f3838
CB		 11875 trnlnm_iter_count++;
11876 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
a1887106
JM		 11877 }
11878 fname = fileified;
e538e23f
CB		 11879 }
11880
c11536f5 11881 vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 11882 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
e538e23f
CB		 11883 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11884 /* Don't know if already in VMS format, so make sure */
360732b5 11885 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
a1887106 11886 PerlMem_free(fileified);
e538e23f 11887 PerlMem_free(vmsname);
a1887106
JM		 11888 return FALSE;
11889 }
a1887106
JM		 11890 }
11891 else {
a35dcc95 11892 my_strlcpy(vmsname, fname, VMS_MAXRSS);
a5f75d66
AD		 11893 }
11894
858aded6 11895 /* sys$check_access needs a file spec, not a directory spec.
312ac60b 11896 * flex_stat now will handle a null thread context during startup.
858aded6 11897 */
e538e23f
CB		 11898
11899 retlen = namdsc.dsc$w_length = strlen(vmsname);
11900 if (vmsname[retlen-1] == ']'
11901 || vmsname[retlen-1] == '>'
858aded6 11902 || vmsname[retlen-1] == ':'
46c05374 11903 || (!flex_stat_int(vmsname, &st, 1) &&
312ac60b 11904 S_ISDIR(st.st_mode))) {
e538e23f 11905
a979ce91 11906 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
e538e23f
CB		 11907 PerlMem_free(fileified);
11908 PerlMem_free(vmsname);
11909 return FALSE;
11910 }
11911 fname = fileified;
11912 }
858aded6
CB		 11913 else {
11914 fname = vmsname;
11915 }
e538e23f
CB		 11916
11917 retlen = namdsc.dsc$w_length = strlen(fname);
11918 namdsc.dsc$a_pointer = (char *)fname;
11919
748a9306 11920 switch (bit) {
f282b18d 11921 case S_IXUSR: case S_IXGRP: case S_IXOTH:
360732b5 11922 access = ARM$M_EXECUTE;
597c27e2
CB		 11923 flags = CHP$M_READ;
11924 break;
f282b18d 11925 case S_IRUSR: case S_IRGRP: case S_IROTH:
360732b5 11926 access = ARM$M_READ;
597c27e2
CB		 11927 flags = CHP$M_READ | CHP$M_USEREADALL;
11928 break;
f282b18d 11929 case S_IWUSR: case S_IWGRP: case S_IWOTH:
360732b5 11930 access = ARM$M_WRITE;
597c27e2
CB		 11931 flags = CHP$M_READ | CHP$M_WRITE;
11932 break;
f282b18d 11933 case S_IDUSR: case S_IDGRP: case S_IDOTH:
360732b5 11934 access = ARM$M_DELETE;
597c27e2
CB		 11935 flags = CHP$M_READ | CHP$M_WRITE;
11936 break;
748a9306 11937 default:
a1887106
JM		 11938 if (fileified != NULL)
11939 PerlMem_free(fileified);
e538e23f
CB		 11940 if (vmsname != NULL)
11941 PerlMem_free(vmsname);
748a9306
LW		 11942 return FALSE;
11943 }
11944
ada67d10
CB		 11945 /* Before we call $check_access, create a user profile with the current
11946 * process privs since otherwise it just uses the default privs from the
baf3cf9c
CB		 11947 * UAF and might give false positives or negatives. This only works on
11948 * VMS versions v6.0 and later since that's when sys$create_user_profile
11949 * became available.
ada67d10
CB		 11950 */
11951
11952 /* get current process privs and username */
ebd4d70b
JM		 11953 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11954 _ckvmssts_noperl(iosb[0]);
ada67d10
CB		 11955
11956 /* find out the space required for the profile */
ebd4d70b 11957 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6151c65c 11958 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11959
11960 /* allocate space for the profile and get it filled in */
c11536f5 11961 usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
ebd4d70b
JM		 11962 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
11963 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6151c65c 11964 &usrprodsc.dsc$w_length,&profile_context));
ada67d10
CB		 11965
11966 /* use the profile to check access to the file; free profile & analyze results */
6151c65c 11967 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
c5375c28 11968 PerlMem_free(usrprodsc.dsc$a_pointer);
ada67d10 11969 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
baf3cf9c 11970
bbce6d69 11971 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
61bb5906 11972 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
22d4bb9c 11973 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
bbce6d69 11974 set_vaxc_errno(retsts);
11975 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11976 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11977 else set_errno(ENOENT);
a1887106
JM		 11978 if (fileified != NULL)
11979 PerlMem_free(fileified);
e538e23f
CB		 11980 if (vmsname != NULL)
11981 PerlMem_free(vmsname);
a3e9d8c9 11982 return FALSE;
11983 }
ada67d10 11984 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
a1887106
JM		 11985 if (fileified != NULL)
11986 PerlMem_free(fileified);
e538e23f
CB		 11987 if (vmsname != NULL)
11988 PerlMem_free(vmsname);
3a385817
GS		 11989 return TRUE;
11990 }
ebd4d70b 11991 _ckvmssts_noperl(retsts);
748a9306 11992
a1887106
JM		 11993 if (fileified != NULL)
11994 PerlMem_free(fileified);
e538e23f
CB		 11995 if (vmsname != NULL)
11996 PerlMem_free(vmsname);
748a9306
LW		 11997 return FALSE; /* Should never get here */
11998
a1887106
JM		 11999}
12000
12001/* Do the permissions allow some operation? Assumes PL_statcache already set. */
12002/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12003 * subset of the applicable information.
12004 */
12005bool
12006Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12007{
12008 return cando_by_name_int
12009 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12010} /* end of cando() */
12011/*}}}*/
12012
12013
12014/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12015I32
12016Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12017{
12018 return cando_by_name_int(bit, effective, fname, 0);
12019
748a9306
LW		 12020} /* end of cando_by_name() */
12021/*}}}*/
12022
12023
61bb5906 12024/*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
748a9306 12025int
fd8cd3a3 12026Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
748a9306 12027{
312ac60b 12028 if (!fstat(fd, &statbufp->crtl_stat)) {
75796008 12029 char *cptr;
988c775c 12030 char *vms_filename;
c11536f5 12031 vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
988c775c 12032 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
75796008 12033
988c775c
JM		 12034 /* Save name for cando by name in VMS format */
12035 cptr = getname(fd, vms_filename, 1);
75796008 12036
988c775c
JM		 12037 /* This should not happen, but just in case */
12038 if (cptr == NULL) {
12039 statbufp->st_devnam[0] = 0;
12040 }
12041 else {
12042 /* Make sure that the saved name fits in 255 characters */
6fb6c614 12043 cptr = int_rmsexpand_vms
988c775c
JM		 12044 (vms_filename,
12045 statbufp->st_devnam,
6fb6c614 12046 0);
75796008 12047 if (cptr == NULL)
988c775c 12048 statbufp->st_devnam[0] = 0;
75796008 12049 }
988c775c 12050 PerlMem_free(vms_filename);
682e4b71
JM		 12051
12052 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12053 VMS_DEVICE_ENCODE
12054 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
2497a41f 12055
61bb5906
CB		 12056# ifdef VMSISH_TIME
12057 if (VMSISH_TIME) {
12058 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12059 statbufp->st_atime = _toloc(statbufp->st_atime);
12060 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12061 }
12062# endif
b7ae7a0d 12063 return 0;
12064 }
12065 return -1;
748a9306
LW		 12066
12067} /* end of flex_fstat() */
12068/*}}}*/
12069
2497a41f
JM		 12070static int
12071Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
748a9306 12072{
9b9f19da
CB		 12073 char *temp_fspec = NULL;
12074 char *fileified = NULL;
312ac60b
JM		 12075 const char *save_spec;
12076 char *ret_spec;
bbce6d69 12077 int retval = -1;
cc5de3bd
CB		 12078 char efs_hack = 0;
12079 char already_fileified = 0;
4ee39169 12080 dSAVEDERRNO;
748a9306 12081
312ac60b
JM		 12082 if (!fspec) {
12083 errno = EINVAL;
12084 return retval;
12085 }
988c775c 12086
2497a41f 12087 if (decc_bug_devnull != 0) {
312ac60b 12088 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2497a41f 12089 memset(statbufp,0,sizeof *statbufp);
cfcfe586 12090 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
2497a41f
JM		 12091 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12092 statbufp->st_uid = 0x00010001;
12093 statbufp->st_gid = 0x0001;
12094 time((time_t *)&statbufp->st_mtime);
12095 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12096 return 0;
12097 }
748a9306
LW		 12098 }
12099
9b9f19da
CB		 12100 SAVE_ERRNO;
12101
12102#if __CRTL_VER >= 80200000 && !defined(__VAX)
12103 /*
12104 * If we are in POSIX filespec mode, accept the filename as is.
12105 */
12106 if (decc_posix_compliant_pathnames == 0) {
12107#endif
12108
12109 /* Try for a simple stat first. If fspec contains a filename without
61bb5906 12110 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9b9f19da 12111 * and sea:[wine.dark]water. exist, the CRTL prefers the directory here.
bbce6d69 12112 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12113 * not sea:[wine.dark]., if the latter exists. If the intended target is
12114 * the file with null type, specify this by calling flex_stat() with
12115 * a '.' at the end of fspec.
12116 */
f36b279d 12117
9b9f19da
CB		 12118 if (lstat_flag == 0)
12119 retval = stat(fspec, &statbufp->crtl_stat);
12120 else
12121 retval = lstat(fspec, &statbufp->crtl_stat);
f36b279d 12122
cc5de3bd
CB		 12123 if (!retval) {
12124 save_spec = fspec;
12125 }
12126 else {
12127 /* In the odd case where we have write but not read access
12128 * to a directory, stat('foo.DIR') works but stat('foo') doesn't.
12129 */
c11536f5 12130 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
cc5de3bd
CB		 12131 if (fileified == NULL)
12132 _ckvmssts_noperl(SS$_INSFMEM);
12133
12134 ret_spec = int_fileify_dirspec(fspec, fileified, NULL);
12135 if (ret_spec != NULL) {
12136 if (lstat_flag == 0)
12137 retval = stat(fileified, &statbufp->crtl_stat);
12138 else
12139 retval = lstat(fileified, &statbufp->crtl_stat);
12140 save_spec = fileified;
12141 already_fileified = 1;
12142 }
12143 }
12144
312ac60b
JM		 12145 if (retval && vms_bug_stat_filename) {
12146
c11536f5 12147 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12148 if (temp_fspec == NULL)
12149 _ckvmssts_noperl(SS$_INSFMEM);
12150
12151 /* We should try again as a vmsified file specification. */
312ac60b
JM		 12152
12153 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12154 if (ret_spec != NULL) {
12155 if (lstat_flag == 0)
12156 retval = stat(temp_fspec, &statbufp->crtl_stat);
12157 else
12158 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12159 save_spec = temp_fspec;
12160 }
2497a41f 12161 }
312ac60b 12162
f1db9cda 12163 if (retval) {
9b9f19da 12164 /* Last chance - allow multiple dots without EFS CHARSET */
312ac60b
JM		 12165 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12166 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12167 * enable it if it isn't already.
12168 */
12169#if __CRTL_VER >= 70300000 && !defined(__VAX)
12170 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12171 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12172#endif
12173 if (lstat_flag == 0)
12174 retval = stat(fspec, &statbufp->crtl_stat);
12175 else
12176 retval = lstat(fspec, &statbufp->crtl_stat);
12177 save_spec = fspec;
12178#if __CRTL_VER >= 70300000 && !defined(__VAX)
12179 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12180 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12181 efs_hack = 1;
12182 }
12183#endif
f1db9cda 12184 }
312ac60b 12185
2497a41f
JM		 12186#if __CRTL_VER >= 80200000 && !defined(__VAX)
12187 } else {
12188 if (lstat_flag == 0)
312ac60b 12189 retval = stat(temp_fspec, &statbufp->crtl_stat);
2497a41f 12190 else
312ac60b 12191 retval = lstat(temp_fspec, &statbufp->crtl_stat);
988c775c 12192 save_spec = temp_fspec;
2497a41f
JM		 12193 }
12194#endif
f36b279d
CB		 12195
12196#if __CRTL_VER >= 70300000 && !defined(__VAX)
12197 /* As you were... */
12198 if (!decc_efs_charset)
12199 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12200#endif
12201
ff0cee69 12202 if (!retval) {
9b9f19da
CB		 12203 char *cptr;
12204 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
d584a1c6
JM		 12205
12206 /* If this is an lstat, do not follow the link */
12207 if (lstat_flag)
12208 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12209
312ac60b
JM		 12210#if __CRTL_VER >= 70300000 && !defined(__VAX)
12211 /* If we used the efs_hack above, we must also use it here for */
12212 /* perl_cando to work */
12213 if (efs_hack && (decc_efs_charset_index > 0)) {
12214 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12215 }
12216#endif
9b9f19da
CB		 12217
12218 /* If we've got a directory, save a fileified, expanded version of it
12219 * in st_devnam. If not a directory, just an expanded version.
12220 */
cc5de3bd 12221 if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
c11536f5 12222 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
9b9f19da
CB		 12223 if (fileified == NULL)
12224 _ckvmssts_noperl(SS$_INSFMEM);
12225
12226 cptr = do_fileify_dirspec(save_spec, fileified, 0, NULL);
12227 if (cptr != NULL)
12228 save_spec = fileified;
12229 }
12230
12231 cptr = int_rmsexpand(save_spec,
12232 statbufp->st_devnam,
12233 NULL,
12234 rmsex_flags,
12235 0,
12236 0);
12237
312ac60b
JM		 12238#if __CRTL_VER >= 70300000 && !defined(__VAX)
12239 if (efs_hack && (decc_efs_charset_index > 0)) {
12240 decc$feature_set_value(decc_efs_charset, 1, 0);
12241 }
12242#endif
12243
12244 /* Fix me: If this is NULL then stat found a file, and we could */
12245 /* not convert the specification to VMS - Should never happen */
988c775c
JM		 12246 if (cptr == NULL)
12247 statbufp->st_devnam[0] = 0;
12248
682e4b71 12249 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
cfcfe586
JM		 12250 VMS_DEVICE_ENCODE
12251 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
61bb5906
CB		 12252# ifdef VMSISH_TIME
12253 if (VMSISH_TIME) {
12254 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12255 statbufp->st_atime = _toloc(statbufp->st_atime);
12256 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12257 }
12258# endif
ff0cee69 12259 }
9543c6b6 12260 /* If we were successful, leave errno where we found it */
4ee39169 12261 if (retval == 0) RESTORE_ERRNO;
9b9f19da
CB		 12262 if (temp_fspec)
12263 PerlMem_free(temp_fspec);
12264 if (fileified)
12265 PerlMem_free(fileified);
748a9306
LW		 12266 return retval;
12267
2497a41f
JM		 12268} /* end of flex_stat_int() */
12269
12270
12271/*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12272int
12273Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12274{
7ded3206 12275 return flex_stat_int(fspec, statbufp, 0);
2497a41f
JM		 12276}
12277/*}}}*/
12278
12279/*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12280int
12281Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12282{
7ded3206 12283 return flex_stat_int(fspec, statbufp, 1);
2497a41f 12284}
748a9306
LW		 12285/*}}}*/
12286
b7ae7a0d 12287
c07a80fd 12288/*{{{char *my_getlogin()*/
12289/* VMS cuserid == Unix getlogin, except calling sequence */
12290char *
2fbb330f 12291my_getlogin(void)
c07a80fd 12292{
12293 static char user[L_cuserid];
12294 return cuserid(user);
12295}
12296/*}}}*/
12297
12298
a5f75d66
AD		 12299/* rmscopy - copy a file using VMS RMS routines
12300 *
12301 * Copies contents and attributes of spec_in to spec_out, except owner
12302 * and protection information. Name and type of spec_in are used as
a3e9d8c9 12303 * defaults for spec_out. The third parameter specifies whether rmscopy()
12304 * should try to propagate timestamps from the input file to the output file.
12305 * If it is less than 0, no timestamps are preserved. If it is 0, then
12306 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12307 * propagated to the output file at creation iff the output file specification
12308 * did not contain an explicit name or type, and the revision date is always
12309 * updated at the end of the copy operation. If it is greater than 0, then
12310 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12311 * other than the revision date should be propagated, and bit 1 indicates
12312 * that the revision date should be propagated.
12313 *
12314 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
a5f75d66 12315 *
bd3fa61c 12316 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
a5f75d66 12317 * Incorporates, with permission, some code from EZCOPY by Tim Adye
01b8edb6 12318 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12319 * as part of the Perl standard distribution under the terms of the
12320 * GNU General Public License or the Perl Artistic License. Copies
12321 * of each may be found in the Perl standard distribution.
a480973c 12322 */ /* FIXME */
a3e9d8c9 12323/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
a480973c
JM		 12324int
12325Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12326{
d584a1c6
JM		 12327 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12328 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
4e0c9737 12329 unsigned long int sts;
a1887106 12330 int dna_len;
a480973c
JM		 12331 struct FAB fab_in, fab_out;
12332 struct RAB rab_in, rab_out;
a1887106
JM		 12333 rms_setup_nam(nam);
12334 rms_setup_nam(nam_out);
a480973c
JM		 12335 struct XABDAT xabdat;
12336 struct XABFHC xabfhc;
12337 struct XABRDT xabrdt;
12338 struct XABSUM xabsum;
12339
c11536f5 12340 vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12341 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12342 vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12343 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
df278665
JM		 12344 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12345 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
c5375c28
JM		 12346 PerlMem_free(vmsin);
12347 PerlMem_free(vmsout);
a480973c
JM		 12348 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12349 return 0;
12350 }
12351
c11536f5 12352 esa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12353 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12354 esal = NULL;
12355#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 12356 esal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12357 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6 12358#endif
a480973c 12359 fab_in = cc$rms_fab;
a1887106 12360 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
a480973c
JM		 12361 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12362 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12363 fab_in.fab$l_fop = FAB$M_SQO;
a1887106 12364 rms_bind_fab_nam(fab_in, nam);
a480973c
JM		 12365 fab_in.fab$l_xab = (void *) &xabdat;
12366
c11536f5 12367 rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12368 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12369 rsal = NULL;
12370#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 12371 rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12372 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12373#endif
12374 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12375 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
a1887106
JM		 12376 rms_nam_esl(nam) = 0;
12377 rms_nam_rsl(nam) = 0;
12378 rms_nam_esll(nam) = 0;
12379 rms_nam_rsll(nam) = 0;
a480973c
JM		 12380#ifdef NAM$M_NO_SHORT_UPCASE
12381 if (decc_efs_case_preserve)
a1887106 12382 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
a480973c
JM		 12383#endif
12384
12385 xabdat = cc$rms_xabdat; /* To get creation date */
12386 xabdat.xab$l_nxt = (void *) &xabfhc;
12387
12388 xabfhc = cc$rms_xabfhc; /* To get record length */
12389 xabfhc.xab$l_nxt = (void *) &xabsum;
12390
12391 xabsum = cc$rms_xabsum; /* To get key and area information */
12392
12393 if (!((sts = sys$open(&fab_in)) & 1)) {
c5375c28
JM		 12394 PerlMem_free(vmsin);
12395 PerlMem_free(vmsout);
12396 PerlMem_free(esa);
d584a1c6
JM		 12397 if (esal != NULL)
12398 PerlMem_free(esal);
c5375c28 12399 PerlMem_free(rsa);
d584a1c6
JM		 12400 if (rsal != NULL)
12401 PerlMem_free(rsal);
a480973c
JM		 12402 set_vaxc_errno(sts);
12403 switch (sts) {
12404 case RMS$_FNF: case RMS$_DNF:
12405 set_errno(ENOENT); break;
12406 case RMS$_DIR:
12407 set_errno(ENOTDIR); break;
12408 case RMS$_DEV:
12409 set_errno(ENODEV); break;
12410 case RMS$_SYN:
12411 set_errno(EINVAL); break;
12412 case RMS$_PRV:
12413 set_errno(EACCES); break;
12414 default:
12415 set_errno(EVMSERR);
12416 }
12417 return 0;
12418 }
12419
12420 nam_out = nam;
12421 fab_out = fab_in;
12422 fab_out.fab$w_ifi = 0;
12423 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12424 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12425 fab_out.fab$l_fop = FAB$M_SQO;
a1887106
JM		 12426 rms_bind_fab_nam(fab_out, nam_out);
12427 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12428 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12429 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
c11536f5 12430 esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12431 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12432 rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
ebd4d70b 12433 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12434 esal_out = NULL;
12435 rsal_out = NULL;
12436#if !defined(__VAX) && defined(NAML$C_MAXRSS)
c11536f5 12437 esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12438 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
c11536f5 12439 rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
ebd4d70b 12440 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
d584a1c6
JM		 12441#endif
12442 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12443 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
a480973c
JM		 12444
12445 if (preserve_dates == 0) { /* Act like DCL COPY */
a1887106 12446 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
a480973c 12447 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
a1887106 12448 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12449 PerlMem_free(vmsin);
12450 PerlMem_free(vmsout);
12451 PerlMem_free(esa);
d584a1c6
JM		 12452 if (esal != NULL)
12453 PerlMem_free(esal);
c5375c28 12454 PerlMem_free(rsa);
d584a1c6
JM		 12455 if (rsal != NULL)
12456 PerlMem_free(rsal);
c5375c28 12457 PerlMem_free(esa_out);
d584a1c6
JM		 12458 if (esal_out != NULL)
12459 PerlMem_free(esal_out);
12460 PerlMem_free(rsa_out);
12461 if (rsal_out != NULL)
12462 PerlMem_free(rsal_out);
a480973c
JM		 12463 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12464 set_vaxc_errno(sts);
12465 return 0;
12466 }
12467 fab_out.fab$l_xab = (void *) &xabdat;
a1887106
JM		 12468 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12469 preserve_dates = 1;
a480973c
JM		 12470 }
12471 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12472 preserve_dates =0; /* bitmask from this point forward */
12473
12474 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
a1887106 12475 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
c5375c28
JM		 12476 PerlMem_free(vmsin);
12477 PerlMem_free(vmsout);
12478 PerlMem_free(esa);
d584a1c6
JM		 12479 if (esal != NULL)
12480 PerlMem_free(esal);
c5375c28 12481 PerlMem_free(rsa);
d584a1c6
JM		 12482 if (rsal != NULL)
12483 PerlMem_free(rsal);
c5375c28 12484 PerlMem_free(esa_out);
d584a1c6
JM		 12485 if (esal_out != NULL)
12486 PerlMem_free(esal_out);
12487 PerlMem_free(rsa_out);
12488 if (rsal_out != NULL)
12489 PerlMem_free(rsal_out);
a480973c
JM		 12490 set_vaxc_errno(sts);
12491 switch (sts) {
12492 case RMS$_DNF:
12493 set_errno(ENOENT); break;
12494 case RMS$_DIR:
12495 set_errno(ENOTDIR); break;
12496 case RMS$_DEV:
12497 set_errno(ENODEV); break;
12498 case RMS$_SYN:
12499 set_errno(EINVAL); break;
12500 case RMS$_PRV:
12501 set_errno(EACCES); break;
12502 default:
12503 set_errno(EVMSERR);
12504 }
12505 return 0;
12506 }
12507 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12508 if (preserve_dates & 2) {
12509 /* sys$close() will process xabrdt, not xabdat */
12510 xabrdt = cc$rms_xabrdt;
12511#ifndef __GNUC__
12512 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12513#else
12514 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12515 * is unsigned long[2], while DECC & VAXC use a struct */
12516 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12517#endif
12518 fab_out.fab$l_xab = (void *) &xabrdt;
12519 }
12520
c11536f5 12521 ubf = (char *)PerlMem_malloc(32256);
ebd4d70b 12522 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
a480973c
JM		 12523 rab_in = cc$rms_rab;
12524 rab_in.rab$l_fab = &fab_in;
12525 rab_in.rab$l_rop = RAB$M_BIO;
12526 rab_in.rab$l_ubf = ubf;
12527 rab_in.rab$w_usz = 32256;
12528 if (!((sts = sys$connect(&rab_in)) & 1)) {
12529 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12530 PerlMem_free(vmsin);
12531 PerlMem_free(vmsout);
c5375c28 12532 PerlMem_free(ubf);
d584a1c6
JM		 12533 PerlMem_free(esa);
12534 if (esal != NULL)
12535 PerlMem_free(esal);
c5375c28 12536 PerlMem_free(rsa);
d584a1c6
JM		 12537 if (rsal != NULL)
12538 PerlMem_free(rsal);
c5375c28 12539 PerlMem_free(esa_out);
d584a1c6
JM		 12540 if (esal_out != NULL)
12541 PerlMem_free(esal_out);
12542 PerlMem_free(rsa_out);
12543 if (rsal_out != NULL)
12544 PerlMem_free(rsal_out);
a480973c
JM		 12545 set_errno(EVMSERR); set_vaxc_errno(sts);
12546 return 0;
12547 }
12548
12549 rab_out = cc$rms_rab;
12550 rab_out.rab$l_fab = &fab_out;
12551 rab_out.rab$l_rbf = ubf;
12552 if (!((sts = sys$connect(&rab_out)) & 1)) {
12553 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12554 PerlMem_free(vmsin);
12555 PerlMem_free(vmsout);
c5375c28 12556 PerlMem_free(ubf);
d584a1c6
JM		 12557 PerlMem_free(esa);
12558 if (esal != NULL)
12559 PerlMem_free(esal);
c5375c28 12560 PerlMem_free(rsa);
d584a1c6
JM		 12561 if (rsal != NULL)
12562 PerlMem_free(rsal);
c5375c28 12563 PerlMem_free(esa_out);
d584a1c6
JM		 12564 if (esal_out != NULL)
12565 PerlMem_free(esal_out);
12566 PerlMem_free(rsa_out);
12567 if (rsal_out != NULL)
12568 PerlMem_free(rsal_out);
a480973c
JM		 12569 set_errno(EVMSERR); set_vaxc_errno(sts);
12570 return 0;
12571 }
12572
12573 while ((sts = sys$read(&rab_in))) { /* always true */
12574 if (sts == RMS$_EOF) break;
12575 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12576 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12577 sys$close(&fab_in); sys$close(&fab_out);
c5375c28
JM		 12578 PerlMem_free(vmsin);
12579 PerlMem_free(vmsout);
c5375c28 12580 PerlMem_free(ubf);
d584a1c6
JM		 12581 PerlMem_free(esa);
12582 if (esal != NULL)
12583 PerlMem_free(esal);
c5375c28 12584 PerlMem_free(rsa);
d584a1c6
JM		 12585 if (rsal != NULL)
12586 PerlMem_free(rsal);
c5375c28 12587 PerlMem_free(esa_out);
d584a1c6
JM		 12588 if (esal_out != NULL)
12589 PerlMem_free(esal_out);
12590 PerlMem_free(rsa_out);
12591 if (rsal_out != NULL)
12592 PerlMem_free(rsal_out);
a480973c
JM		 12593 set_errno(EVMSERR); set_vaxc_errno(sts);
12594 return 0;
12595 }
12596 }
12597
12598
12599 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12600 sys$close(&fab_in); sys$close(&fab_out);
12601 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
a480973c 12602
c5375c28
JM		 12603 PerlMem_free(vmsin);
12604 PerlMem_free(vmsout);
c5375c28 12605 PerlMem_free(ubf);
d584a1c6
JM		 12606 PerlMem_free(esa);
12607 if (esal != NULL)
12608 PerlMem_free(esal);
c5375c28 12609 PerlMem_free(rsa);
d584a1c6
JM		 12610 if (rsal != NULL)
12611 PerlMem_free(rsal);
c5375c28 12612 PerlMem_free(esa_out);
d584a1c6
JM		 12613 if (esal_out != NULL)
12614 PerlMem_free(esal_out);
12615 PerlMem_free(rsa_out);
12616 if (rsal_out != NULL)
12617 PerlMem_free(rsal_out);
12618
12619 if (!(sts & 1)) {
12620 set_errno(EVMSERR); set_vaxc_errno(sts);
12621 return 0;
12622 }
12623
a480973c
JM		 12624 return 1;
12625
12626} /* end of rmscopy() */
a5f75d66
AD		 12627/*}}}*/
12628
12629
748a9306
LW		 12630/*** The following glue provides 'hooks' to make some of the routines
12631 * from this file available from Perl. These routines are sufficiently
12632 * basic, and are required sufficiently early in the build process,
12633 * that's it's nice to have them available to miniperl as well as the
12634 * full Perl, so they're set up here instead of in an extension. The
12635 * Perl code which handles importation of these names into a given
12636 * package lives in [.VMS]Filespec.pm in @INC.
12637 */
12638
12639void
5c84aa53 12640rmsexpand_fromperl(pTHX_ CV *cv)
01b8edb6 12641{
12642 dXSARGS;
bbce6d69 12643 char *fspec, *defspec = NULL, *rslt;
2d8e6c8d 12644 STRLEN n_a;
360732b5 12645 int fs_utf8, dfs_utf8;
01b8edb6 12646
360732b5
JM		 12647 fs_utf8 = 0;
12648 dfs_utf8 = 0;
bbce6d69 12649 if (!items || items > 2)
5c84aa53 12650 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
2d8e6c8d 12651 fspec = SvPV(ST(0),n_a);
360732b5 12652 fs_utf8 = SvUTF8(ST(0));
bbce6d69 12653 if (!fspec || !*fspec) XSRETURN_UNDEF;
360732b5
JM		 12654 if (items == 2) {
12655 defspec = SvPV(ST(1),n_a);
12656 dfs_utf8 = SvUTF8(ST(1));
12657 }
12658 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
bbce6d69 12659 ST(0) = sv_newmortal();
360732b5
JM		 12660 if (rslt != NULL) {
12661 sv_usepvn(ST(0),rslt,strlen(rslt));
12662 if (fs_utf8) {
12663 SvUTF8_on(ST(0));
12664 }
12665 }
740ce14c 12666 XSRETURN(1);
01b8edb6 12667}
12668
12669void
5c84aa53 12670vmsify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12671{
12672 dXSARGS;
12673 char *vmsified;
2d8e6c8d 12674 STRLEN n_a;
360732b5 12675 int utf8_fl;
748a9306 12676
5c84aa53 12677 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
360732b5
JM		 12678 utf8_fl = SvUTF8(ST(0));
12679 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12680 ST(0) = sv_newmortal();
360732b5
JM		 12681 if (vmsified != NULL) {
12682 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12683 if (utf8_fl) {
12684 SvUTF8_on(ST(0));
12685 }
12686 }
748a9306
LW		 12687 XSRETURN(1);
12688}
12689
12690void
5c84aa53 12691unixify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12692{
12693 dXSARGS;
12694 char *unixified;
2d8e6c8d 12695 STRLEN n_a;
360732b5 12696 int utf8_fl;
748a9306 12697
5c84aa53 12698 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
360732b5
JM		 12699 utf8_fl = SvUTF8(ST(0));
12700 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12701 ST(0) = sv_newmortal();
360732b5
JM		 12702 if (unixified != NULL) {
12703 sv_usepvn(ST(0),unixified,strlen(unixified));
12704 if (utf8_fl) {
12705 SvUTF8_on(ST(0));
12706 }
12707 }
748a9306
LW		 12708 XSRETURN(1);
12709}
12710
12711void
5c84aa53 12712fileify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12713{
12714 dXSARGS;
12715 char *fileified;
2d8e6c8d 12716 STRLEN n_a;
360732b5 12717 int utf8_fl;
748a9306 12718
5c84aa53 12719 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
360732b5
JM		 12720 utf8_fl = SvUTF8(ST(0));
12721 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12722 ST(0) = sv_newmortal();
360732b5
JM		 12723 if (fileified != NULL) {
12724 sv_usepvn(ST(0),fileified,strlen(fileified));
12725 if (utf8_fl) {
12726 SvUTF8_on(ST(0));
12727 }
12728 }
748a9306
LW		 12729 XSRETURN(1);
12730}
12731
12732void
5c84aa53 12733pathify_fromperl(pTHX_ CV *cv)
748a9306
LW		 12734{
12735 dXSARGS;
12736 char *pathified;
2d8e6c8d 12737 STRLEN n_a;
360732b5 12738 int utf8_fl;
748a9306 12739
5c84aa53 12740 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
360732b5
JM		 12741 utf8_fl = SvUTF8(ST(0));
12742 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12743 ST(0) = sv_newmortal();
360732b5
JM		 12744 if (pathified != NULL) {
12745 sv_usepvn(ST(0),pathified,strlen(pathified));
12746 if (utf8_fl) {
12747 SvUTF8_on(ST(0));
12748 }
12749 }
748a9306
LW		 12750 XSRETURN(1);
12751}
12752
12753void
5c84aa53 12754vmspath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12755{
12756 dXSARGS;
12757 char *vmspath;
2d8e6c8d 12758 STRLEN n_a;
360732b5 12759 int utf8_fl;
748a9306 12760
5c84aa53 12761 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
360732b5
JM		 12762 utf8_fl = SvUTF8(ST(0));
12763 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12764 ST(0) = sv_newmortal();
360732b5
JM		 12765 if (vmspath != NULL) {
12766 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12767 if (utf8_fl) {
12768 SvUTF8_on(ST(0));
12769 }
12770 }
748a9306
LW		 12771 XSRETURN(1);
12772}
12773
12774void
5c84aa53 12775unixpath_fromperl(pTHX_ CV *cv)
748a9306
LW		 12776{
12777 dXSARGS;
12778 char *unixpath;
2d8e6c8d 12779 STRLEN n_a;
360732b5 12780 int utf8_fl;
748a9306 12781
5c84aa53 12782 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
360732b5
JM		 12783 utf8_fl = SvUTF8(ST(0));
12784 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
748a9306 12785 ST(0) = sv_newmortal();
360732b5
JM		 12786 if (unixpath != NULL) {
12787 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12788 if (utf8_fl) {
12789 SvUTF8_on(ST(0));
12790 }
12791 }
748a9306
LW		 12792 XSRETURN(1);
12793}
12794
12795void
5c84aa53 12796candelete_fromperl(pTHX_ CV *cv)
748a9306
LW		 12797{
12798 dXSARGS;
988c775c 12799 char *fspec, *fsp;
a5f75d66
AD		 12800 SV *mysv;
12801 IO *io;
2d8e6c8d 12802 STRLEN n_a;
748a9306 12803
5c84aa53 12804 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
a5f75d66
AD		 12805
12806 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
988c775c
JM		 12807 Newx(fspec, VMS_MAXRSS, char);
12808 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
6d24fbd1 12809 if (isGV_with_GP(mysv)) {
a15cef0c 12810 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
a5f75d66 12811 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6b88bc9c 12812 ST(0) = &PL_sv_no;
988c775c 12813 Safefree(fspec);
a5f75d66
AD		 12814 XSRETURN(1);
12815 }
12816 fsp = fspec;
12817 }
12818 else {
2d8e6c8d 12819 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
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 }
12826
54310121 12827 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
988c775c 12828 Safefree(fspec);
a5f75d66
AD		 12829 XSRETURN(1);
12830}
12831
12832void
5c84aa53 12833rmscopy_fromperl(pTHX_ CV *cv)
a5f75d66
AD		 12834{
12835 dXSARGS;
a480973c 12836 char *inspec, *outspec, *inp, *outp;
a3e9d8c9 12837 int date_flag;
a5f75d66
AD		 12838 SV *mysv;
12839 IO *io;
2d8e6c8d 12840 STRLEN n_a;
a5f75d66 12841
a3e9d8c9 12842 if (items < 2 || items > 3)
5c84aa53 12843 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
a5f75d66
AD		 12844
12845 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
a480973c 12846 Newx(inspec, VMS_MAXRSS, char);
6d24fbd1 12847 if (isGV_with_GP(mysv)) {
a15cef0c 12848 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
a5f75d66 12849 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12850 ST(0) = sv_2mortal(newSViv(0));
a480973c 12851 Safefree(inspec);
a5f75d66
AD		 12852 XSRETURN(1);
12853 }
12854 inp = inspec;
12855 }
12856 else {
2d8e6c8d 12857 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
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 }
12864 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
a480973c 12865 Newx(outspec, VMS_MAXRSS, char);
6d24fbd1 12866 if (isGV_with_GP(mysv)) {
a15cef0c 12867 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
a5f75d66 12868 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12869 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12870 Safefree(inspec);
12871 Safefree(outspec);
a5f75d66
AD		 12872 XSRETURN(1);
12873 }
12874 outp = outspec;
12875 }
12876 else {
2d8e6c8d 12877 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
a5f75d66 12878 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
fd188159 12879 ST(0) = sv_2mortal(newSViv(0));
a480973c
JM		 12880 Safefree(inspec);
12881 Safefree(outspec);
a5f75d66
AD		 12882 XSRETURN(1);
12883 }
12884 }
a3e9d8c9 12885 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
a5f75d66 12886
fd188159 12887 ST(0) = sv_2mortal(newSViv(rmscopy(inp,outp,date_flag)));
a480973c
JM		 12888 Safefree(inspec);
12889 Safefree(outspec);
748a9306
LW		 12890 XSRETURN(1);
12891}
12892
a480973c
JM		 12893/* The mod2fname is limited to shorter filenames by design, so it should
12894 * not be modified to support longer EFS pathnames
12895 */
4b19af01 12896void
fd8cd3a3 12897mod2fname(pTHX_ CV *cv)
4b19af01
CB		 12898{
12899 dXSARGS;
12900 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12901 workbuff[NAM$C_MAXRSS*1 + 1];
4e0c9737 12902 int counter, num_entries;
4b19af01
CB		 12903 /* ODS-5 ups this, but we want to be consistent, so... */
12904 int max_name_len = 39;
12905 AV *in_array = (AV *)SvRV(ST(0));
12906
12907 num_entries = av_len(in_array);
12908
12909 /* All the names start with PL_. */
12910 strcpy(ultimate_name, "PL_");
12911
12912 /* Clean up our working buffer */
12913 Zero(work_name, sizeof(work_name), char);
12914
12915 /* Run through the entries and build up a working name */
12916 for(counter = 0; counter <= num_entries; counter++) {
12917 /* If it's not the first name then tack on a __ */
12918 if (counter) {
a35dcc95 12919 my_strlcat(work_name, "__", sizeof(work_name));
4b19af01 12920 }
a35dcc95 12921 my_strlcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)), sizeof(work_name));
4b19af01
CB		 12922 }
12923
12924 /* Check to see if we actually have to bother...*/
12925 if (strlen(work_name) + 3 <= max_name_len) {
a35dcc95 12926 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12927 } else {
12928 /* It's too darned big, so we need to go strip. We use the same */
12929 /* algorithm as xsubpp does. First, strip out doubled __ */
12930 char *source, *dest, last;
12931 dest = workbuff;
12932 last = 0;
12933 for (source = work_name; *source; source++) {
12934 if (last == *source && last == '_') {
12935 continue;
12936 }
12937 *dest++ = *source;
12938 last = *source;
12939 }
12940 /* Go put it back */
a35dcc95 12941 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12942 /* Is it still too big? */
12943 if (strlen(work_name) + 3 > max_name_len) {
12944 /* Strip duplicate letters */
12945 last = 0;
12946 dest = workbuff;
12947 for (source = work_name; *source; source++) {
12948 if (last == toupper(*source)) {
12949 continue;
12950 }
12951 *dest++ = *source;
12952 last = toupper(*source);
12953 }
a35dcc95 12954 my_strlcpy(work_name, workbuff, sizeof(work_name));
4b19af01
CB		 12955 }
12956
12957 /* Is it *still* too big? */
12958 if (strlen(work_name) + 3 > max_name_len) {
12959 /* Too bad, we truncate */
12960 work_name[max_name_len - 2] = 0;
12961 }
a35dcc95 12962 my_strlcat(ultimate_name, work_name, sizeof(ultimate_name));
4b19af01
CB		 12963 }
12964
12965 /* Okay, return it */
12966 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12967 XSRETURN(1);
12968}
12969
748a9306 12970void
96e176bf
CL		 12971hushexit_fromperl(pTHX_ CV *cv)
12972{
12973 dXSARGS;
12974
12975 if (items > 0) {
12976 VMSISH_HUSHED = SvTRUE(ST(0));
12977 }
12978 ST(0) = boolSV(VMSISH_HUSHED);
12979 XSRETURN(1);
12980}
12981
dca5a913
JM		 12982
12983PerlIO *
12984Perl_vms_start_glob
12985 (pTHX_ SV *tmpglob,
12986 IO *io)
12987{
12988 PerlIO *fp;
12989 struct vs_str_st *rslt;
12990 char *vmsspec;
12991 char *rstr;
12992 char *begin, *cp;
12993 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12994 PerlIO *tmpfp;
12995 STRLEN i;
12996 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12997 struct dsc$descriptor_vs rsdsc;
12998 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12999 unsigned long hasver = 0, isunix = 0;
13000 unsigned long int lff_flags = 0;
13001 int rms_sts;
85e7c9de 13002 int vms_old_glob = 1;
dca5a913 13003
83b907a4
CB		 13004 if (!SvOK(tmpglob)) {
13005 SETERRNO(ENOENT,RMS$_FNF);
13006 return NULL;
13007 }
13008
85e7c9de
JM		 13009 vms_old_glob = !decc_filename_unix_report;
13010
dca5a913
JM		 13011#ifdef VMS_LONGNAME_SUPPORT
13012 lff_flags = LIB$M_FIL_LONG_NAMES;
13013#endif
13014 /* The Newx macro will not allow me to assign a smaller array
13015 * to the rslt pointer, so we will assign it to the begin char pointer
13016 * and then copy the value into the rslt pointer.
13017 */
13018 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13019 rslt = (struct vs_str_st *)begin;
13020 rslt->length = 0;
13021 rstr = &rslt->str[0];
13022 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13023 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13024 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13025 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13026
13027 Newx(vmsspec, VMS_MAXRSS, char);
13028
13029 /* We could find out if there's an explicit dev/dir or version
13030 by peeking into lib$find_file's internal context at
13031 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13032 but that's unsupported, so I don't want to do it now and
13033 have it bite someone in the future. */
13034 /* Fix-me: vms_split_path() is the only way to do this, the
13035 existing method will fail with many legal EFS or UNIX specifications
13036 */
13037
13038 cp = SvPV(tmpglob,i);
13039
13040 for (; i; i--) {
13041 if (cp[i] == ';') hasver = 1;
13042 if (cp[i] == '.') {
13043 if (sts) hasver = 1;
13044 else sts = 1;
13045 }
13046 if (cp[i] == '/') {
13047 hasdir = isunix = 1;
13048 break;
13049 }
13050 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13051 hasdir = 1;
13052 break;
13053 }
13054 }
85e7c9de
JM		 13055
13056 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13057 if ((hasdir == 0) && decc_filename_unix_report) {
13058 isunix = 1;
13059 }
13060
dca5a913 13061 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
85e7c9de
JM		 13062 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13063 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13064 int wildstar = 0;
13065 int wildquery = 0;
990cad08 13066 int found = 0;
dca5a913
JM		 13067 Stat_t st;
13068 int stat_sts;
13069 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13070 if (!stat_sts && S_ISDIR(st.st_mode)) {
85e7c9de
JM		 13071 char * vms_dir;
13072 const char * fname;
13073 STRLEN fname_len;
13074
13075 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13076 /* path delimiter of ':>]', if so, then the old behavior has */
94ae10c0 13077 /* obviously been specifically requested */
85e7c9de
JM		 13078
13079 fname = SvPVX_const(tmpglob);
13080 fname_len = strlen(fname);
13081 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13082 if (vms_old_glob || (vms_dir != NULL)) {
13083 wilddsc.dsc$a_pointer = tovmspath_utf8(
13084 SvPVX(tmpglob),vmsspec,NULL);
13085 ok = (wilddsc.dsc$a_pointer != NULL);
13086 /* maybe passed 'foo' rather than '[.foo]', thus not
13087 detected above */
13088 hasdir = 1;
13089 } else {
13090 /* Operate just on the directory, the special stat/fstat for */
13091 /* leaves the fileified specification in the st_devnam */
13092 /* member. */
13093 wilddsc.dsc$a_pointer = st.st_devnam;
13094 ok = 1;
13095 }
dca5a913
JM		 13096 }
13097 else {
360732b5 13098 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
dca5a913
JM		 13099 ok = (wilddsc.dsc$a_pointer != NULL);
13100 }
13101 if (ok)
13102 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13103
13104 /* If not extended character set, replace ? with % */
13105 /* With extended character set, ? is a wildcard single character */
85e7c9de
JM		 13106 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13107 if (*cp == '?') {
13108 wildquery = 1;
998e0439 13109 if (!decc_efs_charset)
85e7c9de
JM		 13110 *cp = '%';
13111 } else if (*cp == '%') {
13112 wildquery = 1;
13113 } else if (*cp == '*') {
13114 wildstar = 1;
13115 }
dca5a913 13116 }
85e7c9de
JM		 13117
13118 if (ok) {
13119 wv_sts = vms_split_path(
13120 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13121 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13122 &wvs_spec, &wvs_len);
13123 } else {
13124 wn_spec = NULL;
13125 wn_len = 0;
13126 we_spec = NULL;
13127 we_len = 0;
13128 }
13129
dca5a913
JM		 13130 sts = SS$_NORMAL;
13131 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13132 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13133 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
85e7c9de 13134 int valid_find;
dca5a913 13135
85e7c9de 13136 valid_find = 0;
dca5a913
JM		 13137 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13138 &dfltdsc,NULL,&rms_sts,&lff_flags);
13139 if (!$VMS_STATUS_SUCCESS(sts))
13140 break;
13141
13142 /* with varying string, 1st word of buffer contains result length */
13143 rstr[rslt->length] = '\0';
13144
13145 /* Find where all the components are */
13146 v_sts = vms_split_path
360732b5 13147 (rstr,
dca5a913
JM		 13148 &v_spec,
13149 &v_len,
13150 &r_spec,
13151 &r_len,
13152 &d_spec,
13153 &d_len,
13154 &n_spec,
13155 &n_len,
13156 &e_spec,
13157 &e_len,
13158 &vs_spec,
13159 &vs_len);
13160
13161 /* If no version on input, truncate the version on output */
13162 if (!hasver && (vs_len > 0)) {
13163 *vs_spec = '\0';
13164 vs_len = 0;
85e7c9de
JM		 13165 }
13166
13167 if (isunix) {
13168
13169 /* In Unix report mode, remove the ".dir;1" from the name */
13170 /* if it is a real directory */
13171 if (decc_filename_unix_report || decc_efs_charset) {
13172 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13173 Stat_t statbuf;
13174 int ret_sts;
13175
13176 ret_sts = flex_lstat(rstr, &statbuf);
13177 if ((ret_sts == 0) &&
13178 S_ISDIR(statbuf.st_mode)) {
13179 e_len = 0;
13180 e_spec[0] = 0;
13181 }
13182 }
13183 }
dca5a913
JM		 13184
13185 /* No version & a null extension on UNIX handling */
85e7c9de 13186 if ((e_len == 1) && decc_readdir_dropdotnotype) {
dca5a913
JM		 13187 e_len = 0;
13188 *e_spec = '\0';
13189 }
13190 }
13191
13192 if (!decc_efs_case_preserve) {
13193 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13194 }
13195
85e7c9de
JM		 13196 /* Find File treats a Null extension as return all extensions */
13197 /* This is contrary to Perl expectations */
13198
13199 if (wildstar || wildquery || vms_old_glob) {
13200 /* really need to see if the returned file name matched */
13201 /* but for now will assume that it matches */
13202 valid_find = 1;
13203 } else {
13204 /* Exact Match requested */
13205 /* How are directories handled? - like a file */
13206 if ((e_len == we_len) && (n_len == wn_len)) {
13207 int t1;
13208 t1 = e_len;
13209 if (t1 > 0)
13210 t1 = strncmp(e_spec, we_spec, e_len);
13211 if (t1 == 0) {
13212 t1 = n_len;
13213 if (t1 > 0)
13214 t1 = strncmp(n_spec, we_spec, n_len);
13215 if (t1 == 0)
13216 valid_find = 1;
13217 }
13218 }
13219 }
13220
13221 if (valid_find) {
13222 found++;
13223
13224 if (hasdir) {
13225 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13226 begin = rstr;
13227 }
13228 else {
13229 /* Start with the name */
13230 begin = n_spec;
13231 }
13232 strcat(begin,"\n");
13233 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13234 }
dca5a913
JM		 13235 }
13236 if (cxt) (void)lib$find_file_end(&cxt);
990cad08
CB		 13237
13238 if (!found) {
13239 /* Be POSIXish: return the input pattern when no matches */
a35dcc95 13240 my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS);
2da7a6b5
CB		 13241 strcat(rstr,"\n");
13242 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
990cad08
CB		 13243 }
13244
dca5a913
JM		 13245 if (ok && sts != RMS$_NMF &&
13246 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13247 if (!ok) {
13248 if (!(sts & 1)) {
13249 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13250 }
13251 PerlIO_close(tmpfp);
13252 fp = NULL;
13253 }
13254 else {
13255 PerlIO_rewind(tmpfp);
13256 IoTYPE(io) = IoTYPE_RDONLY;
13257 IoIFP(io) = fp = tmpfp;
13258 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13259 }
13260 }
13261 Safefree(vmsspec);
13262 Safefree(rslt);
13263 return fp;
13264}
13265
cd1191f1 13266
2497a41f 13267static char *
5c4d031a 13268mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
d584a1c6 13269 int *utf8_fl);
2497a41f
JM		 13270
13271void
4d8d3a9c 13272unixrealpath_fromperl(pTHX_ CV *cv)
2497a41f 13273{
d584a1c6
JM		 13274 dXSARGS;
13275 char *fspec, *rslt_spec, *rslt;
13276 STRLEN n_a;
2497a41f 13277
d584a1c6 13278 if (!items || items != 1)
4d8d3a9c 13279 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
2497a41f 13280
d584a1c6
JM		 13281 fspec = SvPV(ST(0),n_a);
13282 if (!fspec || !*fspec) XSRETURN_UNDEF;
2497a41f 13283
d584a1c6
JM		 13284 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13285 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13286
13287 ST(0) = sv_newmortal();
13288 if (rslt != NULL)
13289 sv_usepvn(ST(0),rslt,strlen(rslt));
13290 else
13291 Safefree(rslt_spec);
13292 XSRETURN(1);
2497a41f 13293}
2ee6e19d 13294
b1a8dcd7
JM		 13295static char *
13296mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13297 int *utf8_fl);
13298
13299void
4d8d3a9c 13300vmsrealpath_fromperl(pTHX_ CV *cv)
b1a8dcd7
JM		 13301{
13302 dXSARGS;
13303 char *fspec, *rslt_spec, *rslt;
13304 STRLEN n_a;
13305
13306 if (!items || items != 1)
4d8d3a9c 13307 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
b1a8dcd7
JM		 13308
13309 fspec = SvPV(ST(0),n_a);
13310 if (!fspec || !*fspec) XSRETURN_UNDEF;
13311
13312 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13313 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13314
13315 ST(0) = sv_newmortal();
13316 if (rslt != NULL)
13317 sv_usepvn(ST(0),rslt,strlen(rslt));
13318 else
13319 Safefree(rslt_spec);
13320 XSRETURN(1);
13321}
13322
13323#ifdef HAS_SYMLINK
2ee6e19d
CB		 13324/*
13325 * A thin wrapper around decc$symlink to make sure we follow the
cc9aafbd
CB		 13326 * standard and do not create a symlink with a zero-length name,
13327 * and convert the target to Unix format, as the CRTL can't handle
13328 * targets in VMS format.
2ee6e19d 13329 */
4148925f 13330/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
cc9aafbd
CB		 13331int
13332Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
13333{
13334 int sts;
13335 char * utarget;
4148925f 13336
cc9aafbd
CB		 13337 if (!link_name || !*link_name) {
13338 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13339 return -1;
13340 }
4148925f 13341
c11536f5 13342 utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
cc9aafbd
CB		 13343 /* An untranslatable filename should be passed through. */
13344 (void) int_tounixspec(contents, utarget, NULL);
13345 sts = symlink(utarget, link_name);
13346 PerlMem_free(utarget);
13347 return sts;
2ee6e19d
CB		 13348}
13349/*}}}*/
13350
13351#endif /* HAS_SYMLINK */
2497a41f 13352
2497a41f
JM		 13353int do_vms_case_tolerant(void);
13354
13355void
4d8d3a9c 13356case_tolerant_process_fromperl(pTHX_ CV *cv)
2497a41f
JM		 13357{
13358 dXSARGS;
13359 ST(0) = boolSV(do_vms_case_tolerant());
13360 XSRETURN(1);
13361}
2497a41f 13362
9ec7171b
CB		 13363#ifdef USE_ITHREADS
13364
96e176bf
CL		 13365void
13366Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13367 struct interp_intern *dst)
13368{
7918f24d
NC		 13369 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13370
96e176bf
CL		 13371 memcpy(dst,src,sizeof(struct interp_intern));
13372}
13373
9ec7171b
CB		 13374#endif
13375
96e176bf
CL		 13376void
13377Perl_sys_intern_clear(pTHX)
13378{
13379}
13380
13381void
13382Perl_sys_intern_init(pTHX)
13383{
3ff49832
CL		 13384 unsigned int ix = RAND_MAX;
13385 double x;
96e176bf
CL		 13386
13387 VMSISH_HUSHED = 0;
13388
1a3aec58 13389 MY_POSIX_EXIT = vms_posix_exit;
7a7fd8e0 13390
96e176bf
CL		 13391 x = (float)ix;
13392 MY_INV_RAND_MAX = 1./x;
ff7adb52 13393}
96e176bf
CL		 13394
13395void
f7ddb74a 13396init_os_extras(void)
748a9306 13397{
a69a6dba 13398 dTHX;
748a9306 13399 char* file = __FILE__;
988c775c 13400 if (decc_disable_to_vms_logname_translation) {
93948341
CB		 13401 no_translate_barewords = TRUE;
13402 } else {
13403 no_translate_barewords = FALSE;
13404 }
748a9306 13405
740ce14c 13406 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
a5f75d66
AD		 13407 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13408 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13409 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13410 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13411 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13412 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13413 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4b19af01 13414 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
a5f75d66 13415 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
96e176bf 13416 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
4d8d3a9c
CB		 13417 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13418 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13419 newXSproto("VMS::Filespec::case_tolerant_process",
13420 case_tolerant_process_fromperl,file,"");
17f28c40 13421
afd8f436 13422 store_pipelocs(aTHX); /* will redo any earlier attempts */
22d4bb9c 13423
748a9306
LW		 13424 return;
13425}
13426
f7ddb74a
JM		 13427#if __CRTL_VER == 80200000
13428/* This missed getting in to the DECC SDK for 8.2 */
13429char *realpath(const char *file_name, char * resolved_name, ...);
13430#endif
13431
13432/*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13433/* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13434 * The perl fallback routine to provide realpath() is not as efficient
13435 * on OpenVMS.
13436 */
d584a1c6 13437
c11536f5
CB		 13438#ifdef __cplusplus
13439extern "C" {
13440#endif
13441
d584a1c6
JM		 13442/* Hack, use old stat() as fastest way of getting ino_t and device */
13443int decc$stat(const char *name, void * statbuf);
312ac60b
JM		 13444#if !defined(__VAX) && __CRTL_VER >= 80200000
13445int decc$lstat(const char *name, void * statbuf);
13446#else
13447#define decc$lstat decc$stat
13448#endif
d584a1c6 13449
c11536f5
CB		 13450#ifdef __cplusplus
13451}
13452#endif
13453
d584a1c6
JM		 13454
13455/* Realpath is fragile. In 8.3 it does not work if the feature
13456 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13457 * links are implemented in RMS, not the CRTL. It also can fail if the
13458 * user does not have read/execute access to some of the directories.
13459 * So in order for Do What I Mean mode to work, if realpath() fails,
13460 * fall back to looking up the filename by the device name and FID.
13461 */
13462
312ac60b
JM		 13463int vms_fid_to_name(char * outname, int outlen,
13464 const char * name, int lstat_flag, mode_t * mode)
d584a1c6 13465{
312ac60b
JM		 13466#pragma message save
13467#pragma message disable MISALGNDSTRCT
13468#pragma message disable MISALGNDMEM
13469#pragma member_alignment save
13470#pragma nomember_alignment
d584a1c6
JM		 13471struct statbuf_t {
13472 char * st_dev;
b1a8dcd7 13473 unsigned short st_ino[3];
312ac60b 13474 unsigned short old_st_mode;
d584a1c6
JM		 13475 unsigned long padl[30]; /* plenty of room */
13476} statbuf;
312ac60b
JM		 13477#pragma message restore
13478#pragma member_alignment restore
13479
13480 int sts;
13481 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13482 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13483 char *fileified;
13484 char *temp_fspec;
13485 char *ret_spec;
13486
13487 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
13488 * unexpected answers
13489 */
13490
c11536f5 13491 fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13492 if (fileified == NULL)
13493 _ckvmssts_noperl(SS$_INSFMEM);
13494
c11536f5 13495 temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
312ac60b
JM		 13496 if (temp_fspec == NULL)
13497 _ckvmssts_noperl(SS$_INSFMEM);
13498
13499 sts = -1;
13500 /* First need to try as a directory */
13501 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13502 if (ret_spec != NULL) {
13503 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
13504 if (ret_spec != NULL) {
13505 if (lstat_flag == 0)
13506 sts = decc$stat(fileified, &statbuf);
13507 else
13508 sts = decc$lstat(fileified, &statbuf);
13509 }
13510 }
13511
13512 /* Then as a VMS file spec */
13513 if (sts != 0) {
13514 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
13515 if (ret_spec != NULL) {
13516 if (lstat_flag == 0) {
13517 sts = decc$stat(temp_fspec, &statbuf);
13518 } else {
13519 sts = decc$lstat(temp_fspec, &statbuf);
13520 }
13521 }
13522 }
13523
13524 if (sts) {
13525 /* Next try - allow multiple dots with out EFS CHARSET */
13526 /* The CRTL stat() falls down hard on multi-dot filenames in unix
13527 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
13528 * enable it if it isn't already.
13529 */
13530#if __CRTL_VER >= 70300000 && !defined(__VAX)
13531 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13532 decc$feature_set_value(decc_efs_charset_index, 1, 1);
13533#endif
13534 ret_spec = int_tovmspath(name, temp_fspec, NULL);
13535 if (lstat_flag == 0) {
13536 sts = decc$stat(name, &statbuf);
13537 } else {
13538 sts = decc$lstat(name, &statbuf);
13539 }
13540#if __CRTL_VER >= 70300000 && !defined(__VAX)
13541 if (!decc_efs_charset && (decc_efs_charset_index > 0))
13542 decc$feature_set_value(decc_efs_charset_index, 1, 0);
13543#endif
13544 }
13545
13546
13547 /* and then because the Perl Unix to VMS conversion is not perfect */
13548 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
13549 /* characters from filenames so we need to try it as-is */
13550 if (sts) {
13551 if (lstat_flag == 0) {
13552 sts = decc$stat(name, &statbuf);
13553 } else {
13554 sts = decc$lstat(name, &statbuf);
13555 }
13556 }
d584a1c6 13557
d584a1c6 13558 if (sts == 0) {
312ac60b 13559 int vms_sts;
d584a1c6
JM		 13560
13561 dvidsc.dsc$a_pointer=statbuf.st_dev;
d94c5a78 13562 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
d584a1c6
JM		 13563
13564 specdsc.dsc$a_pointer = outname;
13565 specdsc.dsc$w_length = outlen-1;
13566
d94c5a78 13567 vms_sts = lib$fid_to_name
d584a1c6 13568 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
d94c5a78 13569 if ($VMS_STATUS_SUCCESS(vms_sts)) {
d584a1c6 13570 outname[specdsc.dsc$w_length] = 0;
312ac60b
JM		 13571
13572 /* Return the mode */
13573 if (mode) {
13574 *mode = statbuf.old_st_mode;
13575 }
d584a1c6
JM		 13576 }
13577 }
9e2bec02
CB		 13578 PerlMem_free(temp_fspec);
13579 PerlMem_free(fileified);
d584a1c6
JM		 13580 return sts;
13581}
13582
13583
13584
f7ddb74a 13585static char *
5c4d031a 13586mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
d584a1c6 13587 int *utf8_fl)
f7ddb74a 13588{
d584a1c6
JM		 13589 char * rslt = NULL;
13590
b1a8dcd7
JM		 13591#ifdef HAS_SYMLINK
13592 if (decc_posix_compliant_pathnames > 0 ) {
13593 /* realpath currently only works if posix compliant pathnames are
13594 * enabled. It may start working when they are not, but in that
13595 * case we still want the fallback behavior for backwards compatibility
13596 */
d584a1c6 13597 rslt = realpath(filespec, outbuf);
b1a8dcd7
JM		 13598 }
13599#endif
d584a1c6
JM		 13600
13601 if (rslt == NULL) {
13602 char * vms_spec;
13603 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13604 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
312ac60b 13605 mode_t my_mode;
d584a1c6
JM		 13606
13607 /* Fall back to fid_to_name */
13608
13609 Newx(vms_spec, VMS_MAXRSS + 1, char);
13610
312ac60b 13611 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
4d8d3a9c 13612 if (sts == 0) {
d584a1c6
JM		 13613
13614
13615 /* Now need to trim the version off */
13616 sts = vms_split_path
13617 (vms_spec,
13618 &v_spec,
13619 &v_len,
13620 &r_spec,
13621 &r_len,
13622 &d_spec,
13623 &d_len,
13624 &n_spec,
13625 &n_len,
13626 &e_spec,
13627 &e_len,
13628 &vs_spec,
13629 &vs_len);
13630
13631
4d8d3a9c
CB		 13632 if (sts == 0) {
13633 int haslower = 0;
13634 const char *cp;
d584a1c6 13635
4d8d3a9c
CB		 13636 /* Trim off the version */
13637 int file_len = v_len + r_len + d_len + n_len + e_len;
13638 vms_spec[file_len] = 0;
d584a1c6 13639
f785e3a1
JM		 13640 /* Trim off the .DIR if this is a directory */
13641 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13642 if (S_ISDIR(my_mode)) {
13643 e_len = 0;
13644 e_spec[0] = 0;
13645 }
13646 }
13647
13648 /* Drop NULL extensions on UNIX file specification */
13649 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13650 e_len = 0;
13651 e_spec[0] = '\0';
13652 }
13653
4d8d3a9c 13654 /* The result is expected to be in UNIX format */
0e5ce2c7 13655 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
4d8d3a9c
CB		 13656
13657 /* Downcase if input had any lower case letters and
13658 * case preservation is not in effect.
13659 */
13660 if (!decc_efs_case_preserve) {
13661 for (cp = filespec; *cp; cp++)
13662 if (islower(*cp)) { haslower = 1; break; }
13663
13664 if (haslower) __mystrtolower(rslt);
13665 }
13666 }
643f470b
CB		 13667 } else {
13668
13669 /* Now for some hacks to deal with backwards and forward */
94ae10c0 13670 /* compatibility */
643f470b
CB		 13671 if (!decc_efs_charset) {
13672
13673 /* 1. ODS-2 mode wants to do a syntax only translation */
6fb6c614
JM		 13674 rslt = int_rmsexpand(filespec, outbuf,
13675 NULL, 0, NULL, utf8_fl);
643f470b
CB		 13676
13677 } else {
13678 if (decc_filename_unix_report) {
13679 char * dir_name;
13680 char * vms_dir_name;
13681 char * file_name;
13682
13683 /* 2. ODS-5 / UNIX report mode should return a failure */
13684 /* if the parent directory also does not exist */
13685 /* Otherwise, get the real path for the parent */
29475144 13686 /* and add the child to it. */
643f470b
CB		 13687
13688 /* basename / dirname only available for VMS 7.0+ */
13689 /* So we may need to implement them as common routines */
13690
13691 Newx(dir_name, VMS_MAXRSS + 1, char);
13692 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13693 dir_name[0] = '\0';
13694 file_name = NULL;
13695
13696 /* First try a VMS parse */
13697 sts = vms_split_path
13698 (filespec,
13699 &v_spec,
13700 &v_len,
13701 &r_spec,
13702 &r_len,
13703 &d_spec,
13704 &d_len,
13705 &n_spec,
13706 &n_len,
13707 &e_spec,
13708 &e_len,
13709 &vs_spec,
13710 &vs_len);
13711
13712 if (sts == 0) {
13713 /* This is VMS */
13714
13715 int dir_len = v_len + r_len + d_len + n_len;
13716 if (dir_len > 0) {
a35dcc95 13717 memcpy(dir_name, filespec, dir_len);
643f470b
CB		 13718 dir_name[dir_len] = '\0';
13719 file_name = (char *)&filespec[dir_len + 1];
13720 }
13721 } else {
13722 /* This must be UNIX */
13723 char * tchar;
13724
13725 tchar = strrchr(filespec, '/');
13726
4148925f
JM		 13727 if (tchar != NULL) {
13728 int dir_len = tchar - filespec;
a35dcc95 13729 memcpy(dir_name, filespec, dir_len);
4148925f
JM		 13730 dir_name[dir_len] = '\0';
13731 file_name = (char *) &filespec[dir_len + 1];
13732 }
13733 }
13734
13735 /* Dir name is defaulted */
13736 if (dir_name[0] == 0) {
13737 dir_name[0] = '.';
13738 dir_name[1] = '\0';
13739 }
13740
13741 /* Need realpath for the directory */
13742 sts = vms_fid_to_name(vms_dir_name,
13743 VMS_MAXRSS + 1,
312ac60b 13744 dir_name, 0, NULL);
4148925f
JM		 13745
13746 if (sts == 0) {
29475144 13747 /* Now need to pathify it. */
1fe570cc
JM		 13748 char *tdir = int_pathify_dirspec(vms_dir_name,
13749 outbuf);
4148925f
JM		 13750
13751 /* And now add the original filespec to it */
13752 if (file_name != NULL) {
a35dcc95 13753 my_strlcat(outbuf, file_name, VMS_MAXRSS);
4148925f
JM		 13754 }
13755 return outbuf;
13756 }
13757 Safefree(vms_dir_name);
13758 Safefree(dir_name);
13759 }
13760 }
643f470b 13761 }
d584a1c6
JM		 13762 Safefree(vms_spec);
13763 }
13764 return rslt;
f7ddb74a
JM		 13765}
13766
b1a8dcd7
JM		 13767static char *
13768mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13769 int *utf8_fl)
13770{
13771 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13772 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
b1a8dcd7
JM		 13773
13774 /* Fall back to fid_to_name */
13775
312ac60b 13776 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
cd43acd7
CB		 13777 if (sts != 0) {
13778 return NULL;
13779 }
13780 else {
b1a8dcd7
JM		 13781
13782
13783 /* Now need to trim the version off */
13784 sts = vms_split_path
13785 (outbuf,
13786 &v_spec,
13787 &v_len,
13788 &r_spec,
13789 &r_len,
13790 &d_spec,
13791 &d_len,
13792 &n_spec,
13793 &n_len,
13794 &e_spec,
13795 &e_len,
13796 &vs_spec,
13797 &vs_len);
13798
13799
13800 if (sts == 0) {
4d8d3a9c
CB		 13801 int haslower = 0;
13802 const char *cp;
13803
13804 /* Trim off the version */
13805 int file_len = v_len + r_len + d_len + n_len + e_len;
13806 outbuf[file_len] = 0;
b1a8dcd7 13807
4d8d3a9c
CB		 13808 /* Downcase if input had any lower case letters and
13809 * case preservation is not in effect.
13810 */
13811 if (!decc_efs_case_preserve) {
13812 for (cp = filespec; *cp; cp++)
13813 if (islower(*cp)) { haslower = 1; break; }
13814
13815 if (haslower) __mystrtolower(outbuf);
13816 }
b1a8dcd7
JM		 13817 }
13818 }
13819 return outbuf;
13820}
13821
13822
f7ddb74a
JM		 13823/*}}}*/
13824/* External entry points */
360732b5
JM		 13825char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13826{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
f7ddb74a 13827
b1a8dcd7
JM		 13828char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13829{ return do_vms_realname(filespec, outbuf, utf8_fl); }
f7ddb74a 13830
f7ddb74a
JM		 13831/* case_tolerant */
13832
13833/*{{{int do_vms_case_tolerant(void)*/
13834/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13835 * controlled by a process setting.
13836 */
13837int do_vms_case_tolerant(void)
13838{
13839 return vms_process_case_tolerant;
13840}
13841/*}}}*/
13842/* External entry points */
b1a8dcd7 13843#if __CRTL_VER >= 70301000 && !defined(__VAX)
f7ddb74a
JM		 13844int Perl_vms_case_tolerant(void)
13845{ return do_vms_case_tolerant(); }
13846#else
13847int Perl_vms_case_tolerant(void)
13848{ return vms_process_case_tolerant; }
13849#endif
13850
13851
13852 /* Start of DECC RTL Feature handling */
13853
4ddecfe9
CB		 13854#if __CRTL_VER >= 70300000 && !defined(__VAX)
13855
13856static int
13857set_feature_default(const char *name, int value)
13858{
13859 int status;
13860 int index;
13861
13862 index = decc$feature_get_index(name);
13863
13864 status = decc$feature_set_value(index, 1, value);
13865 if (index == -1 || (status == -1)) {
13866 return -1;
13867 }
13868
13869 status = decc$feature_get_value(index, 1);
13870 if (status != value) {
13871 return -1;
13872 }
13873
13874 /* Various things may check for an environment setting
13875 * rather than the feature directly, so set that too.
13876 */
13877 vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
13878
13879 return 0;
13880}
13881#endif
13882
f7ddb74a 13883
f7ddb74a
JM		 13884/* C RTL Feature settings */
13885
e2367aa8
CB		 13886#if defined(__DECC) || defined(__DECCXX)
13887
13888#ifdef __cplusplus
13889extern "C" {
13890#endif
13891
13892extern void
13893vmsperl_set_features(void)
f7ddb74a
JM		 13894{
13895 int status;
13896 int s;
f7ddb74a 13897 char val_str[10];
3c841f20 13898#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
f7ddb74a
JM		 13899 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13900 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13901 unsigned long case_perm;
13902 unsigned long case_image;
3c841f20 13903#endif
f7ddb74a 13904
9c1171d1
JM		 13905 /* Allow an exception to bring Perl into the VMS debugger */
13906 vms_debug_on_exception = 0;
8dc9d339 13907 status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
9c1171d1 13908 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 13909 val_str[0] = _toupper(val_str[0]);
9c1171d1
JM		 13910 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13911 vms_debug_on_exception = 1;
13912 else
13913 vms_debug_on_exception = 0;
13914 }
13915
b53f3677
JM		 13916 /* Debug unix/vms file translation routines */
13917 vms_debug_fileify = 0;
8dc9d339 13918 status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
b53f3677
JM		 13919 if ($VMS_STATUS_SUCCESS(status)) {
13920 val_str[0] = _toupper(val_str[0]);
13921 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13922 vms_debug_fileify = 1;
13923 else
13924 vms_debug_fileify = 0;
13925 }
13926
13927
13928 /* Historically PERL has been doing vmsify / stat differently than */
13929 /* the CRTL. In particular, under some conditions the CRTL will */
13930 /* remove some illegal characters like spaces from filenames */
13931 /* resulting in some differences. The stat()/lstat() wrapper has */
13932 /* been reporting such file names as invalid and fails to stat them */
13933 /* fixing this bug so that stat()/lstat() accept these like the */
13934 /* CRTL does will result in several tests failing. */
13935 /* This should really be fixed, but for now, set up a feature to */
13936 /* enable it so that the impact can be studied. */
13937 vms_bug_stat_filename = 0;
8dc9d339 13938 status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
b53f3677
JM		 13939 if ($VMS_STATUS_SUCCESS(status)) {
13940 val_str[0] = _toupper(val_str[0]);
13941 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13942 vms_bug_stat_filename = 1;
13943 else
13944 vms_bug_stat_filename = 0;
13945 }
13946
13947
38a44b82 13948 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
360732b5 13949 vms_vtf7_filenames = 0;
8dc9d339 13950 status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
360732b5 13951 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 13952 val_str[0] = _toupper(val_str[0]);
360732b5
JM		 13953 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13954 vms_vtf7_filenames = 1;
13955 else
13956 vms_vtf7_filenames = 0;
13957 }
13958
e0e5e8d6 13959 /* unlink all versions on unlink() or rename() */
d584a1c6 13960 vms_unlink_all_versions = 0;
8dc9d339 13961 status = simple_trnlnm
e0e5e8d6
JM		 13962 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13963 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 13964 val_str[0] = _toupper(val_str[0]);
e0e5e8d6
JM		 13965 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13966 vms_unlink_all_versions = 1;
13967 else
13968 vms_unlink_all_versions = 0;
13969 }
13970
360732b5 13971#if __CRTL_VER >= 70300000 && !defined(__VAX)
5ca74088 13972 /* Detect running under GNV Bash or other UNIX like shell */
360732b5 13973 gnv_unix_shell = 0;
8dc9d339 13974 status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
360732b5 13975 if ($VMS_STATUS_SUCCESS(status)) {
360732b5 13976 gnv_unix_shell = 1;
360732b5
JM		 13977 set_feature_default("DECC$EFS_CHARSET", 1);
13978 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13979 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13980 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13981 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
e0e5e8d6 13982 vms_unlink_all_versions = 1;
1a3aec58 13983 vms_posix_exit = 1;
360732b5 13984 }
5ca74088
CB		 13985 /* Some reasonable defaults that are not CRTL defaults */
13986 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
c342cf44 13987 set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
360732b5 13988#endif
9c1171d1 13989
2497a41f
JM		 13990 /* hacks to see if known bugs are still present for testing */
13991
2497a41f 13992 /* PCP mode requires creating /dev/null special device file */
2623a4a6 13993 decc_bug_devnull = 0;
8dc9d339 13994 status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
2497a41f 13995 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 13996 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 13997 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13998 decc_bug_devnull = 1;
682e4b71
JM		 13999 else
14000 decc_bug_devnull = 0;
2497a41f
JM		 14001 }
14002
2497a41f
JM		 14003 /* UNIX directory names with no paths are broken in a lot of places */
14004 decc_dir_barename = 1;
8dc9d339 14005 status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
2497a41f 14006 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14007 val_str[0] = _toupper(val_str[0]);
2497a41f
JM		 14008 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14009 decc_dir_barename = 1;
14010 else
14011 decc_dir_barename = 0;
14012 }
14013
f7ddb74a
JM		 14014#if __CRTL_VER >= 70300000 && !defined(__VAX)
14015 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14016 if (s >= 0) {
14017 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14018 if (decc_disable_to_vms_logname_translation < 0)
14019 decc_disable_to_vms_logname_translation = 0;
14020 }
14021
14022 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14023 if (s >= 0) {
14024 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14025 if (decc_efs_case_preserve < 0)
14026 decc_efs_case_preserve = 0;
14027 }
14028
14029 s = decc$feature_get_index("DECC$EFS_CHARSET");
b53f3677 14030 decc_efs_charset_index = s;
f7ddb74a
JM		 14031 if (s >= 0) {
14032 decc_efs_charset = decc$feature_get_value(s, 1);
14033 if (decc_efs_charset < 0)
14034 decc_efs_charset = 0;
14035 }
14036
14037 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14038 if (s >= 0) {
14039 decc_filename_unix_report = decc$feature_get_value(s, 1);
1a3aec58 14040 if (decc_filename_unix_report > 0) {
f7ddb74a 14041 decc_filename_unix_report = 1;
1a3aec58
JM		 14042 vms_posix_exit = 1;
14043 }
f7ddb74a
JM		 14044 else
14045 decc_filename_unix_report = 0;
14046 }
14047
14048 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14049 if (s >= 0) {
14050 decc_filename_unix_only = decc$feature_get_value(s, 1);
14051 if (decc_filename_unix_only > 0) {
14052 decc_filename_unix_only = 1;
14053 }
14054 else {
14055 decc_filename_unix_only = 0;
14056 }
14057 }
14058
14059 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14060 if (s >= 0) {
14061 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14062 if (decc_filename_unix_no_version < 0)
14063 decc_filename_unix_no_version = 0;
14064 }
14065
14066 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14067 if (s >= 0) {
14068 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14069 if (decc_readdir_dropdotnotype < 0)
14070 decc_readdir_dropdotnotype = 0;
14071 }
14072
f7ddb74a
JM		 14073#if __CRTL_VER >= 80200000
14074 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14075 if (s >= 0) {
14076 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14077 if (decc_posix_compliant_pathnames < 0)
14078 decc_posix_compliant_pathnames = 0;
14079 if (decc_posix_compliant_pathnames > 4)
14080 decc_posix_compliant_pathnames = 0;
14081 }
14082
14083#endif
14084#else
8dc9d339 14085 status = simple_trnlnm
f7ddb74a
JM		 14086 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14087 if ($VMS_STATUS_SUCCESS(status)) {
14088 val_str[0] = _toupper(val_str[0]);
14089 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14090 decc_disable_to_vms_logname_translation = 1;
14091 }
14092 }
14093
14094#ifndef __VAX
8dc9d339 14095 status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
f7ddb74a
JM		 14096 if ($VMS_STATUS_SUCCESS(status)) {
14097 val_str[0] = _toupper(val_str[0]);
14098 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14099 decc_efs_case_preserve = 1;
14100 }
14101 }
14102#endif
14103
8dc9d339 14104 status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
f7ddb74a
JM		 14105 if ($VMS_STATUS_SUCCESS(status)) {
14106 val_str[0] = _toupper(val_str[0]);
14107 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14108 decc_filename_unix_report = 1;
14109 }
14110 }
8dc9d339 14111 status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
f7ddb74a
JM		 14112 if ($VMS_STATUS_SUCCESS(status)) {
14113 val_str[0] = _toupper(val_str[0]);
14114 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14115 decc_filename_unix_only = 1;
14116 decc_filename_unix_report = 1;
14117 }
14118 }
8dc9d339 14119 status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
f7ddb74a
JM		 14120 if ($VMS_STATUS_SUCCESS(status)) {
14121 val_str[0] = _toupper(val_str[0]);
14122 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14123 decc_filename_unix_no_version = 1;
14124 }
14125 }
8dc9d339 14126 status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
f7ddb74a
JM		 14127 if ($VMS_STATUS_SUCCESS(status)) {
14128 val_str[0] = _toupper(val_str[0]);
14129 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14130 decc_readdir_dropdotnotype = 1;
14131 }
14132 }
14133#endif
14134
28ff9735 14135#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
f7ddb74a
JM		 14136
14137 /* Report true case tolerance */
14138 /*----------------------------*/
14139 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14140 if (!$VMS_STATUS_SUCCESS(status))
14141 case_perm = PPROP$K_CASE_BLIND;
14142 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14143 if (!$VMS_STATUS_SUCCESS(status))
14144 case_image = PPROP$K_CASE_BLIND;
14145 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14146 (case_image == PPROP$K_CASE_SENSITIVE))
14147 vms_process_case_tolerant = 0;
14148
14149#endif
14150
1a3aec58 14151 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
94ae10c0 14152 /* for strict backward compatibility */
8dc9d339 14153 status = simple_trnlnm
1a3aec58
JM		 14154 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14155 if ($VMS_STATUS_SUCCESS(status)) {
b53f3677 14156 val_str[0] = _toupper(val_str[0]);
1a3aec58
JM		 14157 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14158 vms_posix_exit = 1;
14159 else
14160 vms_posix_exit = 0;
14161 }
c11536f5 14162}
f7ddb74a 14163
e2367aa8
CB		 14164/* Use 32-bit pointers because that's what the image activator
14165 * assumes for the LIB$INITIALZE psect.
14166 */
14167#if __INITIAL_POINTER_SIZE
14168#pragma pointer_size save
14169#pragma pointer_size 32
14170#endif
14171
14172/* Create a reference to the LIB$INITIALIZE function. */
14173extern void LIB$INITIALIZE(void);
14174extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
14175
14176/* Create an array of pointers to the init functions in the special
14177 * LIB$INITIALIZE section. In our case, the array only has one entry.
14178 */
14179#pragma extern_model save
2646d7b3 14180#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
e2367aa8
CB		 14181extern void (* const vmsperl_unused_global_2[])() =
14182{
14183 vmsperl_set_features,
14184};
14185#pragma extern_model restore
14186
14187#if __INITIAL_POINTER_SIZE
14188#pragma pointer_size restore
14189#endif
14190
14191#ifdef __cplusplus
14192}
f7ddb74a
JM		 14193#endif
14194
e2367aa8 14195#endif /* defined(__DECC) || defined(__DECCXX) */
748a9306 14196/* End of vms.c */
Unnamed repository; edit this file 'description' to name the repository.